マクロ内で別の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は別のストリームオブジェクトではなく、文字列/ファイルパスを期待しています。 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