metaタグ修正のVBA

- 4月 14, 2018

仕事でHTMLファイル編集する必要が出てきたので
EXCELVBAで組んでみた。
大量のHTMLファイルを修正する際に使えそうなので
メモしとくまぁ、過去問の応用編みたいな感じです。
相変わらずエラー制御は甘い
ちなみに<は全角に置き換えてるんで注意ください。

Option Explicit

Public Type metaExcelRtn
    code As Boolean
    excelFilepath As String
    meta_Discription As String
    meta_Keyword As String
    meta_title As String
End Type

'meta変換用EXCELシート読込
Function readMetaExcel(readmetaExcelbook As Variant) As metaExcelRtn()
On Error GoTo Error_Sub

    Dim orgExcel As Workbook
    Dim orgWorksheet As Worksheet
    Dim sn As Long      'シート番号
    Dim sc As String    '開始列
    Dim ec As String    '終了列
    Dim rowCount As Long
    Dim colCount As Long
    Dim i As Long
    Dim rtnVal() As metaExcelRtn
    
    Dim t_title As Long
    Dim t_keyword As Long
    Dim t_description As Long
    Dim fpath As Long
    
    Const STAR = "J"
    Const ENDR = "L"

    '読込EXCEL指定
    Set orgExcel = Workbooks.Open(readmetaExcelbook)
    sn = InputBox("読込対象のシート番号を入力してください。", "シート番号読取", 1)
    If IsNumeric(sn) Then
        Set orgWorksheet = orgExcel.Worksheets(sn)
    Else
        MsgBox ("番号で入力してください。")
        Exit Function
    End If
    'meta記載箇所の指定
    sc = InputBox("メタタグ読込開始列アルファベットを入力してください。", "列読取", STAR)
    If sc Like "[A-Z]" = True Then
        ec = InputBox("メタタグ読込終了列アルファベットを入力してください。", "列読取", ENDR)
        If ec Like "[A-Z]" = True Then
            rowCount = Cells(Rows.Count, 1).End(xlUp).Row + 1 '最終行番号を取得
            colCount = Cells(1, Columns.Count).End(xlToLeft).Column
            
            'タイトル行判別を取得しそれぞれの列アルファベットを取得
            For i = colCount To 1 Step -1
                If Cells(1, i).Value Like "*FILE_PATH*" Then
                   fpath = Cells(1, i).Column
                ElseIf Cells(1, i).Value Like "*DESCRIPTION*" Then
                   t_description = Cells(1, i).Column
                ElseIf Cells(1, i).Value Like "*KYEWORD*" Then
                   t_keyword = Cells(1, i).Column
                ElseIf Cells(1, i).Value Like "*TITLE*" Then
                   t_title = Cells(1, i).Column
                End If
            Next i
            
            '格納用配列定義
            ReDim rtnVal(rowCount)
            
            For i = 1 To rowCount
                rtnVal(i).code = True
                rtnVal(i).excelFilepath = Cells(i, fpath).Value
                rtnVal(i).meta_Discription = Cells(i, t_description).Value
                rtnVal(i).meta_Keyword = Cells(i, t_keyword).Value
                rtnVal(i).meta_title = Cells(i, t_title).Value
            Next i
        Else
            MsgBox ("終了列名はアルファベットで入力してください。")
            Exit Function
        End If
    Else
        MsgBox ("開始列名はアルファベットで入力してください。")
        Exit Function
    End If
        
    orgExcel.Close
    Set orgExcel = Nothing
    readMetaExcel = rtnVal
    Exit Function

Error_Sub:
    For i = 1 To rowCount
        rtnVal(i).code = False
    Next i
    readMetaExcel = rtnVal
    MsgBox ("ERROR:" & Err.Number & ":" & Err.Description)
End Function

