写入custom.xml步骤:
这里需要注意的是,如果某个Office文件没有custom.xml,除了要写入custom.xml之外,还必须在_rels/.rels文件后面,增加一条Relationship:
'写入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