Question

所以我正在创建一个宏来输出UTF-8编码的XML，因为源文本有时会涉及日文或中文字符。我试图将XML的每个部分分成不同的块，这样我就可以更容易地进行编辑，但是我的调用行无效。由于我没有接受过编程培训，而且我的知识是基于查找VBA宏代码并调整它们直到我得到所需的结果，所以我很难理解如何在调用另一个objStream行时让我的objStream宏不出错。

谢谢！

这是：

Sub Export_iTunes_XML()

Dim FilePath As String
FilePath = ActiveWorkbook.Path & "\"

Dim FileName As String
FileName = "metadata.xml"

Dim Output As String
Output = FilePath & FileName

If Dir(Output, vbNormal) <> "" Then
    Answer = MsgBox("Do you want to overwrite?", vbOKCancel, "File Exists")
End If
If Answer = vbCancel Then Exit Sub

Set objStream = CreateObject("ADODB.Stream") 'Create the stream
objStream.Open 'Initialize the stream
objStream.Position = 0 'Rest the position
objStream.Charset = "UTF-8" 'indicate the character encoding

objStream.WriteText "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCr
objStream.WriteText "      <title>" & Sheets("RawMetadata").Range("A3") & "</title>" & vbCr

If Sheets("RawMetadata").Range("P4") <> 0 Then Call LocaleTest2

objStream.WriteText "      <production_company>" & Sheets("RawMetadata").Range("H3") & "</production_company>" & vbCr
___________________________________________________________________________
Sub LocaleTest2()

Dim FilePath As String
FilePath = ActiveWorkbook.Path & "\"

Dim FileName As String
FileName = "metadata.xml"

Dim Output As String
Output = FilePath & FileName

Set objStream = CreateObject("ADODB.Stream") 'Create the stream
objStream.Open 'Initialize the stream
objStream.Position = 0 'Rest the position
objStream.Charset = "UTF-8" 'indicate the character encoding

objStream.WriteText Sheets("RawMetadata").Range("P4")
objStream.CopyTo Output

End Sub

Answer 1

CopyTo需要另一个流对象，而不是字符串/文件路径。如果您希望LocaleTest2将内容写入与Export_iTunes_XML中已打开的内容相同的流，则应在调用LocaleTest2时将该流作为参数传递。

虽然做出了这样的改变，但我不确定你是否可以将其分解为单独的Sub。

Sub Export_iTunes_XML()

    Dim FilePath As String
    FilePath = ActiveWorkbook.Path & "\"

    Dim FileName As String
    FileName = "metadata.xml"

    Dim Output As String
    Output = FilePath & FileName

    If Dir(Output, vbNormal) <> "" Then
        Answer = MsgBox("Do you want to overwrite?", vbOKCancel, "File Exists")
    End If
    If Answer = vbCancel Then Exit Sub

    Set objStream = CreateObject("ADODB.Stream") 'Create the stream
    objStream.Open 'Initialize the stream
    objStream.Position = 0 'Rest the position
    objStream.Charset = "UTF-8" 'indicate the character encoding

    objStream.WriteText "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCr
    objStream.WriteText "      <title>" & Sheets("RawMetadata").Range("A3") & "</title>" & vbCr

    If Sheets("RawMetadata").Range("P4") <> 0 
        LocaleTest2 objStream '<<< pass the stream object
    End If

    objStream.WriteText "      <production_company>" & 
    Sheets("RawMetadata").Range("H3") & "</production_company>" & vbCr
    '....
End Sub


Sub LocaleTest2(objStream as Object)

    'write to the provided stream
    objStream.WriteText Sheets("RawMetadata").Range("P4")

End Sub

Answer 2

代码就是这样。

Sub Export_iTunes_XML()
    Dim vR(), myText As String
    Dim FilePath As String
    Dim FileName As String
    Dim Output As String
    Dim Ws As Worksheet
    Dim n As Long

    FilePath = ActiveWorkbook.Path & "\"
    FileName = "metadata.xml"
    Output = FilePath & FileName
    Set Ws = Sheets("RawMetadata")


    If Dir(Output, vbNormal) <> "" Then
        Answer = MsgBox("Do you want to overwrite?", vbOKCancel, "File Exists")
    End If
    If Answer = vbCancel Then Exit Sub

    n = n + 1
    ReDim Preserve vR(1 To n)
    vR(n) = "<?xml version=""1.0"" encoding=""UTF-8""?>"
    n = n + 1
    ReDim Preserve vR(1 To n)
    vR(n) = "      <title>" & Sheets("RawMetadata").Range("A3") & "</title>"
    With Ws
        If Sheets("RawMetadata").Range("P4") <> 0 Then
            n = n + 1
            ReDim Preserve vR(1 To n)
            vR(n) = .Range("p4")
        End If
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = "      <production_company>" & .Range("H3") & "</production_company>"
    End With

    myText = Join(vR, vbCrLf)
    TransToUTF8 Output, myText
End Sub
Sub TransToUTF8(myfile As String, str As String)
 Dim objStream As Object
 Set objStream = CreateObject("ADODB.Stream")

    With objStream
        .Charset = "utf-8"
        .Open
        .WriteText str
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub

<强>加成

Sub Export_iTunes_XML()

 Dim XMLFileName As String
 Dim output4 As String
 Dim range4 As Range
 Dim vDB, vR(), vResult()
 Dim i As Long, n As Long, j As Integer
 Dim myText As String

 XMLFileName = "metadata.xml"
 FolderName4 = Sheets("RawMetadata").Range("D42") & "_" & Sheets("iTunes").Range("B8") & ".itmsp"
 FolderPath4 = ActiveWorkbook.Path & "\" & FolderName4

MkDir FolderPath4
output4 = FolderPath4 & "\" & XMLFileName

 vDB = Sheets("iTunes").Range("A1:g936")


For i = 1 To UBound(vDB, 1)
    If vDB(i, 7) = "ON" Then
        ReDim vR(1 To 6)
        For j = 1 To 6
            vR(j) = vDB(i, j)
        Next j
        n = n + 1
        ReDim Preserve vResult(1 To n)
        vResult(n) = Join(vR, "")
    End If
Next i
    myText = Join(vResult, vbCrLf)
    TransToUTF8 output4, myText

 End Sub

在我的宏中调用另一个objectStream.Write文本宏不能正常工作

2 个答案: