色んな現場で毎回作るいつもの画像貼り付けマクロ。

画像貼り付けマクロ

日本中どこでもやっている、画面スクショぺたぺたするアレ。

某エンジニアじゃなくても適応障害発症するほどクソだるい仕事で、可能な限り回避したいが回避しきれない事もある。

そういう時はWinShot先生でjpeg撮り溜めつつ、マクロでぺたぺたやっていくのは良くやる事。

と言う事で、いつも作る画像貼り付けマクロのコードをここにメモっておく。

Option Explicit

Public Sub DoMain()
    
    '// 開始位置を取得。
    Dim sheet As Worksheet
    Set sheet = ActiveWorkbook.ActiveSheet
    
    '// 拡縮してるとバグるバージョンがあるので、等倍表示にしておく。
    ActiveWindow.Zoom = 100
    
    
    '// 開始位置としてカレントセルを取得。
    Dim row As Long
    Let row = ActiveCell.row
    Dim col As Long
    Let col = ActiveCell.Column
    
    
    
    '// 画像ファイル選択（複数選択）
    Dim files As Variant
    files = Application.GetOpenFilename(FileFilter:="画像ファイル,*.png;*.jpg;*.jpeg", MultiSelect:=True)
    
    '// cancel
    If VarType(files) = vbBoolean Then
       Exit Sub
    End If
       
    
    '// 画像貼り付け
    Dim itor As Variant
    For Each itor In files
    
        Dim path As String
        path = itor
        
        '// 貼り付け先の位置を算出。
        Dim cell As Range
        Set cell = sheet.Cells(row, col)
        
        cell.Value = " " '// 貼り付け位置にスペース仕込んでおく。
        
        '// セルの座標を基準に張り付ける（※なんかこの環境だと１ドットくらい補正した方がいいくさい）
        Dim x As Long
        Dim y As Long
        x = 1 + cell.Left
        y = 1 + cell.Top
    
        '// 画像の貼り付け。
        Dim height As Long
        height = Paste(path, sheet, x, y)
        
        
        '// 行シーク。
        row = NextRow(height, row)
        
        '// 次の画像まで２行くらいあけておく。
        row = row + 2
        
        Set cell = Nothing
    Next
    
    Set sheet = Nothing
    Set files = Nothing
End Sub

上記メインメソッドから呼び出しているメソッドは以下の通り。

Private Function Paste(path As String, sheet As Worksheet, x As Long, y As Long) As Long

    '// サイズ指定なしで貼り付け。
    Dim picture As Shape
    Set picture = sheet.Shapes.AddPicture(path, msoFalse, msoTrue, x, y, 0, 0)
    
    '// 比率を当倍率に変更。
    picture.LockAspectRatio = msoTrue
    Call picture.ScaleHeight(1!, msoTrue)
    
    '// 画像の高さを返す。
    Dim h As Double
    h = picture.height
    
    Paste = h
    
End Function

Private Function NextRow(h As Long, r As Long)
    Dim dy As Double
    dy = 0#
    
    Do While dy < h
    
        Dim row As Range
        Set row = ActiveWorkbook.ActiveSheet.Rows(r)
        
        If row.Hidden Then
        Else
        
            Dim y As Double
            y = row.RowHeight
            dy = dy + y
            
        End If
        
        r = r + 1
        
        Set row = Nothing
        
        '// TODO：最大値制御を入れたいが、とりあえず無視。
    Loop
    
    '// 画像の高さ分を超えたら行番号を返す。
    NextRow = r
End Function

まぁ、マクロ（VB6ベース）だと「メソッド」とは言わないけどね・・・。