報告書の作成で写真の貼り付ける場合は撮影した日時を記載する事が多いため、写真データから撮影日の取得機能を追加致しました。
写真の撮影日を日程の隣のセルに表示する様に設定
撮影日が日程の隣のセルに表示されています。
写真を複数枚選択しても写真毎に撮影日を取得
選択しているファイルの撮影日が表示されています。
写真貼り付けの処理（撮影日を取得を追加）
Sub 写真張り付け_Click()
'ループ関数を設定
Dim i As Integer, j As Integer, k As Integer
'写真の一覧を取得
Dim fileName As Variant
Dim dblscal As Double
Dim str As String
'←--------追加
Dim day As Date
Dim ObjShell As Object
Dim ObjFolder As Object
Dim filePath As Variant
Dim file As Variant
'---------->
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
'←--------追加
'シェルの機能の参照
Set ObjShell = CreateObject("Shell.Application")
'-------→
'取得した写真リストをセルに貼り付け
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
'選択ファイル
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
Cells(k, j).Select
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
Application.CutCopyMode = False
'Noに数を記入
Cells(k, j + 13) = i
'←------追加
'ファイルのパスを取得
filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
'ファイル名の取得
file = Mid(fileName(i), Len(filePath) + 1)
'写真のデータを参照
Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)
'写真の撮影日を取得
day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
'写真のデータの参照を解放
Set ObjFolder = Nothing
Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
'-------→
'次のセルの位置を設定する
k = k + 20
Next i
'←--------追加
'シェルの解放
Set ObjShell = Nothing
'-------→
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処理の追加部分は←—-追加と表記しています。
次回は追加部分の処理の説明を行います。
EXCEL VBA 業務の自動化を目指す 