エビデンス生成マクロがバグだらけだったのでデバッグしました

以前、こんな記事を書きました。

指定したフォルダ直下の画像からエビデンスのエクセルファイルを自動生成するマクロ

私の記念すべき第1回目のQiitaの投稿記事でございます。

これを作ったからにはぜひ使ってみてほしいと会社の同僚に使ってもらったところ、バグだらけで怒られたのでデバッグしました。

前のソースと見比べられるように別の記事にしています。（自戒の念も込めて）

使い方は全く変わらないので前回の記事を見てください。

どんなバグが起きたのか

大きなバグとしては2点ありました

ディレクトリ配下の画像を変えたり、エビデンスのエクセルを他の人に送ったりすると画像が消える

これに関してはデバッグは楽勝でした

【備忘録】Excel2010以降のVBAで画像の実体を挿入する

こちらの記事に書いてあるように、**「ActiveSheet.Pictures.Insert」**で画像を貼り付けると、参照扱いになってしまうそうです。

なので、**「ActiveSheet.Shapes.AddPicture」**に変更しました。

この変更点については小さな変更だったので前回の記事の中で対応しています。

1シートに付き、9枚しか画像が貼り付けられない

コイツが曲者でした。

別に1シートあたりの画像枚数とか制限した覚えはないんですよ

ただ急にSlackで同僚から

って連絡来て

そんなわけねーだろぉ
って思って自分でもテストしてみたら、本当に10枚以上貼れないんですよね…

原因は？

原因は、拡張子のバリデーションのところでした。

        '拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
        If UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("png") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("jpeg") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("bmp") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tif") Or _
            UCase(Right(f_name, InStr(f_name, ".") - 1)) = UCase("tiff") Then
            'ファイル名に-（ハイフン）がなかったら飛ばす
            If InStr(f_name, "-") <> 0 Then
                Sheet_name = Left(f_name, InStr(f_name, "-") - 1)  '-(ハイフン)の前の文字列をファイル名とする
                pic_exist_flg = True
            Else
                GoTo Skip
            End If
        Else
            GoTo Skip
        End If

InStr(f_name, ".") - 1で拡張子のドットを左から数えているのに対し、Rightで右から数えているので、ダメだったということです。

今までできていたのは2-1.pngなどといったドットの前と後で文字数が同じファイルを偶然にも使っていたからできていたんですね

なので、以下のように修正しました

            '拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
            If UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("png") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("jpg") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("jpeg") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("bmp") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("tif") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("tiff") Then

これで一件落着…

と思いきや、新たな強敵が現れるわけです。

文字列ソート問題

先程の修正でハイフン後が何桁でもいけるようになった訳ですが、新たな問題が待ち構えていました。

    'ソート
    For j = 1 To i
        For k = i To j Step -1
            If StrComp(f_name_arr(j), f_name_arr(k)) = 1 Then
                swap = f_name_arr(j)
                f_name_arr(j) = f_name_arr(k)
                f_name_arr(k) = swap
            End If
        Next k
    Next j

ここで、文字列でソートしているんですが、この時にハイフン後が2桁のファイルが入ってくると

1-1.png
1-10.png
1-11.png
1-2.png

みたいにソートされちゃうんですよね…

ならハイフン語で文字列抽出して整数型に変換してから比較すりゃええやんって話になるんですが、

・・・
1-10.png
1-11.png
2-1.png
2-2.png
・・・

みたいな時はどうする？って話になったんすよ

要するに

• ハイフンより前の数字で全体をソートする
• ハイフンの前が同じファイル同士はハイフンの後でソートする

という要件なわけです。

こうなってくると、全体として改修が必要になるぞ…ということでデバッグを開始しました。

コード

コーディング中のなんだかんだの紆余曲折を書いているとメチャクチャ長くなっちゃうので割愛します。

最終的なコードがこちらです。

標準モジュール

'テスト関数
Sub generate_sheet(evidence_name As String, PATH_ As String)

    Dim wb As Workbook '新しいworkbookを作成
    Set wb = Workbooks.Add
    Dim f_name As String '挿入する画像の名前
    Dim all_f_name_arr() As String '全体の画像名の配列
    Dim s_name_arr() As String 'シート名の配列
    Dim f_name_arr() As String '同じシートに貼り付ける画像名の配列
    Dim swap As String 'ソート用のスワップ
    Dim i As Long 'Forループ用
    Dim j As Long 'Forループ用
    Dim k As Long 'Forループ用
    Dim ws As Worksheet 'ワークシート
    Dim pic_exist_flg As Boolean '対象のファイルがあるかどうか判別するフラグ
    Dim file_name_flg As Boolean '指定されたディレクトリ配下に保存しようとしたファイル名と同名のファイルがあるか検索
    Dim pic_top As Long '挿入する画像のTop位置
    Dim shp As Shape '画像を挿入する際のShapes
    
    wb.Activate '生成したworkbookをアクティブにする
    
    '選択したpathの配下にファイルが無かったら抜ける
    f_name = Dir(PATH_ & "\*")
    If f_name = "" Then
        MsgBox PATH_ & "にはファイルがありません。"
        Application.Quit
        Exit Sub
    End If
    
    i = 0
    Do
        '作成しようとしているエクセルファイルと同名のエクセルファイルがあった場合はフラグを立てる
        If f_name = evidence_name & ".xlsx" Then
            file_name_flg = True
        Else
            '拡張子がtif,tiff,png,jpg.jpeg,bmpじゃなかったら飛ばす
            If UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("png") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("jpg") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("jpeg") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("bmp") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("tif") Or _
                UCase(Mid(f_name, InStrRev(f_name, ".") + 1)) = UCase("tiff") Then
                'ファイル名に-（ハイフン）がなかったら飛ばす
                If InStr(f_name, "-") <> 0 Then
                    'ハイフンより右でドット（拡張子）より左の文字列が数字と見なせなかったら飛ばす
                    If IsNumeric(Left(Mid(f_name, InStrRev(f_name, "-") + 1), InStr((Mid(f_name, InStrRev(f_name, "-") + 1)), ".") - 1)) Then
                        ReDim Preserve all_f_name_arr(0 To i)
                        all_f_name_arr(i) = f_name
                        i = i + 1
                        pic_exist_flg = True
                    End If
                End If
            End If
        End If
        f_name = Dir
    Loop While f_name <> ""
    
    If pic_exist_flg <> True Then
        MsgBox PATH_ & "には対象となるファイルがありません。"
        Application.Quit
        Exit Sub
    End If
    
    '配列にハイフンの前の文字列（シート名）を詰める
    j = 0
    For i = 0 To UBound(all_f_name_arr)
        '1回目に入ってきた時はそのまま詰める
        If j = 0 Then
            ReDim Preserve s_name_arr(0)
            s_name_arr(0) = Left(all_f_name_arr(i), InStr((all_f_name_arr(i)), "-") - 1)
            j = 1
        '2回目以降は配列にあるかどうか確認してから詰める
        Else
            For k = 0 To UBound(s_name_arr)
                If StrComp(s_name_arr(k), Left(all_f_name_arr(i), InStr((all_f_name_arr(i)), "-") - 1)) = 0 Then
                    GoTo Skip1
                End If
            Next k
            ReDim Preserve s_name_arr(0 To j)
            s_name_arr(j) = Left(all_f_name_arr(i), InStr((all_f_name_arr(i)), "-") - 1)
            j = j + 1
        End If
Skip1:
    Next i
    
    '画像貼り付け
    For i = 0 To UBound(s_name_arr)
    
        'シート作成
        Worksheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = s_name_arr(i)
        pic_top = 20 '1枚目の画像は上から20px空ける
    
        '作成したシートに貼る画像の名前を配列に詰める
        k = 0
        For j = 0 To UBound(all_f_name_arr)
            If StrComp(s_name_arr(i), Left(all_f_name_arr(j), InStr((all_f_name_arr(j)), "-") - 1)) = 0 Then
                ReDim Preserve f_name_arr(0 To k)
                f_name_arr(k) = all_f_name_arr(j)
                k = k + 1
            End If
        Next j
        
        'ソート
        For j = 0 To UBound(f_name_arr)
            For k = UBound(f_name_arr) To j Step -1
                'ハイフンより右で、ドット（拡張子）より左を長整数型にして比較
                If CLng(Left(Mid(f_name_arr(j), InStrRev(f_name_arr(j), "-") + 1), InStr((Mid(f_name_arr(j), InStrRev(f_name_arr(j), "-") + 1)), ".") - 1)) > _
                    CLng(Left(Mid(f_name_arr(k), InStrRev(f_name_arr(k), "-") + 1), InStr((Mid(f_name_arr(k), InStrRev(f_name_arr(k), "-") + 1)), ".") - 1)) Then
                    swap = f_name_arr(j)
                    f_name_arr(j) = f_name_arr(k)
                    f_name_arr(k) = swap
                End If
            Next k
        Next j
        
        For j = 0 To UBound(f_name_arr)
            '任意のワークシートに画像を挿入
            With Sheets(s_name_arr(i))
                Set shp = .Shapes.AddPicture( _
                    Filename:=PATH_ & "\" & f_name_arr(j), _
                    linktofile:=False, _
                    savewithdocument:=True, _
                    Left:=20, _
                    Top:=pic_top, _
                    Width:=0, _
                    Height:=0)
            End With
            
            With shp
                .LockAspectRatio = False
                .ScaleHeight 1, msoTrue
                .ScaleWidth 1, msoTrue
                pic_top = pic_top + .Height + 20 '次の画像は20px空けたところに挿入する
            End With
        Next j
        
        '配列リセット
        Erase f_name_arr
    Next i
    
    '最初から存在するシートを削除
    Application.DisplayAlerts = False
    Worksheets(1).Delete
    Application.DisplayAlerts = True
    
    '一枚目のシートをアクティブにする
    Worksheets(1).Activate
    
    If file_name_flg = True Then
        MsgBox PATH_ & "に同名のエクセルファイルがあります。" & vbCrLf & "ファイル名を変えて保存してください。"
    Else
        '指定したファイル名でエクセルファイルを保存
        wb.SaveAs _
        Filename:=PATH_ & "\" & evidence_name & ".xlsx", _
        FileFormat:=xlOpenXMLWorkbook
    End If
    
    'マクロを実行したエクセルファイルを閉じる
    Workbooks("evidence.xlsm").Close
End Sub

その他のフォーム、ワークシートのコードは前回の記事と同様のものを使っています。

前回の記事と合わせて読んでいただければ、だいたい分かるような内容にはなっていると思います。

大きな変更点としては

• バリデーションのタイミングを前に持ってきた
• バリデーション項目の追加（ハイフンとドットの間の文字が数字であること）
• 全体のファイル名からシート名（ハイフンより前）が同じものを集めてからその中でソートしている

ぐらいだと思います。

バリデーション項目の追加のロジックだけちょっと分かりづらいので、詳細を書きます

ハイフンより右でドットより左

2-34.jpgっていうファイルがあった時に34って数字だけ抜き出したかったので、以下のようなコードになりました

Left(Mid(f_name_arr(k), InStrRev(f_name_arr(k), "-") + 1), InStr((Mid(f_name_arr(k), InStrRev(f_name_arr(k), "-") + 1)), ".") - 1)

長ったらしくて分かりづらいんですが、分解してみるとそうでもなかったりします。

Mid(f_name_arr(k), InStrRev(f_name_arr(k), "-") + 1

ここでハイフンより右を抜き出しています。

2-34.jpgだと34.jpgだけ残っている状態になります。

Left(string, InStr(string, ".") - 1)

これでstringという変数のドットより左を抜き出しているので、このstringという変数に34.jpgを代入した感じになりますね

テストはとてもだいじ

こうなったのも私がちゃんとテストしてなかったのが原因です

てきとーに画像ファイルたくさん作って、画像貼り付けられたから、わーーーーーーい！！って舞い上がってたのがよくなったですね…

今回で言えば

• ファイル名が数字じゃなかったら？
• ハイフン後が2桁以上だったら？
• 作成したエクセルはちゃんと送れる？

などのテストはしておくべきだったなぁと痛感しました。

それをしてれば、私がこんな手間かけてデバッグすることもなかったでしょう。

読者の皆さんにはこんな苦労が起こらないことを願います。