VBAで作成したプログラムを

Webなんかで公開したい場合に使うマクロを作成しました。
色を塗ったり、インデントしたりするだけの動作ですが、自動化しようと思えば
それなりのプログラムになるわけで、作成に2日間くらいかかりました。

動かし方は、
VBAで記述したコードをコピーして、
Excelの1行1列目に貼り付けします。
区切り位置設定は無しで設定する必要があります。
コピペ時の区切り位置は前回の区切り位置設定を覚えているので、
変に張り付けられてしまう場合は、一度、区切り位置設定をしないで区切り位置処理を実施します。

使ってみた感じ、まだ不完全でした。う～ん。プログラミングセンスねぇな。
仕様を決めるところで、まだ詰めが甘い。ダブルクォーテション内の関数に色が付くというところを
回避する部分に改良するべき余地がありそうです。

それとOffice2010のVBAだとWhile文とかでうっかり永久ループに入るとブレークキー Shift+E046でも止められないみたいです。もう誰かが解決策を見つけてくれているとは思いますが、自分はまだOffice2010を使い始めてひと月程度ですし、まだまだ勉強が必要ですね。

ま、Vectorとか行けば、同じようなのが、アドインとかで大それた機能として、
ありますけどね。自分流って奴もあっていいかなと思いまして。作りました。
意外と便利っす。

これも、あとで、もう少し改良しようかな。
130507
改良版に更新しました。

プログラムは以下より入手できます。
Download file

コードは以下のとおりです。

