「食っちゃ寝システム第一弾」（４）：写真Exif編集アプリver500(２)
「食っちゃ寝システム第一弾」（４）：中間報告
②自動分別した写真の確認
写真Exif編集アプリver500は読出した写真を実際開いて確認する機能も追加しました。
１）プログラムの動作説明
これに関して、特別な工夫はなくフォーム上にイメージを１２個起き、１２個ずつ表示切り替え確認出来るようにしたものです。これに関して新しく学んだことはないのですが。もっと軽く動作できるようにしていくこと思案中です。
＜写真確認部のコード＞
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub ckPhotoPath_1_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_1, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_1 = newName
End Sub
Private Sub ckPhotoPath_2_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_2, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_2 = newName
End Sub
Private Sub ckPhotoPath_3_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_3, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_3 = newName
End Sub
Private Sub ckPhotoPath_4_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_4, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_4 = newName
End Sub
Private Sub ckPhotoPath_5_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_5, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_5 = newName
End Sub
Private Sub ckPhotoPath_6_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_6, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_6 = newName
End Sub
Private Sub ckPhotoPath_7_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_7, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_7 = newName
End Sub
Private Sub ckPhotoPath_8_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_8, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_8 = newName
End Sub
Private Sub ckPhotoPath_9_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_9, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_9 = newName
End Sub
Private Sub ckPhotoPath_10_Click()
Dim ckReuse, oldName As String
oldName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_10, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
ckFolder.Rename_1 = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
ckFolder.Rename_1 = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
ckFolder.Rename_10 = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
End Sub
Private Sub ckPhotoPath_11_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_11, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_11 = newName
End Sub
Private Sub ckPhotoPath_12_Click()
Dim ckReuse, oldName, newName As String
oldName = ""
newName = ""
ckReuse = MsgBox("元のファイル名利用しますか?", vbYesNoCancel)
oldName = Replace(ckFolder.ckPhotoPath_12, ".jpg", "")
If (ckReuse = vbCancel) Then
ElseIf (ckReuse = vbYes) Then
MsgBox "元ファイル名" & oldName & "_をコピーします"
newName = oldName & "_.jpg"
Else
If (ckFolder.CoWordReName_2.Value = True) Then
newName = ckFolder.CoWordReName_1 & ckFolder.CoWordReName_3 & ".jpg"
ckFolder.CoWordReName_3 = ckFolder.CoWordReName_3 + 1
Else
newName = ckFolder.CoWordReName_1 & ".jpg"
End If
End If
ckFolder.Rename_12 = newName
End Sub
Private Sub CloseButton_Click()
Unload ckFolder
End Sub
Private Sub Folder1_Click()
Dim LoadFile As String
Dim GetFilePath As String
LoadFile = MsgBox("新規ファイル読込みます", vbOKCancel)
If (LoadFile = vbNo) Then
Exit Sub
Else
ChDir ActiveWorkbook.Path
GetFilePath = Application.GetOpenFilename _
("jpg画像,*.jpg;*.jpeg", , "画像の選択", , False)
End If
ExifModify.Exif_Path = GetFilePath
ExifModify.Exif_Image.Picture = LoadPicture(GetFilePath)
End Sub
Private Sub cmShowPhoto_Click()
Dim LoadPhotos As String
LoadPhotos = MsgBox("写真読込表示します", vbYesNoCancel)
'読み込みデータの初期化
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
End Sub
Private Sub Folder_1_Click()
Dim LoadFile As String
Dim GetFilePath As String
Dim pkupFolder
LoadFile = MsgBox("新規フォルダ読込みます", vbOKCancel)
If (LoadFile = vbNo) Then
Exit Sub
Else
ckFolder.FileList.Clear
ChDir ActiveWorkbook.Path
'フォルダ名取込み
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
pkupFolder = .SelectedItems(1)
End If
End With
End If
ckFolder.Folder_1 = pkupFolder
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_1 = ""
ckFolder.ctFile_2 = ""
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
End Sub
Private Sub GotoBack_Click()
On Error GoTo Skip
'読み込みデータの初期化
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
If (ckFolder.ctFile_1 = "") Then
ckFolder.ctFile_1 = 1
If (ckFolder.ctFile_3 > 12) Then
ckFolder.ctFile_2 = 12
Else
ckFolder.ctFile_2 = ckFolder.ctFile_3
End If
ElseIf (ckFolder.ctFile_1 - 12 < 1 And ckFolder.ctFile_2 = ckFolder.ctFile_3) Then
MsgBox "フォルダ内ファイル数は" & ckFolder.ctFile_3 & "です"
ElseIf (ckFolder.ctFile_1 - 12 > 1 And ckFolder.ctFile_2 = ckFolder.ctFile_3) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 - 12
ckFolder.ctFile_2 = ckFolder.ctFile_1 + 11
ElseIf (ckFolder.ctFile_1 - 12 > 1 And ckFolder.ctFile_2 = ckFolder.ctFile_1 + 11) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 - 12
ckFolder.ctFile_2 = ckFolder.ctFile_2 - 12
ElseIf (ckFolder.ctFile_1 - 12 = 1 And ckFolder.ctFile_2 = ckFolder.ctFile_1 + 11) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 - 12
ckFolder.ctFile_2 = ckFolder.ctFile_2 - 12
ElseIf (ckFolder.ctFile_1 - 12 = 1 And ckFolder.ctFile_2 = ckFolder.ctFile_3) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 - 12
ckFolder.ctFile_2 = ckFolder.ctFile_1 + 11
End If
On Error Resume Next
j = 0
For i = ckFolder.ctFile_1 - 1 To ckFolder.ctFile_2 - 1
j = j + 1
fPath = Folder_1 & "\" & ckFolder.FileList.List(i)
Me.Controls("ckPhotoPath_" & j) = ckFolder.FileList.List(i)
Me.Controls("ckPhotoImage_" & j).Picture = LoadPicture(fPath)
Next i
'リストボックス内検索
If ckFolder.ckPhotoPath_1.Caption = "" Then Exit Sub
For i = 0 To FileList.ListCount - 1
If ckFolder.FileList.List(i) = ckFolder.ckPhotoPath_1.Caption Then
ckFolder.FileList.ListIndex = i
Exit For
End If
Next i
Exit Sub
Skip:
End Sub
Private Sub GotoNext_Click()
Dim i, j, fPath
On Error GoTo Skip
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
If (ckFolder.ctFile_1 = "") Then
ckFolder.ctFile_1 = 1
If (ckFolder.ctFile_3 = "") Then
Exit Sub
ElseIf (ckFolder.ctFile_3 > 12) Then
ckFolder.ctFile_2 = 12
Else
ckFolder.ctFile_2 = ckFolder.ctFile_3
End If
ElseIf (ckFolder.ctFile_2 = "" And ckFolder.ctFile_3 = "") Then
MsgBox "フォルダ内ファイル数は0です"
ElseIf (ckFolder.ctFile_2 = ckFolder.ctFile_3) Then
MsgBox "フォルダ内ファイル数は" & ckFolder.ctFile_3 & "です"
ElseIf (ckFolder.ctFile_1 >= 1 And ckFolder.ctFile_2 + 12 < ckFolder.ctFile_3) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 + 12
ckFolder.ctFile_2 = ckFolder.ctFile_2 + 12
ElseIf (ckFolder.ctFile_1 >= 1 And ckFolder.ctFile_2 + 12 > ckFolder.ctFile_3) Then
ckFolder.ctFile_1 = ckFolder.ctFile_1 + 12
ckFolder.ctFile_2 = ckFolder.ctFile_3
End If
j = 0
For i = ckFolder.ctFile_1 - 1 To ckFolder.ctFile_2 - 1
j = j + 1
fPath = Folder_1 & "\" & ckFolder.FileList.List(i)
Me.Controls("ckPhotoPath_" & j) = ckFolder.FileList.List(i)
Me.Controls("ckPhotoImage_" & j).Picture = LoadPicture(fPath)
Next i
'リストボックス内検索
If ckFolder.ckPhotoPath_1.Caption = "" Then Exit Sub
For i = 0 To FileList.ListCount - 1
If ckFolder.FileList.List(i) = ckFolder.ckPhotoPath_1.Caption Then
ckFolder.FileList.ListIndex = i
Exit For
End If
Next i
Exit Sub
Skip:
End Sub
Private Sub GotoExif_1_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_1
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_2_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_2
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_3_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_3
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_4_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_4
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_5_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_5
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_6_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_6
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_7_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_7
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_8_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_8
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_9_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_9
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_10_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_10
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
End Sub
Private Sub GotoExif_11_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_11
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub GotoExif_12_Click()
If (ckFolder.ckPhotoPath_1 = "") Then
Exit Sub
End If
FilePath = ckFolder.Folder_1 & "\" & ckFolder.ckPhotoPath_12
If Dir(FilePath, vbDirectory) = "" Then
MsgBox "ファイルがありません"
Exit Sub
Else
ExifModify.Exif_Path = FilePath
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
ExifModify.Exif_info1 = ""
ExifModify.Exif_info2 = ""
ExifModify.Exif_info3 = ""
ExifModify.Exif_info4 = ""
ExifModify.Exif_info5 = ""
If (ExifModify.Exif_Path = "") Then
Exit Sub
End If
If (Dir(ExifModify.Exif_Path, vbDirectory) = "") Then
MsgBox "ファイルがありません"
Exit Sub
End If
Set ObjWIA = CreateObject("Wia.ImageFile")
ObjWIA.LoadFile ExifModify.Exif_Path
On Error Resume Next
For Each p In ObjWIA.Properties
i = i + 1
V_ID = p.PropertyID
If p.PropertyID = 2 Then
ExifModify.Exif_info3 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=2=緯度
ElseIf p.PropertyID = 4 Then
ExifModify.Exif_info4 = p.Value(1) + p.Value(2) / 60 + p.Value(3) / 3600 'ID=4=経度
ElseIf p.PropertyID = 272 Then
ExifModify.Exif_info1 = p.Value 'ID=272＝カメラ型番
ElseIf p.PropertyID = 274 Then
ExifModify.Exif_info5 = p.Value 'ID=274＝回転方向
ElseIf p.PropertyID = 36867 Then
ExifModify.Exif_info2 = p.Value 'ID=36867＝撮影時間
End If
Next
On Error GoTo 0
Set ObjWIA = Nothing
ExifModify.Show
End If
End Sub
Private Sub ReNew_Click()
Dim i As Integer
Dim oldPath, newFilename, newPath As String
'新規名称付け直したファイル複製（元ファイルは残します）
End Sub
Private Sub ReNewName_1_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_1
ResultRename = ckFolder.Rename_1
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_2_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_2
ResultRename = ckFolder.Rename_2
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_3_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_3
ResultRename = ckFolder.Rename_3
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_4_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_4
ResultRename = ckFolder.Rename_4
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_5_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_5
ResultRename = ckFolder.Rename_5
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_6_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_6
ResultRename = ckFolder.Rename_6
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_7_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_7
ResultRename = ckFolder.Rename_7
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_8_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_8
ResultRename = ckFolder.Rename_8
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_9_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_9
ResultRename = ckFolder.Rename_9
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_10_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_10
ResultRename = ckFolder.Rename_10
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_11_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_11
ResultRename = ckFolder.Rename_11
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub ReNewName_12_Click()
Dim ResultRename, FilePath, Target, TargetFolder, FileName As String
Dim DateValue As String
' 選択項目入力
ckRename = MsgBox("リネーム格納行います。", vbYesNo)
If (ckRename = vbYes) Then
Else
Exit Sub
End If
On Error Resume Next ' エラー時は強制で次に以降
DateValue = Date
'ファイル元パスがない場合終了
FileName = ckPhotoPath_1
FilePath = ckFolder.Folder_1 & "\" & ckPhotoPath_12
ResultRename = ckFolder.Rename_12
If (FileName = "") Then
Exit Sub
End If
If (ResultRename = "") Then
Exit Sub
End If
If (Right(ResultRename, 4) <> ".jpg") Then
MsgBox "拡張子がjpgではありません"
Exit Sub
End If
'フォルダ格納設定⇒JPGで格納
Target = ckFolder.Folder_1 & "\" & ResultRename
If Dir(Target, vbDirectory) = "" Then
'フォルダ内に重複名がない場合ファイルがない場合そのまま作成
Else
'フォルダ内に重複名がある場合ファイル名に時間とタグをがない場合日時データを付与して複製保存
Target = TargetFolder & "\" & Range("k" & i) & "_" & Format(DateValue, "yyyymmddhhnnss") & "_同名格納" & ".jpg"
End If
FileCopy FilePath, Target
End Sub
Private Sub UserForm_Click()
End Sub
Private Sub UserForm_Initialize()
ckFolder.CoWordReName_3 = 1
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
⇒写真Exif編集アプリver500(３)へ