' フォルダ内のファイル名を取得し変換対象シートのファイル名と比較する
Function FileSearch(path As Variant, targetStrcut() As metaExcelRtn, sCol As Long) As String
On Error GoTo Error_Sub
    Dim objFs As Object, objFiles As Object, objFolders As Object, objHtml As Object
    Dim File_Path As String, File_Name As String
    Dim i As Long, arrData
    Dim j As Long
    Dim s As Variant
    Dim wHtml As String
    'タグ
    Dim start_metaDis As String
    start_metaDis = "＜meta name=" & Chr(34) & "description" & Chr(34) & " content=" & Chr(34)
    Dim start_Metakey As String
    start_Metakey = "＜meta name=" & Chr(34) & "keywords" & Chr(34) & " content=" & Chr(34)
    Dim end_tag As String
    end_tag = Chr(34) & "＞"
    Dim start_Title As String
    start_Title = "＜title＞"
    Dim end_Title As String
    end_Title = "＜/title＞"
    
    Application.ScreenUpdating = False
    Set objFs = CreateObject("Scripting.FileSystemObject")
    i = sCol
    'パスの取得
    For Each objFolders In objFs.getFolder(path).SubFolders
        'サブフォルダまで検索するために再帰実行
        Call FileSearch(objFolders.path, targetStrcut, i)
    Next
     
    'ファイル名の取得
    For Each objFiles In objFs.getFolder(path).Files
        If objFs.GetExtensionName(objFiles.path) = "html" Or objFs.GetExtensionName(objFiles.path) = "htm" Then
            '一致したら置換
            For s = LBound(targetStrcut) To UBound(targetStrcut)
                If targetStrcut(s).excelFilepath = objFiles.path Then
                    wHtml = readHtml(objFiles.path)
                    'description
                    If targetStrcut(s).meta_Discription <> "" Then
                       wHtml = metaTranslate(wHtml, start_metaDis, end_tag, targetStrcut(s).meta_Discription)
                    End If
                    'keyword
                    If targetStrcut(s).meta_Keyword <> "" Then
                       wHtml = metaTranslate(wHtml, start_Metakey, end_tag, targetStrcut(s).meta_Keyword)
                    End If
                    'title
                    If targetStrcut(s).meta_title <> "" Then
                       wHtml = metaTranslate(wHtml, start_Title, end_Title, targetStrcut(s).meta_title)
                    End If
                    'HTMLファイルをUTF-8で保存
                    Call saveHtml(wHtml, objFiles.path)
                End If
            Next s
        End If
    Next
    sCol = i
    
    Application.ScreenUpdating = True
    FileSearch = "True"
    Exit Function

Error_Sub:  'あまりよろしくないが予期せぬエラー処理
    Application.ScreenUpdating = True
    FileSearch = "False"
    MsgBox ("ERROR:" & Err.Number & ":" & Err.Description)
    
End Function

'読込んだHTMLを返す
Function readHtml(fileName As String) As String
On Error GoTo Error_Sub
    Dim buf_strTxt As String '読み込みバッファ
    '全文読み込み
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Open
        .LoadFromFile fileName
        buf_strTxt = .ReadText
        .Close
    End With

    readHtml = buf_strTxt
    Exit Function

Error_Sub:
    readHtml = "False"
    MsgBox ("ERROR:" & Err.Number & ":" & Err.Description)
End Function

'含む文字列が存在すればその間を置換、存在しなければ挿入
Function metaTranslate(targetHtml As String, startText As String, endText As String, Newtext As String) As String

    'Dim wkText As String
    Dim replaceWord As Variant
    Dim fPos As Long
    Dim dPos As Long
    Dim Reg As Object
    Dim mc As Object
    Dim Match As Object
    
    Set Reg = CreateObject("VBScript.RegExp")
    With Reg
        .Pattern = startText & "[\s\S]*?" & endText    'パターン設定
        .IgnoreCase = False              '大文字小文字を区別
        .Global = True                   '文字列全体を検索
    End With

    If InStr(targetHtml, startText) <> 0 Then
       '開始文字列と終了文字列の間を置換する
       
        Set mc = Reg.Execute(targetHtml)
        If mc.Count <> 0 Then
            For Each Match In mc
                metaTranslate = Replace(targetHtml, Match.Value, Newtext)
            Next
        End If
        Set Reg = Nothing
    Else
       'メタタグを挿入する
       'TOTO メタタグがない場合にheadタグの間に埋め込むロジック必要
    End If
End Function

'HTMLファイルを保存する
Function saveHtml(buf_strTxt As String, fileName As String) As String
On Error GoTo Error_Sub
    '全文書き込み
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"
        .Type = 2
        .Open
        .WriteText buf_strTxt
        .SaveToFile (fileName), 2
        .Close
    End With

    saveHtml = "True"
    Exit Function

Error_Sub:
    saveHtml = "False"
    MsgBox ("ERROR:" & Err.Number & ":" & Err.Description)
End Function

あくまで主要ロジック箇所だけ抜き出しているだけなので、
これだけコピペしても動きません。
エラー制御がしっかりかけてメタタグがない場合のロジックがかけたら
どっかで公開してもいいかなぁと。
お役に立てていただけると幸いです。

このブログを検索

アラフィフおやじログ

metaタグ修正のVBA

コメント

このブログの人気の投稿

GASでGoogleDriveのサブフォルダとファイル一覧を出力する

マクロ経済学(IS-LM分析)

IEのセキュリティ設定をいじくるバッチ