Sub VBACode2HTML()
    Dim sh As Worksheet
    Dim lScanRow As Long
    Dim lSpaceCnt As Long
    Dim strFrontStrings As String
    Dim bDblQrt As Boolean
    Dim lPos As Long
    Dim strFeedLine As String
    '課題：ダブルクォーテーションで囲われている場合は色を塗らない処理を追加する必要あり。
 
    
    '①前にはSpaceやTab以外は許されず、後ろにスペースが必要なステートメント配列リスト
    Dim strArrBlueTopSp(72) As String
    strArrBlueTopSp(0) = "Sub "
    strArrBlueTopSp(1) = "Function "
    strArrBlueTopSp(2) = "Dim "
    strArrBlueTopSp(3) = "ReDim "
    strArrBlueTopSp(4) = "Set "
    strArrBlueTopSp(5) = "If "
    strArrBlueTopSp(6) = "Else If "
    strArrBlueTopSp(7) = "Else "
    strArrBlueTopSp(8) = "Call "
    strArrBlueTopSp(9) = "While "
    strArrBlueTopSp(10) = "Print "
    strArrBlueTopSp(11) = "For "
    strArrBlueTopSp(12) = "Debug.Print "
    strArrBlueTopSp(13) = "Debug.Assert "
    strArrBlueTopSp(14) = "Open "
    strArrBlueTopSp(15) = "Close "
    strArrBlueTopSp(16) = "On Error "
    strArrBlueTopSp(17) = "On "
    strArrBlueTopSp(18) = "GoSub "
    strArrBlueTopSp(19) = "GoTo "
    strArrBlueTopSp(20) = "Option Base "
    strArrBlueTopSp(21) = "Option Compare "
    strArrBlueTopSp(22) = "Option Explicit "
    strArrBlueTopSp(23) = "Private "
    strArrBlueTopSp(24) = "Property Get "
    strArrBlueTopSp(25) = "Property Let "
    strArrBlueTopSp(26) = "Property Set "
    strArrBlueTopSp(27) = "Public "
    strArrBlueTopSp(28) = "Put "
    strArrBlueTopSp(29) = "Type "
    strArrBlueTopSp(30) = "RaiseEvent "
    strArrBlueTopSp(31) = "Resume "
    strArrBlueTopSp(32) = "RSet "
    strArrBlueTopSp(33) = "Seek "
    strArrBlueTopSp(34) = "Select Case "
    strArrBlueTopSp(35) = "Case "
    strArrBlueTopSp(36) = "Static "
    strArrBlueTopSp(37) = "Const "
    strArrBlueTopSp(38) = "Declare PtrSafe "
    strArrBlueTopSp(39) = "Declare "
    strArrBlueTopSp(40) = "DefBool "
    strArrBlueTopSp(41) = "DefByte "
    strArrBlueTopSp(42) = "DefInt "
    strArrBlueTopSp(43) = "DefLng "
    strArrBlueTopSp(44) = "DefLngLng "
    strArrBlueTopSp(45) = "DefLngPtr "
    strArrBlueTopSp(46) = "DefCur "
    strArrBlueTopSp(47) = "DefSng "
    strArrBlueTopSp(48) = "DefDbl "
    strArrBlueTopSp(49) = "DefDec "
    strArrBlueTopSp(50) = "DefDate "
    strArrBlueTopSp(51) = "DefStr "
    strArrBlueTopSp(52) = "DefObj "
    strArrBlueTopSp(53) = "DefVar "
    strArrBlueTopSp(54) = "Enum "
    strArrBlueTopSp(55) = "Erase "
    strArrBlueTopSp(56) = "Error "
    strArrBlueTopSp(57) = "Event "
    strArrBlueTopSp(58) = "ByVal "
    strArrBlueTopSp(59) = "ByRef "
    strArrBlueTopSp(60) = "Get "
    strArrBlueTopSp(61) = "GoSub "
    strArrBlueTopSp(62) = "GoTo "
    strArrBlueTopSp(63) = "Implements "
    strArrBlueTopSp(64) = "Input "
    strArrBlueTopSp(65) = "Let "
    strArrBlueTopSp(66) = "Line Input "
    strArrBlueTopSp(67) = "Lock "
    strArrBlueTopSp(68) = "Unlock "
    strArrBlueTopSp(69) = "LSet "
    strArrBlueTopSp(70) = "AddressOf "
    strArrBlueTopSp(71) = "#If "
    strArrBlueTopSp(72) = "#Else If "
    
    '②前には"("," ",vbTabが許され、かつ後ろにSpaceがなくてはならないステートメント配列リスト
    Dim strArrBlueMidSp(3) As String
    strArrBlueMidSp(0) = "ByVal "
    strArrBlueMidSp(1) = "ByRef "
    strArrBlueMidSp(2) = "ParameArray "
    strArrBlueMidSp(3) = "Null "

    '③前には"("," ",vbTabが許され、かつ後ろには、")"," ",","がなくてはならないステートメント配列リスト
    Dim strArrBlueAnySpliter(5) As String
    strArrBlueAnySpliter(0) = "Null"
    strArrBlueAnySpliter(1) = "True"
    strArrBlueAnySpliter(2) = "False"
    strArrBlueAnySpliter(3) = "Nothing"
    strArrBlueAnySpliter(4) = "UBound"
    strArrBlueAnySpliter(5) = "LBound"
    
    '④前にはSpaceやTab以外は許されず、かつ後ろにSpaceがあってはならない配列リスト
    Dim strArrBlueTop(26) As String
    strArrBlueTop(0) = "Do"
    strArrBlueTop(1) = "End Function"
    strArrBlueTop(2) = "End If"
    strArrBlueTop(3) = "Wend"
    strArrBlueTop(4) = "Next"
    strArrBlueTop(5) = "Exit Function"
    strArrBlueTop(6) = "Exit Sub"
    strArrBlueTop(7) = "Loop"
    strArrBlueTop(8) = "Do While"
    strArrBlueTop(9) = "Loop While"
    strArrBlueTop(10) = "Do Until"
    strArrBlueTop(11) = "With"
    strArrBlueTop(12) = "Else"
    strArrBlueTop(13) = "End With"
    strArrBlueTop(14) = "End Sub"
    strArrBlueTop(15) = "On Error Resume Next"
    strArrBlueTop(16) = "On Error GoTo 0"
    strArrBlueTop(17) = "Option Private Module"
    strArrBlueTop(18) = "End Property"
    strArrBlueTop(19) = "End Type"
    strArrBlueTop(20) = "End Select"
    strArrBlueTop(21) = "Case Else"
    strArrBlueTop(22) = "Resume Next"
    strArrBlueTop(23) = "End Enum"
    strArrBlueTop(24) = "Retuen"
    strArrBlueTop(25) = "#Else"
    strArrBlueTop(26) = "#End If"
    '⑤接続句で両側にスペースやタブが許される配列リスト
    Dim strArrBlueMid(23) As String
    strArrBlueMid(0) = " As "
    strArrBlueMid(1) = " Is "
    strArrBlueMid(2) = " And "
    strArrBlueMid(3) = " Imp "
    strArrBlueMid(4) = " Like "
    strArrBlueMid(5) = " Mod "
    strArrBlueMid(6) = " Not "
    strArrBlueMid(7) = " Or "
    strArrBlueMid(8) = " True "
    strArrBlueMid(9) = " False "
    strArrBlueMid(10) = " Nothing "
    strArrBlueMid(11) = " Or "
    strArrBlueMid(12) = " To "
    strArrBlueMid(13) = " Output "
    strArrBlueMid(14) = " Each "
    strArrBlueMid(15) = " In "
    strArrBlueMid(16) = " Property "
    strArrBlueMid(17) = " Get "
    strArrBlueMid(18) = " Let "
    strArrBlueMid(19) = " New "
    strArrBlueMid(20) = " Input "
    strArrBlueMid(21) = " AddressOf "
    strArrBlueMid(22) = " Step "
    strArrBlueMid(23) = " Preserve "

    
    '⑥前には一つ以上のスペースやタブが許され、さらに前には様々な表記も許されるが、後ろにはスペースやTabは入らない配列リスト
    Dim strArrBlueEnd(24) As String
    strArrBlueEnd(0) = " Then"
    strArrBlueEnd(1) = " True"
    strArrBlueEnd(2) = " False"
    strArrBlueEnd(3) = " Nothing"
    strArrBlueEnd(4) = " Exit Do"
    strArrBlueEnd(5) = " Exit For"
    strArrBlueEnd(6) = " Exit Function"
    strArrBlueEnd(7) = " Exit Property"
    strArrBlueEnd(8) = " Exit Sub"
    strArrBlueEnd(9) = " Then"
    strArrBlueEnd(10) = " Boonlean"
    strArrBlueEnd(11) = " Byte"
    strArrBlueEnd(12) = " Currency"
    strArrBlueEnd(13) = " Date"
    strArrBlueEnd(14) = " Decimal"
    strArrBlueEnd(15) = " Double"
    strArrBlueEnd(16) = " Integer"
    strArrBlueEnd(17) = " Long"
    strArrBlueEnd(18) = " LongLong"
    strArrBlueEnd(19) = " LongPtr"
    strArrBlueEnd(20) = " Object"
    strArrBlueEnd(21) = " Single"
    strArrBlueEnd(22) = " DefObj"
    strArrBlueEnd(23) = " String"
    strArrBlueEnd(24) = " Variant"
    
    Dim strArrGreenComment(1) As String
    strArrGreenComment(0) = "'"
    strArrGreenComment(1) = "Rem "
    Set sh = ActiveSheet
    lScanRow = 1
    lSpaceCnt = 1
    
    '15回連続空白行が続くか、最終行まで処理をしたら終了。
    While lSpaceCnt < 15 And lScanRow < 1048561
        strFeedLine = sh.Cells(lScanRow, 1).Value
        '連続空白行カウント処理
        If sh.Cells(lScanRow, 1).Value = "" Then
            lSpaceCnt = lSpaceCnt + 1
        Else
            lSpaceCnt = 0
        End If
        '
       '
      'バックインデント
     '
    '
    If strFeedLine <> "" Then
        '●①前にはSpaceやTab以外は許されず、後ろにスペースやタブが許される配列リストの処理
        For i = 0 To UBound(strArrBlueTopSp)
                lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueTopSp(i), vbTextCompare) > 0
                lPos = InStr(lPos, strFeedLine, strArrBlueTopSp(i), vbTextCompare)
                If strArrBlueTopSp(i) = "Put " Then
                strStop = "Put "
                End If

                bNonConv = False
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
                If lPos > 1 Then
                    strFrontStrings = Left(strFeedLine, lPos - 1)
                    If Right(strFrontStrings, 1) <> " " And Right(strFrontStrings, 1) <> vbTab And Right(strFrontStrings, 1) <> "" Then
                        bNonConv = True
                    End If
                End If
                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & "" & _
                    Left(strArrBlueTopSp(i), Len(strArrBlueTopSp(i)) - 1) & "" & " " & Mid(strFeedLine, lPos + Len(strArrBlueTopSp(i)))
                    lPos = lPos + 29 + Len(strArrBlueTopSp(i))
                    
                Else
                    lPos = lPos + Len(strArrBlueTopSp(i))
                End If

                If bNonConv = False Then
                    strFeedLine = strNewFeedLine
                End If
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
    
        '●②前には"("," ",vbTabが許され、かつ後ろにSpaceがなくてはならない配列リスト
        'Dim strArrBlueMidSp(4) As String
        For i = 0 To UBound(strArrBlueMidSp)
            lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueMidSp(i), vbTextCompare) > 0
                lPos = InStr(lPos, strFeedLine, strArrBlueMidSp(i), vbTextCompare)
                strFrontStrings = Left(strFeedLine, lPos - 1)
                bNonConv = False
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
                If Right(strFrontStrings, 1) <> " " And Right(strFrontStrings, 1) <> "(" And Right(strFrontStrings, 1) <> vbTab And Right(strFrontStrings, 1) <> "" Then
                    bNonConv = True
                End If
                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & "" & _
                    Left(strArrBlueMidSp(i), Len(strArrBlueMidSp(i)) - 1) & "" & " " & Mid(strFeedLine, lPos + Len(strArrBlueMidSp(i)))
                    lPos = lPos + 29 + Len(strArrBlueMidSp(i))
                Else
                    lPos = lPos + Len(strArrBlueMidSp(i))
                End If
                If bNonConv = False Then
                    strFeedLine = strNewFeedLine
                End If
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
    
        '●③直前は"("," ",vbTabが許され、かつ後ろには、")"," ",","がなくてはならないが、直前直後以外は制約の無いステートメント配列リスト
        'Dim strArrBlueAnySpliter(4) As String
        'strArrBlueAnySpliter(0) = "Null"
        For i = 0 To UBound(strArrBlueAnySpliter)
            lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueAnySpliter(i), vbTextCompare) > 0
                lPos = InStr(lPos, strFeedLine, strArrBlueAnySpliter(i), vbTextCompare)
                strFrontStrings = Left(strFeedLine, lPos - 1)
                If Len(strFeedLine) > lPos + Len(strArrBlueAnySpliter(i)) Then
                    strBackStrings = Mid(strFeedLine, lPos + Len(strArrBlueAnySpliter(i)))
                Else
                    strBackStrings = ""
                End If
                bNonConv = False
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
  
                If Right(strFrontStrings, 1) <> "(" And Right(strFrontStrings, 1) <> " " And Right(strFrontStrings, 1) <> vbTab Then
                    bNonConv = True
                End If
                If strBackStrings <> "" Then
                    If Left(strBackStrings, 1) <> "(" And Left(strBackStrings, 1) <> " " And Left(strBackStrings, 1) <> vbTab And Left(strBackStrings, 1) <> "," Then
                        bNonConv = True
                    End If
                End If
                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & "" & _
                    strArrBlueAnySpliter(i) & "" & Mid(strFeedLine, lPos + Len(strArrBlueAnySpliter(i)))
                    lPos = lPos + 29 + Len(strArrBlueAnySpliter(i))
                    
                Else
                    lPos = lPos + Len(strArrBlueAnySpliter(i))
                End If
                If bNonConv = False Then
                    strFeedLine = strNewFeedLine
                End If
                
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
        
        '●④前にはSpaceやTab以外は許されず、かつ後ろにSpaceがあってはならない配列リスト
        'Dim strArrBlueTop(26) As String
        'strArrBlueTop(0) = "Do"
        For i = 0 To UBound(strArrBlueTop)
            lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueTop(i), vbTextCompare) > 0
                lPos = InStr(lPos, strFeedLine, strArrBlueTop(i), vbTextCompare)
                If lPos > 1 Then
                    strFrontStrings = Left(strFeedLine, lPos - 1)
                Else
                    strFrontStrings = ""
                End If
                If Len(strFeedLine) > lPos + Len(strArrBlueTop(i)) - 1 Then
                    strBackStrings = Mid(strFeedLine, lPos + Len(strArrBlueTop(i)))
                Else
                    strBackStrings = ""
                End If
                bNonConv = False
                
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
                If strFrontStrings <> "" Then
                    If Right(strFrontStrings, 1) <> "(" And Right(strFrontStrings, 1) <> " " And Right(strFrontStrings, 1) <> vbTab Then
                        bNonConv = True
                    End If
                End If
                If strBackStrings <> "" Then
                    If Left(strBackStrings, 1) <> "(" And Left(strBackStrings, 1) <> " " And Left(strBackStrings, 1) <> vbTab And Left(strBackStrings, 1) <> "," Then
                        bNonConv = True
                    End If
                End If
                
                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & "" & _
                    Left(strArrBlueTop(i), Len(strArrBlueTop(i))) & "" & Mid(strFeedLine, lPos + Len(strArrBlueTop(i)))
                    lPos = lPos + 29 + Len(strArrBlueTop(i))
                Else
                    lPos = lPos + Len(strArrBlueTop(i))
                End If
                If bNonConv = False Then
                    strFeedLine = strNewFeedLine
                End If
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
        
        '●⑤接続句で両側にスペースやタブが必要な配列リスト
        'Dim strArrBlueMid(22) As String
        'strArrBlueMid(0) = " As "
        For i = 0 To UBound(strArrBlueMid)
            lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueMid(i), vbTextCompare) > 0
                lPos = InStr(1, strFeedLine, strArrBlueMid(i), vbTextCompare)
                bNonConv = False
                
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
                

                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & " " & _
                    Mid(strArrBlueMid(i), 2, Len(strArrBlueMid(i)) - 2) & " " & Mid(strFeedLine, lPos + Len(strArrBlueMid(i)))
                    lPos = lPos + 29 + Len(strArrBlueMid(i))
                    strFeedLine = strNewFeedLine
                Else
                    lPos = lPos + Len(strArrBlueMid(i))
                End If
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
        
        '●⑥前には一つ以上のスペースやタブが許され、さらに前には様々な表記も許されるが、後ろにはスペースやTabは入らない配列リスト
        'Dim strArrBlueEnd(24) As String
        'strArrBlueEnd(0) = " Then"
        For i = 0 To UBound(strArrBlueEnd)
            lPos = 1
            While InStr(lPos, strFeedLine, strArrBlueEnd(i), vbTextCompare) > 0
                lPos = InStr(1, strFeedLine, strArrBlueEnd(i), vbTextCompare)
                If lPos > 1 Then
                    strFrontStrings = Left(strFeedLine, lPos - 1)
                Else
                    strFrontStrings = ""
                End If
                If Len(strFeedLine) > lPos + Len(strArrBlueEnd(i)) - 1 Then
                    strBackStrings = Mid(strFeedLine, lPos + Len(strArrBlueEnd(i)))
                Else
                    strBackStrings = ""
                End If
                bNonConv = False
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
                
                If strBackStrings <> "" Then
                    If Right(strFrontStrings, 1) <> " " Then
                        bNonConv = True
                    End If
                End If
                                
                If bNonConv = False Then
                    strNewFeedLine = Left(strFeedLine, lPos - 1) & " " & _
                    Mid(strArrBlueEnd(i), 2, Len(strArrBlueEnd(i)) - 1) & "" & strBackStrings
                    lPos = lPos + 29 + Len(strArrBlueEnd(i))
                Else
                    lPos = lPos + Len(strArrBlueEnd(i))
                End If
                If bNonConv = False Then
                    strFeedLine = strNewFeedLine
                End If
                If lPos > Len(strFeedLine) Then
                    lPos = Len(strFeedLine)
                End If
            Wend
        Next
        
        i = 1
        n = Len(strFeedLine)
        strHeader = ""
        strNbsp = ""
        While Mid(strFeedLine, i, 1) = " " Or Mid(strFeedLine, i, 1) = vbTab And n > 0
            If Mid(strFeedLine, i, 1) = " " Then
                strHeader = strHeader & " "
            Else
                strHeader = strHeader & vbTab
            End If
            strNbsp = strNbsp & " "
            n = n - 1
            i = i + 1
        Wend
        strFeedLine = Replace(strFeedLine, strHeader, strNbsp, 1, -1, vbTextCompare)

        
        For i = 0 To UBound(strArrGreenComment)
            lPos = InStr(1, strFeedLine, strArrGreenComment(i), vbTextCompare)
            bNonConv = False
            If lPos > 0 Then
                bDblQrt = DblQrtChk(lPos, strFeedLine)
                If bDblQrt = True Then
                    bNonConv = True
                End If
            End If
            If lPos > 0 And bNonConv = False Then
                strMidLine = Mid(strFeedLine, lPos + Len(strArrGreenComment(i)))
                strMidLine = Replace(strMidLine, "#191970", "#006600", 1, -1, vbTextCompare)
                strNewFeedLine = Left(strFeedLine, lPos - 1) & "" & _
                strArrGreenComment(i) & strMidLine & ""
                strFeedLine = strNewFeedLine
            End If
        Next
    End If
    sh.Cells(lScanRow, 2).Value = strFeedLine
    '
    '
     '
      'バックインデント
       '
        '
        lScanRow = lScanRow + 1
    Wend
