VBA编写Ribbon Custom UI编辑器07——写入xml

'写入customUI.xml
Sub WriteCustomUI()
    Dim arr()
    Dim sXML As String
    
    arr = Range("A1").CurrentRegion.Value
    '单元格内容转换为xml文本
    sXML = Array2XMLString(arr)
    If VBA.Len(sXML) = 0 Then
        MsgBox "请在单元格中设置customUI"
        Exit Sub
    End If
    Dim bucs2() As Byte
    bucs2 = sXML
    
    '转换编码
    Dim bUTF8() As Byte
    Dim ret As String
    ret = ToUTF8(bucs2, bUTF8)
    If VBA.Len(ret) Then
        MsgBox "编码转换出错：" & vbNewLine & ret
        Exit Sub
    End If
    
    '检查是否设置了目标文件
    If VBA.Len(FileName) = 0 Then
        FileName = SelectFile()
        If VBA.Len(FileName) = 0 Then Exit Sub
    End If
    
    '备份文件
    If bBakFile Then
        VBA.FileCopy FileName, FileName & ".备份" & VBA.Format(VBA.Now(), "yyyymmddhhmmss")
    End If
    
    Dim zip As CPKZip
    Set zip = NewCPKZip()
    '解析文件
    ret = zip.Parse(FileName)
    If VBA.Len(ret) Then
        MsgBox ret
        Exit Sub
    End If
    
    '判断是否存在CUSTOMUI_NAME，不存在的情况下还要更新rel
    Dim fs() As String
    fs = zip.Files()
    Dim i As Long
    For i = 0 To UBound(fs)
        If fs(i) = CUSTOMUI_NAME Then
            Exit For
        End If
    Next
    
    Dim b() As Byte '记录_rels/.rels
    If i = UBound(fs) + 1 Then
        '添加rel
           ret = zip.UnZipFile("_rels/.rels", b)
        If VBA.Len(ret) Then
            MsgBox ret
            Exit Sub
        End If
        
        ret = FromUTF8(b, bucs2)
        If VBA.Len(ret) Then
            MsgBox ret
            Exit Sub
        End If
        '将最后的</Relationships>替换为<Relationship Id="VBAPKZIP" Type="http://schemas.microsoft.com/office/2006/relationships/ui/extensibility" Target="customUI/customUI.xml"/></Relationships>
        Dim str As String
        str = bucs2
        str = VBA.Left$(str, VBA.Len(str) - VBA.Len("</Relationships>"))
        str = str & "<Relationship Id=""VBAPKZIP"" Type=""http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"" Target=""customUI/customUI.xml""/></Relationships>"
        
        bucs2 = str
        
        ret = ToUTF8(bucs2, b)
        If VBA.Len(ret) Then
            MsgBox ret
            Exit Sub
        End If
        
        ret = zip.AddFile("_rels/.rels", b)
        If VBA.Len(ret) Then
            MsgBox ret
            Exit Sub
        End If
    End If
    
    '添加customUI.xml
    ret = zip.AddFile(CUSTOMUI_NAME, bUTF8)
    If VBA.Len(ret) Then
        MsgBox ret
        Exit Sub
    End If

    
    Set zip = Nothing
End Sub