在我的宏中调用另一个 objectStream.Write 文本宏无效

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 需要另一个流对象，而不是 string/file 路径。如果您希望 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 文本宏无效

Calling another objectStream.Write text macro within my macro isn't workiing

excel

vba

adodb

utf-8