VBEモジュール内の特定文字置換

'--------------------------------------------------
'プロシージャの概要:
'処理名:replaceColonSetAll
'概要:自身のブックを上書き保存後タイムスタンプ付きでバックアップし、
'     VBEモジュール内の": Set "を一括で改行+インデント+"Set "に置換する処理。
'     本プロシージャ自身およびコメント行は置換対象から除外する。
'--------------------------------------------------
Public Sub replaceColonSetAll()

    Dim strBackupPath    As String
    Dim strTimestamp      As String
    Dim strBaseName       As String
    Dim strExtension      As String
    Dim strFolderPath     As String
    Dim lngDotPos         As Long
    Dim objVBComp         As Object
    Dim objCodeModule     As Object
    Dim lngLine           As Long
    Dim strLine           As String
    Dim strTrimmedLine    As String
    Dim strIndent         As String
    Dim lngPos            As Long
    Dim lngCountReplace   As Long
    Dim lngProcStartLine  As Long
    Dim lngProcEndLine    As Long

    Const C_SELF_PROC_NAME As String = "replaceColonSetAll"
    Const C_VBEXT_PK_PROC  As Long = 0

    '==============================================
    ' バックアップ処理
    '==============================================
    strFolderPath = ThisWorkbook.Path & "\"
    strTimestamp = Format$(Now, "yyyyMMdd_HHmmss")

    'ファイル名と拡張子を分離
    lngDotPos = InStrRev(ThisWorkbook.Name, ".")
    If lngDotPos > 0 Then
        strBaseName = Left$(ThisWorkbook.Name, lngDotPos - 1)
        strExtension = Mid$(ThisWorkbook.Name, lngDotPos)
    Else
        strBaseName = ThisWorkbook.Name
        strExtension = ""
    End If

    strBackupPath = strFolderPath & strBaseName & "_backup_" & strTimestamp & strExtension

    On Error GoTo ErrBackup

    '現在の状態を上書き保存してからコピーを取得
    ThisWorkbook.Save
    ThisWorkbook.SaveCopyAs strBackupPath

    On Error GoTo 0

    '==============================================
    ' 一括置換処理
    '==============================================
    lngCountReplace = 0

    For Each objVBComp In ThisWorkbook.VBProject.VBComponents
        Set objCodeModule = objVBComp.CodeModule

        '自プロシージャの行範囲を特定（存在しない場合は0）
        lngProcStartLine = 0
        lngProcEndLine = 0
        On Error Resume Next
        lngProcStartLine = objCodeModule.ProcStartLine(C_SELF_PROC_NAME, C_VBEXT_PK_PROC)
        If lngProcStartLine > 0 Then
            lngProcEndLine = lngProcStartLine _
                           + objCodeModule.ProcCountLines(C_SELF_PROC_NAME, C_VBEXT_PK_PROC) - 1
        End If
        On Error GoTo 0

        lngLine = 1
        Do While lngLine <= objCodeModule.CountOfLines

            '自プロシージャの範囲内はスキップ
            If lngProcStartLine > 0 Then
                If lngLine >= lngProcStartLine And lngLine <= lngProcEndLine Then
                    lngLine = lngLine + 1
                    GoTo NextLine
                End If
            End If

            strLine = objCodeModule.Lines(lngLine, 1)

            'コメント行はスキップ
            strTrimmedLine = LTrim$(strLine)
            If Left$(strTrimmedLine, 1) = "'" Then
                lngLine = lngLine + 1
                GoTo NextLine
            End If

            lngPos = InStr(strLine, ": Set ")
            If lngPos > 0 Then
                '現在行のインデントを取得
                strIndent = Space$(Len(strLine) - Len(LTrim$(strLine)))

                '": Set "の前後で分割し、2行に置換
                objCodeModule.ReplaceLine lngLine, Left$(strLine, lngPos - 1)
                objCodeModule.InsertLines lngLine + 1, strIndent & "Set " & Mid$(strLine, lngPos + 6)

                lngCountReplace = lngCountReplace + 1
                lngLine = lngLine + 1
            Else
                lngLine = lngLine + 1
            End If
NextLine:
        Loop
    Next objVBComp

    MsgBox "置換が完了しました。" & vbCrLf _
         & "置換: " & lngCountReplace & " 件" & vbCrLf _
         & vbCrLf _
         & "バックアップ:" & vbCrLf _
         & strBackupPath, _
           vbInformation, "完了"

    Exit Sub

ErrBackup:
    MsgBox "バックアップの保存に失敗しました。" & vbCrLf _
         & "置換処理は実行しません。" & vbCrLf _
         & vbCrLf _
         & "エラー: " & Err.Description, _
           vbCritical, "エラー"

End Sub