「食っちゃ寝システム第一弾」（3）：写真Exif編集アプリver500(１)
「食っちゃ寝システム第一弾」（3）：中間報告
ついぞサボって、沖縄に行ってしまいました＾＾
1．食っちゃ寝システムに向けて
「食っちゃ寝システム第一弾」に関連して、活動したこと...
・・・あまり進んでないです。
なんか、ひたすらVBAを組んでいたばっかりでした。ただそこでいろいろと身に着けたことがあるので備忘録として記録します
2．作成したもの備忘録
この間、大量に撮った写真を自動で整理できなかと思いVBA組んだ内容整理します。
（将来的にはPythonで一元化予定）
①写真を自動分別⇒リスト作成する
写真からExif情報を読み出し、その内容からフォルダ作成⇒ファイルリネーム⇒リサイズ⇒Exif編集行うもの作りました。将来的にはPythonでプログラム部分は作成し、エクセルに流し込む形で作り直しとします。(いろんな機能付加しましたが、今回はGPS情報用見出しから⇒リスト作成まで)
＜事前準備＞
①Exif情報読込には、以下のサイトのクラスモジュールを拝借しインポート。
↓クラスモジュールとしてインポート
②縮小には「縮小専用」をShellオブジェクト⇒コマンドラインから読出す形で対応。そのため同フォルダに縮小専用.exeを入れます。
③Exif情報についての学習
Exchangeable image file format（エクスチェンジャブル・イメージ・ファイル・フォーマット）は、富士フイルムが開発し、当時の日本電子工業振興協会 (JEIDA)で規格化された、写真用のメタデータを含む画像ファイルフォーマット。デジタルカメラの画像の保存に使われる。略称はExifで「エグジフ」（もしくは「イグジフ」）。
カメラの機種や撮影時の条件情報を画像に埋め込んでいて、ビューワやフォトレタッチソフトなどで応用することができる。Exif2.2ではExif Printという規格を組み込んでおり、撮影時の条件情報を元に自動的に最適化を行って、的確な状態でプリント出力を可能にしている。また撮影者や著作権情報、コメントなど付随することが出来る。
Exifのタグ一覧(以下参照)
今回は、限定的な情報の読込のみとクラスモジュールがあるので特別タグを覚える必要はありませんでしたが。次のステップでExif編集する場合必要になります。
④VBAからコマンドライン操作
VBAから、値を渡して、他のアプリ開いて使用することができます。
１）プログラムの動作説明
＜リスト作成部分のコード＞
Pythonで書くとき再整理します
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Public ckCurrentRow As Long
Public pkupFolder As String
Public pkupPath As String
Sub フォルダ内のファイル確認()
'画像確認用のマクロです。
Dim SrcName As String, ReExif, i, FolderPath, ckCurrentRow
Dim pkupPath As String
Dim pkupJpegFile, ctFile, IntoPath, IntoPicture
i = ActiveCell.Row
If (Range("K" & i) = "" Or i < 10) Then
i = 10
Else
If (Range("J" & i) = "") Then
MsgBox "フォルダ名が不正です"
Exit Sub
End If
End If
'データの格納
ckFolder.Folder_1 = ThisWorkbook.Path & Range("J8") & Range("J" & i)
If Dir(ckFolder.Folder_1, vbDirectory) = "" Then
MsgBox "フォルダがありません(直接フォルダ選択してください)"
ckFolder.Folder_1 = ""
ElseIf Dir(ckFolder.Folder_1 & "\*.Jpg", vbDirectory) = "" Then
MsgBox "ファイルがありません(直接フォルダ選択してください)"
ckFolder.Folder_1 = ""
Else
With ckFolder.FileList
pkupJpegFile = Dir(ckFolder.Folder_1 & "\*.Jpg")
Do While pkupJpegFile <> ""
ctFile = ctFile + 1
.AddItem pkupJpegFile
pkupJpegFile = Dir()
Loop
End With
ckFolder.ctFile_3 = ctFile
End If
'読み込みデータの初期化
ckFolder.ckPhotoPath_1 = ""
ckFolder.ckPhotoPath_2 = ""
ckFolder.ckPhotoPath_3 = ""
ckFolder.ckPhotoPath_4 = ""
ckFolder.ckPhotoPath_5 = ""
ckFolder.ckPhotoPath_6 = ""
ckFolder.ckPhotoPath_7 = ""
ckFolder.ckPhotoPath_8 = ""
ckFolder.ckPhotoPath_9 = ""
ckFolder.ckPhotoPath_10 = ""
ckFolder.ckPhotoPath_11 = ""
ckFolder.ckPhotoPath_12 = ""
ckFolder.Rename_1 = ""
ckFolder.Rename_2 = ""
ckFolder.Rename_3 = ""
ckFolder.Rename_4 = ""
ckFolder.Rename_5 = ""
ckFolder.Rename_6 = ""
ckFolder.Rename_7 = ""
ckFolder.Rename_8 = ""
ckFolder.Rename_9 = ""
ckFolder.Rename_10 = ""
ckFolder.Rename_11 = ""
ckFolder.Rename_12 = ""
ckFolder.ckPhotoImage_1.Picture = LoadPicture("")
ckFolder.ckPhotoImage_2.Picture = LoadPicture("")
ckFolder.ckPhotoImage_3.Picture = LoadPicture("")
ckFolder.ckPhotoImage_4.Picture = LoadPicture("")
ckFolder.ckPhotoImage_5.Picture = LoadPicture("")
ckFolder.ckPhotoImage_6.Picture = LoadPicture("")
ckFolder.ckPhotoImage_7.Picture = LoadPicture("")
ckFolder.ckPhotoImage_8.Picture = LoadPicture("")
ckFolder.ckPhotoImage_9.Picture = LoadPicture("")
ckFolder.ckPhotoImage_10.Picture = LoadPicture("")
ckFolder.ckPhotoImage_11.Picture = LoadPicture("")
ckFolder.ckPhotoImage_12.Picture = LoadPicture("")
ckFolder.ckConfirm_1 = False
ckFolder.ckConfirm_2 = False
ckFolder.ckConfirm_3 = False
ckFolder.ckConfirm_4 = False
ckFolder.ckConfirm_5 = False
ckFolder.ckConfirm_6 = False
ckFolder.ckConfirm_7 = False
ckFolder.ckConfirm_8 = False
ckFolder.ckConfirm_9 = False
ckFolder.ckConfirm_10 = False
ckFolder.ckConfirm_11 = False
ckFolder.ckConfirm_12 = False
ckFolder.Show
End Sub
Sub フォルダ内写真データ取込み()
Dim ckend, ckCancel, pkupFolder As String
'オートフィルタ絞込解除
With ActiveSheet
If .FilterMode Then .ShowAllData
End With
'初期値設定 初期値は最終行 ただし10より小さい値の場合 10から
ckCurrentRow = Cells(Rows.Count, 2).End(xlUp).Row
If (ckCurrentRow < 9) Then
ckCurrentRow = 9
Else
End If
'フォルダ名初期化
pkupFolder = ""
ckend = MsgBox("元写真フォルダ読込", vbYesNoCancel)
If (ckend = vbYes) Then
'フォルダ名取込み
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
pkupFolder = .SelectedItems(1)
End If
End With
'フォルダ内の写真読込
Call フォルダ内Jpeg読込(pkupFolder)
Call 入力準備 '事前準備
Call 地域区分 '事前準備
ElseIf (ckend = vbNo) Then
MsgBox "既存リストの更新します"
If (Range("B10") = "") Then
Exit Sub
Else
Call 入力準備 '事前準備
Call 地域区分 '事前準備
End If
ElseIf (ckend = vbCancel) Then
End If
ckend = MsgBox("ファイルリネーム＆フォルダー格納", vbYesNoCancel)
If (ckend = vbYes) Then
Call 写真リネーム格納 '実際のリネーム格納
ElseIf (ckend = vbNo) Then
Else
ckCancel = MsgBox("リストデータを削除してやり直します。", vbYesNo)
If (ckCancel = vbYes) Then
Range("A10:M10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Else
Exit Sub
End If
End If
End Sub
Sub フォルダ内Jpeg読込(pkupFolder As String)
Dim pkupPath As String
Dim pkupJpegFile
pkupPath = ""
pkupJpegFile = ""
pkupJpegFile = Dir(pkupFolder & "\*.Jpg")
Do While pkupJpegFile <> ""
ckCurrentRow = ckCurrentRow + 1
Cells(ckCurrentRow, 2) = pkupFolder & "\" & pkupJpegFile
pkupJpegFile = Dir()
Loop
pkupJpegFile = Dir(pkupFolder & "\*.Jpeg")
Do While pkupJpegFile <> ""
ckCurrentRow = ckCurrentRow + 1
Cells(ckCurrentRow, 2) = pkupFolder & "\" & pkupJpegFile
pkupJpegFile = Dir()
Loop
End Sub
Sub 入力準備()
'写真情報取込み出力
On Error Resume Next ' エラー時は強制で次に以降
Dim ER '＜－－インスタンス Exif用クラスより入手
Dim ctRow, i As Long
Dim nameID, pkupDate, ckDate, ckDate1 As String
Dim nameArea, nameFolder, pkupArea, ckCategory As String
Dim pkupLon, pkupLat
'名前初期値
nameID = Range("C8")
'GPSクラスインスタンス格納
Set ER = New GPSExifReader
For ctRow = 10 To 20000
FilePath = Range("B" & ctRow)
If (FilePath = "") Then
Exit For
End If
i = i + 1
Range("C" & ctRow) = nameID & i '画像ID
pkupDate = ""
If (Range("A" & ctRow) = "") Then 'チェック欄空欄でのときのみ処理
With ER.Openfile(FilePath) '画像より情報抽出
Range("D" & ctRow) = .DateTimeOriginal '日時
pkupDate = .DateTimeOriginal
ckDate = Replace(pkupDate, ":", "")
ckDate1 = Replace(ckDate, " ", "")
If (ckDate1 = "") Then '日時→日付のみ抽出
Range("G" & ctRow) = "日付無"
Else
Range("G" & ctRow) = Left(ckDate, 8)
End If
Range("E" & ctRow) = .GPSLatitudeDecimal '緯度
Range("F" & ctRow) = .GPSLongitudeDecimal '経度
End With '緯度経度データからエリア作成⇒指定誤差範囲
If (Range("K" & ctRow) = "") Then '事前に入っている値を優先する
If (Range("E" & ctRow) = "" Or Range("F" & ctRow) = "") Then
Range("H" & ctRow) = "地域無" '緯度経度データない場合事前に「地域無」代入
Range("K" & ctRow) = Right(Range("G" & ctRow), 4) & "_" & Range("C" & ctRow) & "_無_無" 'ファイル名⇒日時(4桁)_ID_無_無.jpg
ActiveSheet.Hyperlinks.Add Anchor:=Range("L" & ctRow), Address:="https://www.google.co.jp/maps,ScreenTip:=" & "緯地図", TextToDisplay:="https://www.google.co.jp/maps"
Else
Range("K" & ctRow) = Right(Range("G" & ctRow), 4) & "_" & Range("C" & ctRow) & "_" & Range("E" & ctRow) & "_" & Range("F" & ctRow) 'ファイル名⇒日時(4桁)_ID_緯度_経度.jpg
ActiveSheet.Hyperlinks.Add Anchor:=Range("L" & ctRow), Address:="https://www.google.co.jp/maps/@" & Range("E" & ctRow) & "," & Range("F" & ctRow) & ",72m/data=!3m1!1e3,ScreenTip:=" & Range("E" & ctRow) & "緯度" & Range("F" & ctRow) & "経度地図", TextToDisplay:="https://www.google.co.jp/maps/@" & Range("E" & ctRow) & "," & Range("F" & ctRow) & ",72m/data=!3m1!1e3"
End If
End If
End If
Next ctRow
ER = Nothing
End Sub
Sub 地域区分()
Dim h, i, j, ctArea As Long
Dim ckLatGap, ckLonGap
Dim pkupLat, pkupLon, TmpLat, TmpLon, ckFlag
Dim nameAreaLat, stArea(0 To 2000, 1 To 3) 'stArea(1 To 100, 1 To 3)=基準エリア
Dim newFolder, fPath As String
'固定値入力
ckLatGap = Range("H2")
ckLonGap = Range("H3")
nameArea = Range("H8")
nameTerm = Range("E2")
'親フォルダ確認⇒なければ作成
If Dir(ThisWorkbook.Path & Range("J8"), vbDirectory) = "" Then
MkDir ThisWorkbook.Path & Range("J8")
Else
End If
'初期設定
TmpLatGap = ckLatGap '仮の中心緯度<絶対値>
TmpLonGap = ckLonGap '仮の中心経度<絶対値>
ctArea = 1
stArea(0, 1) = nameArea_0
stArea(0, 2) = ckLatGap
stArea(0, 3) = ckLonGap
For i = 10 To 20000
FilePath = Range("B" & i)
If (FilePath = "") Then
Exit For
End If
If (Range("E" & i) = "" Or Range("F" & i) = "") Then '"地域無"はスキップ
Else
pkupLat = Range("E" & i)
pkupLon = Range("F" & i)
'なければ過去分中から検索⇒それでもなければ新しいエリア作成
ckFlag = 0
For j = 0 To ctArea
TmpLatGap = Abs(pkupLat - stArea(j, 2)) '差分の絶対値
TmpLonGap = Abs(pkupLon - stArea(j, 3)) '差分の絶対値
If (TmpLatGap <= ckLatGap And TmpLonGap <= ckLatGap) Then 'エリア内にいる場合値入力ない場合新しいエリア作成,ckFlag=1でエリアあり判定
Range("H" & i) = stArea(j, 1)
ckFlag = 1
Exit For
End If
Next j
' ckFlag=0⇒新しいエリア作成
If (ckFlag = 0) Then
ctArea = ctArea + 1
'緯度経度データからエリア作成⇒指定中心位置誤差範囲小数2桁間で表示
If (pkupLat >= 0) Then
nameAreaLat = "N" & Int(Abs(pkupLat)) & "@" & Int*1 & "@" & Int*2 & "@" & Int*3 & "@" & Int*4 - Len(Replace(Range("J" & i), "\", ""))
If (ctFolderLyer > 2) Then
Exit Sub
End If
'フォルダ無い場合作成
'2層目フォルダ確認
ckFolder = Mid(Range("J" & i), 2)
If (ctFolderLyer = 1) Then
ckFolder1 = ckFolder
If Dir(ThisWorkbook.Path & Range("J8") & "\" & ckFolder1, vbDirectory) = "" Then
MkDir ThisWorkbook.Path & Range("J8") & "\" & ckFolder1
End If
ElseIf (ctFolderLyer = 2) Then
ckFolder1 = Left(ckFolder, InStr(ckFolder, "\") - 1)
ckFolder2 = Replace(Range("J" & i), "\" & ckFolder1 & "\", "")
'3層目フォルダ確認
If Dir(ThisWorkbook.Path & Range("J8") & "\" & ckFolder1, vbDirectory) = "" Then
MkDir ThisWorkbook.Path & Range("J8") & "\" & ckFolder1
End If
If Dir(ThisWorkbook.Path & Range("J8") & "\" & ckFolder1 & "\" & ckFolder2, vbDirectory) = "" Then
MkDir ThisWorkbook.Path & Range("J8") & "\" & ckFolder1 & "\" & ckFolder2
End If
End If
'フォルダ格納設定⇒JPGで格納
Target = TargetFolder & "\" & Range("k" & i) & ".jpg"
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End If
'確認のマーカー及びリンクの作成
Range("A" & i) = "●"
Range("I" & i) = "★"
ActiveSheet.Hyperlinks.Add Anchor:=Range("I" & i), Address:=TargetFolder
Next i
'罫線を引き直す
If (Range("B10") = "") Then
Else
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
End If
'写真リサイズ
If (ckResize = "有") Then
Call 写真データリサイズ
End If
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
⇒写真Exif編集アプリver500(２)へ
*1:Abs(pkupLat) - Int(Abs(pkupLat))) * 100)
ElseIf (pkupLat < 0) Then
nameAreaLat = "S" & Int(Abs(pkupLat
*2:Abs(pkupLat) - Int(Abs(pkupLat))) * 100)
End If
If (pkupLon >= 0) Then
nameAreaLon = "E" & Int(Abs(pkupLon
*3:Abs(pkupLon) - Int(Abs(pkupLon))) * 100)
ElseIf (pkupLon < 0) Then
nameAreaLon = "W" & Int(Abs(pkupLon
*4:Abs(pkupLon) - Int(Abs(pkupLon))) * 100)
End If
stArea(ctArea, 1) = nameAreaLat & nameAreaLon
stArea(ctArea, 2) = pkupLat
stArea(ctArea, 3) = pkupLat
Range("H" & i) = nameAreaLat & nameAreaLon
End If
End If
'仮フォルダ名格納
If (nameTerm = "年") Then
Range("J" & i) = "\" & Left(Range("G" & i), 4) & "\" & Range("H" & i)
ElseIf (nameTerm = "月") Then
Range("J" & i) = "\" & Left(Range("G" & i), 6) & "\" & Range("H" & i)
Else
Range("J" & i) = "\" & Range("G" & i) & "\" & Range("H" & i)
End If
Next i
End Sub
Sub 写真リネーム格納()
Dim i, ctFolderLyer As Long
Dim ckResize, ckRename, ckStroged, ckFolder As String
Dim ResultRename, FilePath, Target, TargetFolder, FolderName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
ckResize = Range("E4")
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'親フォルダ確認(1層目),フォルダ無い場合直下に作成
If (Range("J8") = "") Then
'親フォルダない場合、無しのまま作成⇒もし"\"が先頭にない場合、\を追加
ElseIf (Left(Range("J8"), 1) <> "\") Then
Range("J8") = "\" & Range("J8")
Else
End If
If Dir(ThisWorkbook.Path & Range("J8"), vbDirectory) = "" Then
MkDir ThisWorkbook.Path & Range("J8")
Else
End If
For i = 10 To 20000
'ファイル元パスがない場合終了
FilePath = Range("B" & i)
If (FilePath = "") Then
Exit For
End If
'ファイルの保存先ファイル名がない場合及び確認にチェックがついている場合はスキップ
ckStroged = Range("A" & i)
ResultRename = Range("K" & i)
If (ckStroged = "●" Or ResultRename = "") Then
'リネームコピーせずにスキップ
Else
'フォルダ名に"\"ない場合追記
FolderName = Range("J" & i)
If (Left(FolderName, 1) <> "\") Then
FolderName = "\" & FolderName
End If
'\\の場合は\へ
Range("J" & i) = Replace(FolderName, "\\", "\")
TargetFolder = ThisWorkbook.Path & Range("J8") & Range("J" & i)
'フォルダがない場合直下を格納場所に指定 三層まで \⇒3つ不可
ctFolderLyer = Len(Range("J" & i
