ファイル名から文字列の取得

写真の一括貼り付けを行う時に写真の貼り付けたい順番とファイル名を決めます。

名前の付け方にルールを決めてファイル名を取得して、セルに値を設定する様に致しました。

ファイル名から文字列を取得して各項目に設定

ファイル名の決め方

ファイル名　　1_場所_工事_花(1).jpg

表示したい順番、場所、工事種目、施工状況の間に”_“を設定しています。

今回は”_“を判断材料として使用しているだけです。

判断材料はファイルの命名規則に問題なければ何でも大丈夫です。

例 “.””\”等はファイルの命名上問題が発生します。

写真毎に各項目のセルに値を設定

処理の説明

変数の宣言

    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String

検索文字の初期設定

    '検索文字の初期設定
    kensakuMoji = "_"

文字列検索

fileにファイル名が設定されています。

        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")

InStrでファイル名にある”_”の位置を取得しています。

各項目のセルに文字列を設定

        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou

Midで文字列を抜き出しています。

Cellsで抜き出した値をセルに設定しています。

処理全体の内容

Sub 写真張り付け_Click()
    
    'ループ関数を設定
    Dim i As Integer, j As Integer, k As Integer
    '写真の一覧を取得
    Dim fileName As Variant
    Dim dblscal As Double
    Dim str As String
    
    Dim day As Date
    Dim ObjShell As Object
    Dim ObjFolder As Object
    Dim filePath As Variant
    Dim file As Variant
    
'←--------追加
    'ファイル名から場所,工事種目,施工状況の変数の宣言
    Dim basyo, koujisyu, sekou As String
    Dim basyoi, koujisyui, sekoui, doti As Integer
    Dim kensakuMoji As String
'---------->
  
    Dim startTime As Double
    Dim endTime As Double
    Dim processTime As Double
    
  
    fileName = Application.GetOpenFilename( _
        filefilter:="画像ファイル,*.bmp;*.jpg;*.gif;*.JPG", _
        MultiSelect:=True)
    '画像ファイルを選択しなかった場合は処理を終わらせる
    If Not IsArray(fileName) Then Exit Sub
    
    '処理中画面描写をしない
    Application.ScreenUpdating = False
    
    
'←------追加
    '検索文字の初期設定
    kensakuMoji = "_"
'---------->
    
    '写真を貼る開始セルの列
    j = 2
    '写真を貼る開始セルの行
    k = 2
    
    '印刷範囲の初期設定
    str = Range(Cells(1, 1), Cells(60, 16)).Address
    '原本シートのコピーを末尾に追加
    Worksheets("原本").Copy After:=Worksheets(Worksheets.Count)
    'ボタンを削除
    ActiveSheet.DrawingObjects.Delete
    
    'シェルの設定
    Set ObjShell = CreateObject("Shell.Application")
    
    '取得した写真リストをセルに貼り付け
    For i = LBound(fileName) To UBound(fileName)
        If i <> 1 And i Mod 3 = 1 Then
            Worksheets("原本").Range(str).Copy
            Cells(k - 1, 1).PasteSpecial
            Application.CutCopyMode = False
            ActiveSheet.HPageBreaks.Add before:=Cells(((i \ 3) * 60) + 1, 1)
        End If
        
        '選択ファイル
        With ActiveSheet.Shapes.AddPicture( _
            fileName:=fileName(i), _
            linktofile:=False, _
            savewithdocument:=True, _
            Left:=ActiveCell.Left + 1, _
            Top:=ActiveCell.Top + 1, _
            Width:=ActiveCell.Width * 10, _
            Height:=ActiveCell.Height * 18)
            '結合セルの大きさに設定する場合は下記の内
            'Height:=ActiveCell.MergeArea.Height, _
            'Width:=ActiveCell.MergeArea.Width)
        End With
        
        '写真の貼り直し
        ActiveSheet.Shapes(i).Select
        Selection.Cut
        Cells(k, j).Select
        ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayasIcon:=False
        Application.CutCopyMode = False
        
        
        'Noに数を記入
        Cells(k, j + 13) = i
        
        'ファイルのパスを取得
        filePath = Left(fileName(i), InStrRev(fileName(i), "\"))
        'ファイル名の取得
        file = Mid(fileName(i), Len(filePath) + 1)
        
        '写真のデータを参照
        Set ObjFolder = ObjShell.Namespace(filePath).ParseName(file)

        '写真の撮影日を取得
        day = ObjFolder.ExtendedProperty("System.Photo.DateTaken")
        '写真のデータの参照を解放
        Set ObjFolder = Nothing
        '写真の撮影日をセルに設定
        Cells(k + 2, j + 13) = Format(day, "yyyy年m月d日")
        
'←------追加
        '文字列検索
        '場所の初期位置を取得
        basyoi = InStr(file, kensakuMoji)
        '工事種目の初期位置を取得
        koujisyui = InStr(basyoi + 1, file, kensakuMoji)
        '施工状況の初期位置を取得
        sekoui = InStr(koujisyui + 1, file, kensakuMoji)
        '.の位置を取得
        doti = InStr(file, ".")
        '場所のセルに設定
        basyo = Mid(file, basyoi + 1, koujisyui - basyoi - 1)
        Cells(k + 4, j + 13) = basyo
        '工事種目のセルに設定
        koujisyu = Mid(file, koujisyui + 1, sekoui - koujisyui - 1)
        Cells(k + 6, j + 13) = koujisyu
        '施工状況のセルに設定
        sekou = Mid(file, sekoui + 1, doti - sekoui - 1)
        Cells(k + 8, j + 13) = sekou
'-------→
        
        '次のセルの位置を設定する
        k = k + 20
        
    Next i
    
    'シェルの解放
    Set ObjShell = Nothing
    
    i = i - 1
    k = k - 20
    
    Select Case i Mod 3
        Case 1
            str = Range(Cells(1, 1), Cells(k + 58, 16)).Address
        Case 2
            str = Range(Cells(1, 1), Cells(k + 38, 16)).Address
        Case Else
            str = Range(Cells(1, 1), Cells(k + 18, 16)).Address
    End Select
    
    ActiveSheet.PageSetup.PrintArea = str
    
    '写真のズレを修正
    ActiveSheet.Shapes.SelectAll
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.Height = Cells(2, 2).Height * 18
    Selection.ShapeRange.Width = Cells(2, 2).Width * 10
    

    
    Cells(1, 1).Select
    
    '画面描写を実行
    Application.ScreenUpdating = True
    
End Sub

今回の内容で各項目に値を設定する事が出来ました。

写真の一括貼り付け処理はエクセル上での操作でファイルを取得すれば自動で各項目に設定するため、自動化完了とします。

また、処理など思いつけば機能の追加を行います。