特殊・他 CSSのIDとClass名をHtmlと同時に変更する

※より実装に近く表示させる為、コードの改行を避けています。スマホ等で閲覧される際は向きを変えてご覧ください。

※実装するバージョンによってはバージョンアップの仕様により動作しないコードもあります。実装には動作確認の上ご使用下さい。

Option Explicit
'***********************************************
'CSSのIDとClass名をHtmlと同時に変更する
'***********************************************
'CSSは１行づつ並んでいることが条件です。
'http://www.akiyan.com/css_beautifier
'↑オンラインで無料で整形可能です(スペースが必要)
'先にHTMLの方からIDとClassを探します。
'動作確認済ですがバックアップをとってから実行願います。
'同階層に[変換元][変換先]フォルダが必要です。
'[変換元]フォルダに変更するそれぞれのファイルを入れて実行。

Dim shtDdata As Worksheet

Sub 開始1()
'***********************************************
'フォルダ内の全てのファイル取得
'***********************************************

Dim buf As String, tgtPath As String, sbuf As String
Dim strExtension As String, OutPath As String
Dim TargetFile As String, n As Long
Dim sampleName As String

strExtension = "*.htm*" '拡張子指定

Set shtDdata = ThisWorkbook.Worksheets("Data")
shtDdata.Cells.ClearContents
    shtDdata.Cells(1, 1).Value = "HTMLID"
    shtDdata.Cells(1, 2).Value = "→"
    shtDdata.Cells(1, 3).Value = "変更"

    shtDdata.Cells(1, 5).Value = "HTMLClass"
    shtDdata.Cells(1, 6).Value = "→"
    shtDdata.Cells(1, 7).Value = "変更"

    shtDdata.Cells(1, 9).Value = "【説明】"
    shtDdata.Cells(2, 9).Value = "・変更不要な場合は空白のまま。"
    shtDdata.Cells(3, 9).Value = "・id=""aaa""のaaa部分のみ入力"
    shtDdata.Cells(4, 9).Value = "・一目で変更したと判るような変更が良い"

tgtPath = ThisWorkbook.Path & "\変換元"
OutPath = ThisWorkbook.Path & "\変換先"

DeleteFile OutPath & "\", strExtension

