書斎仮想化

主にプログラムに関連した記事を投稿していきます。なるべく素早く導入して頂けるよう、独自の粒度で情報をまとめることをモットーに記事を執筆しております。

Excelのセルをダブルクリックしてその位置にスクリーンショット画像を貼り付けるコピペ

はじめに

開発環境

コピペ場所

VBA Projectの任意の場所にコピーしてお使いください。

例)VBA Project > Microsoft Excel Objects > Sheet1 (Sheet1)に貼り付けるなど

f:id:readyhawker:20180617011233j:plain

ポイント

動作

結論

コピペ内容

' セルのクリックイベント
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ' 画像貼り付け
    Call fromClipBoardToCellPasteAction
End Sub

' クリップボードから画像をセルに貼り付け
Sub fromClipBoardToCellPasteAction()
    ' 変数宣言
    ' リサイズ値
    Dim reSize As Integer
    
    ' 変数設定
    reSize = 600
    
    ' クリップボードの内容が画像か判定する
    If isImg = False Then
        MsgBox "画像ではありません"
        Exit Sub
    End If
    
    ' クリップボードから画像をセルに貼り付け
    Call fromClipBoardToCellPaste(reSize)
End Sub

' クリップボードから画像をセルに貼り付け
Function fromClipBoardToCellPaste(ByVal reSize As Integer)
    ' 変数宣言
    ' 画像リサイズの縦と横
    Dim reSizeW As Integer
    Dim reSizeH As Integer
    
    ' 変数設定
    reSizeW = 0
    reSizeH = 0

    ' 貼り付け
    ActiveCell.PasteSpecial

    ' 画像リサイズ
    With Selection
        ' リサイズ値を算出(短辺を指定のサイズに設定し、長編の比率を合わせる)
        If (.Width <= .Height) Then
            reSizeW = reSize
            reSizeH = .Height * (reSizeW / .Width)
        Else
            reSizeH = reSize
            reSizeW = .Width * (reSizeH / .Height)
        End If
        
        ' リサイズ値の設定
        .Width = reSizeW
        .Height = reSizeH
    End With

    ' 画像配置調整
    With Selection
        '選択セルの左端から10ピクセル移動
        .Left = ActiveCell.Left + 10
        '選択セルの上端から10ピクセル移動
        .Top = ActiveCell.Top + 10
    End With

    ' 画像編集(枠線追加)
    With Selection.ShapeRange.line
        '枠線表示
        .Visible = msoTrue
        '枠線幅指定1ピクセル
        .Weight = 1
    End With
End Function

' クリップボードの内容が画像か確認する
Function isImg() As Boolean
    ' 変数宣言
    'クリップボードのデータ形式を確認・表示します。
    Dim tempObject As Variant
    Dim i As Long
    
    ' 結果
    Dim result As Boolean

    ' 変数設定
    result = False

    ' クリップボードオブジェクトを取得する
    tempObject = Application.ClipboardFormats

    ' クリップボードが空か判定する
    If tempObject(1) = -1 Then
        isImg = False
        Exit Function
    End If

    ' クリップボードの内容を確認
    For i = 1 To UBound(tempObject)
        Select Case tempObject(i)
            ' スクリーンショットはbitmap
            Case xlClipboardFormatBitmap
                result = True
            Case Else
                
        End Select
    Next
    isImg = result
End Function

出力結果

f:id:readyhawker:20180617012538j:plain

テストでのハードコピー系エビデンスの取得にどうぞ。