写真の一括貼り付け処理の流れ

今回は写真一括貼り付け処理の流れを説明していきます。

処理ごとにExcel上でどの様に動いているか画像を貼り付けていきます。

変数の宣言

    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    
    Dim FileName As Variant
    Dim dblscal As Double
    Dim str As String

処理の追加修正を後に行いやすくするため、最初に宣言しています。

写真の一覧を取得

'写真の一覧を取得
FileName = Application.GetOpenFilename( _
    filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
    MultiSelect:=True)
'写真ファイルを選択しなかった場合は処理を終わらせる
If Not IsArray(FileName) Then Exit Sub

キャンセルを押下時は処理が終了します。

処理中画面描写をしない

    Application.ScreenUpdating = False

処理中の過程を表示してしまうと処理速度が遅くなってしまうため、画面描写を行わないようにしています。

印刷範囲の初期設定

str = Range(Cells(1, 1), Cells(60, 16)).Address

原本シートのコピーを末尾に追加

Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)

貼り付ける写真を間違えても追加したシートを削除する事で作り直しが容易にしています。

ボタンを削除

    ActiveSheet.DrawingObjects.Delete

シートを追加するとボタンまでコピーされるためボタンの削除を行います。

取得した写真リストをセルに貼り付け

取得した写真リストの数だけ繰り返し処理を行う

For i = LBound(FileName) To UBound(FileName)

取得した写真のリスト分だけ繰り返し処理を行います。

5枚選択したら5回、10枚選択したら10回

写真のリストの数が3で割って余りが1になったら処理を行う

If i <> 1 And i Mod 3 = 1 Then

1ページに写真を3枚貼ったら次のページに設定を行うための判定です。

印刷範囲の初期設定のエリアをコピー

Worksheets("原本").Range(str).Copy

次の写真を貼り付けるためのエリアを貼り付け

Cells(k - 1, 1).PasteSpecial

コピーした領域を解放

Application.CutCopyMode = False

改ページの挿入

ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)

判定の終了

End If

写真を貼り付ける位置を設定

Cells(k, j).Select

写真の貼り付け

        With ActiveSheet.Shapes.AddPicture( _
            FileName:=FileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left, _
            Top:=ActiveCell.Top, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With

写真の貼り直し

        ActiveSheet.Shapes(i).Select
        Selection.Cut
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False

Noに何枚目か数を入力

Cells(k, j + 13) = i

次のセルの位置を設定する

k = k + 20

次の写真を選択

Next i

上の繰り返し処理に戻る。

写真の枚数を-1する

i = i - 1

繰り返し処理が終わったときは写真の枚数+1になっているため-1する。

選択しているセルの位置も1つ前に戻す

k = k - 20

写真の枚数を3で割って余りの数により処理を変更

    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select

印刷範囲の設定

ActiveSheet.PageSetup.PrintArea = str

写真のズレを修正

    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10

画面描写を実行

Application.ScreenUpdating = True

上記の処理で写真のズレを修正までの内容が画面上に描画されます。

処理全体の内容

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    
    Dim FileName As Variant
    Dim dblscal As Double
    Dim str As String
  
    '写真の一覧を取得
    FileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '写真ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(FileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(FileName) To UBound(FileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        Cells(k, j).Select
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            FileName:=FileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left, _
            Top:=ActiveCell.Top, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
        
    i = i - 1
    k = k - 20
    
    '印刷範囲を設定
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    
    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

今回は処理の全体を説明させて頂きました。

これだけの処理内容ではまだ自動化と呼べないので次回は機能の追加を行っていきます。