AW: VBA Stream Objekte zusammenführen
24.07.2018 23:33:37
Zwenn
Hallo,
habe mich nun mit Deinem Problem beschäftigt und habe es auch gelöst. Da ich mich bisher mit diesen Streams nicht auskannte, musste ich erstmal ein paar Dinge rausfinden. Aber es ist wie immer: Wenn man erstmal weiß wie es geht, ist es plötzlich ganz einfach.
Also die Grundidee, die ich gleich hatte, als ich Deinen ganzen Code sichtete, war das Erzeugen eines zweiten Streams, in dem Du die IDB's parallel zum Rest aufbauen kannst. An der richtigen Stelle werden die beiden Streams dann zusammengeführt. Ich habe mich für die CopyTo Methode entschieden. Es ginge auch mit ReadText nehme ich an. Wie das funktioniert, habe ich im Code Kommentiert. Hat etwas gedauert, bis ich die Methode Position gefunden habe. Aber ohne die gehts nicht.
Ich habe den Code für Deine Sub gen_014() umgeschrieben. Du kannst die Änderungen aber für die anderen Subs leicht übernehmen:
Sub gen_014()
Dim i As Integer
Dim Name As String
Dim intLen As Long
Dim Anf As Integer
Dim LZeil As Integer
Dim Zelle As Range
Dim FstOB_1 As Object
Dim FstOB_2 As Object
Dim streamZwischenSpeicher As String
'XML Definieren
Set FstOB_1 = CreateObject("ADODB.Stream")
FstOB_1.Type = 2 'Stream-Typ: Text/String
FstOB_1.Charset = "utf-8" 'Zeichensatz
FstOB_1.Open 'Stream öffnen
'Eigener Stream für IDB's
Set FstOB_2 = CreateObject("ADODB.Stream")
FstOB_2.Type = 2 'Stream-Typ: Text/String
FstOB_2.Charset = "utf-8" 'Zeichensatz
FstOB_2.Open 'Stream öffnen
'XML Start
XMLStart FstOB_1
FC14_Start FstOB_1
LZeil = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row 'Letzte Zeile
If LZeil > 500 Then
LZeil = 1
End If
'Abbruch bei doppeltem Wert
For Each Zelle In ActiveSheet.Range(Cells(4, 3), Cells(LZeil, 3))
If Application.WorksheetFunction.CountIf(Range(Cells(4, 3), Cells(LZeil, 3)), Zelle) _
> 1 Then
'Hinweis ausgeben Aufräumen und Makro verlassen
MsgBox "Doppelter Wert vorhanden in Spalte C, Zeile " & Zelle.Row
Set FstOB_1 = Nothing
Set FstOB_2 = Nothing
Exit Sub
End If
Next Zelle
'XML parallel in zwei Streams aufbauen
For i = 4 To LZeil
Select Case Cells(i, 2)
Case "Antrieb 2DR_1200"
Antrieb2DR_1200 FstOB_1, XMLName(Cells(i, 3)), i * 10, Cells(i, 4)
'IDB's erzeugen in Stream 2
IDBAntrieb2DR_1200 FstOB_2, XMLName(Cells(i, 3)), (i + LZeil) * 10
Case Else
'Hinweis ausgeben Aufräumen und Makro verlassen
MsgBox "FC/FB Typ oder IDB Typ " + Cells(i, 2) + " für " + Cells(i, 3) + _
" in Zeile " & i & " unbekannt."
Set FstOB_1 = Nothing
Set FstOB_2 = Nothing
Exit Sub
End Select
Next i
'Den Abschlussteil in Stream 1 schreiben
FC14_Ende FstOB_1
'Streams zusammenführen
'Die Curser Position muss vor der nächsten Operation
'auf den Anfang des Streams, der kopiert werden soll
'gesetzt werden. Sonst wird nix kopiert, da die aktuelle
'Position nach dem letzten Schreiben in den Stream immer
'nach dem letzten Zeichen ist
FstOB_2.Position = 0
'Stream 2 (IDB's) in Stream 1 kopieren
'Die Methode CopyTo kopiert den angegebenen Stream ab
'der aktuelle Curser Position im zu kopierenden Stream
'in den Ziel-Stream
FstOB_2.CopyTo FstOB_1
'XML-ENDE
FstOB_1.writeText "" + vbCrLf
'Datei speichern
FstOB_1.SaveToFile "C:\Mailbox\ILS705\OPN\014.xml", 2
'Aufräumen
Set FstOB_1 = Nothing
Set FstOB_2 = Nothing
End Sub
Ich hoffe das nun auch wirklich das, was Du gesucht hast ;-)
Viele Grüße,
Zwenn