End Sub

Function DblQrtChk(lChkPos As Long, strFeed As String) As Boolean
    Dim lBeforePos As Long
    Dim lAfterPos As Long
    Dim bFindBeforeAfter As Boolean
    Dim bFindAfter As Boolean
    lBeforePos = 1
    bFinderBeforeAfter = False
    bFinderAfter = False
    DblQrtChk = False
    While bFindBeforeAfter = False And Len(strFeed) > lBeforePos
        If InStr(lBeforePos, strFeed, """", vbTextCompare) > 0 Then
            lBeforePos = InStr(lBeforePos, strFeed, """", vbTextCompare)
            '先頭のダブルクォーテションが見つかっても行末なら
            '着色処理を実施することにして終わらせる。
            'ただし、構文エラー
            If Len(strFeed) = lBeforePos Then
                bFindBeforeAfter = True
            ElseIf InStr(lBeforePos + 1, strFeed, """", vbTextCompare) > 0 Then
                '二つ目のダブルクォーテーションがある場合の処理
                'まず文字位置を記録
                lAfterPos = InStr(lBeforePos + 1, strFeed, """", vbTextCompare)
                '検出した２つめの文字位置のもう一文字後ろにダブルクォーテションがある場合
                '終端ではなく、ダブルクォーテーションそのものを表示させるためのエスケープダブルクォーテーション
                'なので、検索開始位置を lAfterPos + 2 として再検索する｡
                While lAfterPos <= Len(strFeed) And bFindAfter = False
                    If lAfterPos < Len(strFeed) Then
                        If Mid(strFeed, lAfterPos, 2) = """""" Then
                            If Len(strFeed) >= lAfterPos + 2 Then
                                lAfterPos = lAfterPos + 2
                            End If
                        ElseIf InStr(lAfterPos, strFeed, """", vbTextCompare) > 0 Then
                            lAfterPos = InStr(lAfterPos, strFeed, """", vbTextCompare)
                            bFindAfter = True
                        Else
                            '　"" の組み合わせのみで、" としての記述がない場合は
                            ' ２つ目はないので、着色処理 DblQrtChk = Falseのまま終了。
                           bFindBeforeAfter = True
                            DblQrtChk = True
                        End If
                    ElseIf lAfterPos = Len(strFeed) Then
                        If InStr(lAfterPos, strFeed, """", vbTextCompare) > 0 Then
                            lAfterPos = InStr(lAfterPos, strFeed, """", vbTextCompare)
                            bFindAfter = True
                        Else
                            '　"" の組み合わせのみで、" としての記述がない場合は
                            ' ２つ目はないので、着色処理 DblQrtChk = Falseのまま終了。
                            bFindBeforeAfter = True
                            DblQrtChk = True
                        End If
                    End If
                Wend
                bFindAfter = False
                If lBeforePos < lChkPos And lAfterPos > lChkPos Then
                    DblQrtChk = True
                    bFindBeforeAfter = True
                ElseIf lBeforePos > lChkPos Then
                    bFindBeforeAfter = True
                Else
                    lBeforePos = lAfterPos + 1
                End If
            Else
                'ダブルクォーテーションが一つだけの行は構文エラー
                '見つかったことにして、
                'ダブルクォーテーション位置が後ろなら着色処理 DblQrtChk = Falseのまま
                '前なら、色を塗らないことにして、この関数の処理を終わらせる。
                If lBeforePos < lChkPos Then
                    DblQrtChk = True
                End If
                bFindBeforeAfter = True
            End If
        Else
           'ダブルクォーテションが見つからない場合は着色処理をするので
           'DblQrtChk = Falseのまま、この関数の処理を終わらせる。
            bFindBeforeAfter = True
        End If
    Wend

End Function

前から使っていたものですが、
パソコンが新しくなったついでに、URL ドメイン抽出マクロを更新しました。

せっかくなのでここにアップロードしておきます。
Download file

ちょっとした動作なので、大したものではないです。

ここのブログはコメントが少ないので、余計に気を使うというか、
なんというか、よくある自動投稿ロボット対策の画像にぐにゃりと読みにくくした
文字列を表示させて、人間様に入力していただいて、やっとで投稿できるものが
あるんですけど、それをやっちゃうと、こういうどうでもいいサイトには致命傷なわけで
ただでさえ、コメントなんて集まらないのに、そんなもんのをつけたら余計にコメントが
あつまらないっす。

セキュリティをかけるという事により、本来のユーザに面倒をかけるという事自体が、
自動投稿ロボットを使う悪人の思うツボになっている訳でして、そういうものに
屈してはいけないと思うのです。

やれ、ウィルスバスターだのノートンだのマカフィだのにお金を使うのも同じことです。
悪人たちの手によって、われわれの生活スタイルが不便になるのは御免なのです。

わるいことする奴がいるから、普通の人の生活にまで浸食するような規制がかかったり、
余計なコストがかかるのです。税金もそうやって消えて行ってるわけです。
そんなことをするくらいなら、最初から税金をお金のない人に還元して
犯罪をおこそうなんて思わない社会にするべきだと思うのです。

でも、まぁ犯罪はなくならないわけでして、ちょっとした予防はせにゃならん。
それも生活スタイルをかえることなくシンプルにかつ効果的かつ効率よく。

そういう意味では２ちゃんねるは書き込みが楽なので流行っているんだと思います。
誰でも使えて、本音をぶちかまし、ありのままの自分でいられるわけです。
それでいて、モラルを築きあげる努力とか、悪い人も、あとから痛い目に合うシステム。
正しい方向には向かってると思いますね。でも、意見がかみ合うことのない議論の場にも
なりつつあるのも確かです。

またまた前置きが長くなりましたが、
作成したマクロはブログのDBシステムからエクスポートできる
コメントやトラックバック履歴のCSV形式のファイルを
エクセルで開いて
https://www.yo-net.jp/といったURI(Uniform Resource Indicater)から
yo-net.jp ドメイン名を抽出し、

(
'yo-net.jp’,
'yo-net.com'.
'yo-net.info'.
'yo-net.net'.
'yo-net.xxx'
)

のようなPerlやPHPの配列初期化に使える形式に変換するものです。

この配列を投稿時に動作するプログラムの中のチェックプログラムとして使うことができます。
まぁ活用する知識がないとこのマクロは何にもならないわけなので、配布しても
役に立たないっすけど。

おまけに、これまでにやってきた、SPAMerのリストもつけておきまかね。

ともかく
トラックバックスパムやコメントスパムをしてきたサイトやメールアドレスからの書き込みを
排除するためにリスト化します。
メールアドレスも一緒にリスト化する関数もオプションで存在しています。

●メールアドレスとURLを抽出するのがCommentNG_SiteList
●URLだけを抽出するのがTrackBackNG_SiteList

があります。
Call TrackBackNGSite(7, "Comment")
となっている部分の最初の引数がドメインが格納されている列番号を指定しています。
上記の例だと 7列目がドメイン名が格納されている列を示します。
lMailAdrsCol = 6
となっている部分がメールアドレスが格納されている列を示します。
誰でも取得できるトップレベルドメインについては
サブドメインがいくらでも設定できるので、
spam.superspam.com
spam1.superspam.com
spam2.superspam.com
と無限に変化させてスパムを投稿してきますので、
ばっさりと、superspam.comというドメインを一毛打尽にするような処理が
はいっています。
各国のトップレベルドメインと２レベルドメインの組み合わせまでは網羅していないので、
そのあたりは、おいおい改良しないといけないなぁと思ってます。
こういうのは、今はエクセルで区切り位置調整とかを駆使してサブドメイン削除とかやります。

Sub CommentNG_SiteList()
    Call TrackBackNGSite(7, "Comment")
End Sub
Sub TrackBackNG_SiteList()
    Call TrackBackNGSite(6, "TrackBack")
End Sub
Function TrackBackNGSite(lDomainCol As Long, strMode As String)
    Dim strAdrs As String
    Dim lAdrsCol As Long
    Dim lScanRow As Long
    Dim sh As Worksheet
    Dim strDomainAdrs As String
    Dim strCSVtext As String
    Dim lPos As Long
    Dim strNGAllList() As String
    Dim strNGList() As String
    Dim strNGMailAllList() As String
    Dim strNGMailList() As String
    
    Dim TopLevelDomain(5) As String '誰でも取得できるトップレベルドメイン一覧
    TopLevelDomain(0) = ".com"
    TopLevelDomain(1) = ".net"
    TopLevelDomain(2) = ".org"
    TopLevelDomain(3) = ".info"
    TopLevelDomain(4) = ".biz"
    TopLevelDomain(5) = ".xxx"
    strDateTime = Format(Now, "YYMMDDHHMMSS")
    If strMode = "TrackBack" Then
        strFileName = "TrackBackNGList" & strDateTime & ".txt"
    Else
        strFileName = "CommentNGList" & strDateTime & ".txt"
    End If
    Set sh = ActiveSheet
    lAdrsCol = lDomainCol
    lMailAdrsCol = 6
    lScanRow = 1
    strCSVtext = "(" & vbLf
    While sh.Cells(lScanRow, 1).Value <> ""
        ReDim Preserve strNGAllList(lScanRow - 1)
        ReDim Preserve strNGMailAllList(lScanRow - 1)
        strDomainAdrs = sh.Cells(lScanRow, lAdrsCol).Value
        If strMode = "Comment" Then
            strMailAdrs = sh.Cells(lScanRow, 6).Value
        End If
        'http://の削除と 最初の / 以降の文字列削除
        If Len(strDomainAdrs) > 8 Then
            If Left(strDomainAdrs, 7) = "http://" Then
                strDomainAdrs = Mid(strDomainAdrs, 8)
                If InStr(1, strDomainAdrs, "/", vbTextCompare) > 0 Then
                    lPos = InStr(1, strDomainAdrs, "/", vbTextCompare)
                    strDomainAdrs = Left(strDomainAdrs, lPos - 1)
                End If
            End If
        End If
        
        'www.の削除処理
        If Len(strDomainAdrs) > 4 Then
            If Left(strDomainAdrs, 4) = "www." Then
                strDomainAdrs = Mid(strDomainAdrs, 5)
            End If
        End If
        
        'Topレベルドメインのサブドメイン削除処理
        For i = 0 To UBound(TopLevelDomain)
        If Len(strDomainAdrs) > Len(TopLevelDomain(i)) Then
            If Right(strDomainAdrs, Len(TopLevelDomain(i))) = TopLevelDomain(i) Then
                If InStrRev(strDomainAdrs, ".", Len(strDomainAdrs) - Len(TopLevelDomain(i)), vbTextCompare) > 0 Then
                    lPos = InStrRev(strDomainAdrs, ".", Len(strDomainAdrs) - Len(TopLevelDomain(i)), vbTextCompare)
                    strDomainAdrs = Mid(strDomainAdrs, lPos + 1)
                End If
            End If
        End If
        Next
        strNGAllList(lScanRow - 1) = strDomainAdrs
        If strMode = "Comment" Then
            strNGMailAllList(lScanRow - 1) = strMailAdrs
        End If
        strCSVtext = strCSVtext & "'" & strDomainAdrs & "'"
        
        '最後の行でないなら、区切り,と改行。最後なら)で閉じるだけ。
        If sh.Cells(lScanRow + 1, 1).Value <> "" Then
            strCSVtext = strCSVtext & "," & vbLf
        End If
        lScanRow = lScanRow + 1
        
    Wend
    
    '重複部分の削除処理 ドメイン部分
    j = -1
    For i = 0 To UBound(strNGAllList)
        
        If j = -1 Then
            j = 0
            ReDim strNGList(0)
            strNGList(j) = strNGAllList(i)
        Else
            strOverlapChk = strNGAllList(i)
            bOverlap = False
            For j = 0 To UBound(strNGList)
                If strOverlapChk = strNGList(j) Then
                    bOverlap = True
                End If
            Next
            If bOverlap = False Then
                
                ReDim Preserve strNGList(UBound(strNGList) + 1)
                strNGList(j) = strOverlapChk
                j = j + 1
            End If
        End If
    Next
    
    '重複部分の削除処理 ドメイン部分
    If strMode = "Comment" Then
    j = -1
    For i = 0 To UBound(strNGMailAllList)
        
        If j = -1 Then
            j = 0
            ReDim strNGMailList(0)
            strNGMailList(j) = strNGMailAllList(i)
        Else
            strOverlapChk = strNGMailAllList(i)
            bOverlap = False
            For j = 0 To UBound(strNGMailList)
                If strOverlapChk = strNGMailList(j) Then
                    bOverlap = True
                End If
            Next
            If bOverlap = False Then
                ReDim Preserve strNGMailList(UBound(strNGMailList) + 1)
                strNGMailList(j) = strOverlapChk
                j = j + 1
            End If
        End If
    Next
    End If
    strCSVtext = strCSVtext & vbLf & ")"
    lArrSize = UBound(strNGList)
    
    If strMode = "Comment" Then
    ReDim Preserve strNGList(UBound(strNGList) + UBound(strNGMailList) + 1)
    For j = 0 To UBound(strNGMailList)
          strNGList(lArrSize + 1 + j) = strNGMailList(j)
    Next
    End If
    'strNGList配列をPerl配列形式へ書き出す。
    strText = "(" & vbLf
    For j = 0 To UBound(strNGList)
        If j < UBound(strNGList) Then
            strText = strText & "'" & strNGList(j) & "'," & vbLf
        Else
            strText = strText & "'" & strNGList(j) & "'" & vbLf & ")"
        End If
    Next
    
    Debug.Print strText
    strPathName = ActiveWorkbook.Path
    strPathFileName = strPathName & "\" & strFileName
    Debug.Print strCSVtext
    intFF = FreeFile
    Open strPathFileName For Output As #intFF
    Print #intFF, strText
    Close #intFF
End Function