【VBA XML操作】ドコモバックアップのファイル復旧

Option Explicit

‘ファイル一覧を取得
Sub Main_SearchAllXmlFiles()
    Dim objFSO As FileSystemObject
    Dim strPATHNAME As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet2")
   
    strPATHNAME = InputBox("ファイル名指定", "ファイル名指定", "C:\")
       
    ‘初期化
    ws.Cells.ClearContents
    ws.Cells.NumberFormatLocal = "@"
   
    Set objFSO = New FileSystemObject
    ‘ ルートフォルダから探索開始
    Call ReadAllXmlFile(objFSO.GetFolder(strPATHNAME), ws, 0, 1)
    Set objFSO = Nothing

End Sub

‘ファイル一覧を取得　うちxmlファイルだけ解析
Private Sub ReadAllXmlFile(ByVal objPATH As Folder, _
                              ByRef ws As Worksheet, _
                              ByRef RowPos As Long, _
                              ByVal colmunPos As Long)
    Dim objPATH2 As Folder
    Dim objFILE As File

    RowPos = RowPos + 1
    colmunPos = 1
   
    ws.Cells(RowPos, colmunPos).Value = objPATH.Path
    ws.Cells(RowPos, colmunPos + 1).Value = objPATH.Type
    ws.Cells(RowPos, colmunPos + 2).Value = objPATH.Name

    For Each objPATH2 In objPATH.SubFolders
        ‘ フォルダ単位のサブ処理(再帰呼び出し)
        Call ReadAllXmlFile(objPATH2, ws, RowPos, 1)
    Next objPATH2

    ‘xmlファイルをシート上に表示
    For Each objFILE In objPATH.Files
        RowPos = RowPos + 1  ‘ 行を加算
        With objFILE
            ws.Cells(RowPos, colmunPos).Value = objPATH.Path
            ws.Cells(RowPos, colmunPos + 1).Value = .Type
            ws.Cells(RowPos, colmunPos + 2).Value = .Name
        End With
        If objFILE.Type = "XML ドキュメント" Then
            ‘xmlだけ中身を確認
            Call ReadmediaNameFromXML(objFILE.Path, ws, RowPos, 1)
        End If
        DoEvents
    Next objFILE
    ‘ 参照OBJECTを破棄
    Set objPATH = Nothing
End Sub

‘xmlファイル解析のコアロジック
‘docomoバックアップでは、audio image video　があるようだ
Sub ReadmediaNameFromXML(ByVal Fname As String, _
                              ByRef ws As Worksheet, _
                              ByRef RowPos As Long, _
                              ByVal colmunPos As Long)
   
    On Error GoTo Err
   
    Dim xmlDocument As MSXML2.DOMDocument60
    Dim elem_hoge As IXMLDOMElement
    Dim elem_fuga As IXMLDOMElement
   
    Set xmlDocument = Nothing
    Set xmlDocument = New MSXML2.DOMDocument60
   
    Call xmlDocument.Load(Fname)

    Set elem_hoge = xmlDocument.getElementsByTagName("audio").Item(0)
    If Not elem_hoge Is Nothing Then
   
        For Each elem_fuga In elem_hoge.getElementsByTagName("media_columns")
            ws.Cells(RowPos, colmunPos + 4).Value = elem_fuga.getAttribute("data")
            ws.Cells(RowPos, colmunPos + 5).Value = elem_fuga.Text
        Next elem_fuga
        GoTo EXIT_
    End If

    Set elem_hoge = xmlDocument.getElementsByTagName("image").Item(0)
    If Not elem_hoge Is Nothing Then
        For Each elem_fuga In elem_hoge.getElementsByTagName("media_columns")
            ws.Cells(RowPos, colmunPos + 4).Value = elem_fuga.getAttribute("data")
            ws.Cells(RowPos, colmunPos + 5).Value = elem_fuga.Text
        Next elem_fuga
        GoTo EXIT_

    End If

    Set elem_hoge = xmlDocument.getElementsByTagName("video").Item(0)
    If Not elem_hoge Is Nothing Then
        For Each elem_fuga In elem_hoge.getElementsByTagName("media_columns")
            ws.Cells(RowPos, colmunPos + 4).Value = elem_fuga.getAttribute("data")
            ws.Cells(RowPos, colmunPos + 5).Value = elem_fuga.Text
        Next elem_fuga
        GoTo EXIT_

    End If
    ws.Cells(RowPos, colmunPos + 4).Value = "UNNOUNーーーーーーーーーーーーーーーーーー"
   
Err:
    ws.Cells(RowPos, colmunPos + 6).Value = Err.Description

EXIT_:
End Sub

‘１ファイルのxmlファイルを解析するロジック（audioのみのサンプル）
Sub ReadXML()
   
    Dim xmlDocument As MSXML2.DOMDocument60
   
    Set xmlDocument = Nothing
    Set xmlDocument = New MSXML2.DOMDocument60

    Dim membersNode As IXMLDOMNode
    Dim memberNode As IXMLDOMNode
    Dim memberAttribute As MSXML2.IXMLDOMAttribute
   
    Dim elem_hoge As IXMLDOMElement
    Dim elem_fuga As IXMLDOMElement
   
    Call xmlDocument.Load("C:\test\1.xml")

    Set elem_hoge = xmlDocument.getElementsByTagName("audio").Item(0)

    ‘ 子要素をリストアップ
    Dim i As Integer
    i = 1
    For Each elem_fuga In elem_hoge.getElementsByTagName("media_columns")
        Cells(i, 1).Value = elem_fuga.getAttribute("data")
        Cells(i, 2).Value = elem_fuga.Text
      
             
        i = i + 1
    Next elem_fuga
   
    MsgBox "読み込みました。"

End Sub

‘sdbファイル名の置換
Sub sdbファイル名の変換()
    Dim src As String
    Dim dst As String
    Dim ws As Worksheet
    Dim r As Range
    Set ws = ThisWorkbook.Sheets("Sheet2")
   
    For Each r In ws.Range("A1:A16625")
        If r.Offset(0, 1).Value = "SDB ファイル" Then
            
            Debug.Print r.Value
            Debug.Print r.Offset(0, 1).Value
            Debug.Print r.Offset(0, 2).Value
            Debug.Print r.Offset(0, 4).Value
            src = r.Value & "\" & r.Offset(0, 2).Value
            dst = r.Value & "\" & r.Offset(0, 4).Value
            Debug.Print src
            Debug.Print dst
            Application.StatusBar = "変換前=" & r.Offset(0, 2).Value & "  変換後=" & r.Offset(0, 4).Value
            
            Call FileCopy(src, dst)
        End If
        DoEvents
    Next r
End Sub