VBA使用頻度の高いコード（１１）：罫線を引き直す
罫線を引き直す
罫線を引き直す用コード
票のセインを引き直すとき頻繁に使用
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 罫線を引き直す()
'罫線を引き直す
Range("A9:L9").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders.LineStyle = xlContinuous
End If
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（１０）：フォルダ一括作成
フォルダ一括作成
フォルダ内の特定ファイル読出し用コード
シート上の名称をもとに一括でフォルダ作るコードです
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub フォルダ一括作成()
Dim Path As String '作成予定フォルダの上位パス
Path = ThisWorkbook.Path
Dim i As Long 'フォルダ数カウンタ
For i = 10 To Range("N10").End(xlDown).Row
Dim FolderName As String '作成するフォルダ名
FolderName = Cells(i, 任意の列番号).Value
Dim NewDirPath As String '作成予定のフォルダパス
NewDirPath = Path & "\" & FolderName
'作成予定フォルダと同名のフォルダの存在有無を確認し、存在しない場合フォルダ作成
If Dir(NewDirPath, vbDirectory) = "" Then
MkDir Path & "\" & FolderName
Else
End If
Next i
MsgBox "終了しました。"
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（９）：フォルダ内の特定ファイル読出し
フォルダ内の特定ファイル読出し
フォルダ内の特定ファイル読出し用コード
これはjpg読み出しようです。
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
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
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（８）：インターネットエクスプローラーの起動
インターネットエクスプローラーの起動
インターネットエクスプローラーの起動用コード
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub IEOpen(ByRef MapURL As String)
Dim objIE As Object
Dim waitTime As Variant
Target = MapURL
Set objIE = CreateObject("InternetExplorer.Application")
With objIE
.Top = 0 'Y位置（上下）
.Left = 900 'X位置（左右）
.Width = 800 'IEウィンドウの幅
.Height = 600
'InternetExplorerを表示
.Visible = True
'指定したURLのページを表示する
.navigate Target
'完全にページが表示されるまで待機する
Do While .Busy = True Or .readyState <> 4
DoEvents
Loop
'完全にドキュメントが読み込まれるまで待機する
Do While .document.readyState <> "complete"
DoEvents
Loop
End With
Set objIE = Nothing
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（７）：コマンドラインからアプリ読出し
コマンドラインからアプリ読出し
コマンドラインからアプリ読出し用コード
ここコードは同じ、フォルダ内の「縮小専用」にファイルパスを渡しリサイズする例です。
流れとしては、
事前に貼付用CSVファイル作成
⇒元のシートからファイルパス取出し
⇒Shellオブジェクトにアプリのパスとファイルパス渡す
⇒完了
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 写真データリサイズ()
Dim SrcName As String, Res, i, FilePath, newFolder
newFolder = newFolder & " " & ThisWorkbook.Path & Range("J8") & Range("J" & i) & "\" & Range("k" & i) & ".jpg"
On Error Resume Next
'この例ではBookと同じフォルダにShukuSen.exeがあります。
Res = Shell(ThisWorkbook.Path & "\ShukuSen.exe" & newFolder, vbNormalFocus)
If Err.Number Then
MsgBox "error"
Exit Sub
End If
On Error GoTo 0
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（６）：エクセルシートのCSV出力
エクセルシートのCSV出力
エクセルシートのCSV出力用コード
ここコードはリストから一部の列をTEMPシートに整理しなおして出力するように作っています。
流れとしては、
事前に貼付用CSVファイル作成
⇒元のシートから必要なデータ範囲（ここでは"B9:K2000"）をコピー
⇒「TEMP」シートに内容貼付け
⇒「TEMP」の内容を事前に作成したCSVに貼付け
⇒完了
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub CSV書出し()
Dim FileN, DateValue As String
Dim re As Integer
DateValue = Date
FileN = Application.GetSaveAsFilename(InitialFileName:="GoogleMap出力用_" & Range("C6") & "_" & Format(DateValue, "yyyymmddhhnn") & "_1" & ".csv", _
FileFilter:="ＣＳＶ ファイル (*.csv), *.csv")
'既にある場合の上書き
If FileN <> "False" Then
If Dir(FileN) <> "" Then
re = MsgBox(FileN & String(2, vbLf) & _
"は、存在します。 上書きしますか？", vbYesNo)
'開いているかのチェック
On Error Resume Next
Open FileN For Append As #1
Close #1
If Err.Number > 0 Then
MsgBox "すでに開かれています、閉じてやり直してください"
Exit Sub
End If
If re = vbYes Then Kill FileN
Else
End If
Application.ScreenUpdating = False
Sheets("TEMP").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("画像リスト").Select
'GoogleMyMap1レイヤ2000までなので1990レコードを上限にしています。それ以上は別ファイルで作業して下さい
Range("B9:K2000").Select
Selection.Copy
Sheets("TEMP").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Copy
ActiveWorkbook.SaveAs FileName:=FileN, FileFormat:=xlCSV, Local:=True
ActiveWorkbook.Close SaveChanges:=False
MsgBox "CSVファイルで書き出しました。", vbInformation
End If
Sheets("画像リスト").Select
Application.ScreenUpdating = True
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（５）：エクセルシートのPDF出力
エクセルシートのPDF出力
エクセルシートのPDF出力用コード
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub PDF出力()
'
' PDF出力
'
Dim fPath, pPoint, BaseFilename, CurrentFile As String
'ファイル名
CurrentFile = ActiveWorkbook.Name
pPoint = InStrRev(CurrentFile, ".")
BaseFilename = Left(CurrentFile, pPoint - 1)
fPath = ThisWorkbook.Path & "\【一覧表】" & BaseFilename & Format(Now, "_yyyymmddhhnnss") & ".pdf"
'同名のファイルが存在するか確認
If Dir(fPath, vbNormal) <> "" Then
fPath = ThisWorkbook.Path & "\【一覧表】" & BaseFilename & Format(Now, "_yyyymmddhhnnss") & "_1.pdf"
MsgBox "同名のファイルが存在。別名で保存" & fPath
End If
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=fPath, Quality:=xlQualityMinimum, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（４）：エクセルファイル更新バックアップ
エクセルファイル更新バックアップ
エクセルファイル更新バックアップ用コード
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub データバックアップ更新()
'
Dim backupcheck As String
Dim CurrentPath, CurrentFile, ckBackup As String
Dim pPoint, BaseFilename, newFilename
' エラー時は強制終了
On Error GoTo ErrorProcess
ckBackup = MsgBox("更新バックアップします", vbOKCancel)
If (ckBackup = vbCancel) Then
Exit Sub
End If
' データ更新
ActiveWorkbook.RefreshAll
' 更新時上書き
ActiveWorkbook.Save
' バックアップ
If (ckBackup = vbOK) Then
CurrentPath = ThisWorkbook.Path
CurrentFile = ActiveWorkbook.Name
pPoint = InStrRev(CurrentFile, ".")
BaseFilename = Left(CurrentFile, pPoint - 1)
'ファイル名
newFilename = CurrentPath & "\" & BaseFilename & Format(Now, "_yyyymmddhhnnss") & ".xlsm"
MsgBox (BaseFilename & Format(Now, "_yyyymmddhhnnss") & ".xlsmにバックアップ")
Set objFso = CreateObject("Scripting.FilesystemObject")
objFso.Copyfile CurrentPath & "\" & CurrentFile, newFilename
Set objFso = Nothing
Else
MsgBox ("バックアップ無し")
End If
Exit Sub
ErrorProcess:
MsgBox ("エラー発生、終了します")
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（３）：エクセルシート上の写真カウント
エクセルシート上の写真カウント
シート上の画像のカウント
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 写真カウント()
Dim ctPicture As Double
'写真数カウント
ctPicture = 0
ctPicture = ActiveSheet.Pictures.Count
If PageCount = 0 Then
Exit Sub
End If
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（２）：エクセル上の写真の縮小
エクセル上の写真の縮小
エクセル上の写真を縮小するためのマクロ
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 写真縮小()
ActiveSheet.Unprotect
Dim shp As Shape
Dim x As Double
Dim y As Double
Application.ScreenUpdating = False
If MsgBox("画像データを圧縮しますか？", vbQuestion + vbOKCancel) = vbCancel Then
MsgBox "終了します。"
Exit Sub
End If
'実行継続
For Each shp In ActiveSheet.Shapes
'写真判定
If shp.Type = msoPicture Then
With shp
x = .Left
y = .Top
.Cut
End With
ActiveSheet.PasteSpecial Format:="図 (JPEG)"
With Selection
.Left = x
.Top = y
End With
End If
Next
ActiveSheet.Protect
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
VBA使用頻度の高いコード（１）：５行以上の結合セルに合わせて写真貼付け
５行以上の結合セルに合わせて写真貼付け
結合セルに合わせて写真サイズ修正貼付け用のコードです
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Sub 写真貼付直接()
'===============セル選択＆セル選択エラー判定付(6行以上の結合セルのみ貼り付け)
Dim i As Long, MargeCHK, Celldata As String
Dim PicWidth, PicHeight
Dim Pict As String
Dim CurrentPath1 As String
Dim H_CHK, W_CHK As Double
Dim RotateDirection As Single
ActiveSheet.Unprotect
If TypeName(Selection) = "Range" Then
If Selection.MergeCells Then
If Selection.Rows.Count > 5 Then
'buf = "写真貼付します" & vbCrLf
Else
Exit Sub
End If
Else
Exit Sub
End If
Else
MsgBox "セルを選択してから実行してください。"
Exit Sub
End If
Celldata = Selection.Address
'===============画像選択
ChDir ActiveWorkbook.Path
myF = Application.GetOpenFilename _
("jpg bmp tif png,*.jpg;*.bmp;*.tif;*.png", , "画像の選択", , False)
If myF = False Then
MsgBox "画像を選択してください(終了)"
Exit Sub
End If
'===============画像表示サイズを75％へ
ActiveWindow.Zoom = 75
'===============セルサイズを計算
PicWidth = Selection.Width
PicHeight = Selection.Height
'===============画像の貼り付け
With ActiveSheet.Pictures.Insert(Filename:=myF)
.CopyPicture 'クリップボードにコピー
.Delete '画像をいったん削除
End With
ActiveSheet.Paste '画像を貼り付け
Selection.Name = "Pic" & Format(Now, "yyyymmddhhnnss")
Pict = Selection.Name
'===============セルサイズに合わせて変更+回転方向判定:90度回転の場合横に引き延ばす
RotateDirection = ActiveSheet.Shapes(Pict).Rotation
If RotateDirection = 0 Or RotateDirection = 180 Then
W_CHK = PicWidth
H_CHK = PicHeight
Else
W_CHK = PicHeight
H_CHK = PicWidth
End If
With ActiveSheet.Shapes(Pict)
.LockAspectRatio = msoFalse
.Placement = xlFreeFloating
.Placement = xlMove
.Top = Range(Celldata).Top
.Left = Range(Celldata).Left
.Width = W_CHK
.Height = H_CHK
End With
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
「食っちゃ寝システム第一弾」（５）：写真Exif編集アプリver500(３)
「食っちゃ寝システム第一弾」（５）：中間報告
②写真のExif情報確認／編集
写真Exif編集アプリver500は読出した写真をExif情報確認／編集機能つけました
１）プログラムの動作説明
ここに関しては、練習用にWIAを使ってみました。
直訳通り、ウィンドウズのイメージ取得用のオブジェクトで
歴史は意外に古くWindowsME(２０００年から）ある機能です
Wia object - Windows applications | Microsoft Docs
Windows Image Acquisition - Wikipedia
使う前の準備として、先にVBAエディタからツール⇒参照設定
⇒Windows Image Acquisitionにチェック入れてください
尚、Exif編集に関しては、今回は自分で作らず。フリーウェア「F6Exif」をコマンドラインで値渡し起動させることで一応対応しています。（縮小専用を外部操作するのと同じ手法です）そのため事前にF6Exif.exeを同一フォルダに格納しています
＊コードとしては以下の部分で対応しています
Res = Shell(ThisWorkbook.Path & "\F6Exif.exe" & ExifTarget, vbNormalFocus)
＜Exif確認編集部のコード＞
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
Private Sub Exif_Com1_Click()
Dim MapURL As String
MapURL = "https://www.google.co.jp/maps/@" & ExifModify.Exif_info3 & "," & ExifModify.Exif_info4 & ",72m/data=!3m1!1e3"
Call IEOpen(MapURL)
End Sub
Private Sub Exif_Com2_Click()
Dim ckExifEdit, ckExif_Camera, ckExif_Date, ckExif_Lat, ckExif_Lon, ckExif_Rotate
Dim overwriteExif
'Exif情報 変更ある場合は変更後⇒exif情報読込
ckExifEdit = ExifModify.Exif_edit1.Value & ExifModify.Exif_edit2.Value & ExifModify.Exif_edit3.Value & ExifModify.Exif_edit4.Value & ExifModify.Exif_edit5.Value
If (ckExifEdit = "") Then
'そのままexif情報読込
Else
'Exiftool通じて上書き
If (ExifModify.Exif_edit2.Value <> "") Then
Exiftooldate = " " & "-overwrite_original -MediaCreateDate='" & Exif_info2 & "' " & "-MediaModifyDate='" & ExifModify.Exif_edit2.Value & "' " & ExifModify.Exif_Path
End If
On Error Resume Next
MsgBox Exiftooldate
overwriteExif = Shell(ThisWorkbook.Path & "\exiftool.exe" & Exiftooldate, vbNormalFocus)
MsgBox overwriteExif
If Err.Number Then
MsgBox "Exiftool使えない環境です。別途Exif読取君開いてください。（変更内容に制限あります）"
Exit Sub
End If
On Error GoTo 0
End If
Call GetExifinfo
End Sub
Private Sub Exif_Com3_Click()
Unload ExifModify
End Sub
Private Sub Exif_Import_Click()
If (ExifModify.Exif_Path = "") Then
End If
ExifModify.Exif_Image.Picture = LoadPicture(FilePath)
End Sub
Private Sub Exif_Path_Click()
Dim LoadFile As String
Dim GetFilePath As String
LoadFile = MsgBox("新規ファイル読込みます", vbYesNo)
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)
Call GetExifinfo
End Sub
Sub GetExifinfo()
Dim ObjWIA As Object '情報読込にはWIAライブラリを使用する
'初期化
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
End Sub
Private Sub OpenApp_Click()
Dim ExifTarget
On Error Resume Next
'この例ではBookと同じフォルダにShukuSen.exeがあります。
ExifTarget = " " & ExifModify.Exif_Path.Caption
Res = Shell(ThisWorkbook.Path & "\F6Exif.exe" & ExifTarget, vbNormalFocus)
If Err.Number Then
MsgBox "error"
Exit Sub
End If
On Error GoTo 0
End Sub
Private Sub UserForm_Initialize()
With ExifModify.Exif_edit5
.AddItem "1"
.AddItem "2"
.AddItem "3"
.AddItem "4"
.AddItem "5"
.AddItem "6"
.AddItem "7"
.AddItem "8"
.Value = ""
End With
Call Exif_Com2_Click
End Sub
＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝
⇒写真Exif編集アプリver500(４)
「食っちゃ寝システム第一弾」（４）：写真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(３)へ
Python勉強（５）：ここまでやってなんですが改めてさくらVPS初めからやり直し
さくらVPSにPython3インストール
Python３学習用のプラットホームとして、さくらVPSにPython3インストールできたのですが全体システム作成に難儀したので、「ネコでもわかる！さくらインターネットのVPS講座」に従い、一気にインストールしなおします。
入門ガイド｜VPS（仮想専用サーバー）はさくらインターネット
内容は、ここでWordPress入れる＋Python3をインストール入力になります。
１）OSインストール(CentOS7)＋スタートアップスクリプト(LAMP)
サーバーには重要な情報おいていないのでOSセットアップからやり直し。OSは、さくらVPS上で参考資料の多いCentOS7へ変更。Wordpressインストールするので、スタートアップスクリプトは、LAMP（Apache+MySQL＋PHP同時インストール）。
設定項目以下に記す。
２）SSHクライアントソフトのインストール
ちょうどパソコンも新調したので、SSHクライアントソフトもインストール(以前はTeraTerm使用)。今回はさくらVPSで進められているPuttyをインストール⇒起動してみる。
３）OSのアップデート
最初にインストールしたOSのアップデート
上記画面より
login as:設定したID
root@******’s password:設定したID
でログイン後、
[root@******]#
と出るので
#yum update
と入力すると
~
アップデート内容出力
~
Is this ok [y/d/N]:
と出力されるので⇒yを押す⇒あとはひたすら待つ(状況に応じては結構長いです)
Complete!
完了出力確認して終了！
４）一般ユーザーの作成 ＆ rootTeraTerm直接アクセスの禁止
↓一般ユーザーを追加、adduserコマンド⇒passwdコマンドで作成
[root@******]#adduser User*****
[root@******]# passwd User*****
Changing password for user UserTaikobo.
New password:
Retype new password:
passwd: all authentication tokens updated successfully.
↓作成後、ログインできることを確認したのち
login as: User*****
User*****@*******'s password:
SAKURA Internet [Virtual Private Server SERVICE]
↓コマンド su - にてroot(管理者)に切り替え
[User*****@*******]$ su -
Password:
↓コマンド su - にてroot(管理者)に切り替えsshの設定ファイル保存
[root@******* ~]# cd /etc/ssh
[root@******* ~]# cp sshd_config sshd_config.old
[root@******* ssh]# vim sshd_config
↓Vimエディタを開いて編集
49行目の
PermitRootLogin yes⇒PermitRootLogin no
⇒rootによるログインする⇒しないの切替設定を行う
⇒Vimエディタを保存して終了
↓sshd再起動
[root@******* ssh]# systemctl restart sshd.service
編集内容詳細は以下参照
SSHのポート番号を変更 – SSHサーバーの設定 – Linux入門
http://webkaru.net/linux/change-ssh-port/ssh接続を鍵認証で行なう
http://www.tooyama.org/ssh-key.htmlLinuxのコマンドを勉強しよう！！Linux初心者の基礎知識
http://www.linux-beginner.com/linux_command.html
４）Apacheの設定
すでにスタートアップ時にApacheインストール済みなので、ファイヤーウォール設定のみ行う
↓一般ユーザー⇒管理者切替後、”systemctl start httpd” Apache起動
[root@******* ~]# systemctl start httpd
↓コマンド”firewall-cmd”でhttpとhttpsをpublic(ファイヤーウォールの解除)
[root@******* ~]# firewall-cmd --add-service=http --zone=public --permanent
Warning: ALREADY_ENABLED: http
success
[root@******* ~]# firewall-cmd --add-service=https --zone=public --permanent
Warning: ALREADY_ENABLED: https
success
↓直接アドレス打ち込みアクセスできること確認
↓コマンド”systemctl enable httpd”でHTTPサーバー常時起動
[root@******* ~]# systemctl enable httpd
５）パーミッション（権限許可）の確認⇒変更
↓root(管理者)権限で⇒”cd /var/www”でwwwフォルダ移動⇒”ls -l”ファイル詳細表示
[root@*******~]# cd /var/www
[root@******* www]# ls -l
total 0
drwxr-xr-x 2 root root 6 Nov 5 10:47 cgi-bin
drwxr-xr-x 2 root root 6 Nov 5 10:47 html
権限
r＝read(読み)
w＝write(書き)
x＝execute(実行)
↓新しく作った”User*****”にも権限許可
[root@****** www]# cd /var/www
[root@****** www]# chown apache:User****** html
[root@****** www]# chmod 775 html
＊
Wordpressから触ることも前提なので、下記のリンク内容そのまま利用します。
ネコでもわかる！さくらのVPS講座 ～第三回「Apacheをインストールしよう」 | さくらのナレッジ
ここに丁寧に説明あります
↓変更確認
drwxrwxr-x 2 apache User****** 6 Nov 5 10:47 html
６）ドメイン取得
ドメイン取得していないことに気が付いたので、取得。
独自ドメイン取得・管理 – レンタルサーバーはさくらインターネット
https://www.sakura.ne.jp/domain/
ここはサクッと「Kuccha-Ne.com」で作成確認
↓ドメイン側のネームサーバー設定
ドメイン読込確認する
７）先にPython３インストールしておく
↓以下の内容に即て、Python3先にインストール
qiita.com
↓Pythonバージョン確認⇒Python2インストール済み確認
[root@*****www]# rpm -qa | grep python
libreport-python-2.1.11-42.el7.centos.x86_64
[root@*****www]# ｑyum -y install https://centos7.iuscommunity.org/ius-release.rpm
↓Python3.6.5インストール (拡張モジュール/必要な開発環境/pip コマンド込み）
[root@*****www]# yum -y install python36u python36u-devel python36u-pip
レポジトリ＝ repository（直訳：倉庫転じて以下の意味）
情報工学において、仕様・デザイン・ソースコード・テスト情報・インシデント情報など、システムの開発プロジェクトに関連するデータの一元的な貯蔵庫を意味する。日本語でレポジトリと表記される場合もある。一種のデータベースであり、ソフトウェア開発および保守における各工程の様々な情報を一元管理する。IUSはレポジトリの一つ
pipとは⇒Pythonのパッケージを管理するためのツール
yum＝Yellowdog Updater Modified
rpm＝Red Hat Package Manager(レッドハット社作成のため）
８）phpMyAdminもインストール
初期状態で、データベースはインストール済みなので、ブラウザからデータベース操作できるphpMyAdminツールもインストール。
ネコでもわかる！さくらのVPS講座 ～第五回「phpMyAdminを導入しよう」 | さくらのナレッジ
↓root権限でphpMyAdminインストール
[root@****** ]# yum install --enablerepo=remi,remi-php71 phpMyAdmin
↓root権限でphpMyAdminの設定変更のためバックアップしてVim起動
[root@****** ]# cd /etc/httpd/conf.d/
[root@****** ]# cp phpMyAdmin.conf phpMyAdmin.conf.old
[root@****** ]# vim phpMyAdmin.conf
↓Vimエディタで16行目付近を編集
#Require local
Require all granted
何か間違えたみたいなので確認⇒後回し
９）HTML／PHPの動作確認 ドメイン手続き待っている間に
PHPはスタートアップ時点でインストールされているので動作確認のみ。
アップデート用のSFTPソフト「RLogin」を準備⇒index.php作成し「Hollow World」
出力用ミニプログラムを準備⇒アップロードして動作確認。
(改め知ったことだがFTPって今はあまり使わないんですね・・・)
⇒続き
