EXCEL VBA エクセルシートに押印処理を行う・ダブルクリックで押印（判子・電子印鑑・スタンプ）（テクニック）

EXCEL VBA エクセルシートに押印処理を行う・ダブルクリックで押印（判子・電子印鑑・スタンプ）（テクニック）

EXCEL VBA ダブルクリックをしてワークシートに個人印を押印します。（イベントプロシージャ：WorkSheet Before DoubleClick)　（シート単位）

'
'
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim SetCells As Range
    Dim Rc As Integer
    
    Set SetCells = ActiveCell
    
    Rc = MsgBox("押印しますか？", vbYesNo + vbQuestion, "確認") '押印するか確認
        If Rc = vbYes Then
        
            With Pictures.Insert("C:\Users\akira\OneDrive\デスクトップ\suzuki.png")  '担当印を設定　（デスクトップの位置は環境により異なります。）
                .Top = SetCells.Top
                .Left = SetCells.Left
                .Width = SetCells.Width
            End With
        End If
            
    Set SetCells = Nothing

End Sub
'

EXCEL VBA ダブルクリックをしてワークシート毎に別の角印を押印します。（イベントプロシージャ：WorkBook　Sheet Before DoubleClick)　（ブック単位）

'
'
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    Dim StampPass As String
    Dim SetCells As Range
    Dim Rc As Integer
    
    Set SetCells = ActiveCell
    
    Rc = MsgBox("押印しますか？", vbYesNo + vbQuestion, "確認") '押印するか確認
        If Rc = vbYes Then
        
            If ActiveSheet.Name = "請求書" Then
                    StampPass = "C:\DATA\請求印.png"
               ElseIf ActiveSheet.Name = "領収書" Then
                    StampPass = "C:\DATA\領収印.png"
               Else
                    MsgBox "該当するシートが選択されていません。"
                    Exit Sub
            End If
            
        
            With ActiveSheet.Pictures.Insert(StampPass)  '角印を設定
                .Top = SetCells.Top
                .Left = SetCells.Left
                .Width = SetCells.Width
            End With
        End If
            
    Set SetCells = Nothing

End Sub
'

EXCEL VBA ダブルクリックをして登録されている氏名に応じて自動的に個人印を押印します。（イベントプロシージャ：WorkBook　Sheet Before DoubleClick)　（複数印鑑）

'
'
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)

    Dim StampPass As String
    Dim SetCells As Range
    Dim Rc, L As Integer
    
    Set SetCells = ActiveCell  'アクティブセルをセットします。
    
    L = SetCells.Row 'アクティブセルの行番号取得
    
    Rc = MsgBox(ActiveSheet.Cells(L, "F") & "の押印しますか？", vbYesNo + vbQuestion, "確認") '押印するか確認
        If Rc = vbYes Then
            
            Select Case ActiveSheet.Cells(L, "F") 'F列の登録されている氏名から印影パスを取得します。
            
                Case "竈門炭治郎"
                    StampPass = "C:\DATA\竈門.png"
                
                Case "嘴平伊之助"
                    StampPass = "C:\DATA\嘴平.png"
                
                Case "煉獄杏寿郎"
                    StampPass = "C:\DATA\煉獄.png"
                
                Case "甘露寺蜜璃"
                    StampPass = "C:\DATA\甘露寺.png"
                    
                Case "胡蝶しのぶ"
                    StampPass = "C:\DATA\胡蝶.png"
                
                Case Else
                    MsgBox "登録されていない氏名が入力されています。"
                    Exit Sub
            
            End Select
        
            With ActiveSheet.Pictures.Insert(StampPass)  '該当する個人印を押印
                .Top = SetCells.Top
                .Left = SetCells.Left
                .Width = SetCells.Width
            End With
        End If
            
    Set SetCells = Nothing

End Sub
'