sbuf = Dir(tgtPath & "\" & strExtension)
Do While sbuf <> ""
    n = FreeFile '使われていないファイル番号を自動的に割り振る
    TargetFile = tgtPath & "\" & sbuf
    buf = Space(FileLen(TargetFile))
    Open TargetFile For Binary As #n 'binaryモードで開いたファイル
        Get #n, , buf 'からデータを読み込むにはGetステートメントを使う
    Close #n

    SearchAllLettersBetween buf, " id=", """", 1
    SearchAllLettersBetween buf, " class=", """", 5
    sbuf = Dir()
Loop

sampleName = InputBox("ここでサンプル改変名で入力できます。※英字小文字で入力" _
 & vbCr & vbCr & "※全て実行されます。", "サンプル", "sample")
If sampleName <> "" Then
    SampleMaking sampleName
    開始2
Else
MsgBox "シート" & shtDdata.Name & "を参照し変更後、[開始2]を行って下さい。"
End If

End Sub

Private Sub SearchAllLettersBetween(str As String, strFoundFront As String, strFoundBack As String, lngCol As Long)
'************************************************
'文字中の指定文字と指定文字間の文字を全て検索
'************************************************
'引数strは対象文字群
'引数strFoundFrontは前方検索対象文字
'引数strFoundBackは後方検索対象文字

'＜例＞
'str = "zyzyzyzabc="def"zyzyzyzabc="ghij"zyz"
'strFoundFront = "abc="
'strFoundBack = """"
'返値は [abc="def"] と[abc="ghij"]　になります。

'＜解説＞
'Replace関数で一度検索したものは全て消すところがミソ！
'検索文字がなくなるまで実行します。
'書き出したい場合は[Debug.Print Xa]の個所を改変してください。

Dim i As Long, Xa As String, Xb As Long, j As Long

reTRY: '再帰①
i = InStr(1, str, strFoundFront) '前方検索対象文字位置
If i = 0 Then GoTo TheEnd: '無ければ終了②
Xb = InStr(i + Len(strFoundFront) + 1, str, strFoundBack) '後方検索対象文字位置
Xa = Mid(str, i, Xb - i + 1) '値をゲット
Debug.Print Xa
j = shtDdata.Cells(65536, lngCol).End(xlUp).Row + 1
shtDdata.Cells(j, lngCol).Value = Xa
shtDdata.Cells(j, lngCol + 1).Value = "→"
str = Replace(str, Xa, "") 'ゲット後は削除する(対象文字群内全て)

GoTo reTRY: '再帰①
TheEnd: '無ければ終了②
End Sub

Sub 開始2()
'***********************************************
'フォルダ内の全てのファイル取得
'***********************************************

Dim buf As String, tgtPath As String, sbuf As String
Dim strExtension As String, OutPath As String
Dim TargetFile As String, n As Long
Dim strExtension2 As String
Dim i As Long, vrnCSS As Variant, vrnCSS2 As Variant, vrnCSS3 As Variant
Dim strA As String, lngCSS As Long

Set shtDdata = ThisWorkbook.Worksheets("Data")

tgtPath = ThisWorkbook.Path & "\変換元"
OutPath = ThisWorkbook.Path & "\変換先"

DeleteFile OutPath & "\", strExtension

strExtension = "*.htm*" '拡張子指定
strExtension2 = "*.css" '拡張子指定

'===================================================================================
'【HTML】
sbuf = Dir(tgtPath & "\" & strExtension)
Do While sbuf <> ""
    n = FreeFile '使われていないファイル番号を自動的に割り振る
    TargetFile = tgtPath & "\" & sbuf
    buf = Space(FileLen(TargetFile))
    Open TargetFile For Binary As #n 'binaryモードで開いたファイル
        Get #n, , buf 'からデータを読み込むにはGetステートメントを使う
    Close #n
    strA = buf
    With shtDdata
        For i = 1 To .Cells(65536, 1).End(xlUp).Row
            If .Cells(i, 3).Value <> "" Then
                If InStr(1, .Cells(i, 1).Value, "=") <> 0 Then
                   strA = Replace(strA, Trim(.Cells(i, 1).Value), "id=""" & Trim(.Cells(i, 3).Value) & """")
                End If
            End If
        Next i

        For i = 1 To .Cells(65536, 5).End(xlUp).Row
            If .Cells(i, 7).Value <> "" Then
                If InStr(1, .Cells(i, 5).Value, "=") <> 0 Then
                   strA = Replace(strA, Trim(.Cells(i, 5).Value), "class=""" & Trim(.Cells(i, 7).Value) & """")
                End If
            End If
        Next i
        pbsTxtWrites TargetFile, strA
    End With

    sbuf = Dir()
Loop
'===================================================================================
'【CSS】
sbuf = Dir(tgtPath & "\" & strExtension2)
Do While sbuf <> ""
    n = FreeFile '使われていないファイル番号を自動的に割り振る
    TargetFile = tgtPath & "\" & sbuf
    buf = Space(FileLen(TargetFile))
    Open TargetFile For Binary As #n 'binaryモードで開いたファイル
        Get #n, , buf 'からデータを読み込むにはGetステートメントを使う
    Close #n
    strA = buf
    With shtDdata
        For i = 1 To .Cells(65536, 1).End(xlUp).Row
            If .Cells(i, 3).Value <> "" Then
                If InStr(1, .Cells(i, 1).Value, "=") <> 0 Then
                    vrnCSS = Split(Trim(.Cells(i, 1).Value), """")
                    strA = Replace(strA, "#" & Trim(vrnCSS(1)) & " ", "#" & Trim(.Cells(i, 3).Value) & " ")
                End If
            End If
        Next i

        For i = 1 To .Cells(65536, 5).End(xlUp).Row
            If .Cells(i, 7).Value <> "" Then
                If InStr(1, .Cells(i, 5).Value, "=") <> 0 Then
                    vrnCSS = Split(Trim(.Cells(i, 5).Value), """")
                    '複数要素設定の場合
                    vrnCSS2 = Split(Trim(vrnCSS(1))) '原文字
                    vrnCSS3 = Split(Trim(.Cells(i, 7).Value)) '変更文字
                    For lngCSS = LBound(vrnCSS2) To UBound(vrnCSS2)
                        strA = Replace(strA, "." & Trim(vrnCSS2(lngCSS)) & " ", "." & Trim(vrnCSS3(lngCSS)) & " ")
                    Next lngCSS
                End If
            End If
        Next i
        pbsTxtWrites TargetFile, strA
    End With

    sbuf = Dir()
Loop
'===================================================================================

MsgBox "完了"

tgtPath = ThisWorkbook.Path & "\変換元"
OutPath = ThisWorkbook.Path & "\変換先"

Name tgtPath As ThisWorkbook.Path & "\変換元A"
Name OutPath As ThisWorkbook.Path & "\変換先A"

Name ThisWorkbook.Path & "\変換元A" As ThisWorkbook.Path & "\変換先"
Name ThisWorkbook.Path & "\変換先A" As ThisWorkbook.Path & "\変換元"

End Sub

Private Sub pbsTxtWrites(TxtPath As String, str As String)
'*******************************************************************************
'指定パスのテキストファイルに書き込み
'*******************************************************************************
    Dim n As Long
    n = FreeFile '使われていないファイル番号を自動的に割り振る
    Open TxtPath For Output As #n
        Print #n, str
    Close #n

' キーワード 処理             モード
' Input   読み込み           入力モード
' Output  書き込み           出力モード
' Append  書き込み           追加モード
' Random  読み込み/書き込み  ランダムアクセスモード(データベースのデータファイルにアクセスするモード)
' Binary  読み込み/書き込み  バイナリモード(ファイルのデータを一気に読み込む)

End Sub

Private Sub DeleteFile(strPath As String, strFileName As String)
'**************************************
'ファイルを削除　引数指定
'パスの最後に[\]を付けない
'**************************************

On Error Resume Next

Kill strPath & "\" & strFileName

On Error GoTo 0

End Sub

Private Sub SampleMaking(str As String)
Dim shtDdata As Worksheet, i As Long, vrnCSS As Variant, vrnCSS2 As Variant
Dim lngCSS As Long, smName() As String, cntName As Long, blnName As Boolean
Dim mkName As String
ReDim smName(cntName) As String
Set shtDdata = ThisWorkbook.Worksheets("Data")
    With shtDdata
        For i = 1 To .Cells(65536, 1).End(xlUp).Row
            If .Cells(i, 3).Value = "" Then
                If InStr(1, .Cells(i, 1).Value, "=") <> 0 Then
                   .Cells(i, 3).Value = "id_" & str & "_" & i - 1
                End If
            End If
        Next i

        For i = 1 To .Cells(65536, 5).End(xlUp).Row
            If .Cells(i, 7).Value = "" Then
                If InStr(1, .Cells(i, 5).Value, "=") <> 0 Then
                    vrnCSS = Split(Trim(.Cells(i, 5).Value), """")
                    '複数要素設定の場合
                    vrnCSS2 = Split(Trim(vrnCSS(1)))
                    For lngCSS = LBound(vrnCSS2) To UBound(vrnCSS2)
                        '既にあるかチェック
                        blnName = False
                        For cntName = LBound(smName) To UBound(smName)
                            If smName(cntName) = vrnCSS2(lngCSS) Then
                                blnName = True
                                Exit For
                            End If
                        Next cntName
                        If blnName = False Then
                            ReDim Preserve smName(cntName)
                            smName(cntName) = vrnCSS2(lngCSS)
                            cntName = cntName + 1
                        End If
                    Next lngCSS
                End If
            End If
        Next i

        For i = 1 To .Cells(65536, 5).End(xlUp).Row
            If .Cells(i, 7).Value = "" Then
                If InStr(1, .Cells(i, 5).Value, "=") <> 0 Then
                    vrnCSS = Split(Trim(.Cells(i, 5).Value), """")
                    '複数要素設定の場合
                    vrnCSS2 = Split(Trim(vrnCSS(1)))
                    mkName = ""
                    For lngCSS = LBound(vrnCSS2) To UBound(vrnCSS2)
                        For cntName = LBound(smName) To UBound(smName)
                            If vrnCSS2(lngCSS) = smName(cntName) Then
                               mkName = mkName & "cls_" & str & "_" & cntName & " "
                            End If
                        Next cntName
                    Next lngCSS
                   .Cells(i, 7).Value = Trim(mkName)
                End If
            End If
        Next i
    End With
End Sub

Private Sub test()
SampleMaking "smsmsms"
End Sub

 

 

 

2000年01月01日|[VBサンプルコード]:[特殊・他]