So funktioniert JustAnswer:

  • Fragen Sie einen Experten
    Tausende Experten in über 200 Kategorien.
  • Erhalten Sie eine professionelle Antwort
    Per E-Mail oder sofortiger Benachrichtigung, während Sie auf unserer Website warten.
    Stellen Sie ggf. weitere Anschlussfragen.
  • 100%ige Zufriedenheit garantiert
    Bewerten Sie die erhaltene Antwort.

Stellen Sie Ihre Frage an Tronic.

Tronic
Tronic, IT-Specialist
Kategorie: Computer
Zufriedene Kunden: 2269
Erfahrung:  Elektroniker und EDV-Service
31581453
Geben Sie Ihre Frage in der Kategorie Computer hier ein
Tronic ist jetzt online.

Hallo allerseits, ich bin dabei, ein VBA-Programm für WORD

Kundenfrage

Hallo allerseits,

ich bin dabei, ein VBA-Programm für WORD zu schreiben, das verschiedene Teildokumente zu einem Gesamtdokument zusammenfügen soll.

Nach einigen Einfügeoperationen (auch von Tabellen) bekomme ich Speicherprobleme, und zwar sagt mir einerseits Basic, dass eine Funktion nicht zur Verfügung stehe (die ich vorher aber schon erfolgreich aufgerufen habe), und auch, wenn ich versucher, etwas mit Cut&Paste zu kopieren, bekomme ich vom System die Meldung, dass kein Speicher mehr vorhanden sei.

Was mache ich falsch, bzw., wonach kann ich in meinem Code suchen?

Vielen Dank & Grüße,
Helmut Römer
Gepostet: vor 5 Jahren.
Kategorie: Computer
Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Hallo,

kommt von VBA diese Meldung, das der Speicher voll ist? Welche Word Version und welchen Code setzen Sie wo ein?

Gruss Günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo Günter,

 

danke für die rasche Antwort.

 

In der Firma wird noch Word 2003 eingesetzt.

 

Von VBA kommt beim Hinzufügen einer Tabelle die Meldung "Funktion steht nicht zur Verfügung", und wenn ich versuche, etwas mit Strg-C zu kopieren, bekomme ich die Meldung "Nicht genügend Speicher".

 

Ausserdem kommt ab und zu mal Word mit einem Runtime-Error ("Word hat ein internes Problem festgestellt und muss beendet werden")

 

Meine Frage ist eigentlich: Wie entstehen solche Speicherprobleme bzw. was kann ich allgemein unternehmen, um sie zu vermeiden? Sind Objektvariablen die Ursache? Übergabeparameter? Ich habe einige als ByVal, andere als ByRef deklariert.

 

Viele Grüße,

Helmut

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Hallo,

ja also Sie müssen die Bibliotheken die Sie nutzen wollen natürlich erst mal auswählen:

ALT+F11 für den VBA-Editor dann auf Menü Extras > Verweise dort bitte Haken setzen bei den Bibliotheken die Sie brauchen z.B. Excel Objekt Library oder Microsoft Office 2003 Object Library.

Ich müsste schon wissen, was Sie eigentlich außer Word selbst nutzen wollen und der Code wäre sehr gut, wenn ich den mal sehen würde.

Gruss Günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo,

 

nun, ich sitze gerade zuhause und habe hier natürlich keinen Zufgriff auf den Firmenrechner und damit auch nicht auf den Code. Ich kann das Programmfile aber heute abend per Mail nach Hause schicken und könnte es Ihnen morgen früh zukommen lassen.

 

Ich will im Grunde gar keine besondere Bibliothek nutzen, also keine Forms etc. etc. Ich kann aber zur Zeit auch nicht feststellen, welche Verweise standardmäßig eingestellt sind.

 

Es geht nur darum, den (formatierten) Text aus Teildokumenten zu holen und im Hauptdokument abzulegen. Dafür reichen (falls es sich nicht um Tabellen handelt) m.E. einfache Zuweisungen der Art

Hauptdok.Range.FormattedText = Unterdok.Range.FormattedText,

dazu verwende ich entsprechende Move-Befehle, um von Paragraph zu Paragraph zu wandern.

 

Für Tabellen muss ich natürlich mehr Klimmzüge machen, insbesondere muss ich eine neue Tabelle in das Hauptdokument einfügen können. Beim erstenmal funktioniert das ja auch noch, nur beim zweitenmal kommt diese komische Fehlermeldung.

 

Viele Grüße,

Helmut

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Ja, verstehe aber den Code muss ich schon haben. Evtl. haben Sie nur falsche Datentypen die zu diesem Fehler führen VBA ist leider sehr schwach, was das angeht d.h. die Datenmenge ist eingeschränkt aber ohne Code kann ich nichts machen evtl. mal Beispielcode suchen .-) LG Günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo,

 

ich bin erst heute auf JustAnswer aufmerksam geworden - wußte nicht, dass es so etwas gibt!

 

Wie gesagt, kann ich Ihnen erst morgen den Code zukommen lassen.

Können wir uns also auf morgen vertagen?

 

Viele Grüße,

Helmut

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Ja natürlich, kein Problem bin aber nur bis 13 h hier und danach erst abends wieder :-) einfach wieder auf meine Antwort antworten. LG Günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo Günter,

anbei der Code - hoffe, dass es mit den Tabzeichen okay ist.

Gruß, Helmut

Option Explicit

' Konstanten
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateFalse = 0

' Eigener Typ (zum Scannen der Config-Datei)
Type properties
strKey As String ' name
strValue As String ' value
End Type

' Globale Variable, können durch Konfigurationseinträge überschrieben werden
Dim Silent As Boolean ' aktuelle Position im Dokument anzeigen?
Dim Mark As Boolean ' Anfang- und Endemarkierung im Text


' =====================================================================
' Name: Fit
' Zweck: LookAhead im Hauptdokument
' Beschreibung: Es wird nachgeschaut, ob einer der nächsten 'n'
' Paragraphen des Hauptdokuments mit dem aktuellen
' Paragraphen aus der Referenzdatei übereinstimmt.
' Rückgabe: = 0 ... keine Übereinstimmung gefunden
' > 0 ... Es gibt eine textliche Übereinstimmung
' =====================================================================
Private Function Fit(ByVal rngDoc As Word.Range, _
ByVal rngRef As Word.Range, _
ByVal iEndeDoc As Long, _
ByVal iEndeRef As Long) As Boolean

Dim k As Integer
Dim pos As Long ' Position im Dokument
Dim idx As Integer ' Position im String
Dim docTxt, refTxt As String

k = 0
pos = rngDoc.End ' aktuelle Position des Ranges

' Zeilenwechselzeichen sind zum Vergleich ungeeignet!
While rngRef.FormattedText = Chr(13)
rngRef.Move Unit:=wdParagraph, Count:=1
rngRef.MoveEnd Unit:=wdParagraph
k = k + 1
Wend
While rngDoc.FormattedText = Chr(13)
rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph
k = k + 1
Wend

' Zeilenwechsel und Blanks sowohl aus docTxt als auch aus
' refTxt entfernen, die stören beim Textvergl.!
refTxt = Clip(rngRef.FormattedText)

' Vielleicht passt es ja jetzt schon?
If Clip(rngDoc.FormattedText) = refTxt Then
Fit = True
Exit Function
End If

' Wir haben zwar nix gefunden, aber wir dürfen k nicht
' wieder zurück auf 0 setzen, da wir k noch brauchen, um
' wieder auf die aktuelle Position zu kommen!

' Wurden Fragezeichen im Referatsdokument entfernt?
idx = InStr(rngDoc.Text, "??")
If idx > 0 Then
docTxt = Clip(Replace(rngDoc.Text, "?", ""))

If docTxt = refTxt Then
' Ja, dann sollten sie auch im Originaldokument
' entfernt werden!
rngDoc.FormattedText = rngRef.FormattedText
Fit = True
Exit Function
End If
End If

' Auch das hat nix gebracht, dann müssen wir halt weitersuchen!
While k < 500 And pos < iEndeDoc

rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph

If Clip(rngDoc.Text) = refTxt Then
Fit = True
Exit Function
End If

k = k + 1
pos = rngDoc.End
Wend

' Hat alles nicht geholfen? Dann gehen wir mit dem Cursor wieder rückwärts
rngDoc.Move Unit:=wdParagraph, Count:=-k - 1
rngDoc.MoveEnd Unit:=wdParagraph
'rngDoc.Select

Fit = False
End Function

' ==============================================================
' Name: ReferatEintragen
' Zweck: Den Namen des Referats zur Identifikation ins
' Hauptdokument eintragen (Anfang und Ende markieren)
' ==============================================================
Private Sub ReferatEintragen(ByVal rngDoc As Word.Range, ref As String, _
art As String)
If art = "A" Then
rngDoc.Text = "Anfang " & ref & Chr(13)
Else
rngDoc.Text = "Ende " & ref & Chr(13)
End If

rngDoc.Style = wdStyleNormal
rngDoc.Font.Bold = True
rngDoc.Font.Size = 10
rngDoc.Font.Color = wdColorRed
rngDoc.Collapse wdCollapseEnd

End Sub

' =================================================================
' Name: Clip
' Zweck: Nicht-druckbare Zeichen und Blanks abschneiden
'
' =================================================================
Private Function Clip(txt As String) As String
Dim ch

While Len(txt) <> 0
ch = Right(txt, 1)
If Asc(ch) < 32 Or ch = " " Then
txt = Left(txt, Len(txt) - 1)
Else
Clip = txt
Exit Function
End If
Wend
Clip = txt
End Function

' =================================================================
' Name: TabVglUndÜbertragen
' Zweck: Tabellen vergleichen und übertragen
'
' =================================================================

Private Sub TabVglUndÜbertragen(doc, docRef As Document, _
rngDoc, rngRef As Range, ref As String)
Dim i, j, k, idxRef, idxDoc As Integer
Dim tbl As Word.Table
Dim myDocCell, myRefCell, myStyle
Dim rngTabRef, rngTabDoc As Word.Range
Dim newTab As Boolean
Dim RowsRef, ColumnsRef As Integer
Dim txt As String

' If Mark Then
' rngRef.Select
' End If

' Ist auch im Hauptdokument schon eine Tabelle?
newTab = True
If rngDoc.Information(wdWithInTable) Then
newTab = False
End If

' Herausfinden, die wievielte Tabelle des Referatsdok. es ist
idxRef = 0
For k = 1 To docRef.Tables.Count
If rngRef.InRange(docRef.Tables(k).Range) Then
idxRef = k
Set rngTabRef = docRef.Tables(idxRef).Range
Exit For
End If
Next k

idxDoc = 0
For k = 1 To doc.Tables.Count
If rngDoc.InRange(doc.Tables(k).Range) Then
idxDoc = k
Set rngTabDoc = doc.Tables(idxDoc).Range
Exit For
End If
Next k

If newTab Then
' Style auf Normal setzen, sonst haben wir nur
' Überschriften in der Tabelle
Set myStyle = rngDoc.Style
With rngDoc
.Collapse Direction:=wdCollapseStart
.InsertBefore Chr(13)
.Style = wdStyleNormal
End With
End If

' Cursor auf den Anfang der Tabelle
rngDoc.MoveStart Unit:=wdTable, Count:=-1
rngDoc.Collapse Direction:=wdCollapseStart
rngRef.MoveStart Unit:=wdTable, Count:=-1
rngRef.Collapse Direction:=wdCollapseStart

If newTab Then
' Tabelle einfügen
Set tbl = doc.Tables.Add(rngDoc, _
rngRef.Tables.Item(1).Rows.Count, _
rngRef.Tables.Item(1).Columns.Count, _
wdWord8TableBehavior, _
wdAutoFitWindow)
Else
' Haben die beiden Tabellen gleiche Zeilen- und Spaltenzahl?
RowsRef = rngRef.Tables.Item(1).Rows.Count
ColumnsRef = rngRef.Tables.Item(1).Columns.Count

If rngTabDoc.Rows.Count <> RowsRef Then
MsgBox ("Unterschiedl. Anzahl Zeilen")
End If
If rngTabDoc.Columns.Count <> ColumnsRef Then
MsgBox ("Unterschiedl. Anzahl Spalten")
End If

Set tbl = doc.Tables(idxDoc)

End If

' Die Zellen einzeln übertragen
For i = 1 To rngTabRef.Rows.Count
For j = 1 To rngTabRef.Columns.Count
Set myRefCell = docRef.Tables(idxRef).Cell(i, j)
Set myDocCell = tbl.Cell(i, j)

If myDocCell.Range.Text <> myRefCell.Range.Text Then

' Soll die Quelle der Änderung eingetragen werden?
txt = ""
If Mark And Not newTab Then
txt = ref & ": "
End If

myDocCell.Range.Text = txt & Clip(myRefCell.Range.Text)
myDocCell.Range.Style = myRefCell.Range.Style
myDocCell.Range.Font = myRefCell.Range.Font
myDocCell.Range.HighlightColorIndex = _
myRefCell.Range.HighlightColorIndex
myDocCell.Height = myRefCell.Height
myDocCell.Width = myRefCell.Width
myDocCell.Shading.ForegroundPatternColor = _
myRefCell.Shading.ForegroundPatternColor
myDocCell.Shading.BackgroundPatternColor = _
myRefCell.Shading.BackgroundPatternColor
' Set rngTabDoc = Null
' Set rngTabRef = Null
End If
Next j
Next i

' Ende der Tabelle suchen
rngRef.MoveEnd Unit:=wdTable
rngDoc.MoveEnd Unit:=wdTable

Set tbl = Nothing

End Sub

' ================================================================
' Name: TextÜbertragen
' Zweck: Text bzw. Tabelle etc. übertragen
' ================================================================
Private Sub TextÜbertragen(doc, docRef As Document, rngDoc, rngRef As Range, _
txtSav As String, ref As String)
'Dim bTable As Boolean
Dim rngRefText As String

'bTable = False

' Damit wir Äpfel nicht mit Birnen vergleichen, Zeilenumbrüche etc. entfernen
rngRefText = Clip(rngRef.Text)

While Not txtSav = rngRefText

' Tabellen müssen gesondert übertragen werden!
If rngRef.Information(wdWithInTable) Then
Call TabVglUndÜbertragen(doc, docRef, rngDoc, rngRef, ref)
Else
If rngDoc.Information(wdWithInTable) Then
' Wir befinden uns im Hauptdokument in einer Tabelle!
' Hier dürfen wir nicht einfach loslegen zu schreiben!
MsgBox ("Hier muss noch etwas im Programm geschehen!")
Else
' Text (oder OLE-Objekt etc.) übertragen
rngDoc.FormattedText = rngRef.FormattedText
End If
End If

' Auch im Hauptdokument auf die Stelle nach dem eingefügten
' Text positionieren
rngRef.Move Unit:=wdParagraph, Count:=1
rngRef.MoveEnd Unit:=wdParagraph
' rngRef.Select
rngDoc.Collapse wdCollapseEnd
rngDoc.Select

rngRefText = Clip(rngRef.Text)

Wend
End Sub

' ================================================================
' Name: ÜbertrageText
' Zweck: Text bzw. Tabelle etc. übertragen
' ================================================================
Private Sub ÜbertrageText(doc, docRef As Document, rngDoc, rngRef As Range, _
iEndeDoc, iEndeRef As Long, ref As String)
Dim k As Integer
Dim passt As Boolean
Dim txtSav As String

' Feststellen, ob es einen Paragraphen gibt, der besser passt
passt = Fit(rngDoc, rngRef, iEndeDoc, iEndeRef)
If passt Then ' einen matchenden Bereich gefunden
If Not Silent Then
rngDoc.Select
End If
Else
' Keine passende Stelle gefunden:
' Stelle merken und Text aus Referatsdokument einfügen.
'
' Hier erstmal solange weiterlesen, bis ein sinnvoller Text
' (am besten eine Überschrift) kommt, da ein Zeilenumbruch
' zu jedem Zeilenumbruch des einzufügenden Textes passen würde
' und wir dann aufhören würden einzufügen.
k = 1 ' Mindestens einen Paragrafen zurück!!
While Asc(rngDoc.Text) < 32 ' Zeilenumbruch etc.
rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph
k = k + 1
Wend

' Den Text der Überschrift merken ... aber bitte auch ohne
' Zeilenumbrüche am Ende!
txtSav = Clip(rngDoc.Text)

' zurück auf das erste CR-Zeichen positionieren
If k > 0 Then
rngDoc.Move Unit:=wdParagraph, Count:=-k - 1
End If
rngDoc.Collapse Direction:=wdCollapseStart

If Not Silent Then
rngDoc.Select ' aktuelle Position anzeigen
End If

If Mark Then
' Referat eintragen (Anfang)
Call ReferatEintragen(rngDoc, ref, "A")
End If

'========================================================
' Nun den Text bzw. die Tabelle etc. übertragen, bis
' die gemerkte Überschrift gefunden wird
'========================================================
Call TextÜbertragen(doc, docRef, rngDoc, rngRef, txtSav, ref)

If Mark Then
' Ende von Referat eintragen (Ende)
Call ReferatEintragen(rngDoc, ref, "E")
End If

' Im Hauptdokument können nun noch 'n' Leerzeilen kommen,
' wir müssen so lange weiterlesen, bis wir wieder an der
' Stelle sind, die wir in 'txtSav' gespeichert haben.
While Clip(rngDoc.Text) <> txtSav
rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph
Wend

'If Not Silent Then
' rngRef.Select ' aktuelle Position anzeigen
'End If
End If
End Sub

' ===================================================================
' Name: vergleichen
' Zweck: Dokumente vergleichen und Abweichungen übernehmen
' Beschreibung: In dieser Routine werden die Dokumente verglichen,
' und abweichende Texte werden in das Haupt-Dokument
' übernommen
' ===================================================================

Private Sub vergleichen(doc, docRef As Document, ref As String)
Dim rngDoc, rngRef As Word.Range
Dim ende, inhaltsverzDoc, inhaltsverzRef As Boolean
Dim txtSav As String
Dim DocEnd, RefEnd As Word.Range
Dim iEndeDoc, iEndeRef As Long
Dim lngIndex As Long

Dim i, j, k As Integer
k = 1

ende = False

' Dokument-Enden bestimmen
Set DocEnd = doc.Content
DocEnd.Collapse wdCollapseEnd
iEndeDoc = DocEnd.End

Set RefEnd = docRef.Content
RefEnd.Collapse wdCollapseEnd
iEndeRef = RefEnd.End

' Um ein Zugriff über die Auflistung in der Schleife zu vermeiden, ist
' die Move-Methode zu verwenden!
Set rngDoc = doc.Paragraphs(1).Range
Set rngRef = docRef.Paragraphs(1).Range

While Not ende
If Not Silent Then
rngDoc.Select ' aktuelle Position anzeigen
End If

' Nachschauen, ob wir im Inhaltsverzeichnis sind.
' Es hat nämlich keinen Sinn, die Seitenzahlen zu vergleichen!
inhaltsverzDoc = False
inhaltsverzRef = False
If rngDoc.Fields.Count > 0 And rngRef.Fields.Count > 0 Then
For i = 1 To rngDoc.Fields.Count
If rngDoc.Fields(i).Type = wdFieldPageRef Then
inhaltsverzDoc = True
Exit For
End If
Next i

For i = 1 To rngRef.Fields.Count
If rngRef.Fields(i).Type = wdFieldPageRef Then
inhaltsverzRef = True
Exit For
End If
Next i

If inhaltsverzRef Then
While rngRef.Fields.Count > 0
If Not Silent Then
rngRef.Select
End If
rngRef.Move Unit:=wdParagraph, Count:=1
rngRef.MoveEnd Unit:=wdParagraph
Wend
End If

If inhaltsverzDoc Then
While rngDoc.Fields.Count > 0
If Not Silent Then
rngDoc.Select
End If
rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph
Wend
End If
End If

' Gibt es eine Abweichung?
If Not Clip(rngDoc.Text) = Clip(rngRef.Text) Then
'If Not Silent Then
' rngRef.Select ' aktuelle Position anzeigen
'End If

' Wenn ein Text vor der Tabelle einzufügen ist, müssen wir
' vor die Tabelle positionieren
If rngDoc.Information(wdWithInTable) Then
If rngRef.Information(wdWithInTable) Then
Call TabVglUndÜbertragen(doc, docRef, rngDoc, rngRef, ref)
Else '
rngDoc.Move Unit:=wdParagraph, Count:=-2
rngDoc.Collapse Direction:=wdCollapseStart
'rngDoc.Select

Call ÜbertrageText(doc, docRef, rngDoc, rngRef, _
iEndeDoc, iEndeRef, ref)
rngDoc.Select
End If
Else ' keine Tabelle
'rngDoc.Select
Call ÜbertrageText(doc, docRef, rngDoc, rngRef, _
iEndeDoc, iEndeRef, ref)
End If
End If

' Cursor in beiden Dokumenten weitersetzen
rngDoc.Move Unit:=wdParagraph, Count:=1
rngDoc.MoveEnd Unit:=wdParagraph
rngRef.Move Unit:=wdParagraph, Count:=1
rngRef.MoveEnd Unit:=wdParagraph

' Bis zum Ende des Referatsdokuments, das Originaldokument
' ist unwichtig (Was fehlt, muss im Originaldokument ergänzt werden!)
If rngRef.End >= iEndeRef Then
ende = True
End If
Wend

Set RefEnd = Nothing
Set DocEnd = Nothing
End Sub

' ===============================================================
' Name: ParseZeile
' Zweck: Eine Zeile der Config-Datei parsen
' Rückgabe: True: Es wurde ein Paar (Name, Wert) gefunden
' False: Kommentar oder Leerzeile
' ===============================================================
Private Function ParseZeile(ByVal zeile As String, ByRef refer() As properties, _
ByRef refnr As Integer) As Boolean

Dim idx As Integer
Dim ch As String
Dim gleich_found As Boolean
Dim rng As Word.Range

ParseZeile = False
gleich_found = False
refer(refnr).strValue = ""
refer(refnr).strKey = ""

idx = 1
While idx <= Len(zeile)
ch = Mid(zeile, idx, 1)
If (InStr(1, " =#" & Chr(13), ch)) Then
If ch = "#" Then ' Kommentar
Exit Function
Else
If ch = "=" Then
gleich_found = True
idx = idx + 1
Else ' Blank
idx = idx + 1
End If
End If
Else ' Referatsname oder Pfad/Dateiname
' Namen kopieren
ParseZeile = True
If gleich_found Then
refer(refnr).strValue = refer(refnr).strValue & ch
Else
refer(refnr).strKey = refer(refnr).strKey & ch
End If

idx = idx + 1
End If
Wend

' Gänsefüßchen entfernen
If ParseZeile = True Then
If Left(refer(refnr).strValue, 1) = Chr(34) Then
refer(refnr).strValue = Mid(refer(refnr).strValue, _
2, Len(refer(refnr).strValue) - 1)
End If
If Right(refer(refnr).strValue, 1) = Chr(34) Then
refer(refnr).strValue = Left(refer(refnr).strValue, _
Len(refer(refnr).strValue) - 1)
End If

End If
End Function

' ============================================================
' Name: ParseConfig
' Zweck: Die Config-Datei parsen.
' Dabei Kommentar- und Leerzeilen überlesen
'
' Hinweis: Die Config-datei sollte besser als Textdatei
' geöffnet und gelesen werden!
'
' Rückgabe: > 0 Anzahl gelesener Referate
' = 0 Kein Referat gelesen
' < 0 Fehler (Verarbeitung abbrechen!)
' ============================================================
Private Function ParseConfig(ByRef refer() As properties, _
ByRef hauptdok As properties)
Dim fs As Object
Dim Text, CfgFile
Dim refnr As Integer ' Nummer des Referats
Dim refFound, hauptdokFound As Boolean
Dim docName, strCfgDateiname As String

refnr = 0

hauptdokFound = False

' Nachschauen, ob Config-Datei vorhanden
docName = ActiveDocument.Path & Application.PathSeparator & _
"Config.txt"
strCfgDateiname = Dir$(docName)
If strCfgDateiname = "" Then
MsgBox ("Config-Datei '" & docName & "' nicht vorhanden." & _
Chr(13) & "Weiterarbeit nicht möglich!")
ParseConfig = -1
Exit Function
End If
Set fs = CreateObject("Scripting.FileSystemObject")
Set CfgFile = fs.OpenTextFile(docName, _
ForReading, False, TristateFalse)

' Zeilen lesen und parsen
' Hinweis: Die folgende Verarbeitung sollte dringend überarbeitet werden, da
' sie beim Hinzukommen weiterer Attribute immer komplizierter wird!
Do While CfgFile.AtEndOfStream <> True

' Zeile lesen und parsen
Text = CfgFile.readline
refFound = ParseZeile(Text, refer, refnr + 1)

If refFound Then ' wenn etwas Sinnvolles gefunden wurde
If refer(refnr + 1).strKey = "Hauptdokument" Then
hauptdokFound = True
hauptdok.strValue = refer(refnr + 1).strValue
' Hier refnr nicht erhöhen, die nächste Referats-Angabe
' überschreibt die Hauptdokument-Angaben!
Else
If LCase(refer(refnr + 1).strKey) = "silent" Then
If LCase(refer(refnr + 1).strValue) = "false" Then
Silent = False
End If
' Hier refnr nicht erhöhen, die nächste Referats-Angabe
' überschreibt die Silent-Angaben!
Else
If LCase(refer(refnr + 1).strKey) = "mark" Then
If LCase(refer(refnr + 1).strValue) = "false" Then
Mark = False
End If
Else
refnr = refnr + 1
End If
End If
End If
End If
Loop
CfgFile.Close

' Fehlerfälle
If refnr = 0 Then
MsgBox ("In der Config-Datei wurde kein Referat gefunden." & Chr(13) & _
"Weiterarbeit nicht möglich!")
End If

If Not hauptdokFound Then
MsgBox ("In der Config-Datei wurde das Schlüsselwort 'Hauptdokument' nicht gefunden." & _
Chr(13) & "Verarbeitung kann nicht fortgesetzt werden!")
refnr = -1
End If
ParseConfig = refnr

Set CfgFile = Nothing
Set fs = Nothing

End Function

' ================================================================
' Name: TestObDokVorh
' Zweck: Feststellen, ob es das Dokument gibt.
' Wenn nicht, Benutzer fragen, was geschehen soll
'
' Rückgabe: 0 .. Datei vorhanden
' 1 .. nicht vorhanden, aber Benutzer will weitermachen
' 9 .. Benutzer will Abbruch
' ================================================================

Private Function TestObDokVorh(ByRef referat As properties, _
proto As Object) As Integer

Dim strRefDateiname As String
Dim antw

TestObDokVorh = 0 ' vorhanden
strRefDateiname = Dir$(referat.strValue)
If strRefDateiname = "" Then
' Nicht vorhanden! --> Protokollieren
proto.write "Referat " & referat.strKey & ": Konnte Datei '" & _
referat.strValue & "' nicht öffnen." & Chr(13) & Chr(10)

TestObDokVorh = 1 ' nicht vorhanden, aber wenn nicht
' Abbruch gewünscht, weitermachen

' Weiter oder Abbruch?
antw = MsgBox("Referat " & referat.strKey & _
": Datei " & referat.strValue & " nicht gefunden." & _
Chr(13) & "Bei 'OK' wird die Verarbeitung " & _
"mit der nächsten Referatsdatei fortgesetzt, " & _
"'Abbrechen' beendet die Verarbeitung", vbOKCancel)
If antw = vbCancel Then
antw = MsgBox("Verarbeitung wirklich abbrechen?", vbYesNo)
If antw = vbYes Then
TestObDokVorh = 9 ' Abbruch
Exit Function
End If
End If
Else
TestObDokVorh = 0 ' vorhanden
End If

End Function


' ===============================================================
' Zusammenführen mehrerer Dokumente
'
' Es wird vorausgesetzt, dass am aktuellen Dokument Änderungen
' vorgenommen werden!
'
' Und zwar werden alle Absätze, die in den Referatsdokumenten
' mehr sind, ins aktuelle Dokument übernommen.
'
' Wenn dem Benutzer das Endergebnis gefällt, möge er die Datei
' speichern, sonst abbrechen.
' ===============================================================

Public Sub Zusammenführen()

Dim fs As Object

Dim doc As Word.Document ' das Hauptdokument
Dim docRef As Word.Document ' die Referatsdokumente
Dim proto As Object ' Protokolldatei

Dim referate(20) As properties
Dim hauptdok As properties

Dim antw
Dim fehler As Integer

Dim ret As Integer
Dim anzref, i As Integer ' Anzahl Referate
Dim ende As Boolean
Dim ProtoPfadName, strDokDateiname As String

fehler = 0

' Defaultwerte für
Silent = True ' die aktuelle Position im Dokument wird nicht angezeigt
Mark = True

' Protokolldatei öffnen
ProtoPfadName = ActiveDocument.Path & Application.PathSeparator & _
"zusfuehr_proto.txt"
Set fs = CreateObject("Scripting.FileSystemObject")
Set proto = fs.OpenTextFile(ProtoPfadName, _
ForWriting, True, TristateFalse)

' Config-Datei parsen
anzref = ParseConfig(referate, hauptdok)

' Schwerer Fehler, wir können nicht weitermachen!
If anzref <= 0 Then
Set proto = Nothing
Set fs = Nothing
Exit Sub
End If

' Angegebenes Hauptdokument vorhanden?
strDokDateiname = Dir$(hauptdok.strValue)
If strDokDateiname = "" Then
MsgBox ("Hauptdokument '" & hauptdok.strValue & "' nicht vorhanden." & _
Chr(13) & "Weiterarbeit nicht möglich!")
Set proto = Nothing
Set fs = Nothing
Exit Sub
End If

' Leider keine Statusbar sichtbar
' (wahrscheinlich, weil wir kein Formular haben)!
'Application.DisplayStatusBar = True
'Application.StatusBar = "Haupt-Dokument wird geöffnet."
Set doc = Documents.Open(hauptdok.strValue)

' Schleife über alle Referatsdokumente
For i = 1 To anzref
'Application.StatusBar = "Verarbeite Dokument von " _
' & referate(i).strKey

' Nachschauen, ob das Dokument vorhanden ist
ret = TestObDokVorh(referate(i), proto)
If ret = 0 Then
' Dokument vorhanden, also es verarbeiten!
Set docRef = Documents.Open(referate(i).strValue)
Call vergleichen(doc, docRef, referate(i).strKey)
docRef.Close
Else
' Benutzer will Abbruch
If ret = 9 Then
proto.write ("Abbruch durch den Benutzer.")
proto.Close
MsgBox ("Protokolldatei: " & ProtoPfadName)

Set docRef = Nothing
Set doc = Nothing
Set proto = Nothing
Set fs = Nothing
Exit Sub
End If
End If
Next i

' Inhaltsverzeichnis aktualisieren
doc.TablesOfContents(1).Update

antw = MsgBox("Verarbeitung beendet (" & CStr(fehler) & _
"). Hauptdokument speichern (j/n)?", vbYesNo)
If antw = vbYes Then
' Das aktuelle Dokument wegschreiben
' Wegen Schreibschutz gibt's immer eine Fehlermeldung,
' die den Benutzer unnötig irriertiert, denn er schreibt
' ja normalerweise in eine neue Datei mit neuem Namen.
' Daher die Fehlermeldung unterdrücken.
On Error GoTo machtnix
doc.Save
machtnix:
doc.Close
End If

proto.Close
MsgBox ("Verarbeitung erfolgreich beendet (" & CStr(fehler) & _
"). Protokolldatei: " & ProtoPfadName)

Set docRef = Nothing
Set doc = Nothing
Set proto = Nothing
Set fs = Nothing

End Sub

' ================================================================
' Name: AutoOpen
' Zweck: Diese Routine wird (aufgrund des Prozedurnamens!)
' automatisch beim Öffnen des Dokuments ausgeführt.
' Der Benutzer hat so die Möglichkeit, den Dokument-Text
' zu lesen und dann den OK-Knopf zum Start der
' Verarbeitung zu drücken
' ================================================================

Public Sub AutoOpen()
Dim antw As String

antw = MsgBox("Verarbeitung starten?", vbOKCancel, "Dokumentenzusammenführung")
If antw = vbOK Then
Call Zusammenführen
End If
End Sub

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Hallo,

also der Code ist zwar da aber nicht sehr übersichtlich, da alle Tabs gelöscht wurden. Der Code an sich ist offenbar erst mal ok man müsste ihn testen. Wissen Sie, an welcher Zeile welcher Fehler auftritt? Das würde es erheblich einfacher machen, bevor ich anfange aufwendig den ganzen Code bei mir zu testen. Ich vermute nämlich, das er bei mir sofort jede Menge Fehler auswiirft, wenn man ihm so rein kopiert.

Gruss Günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo Günter,

 

ich bin mir nicht sicher, ob meine letzte ausführliche Antwort angekommen ist, da das Fenster plötzlich leer war.

 

Ich hänge meinen Quellcode nochmal als PDF-Datei (Bild) an.

 

Sag mir bitte Bescheid, ob meine Antwort mit der genauen Fehlerbeschreibung angekommen ist.

 

Gruß, Helmut

Anlage: 2011-11-11_100917_zpfile001.pdf

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Hallo, ich schaue es mir mal an aber das kann noch einige Zeit dauern.
LG günter
Kunde: hat geantwortet vor 5 Jahren.

Hallo Günter,

 

ich habe lange nichts von Ihnen gehört. Ich bin aber noch immer sehr an der Antwort bzw. Lösung interessiert.

 

Muss ich eigentlich immer antworten, damit Sie mir antworten können?

 

Vielen Dank & Grüße

Helmut

Experte:  IT-Fachinformatiker hat geantwortet vor 5 Jahren.
Hallo,

ioh muss den gesamten Quelltext erstmal testen mailen Sie mr bitte mal das Word-Dokument inkl. VBA-Code an:

rufushoschi AT yahoo PUNKT de

dann kann ich es testen (debuggen) das kann aber etwas dauern.

Gruss Günter

Bekannt aus:

 
 
 
„[...]mehr als Zehntausend Experten weltweit; 1500 davon in Deutschland. Acht Jahre nach dem Start ist das [...] Online-Unternehmen mit seinen 90 Mitarbeitern die größte Web-Seite für das Vermitteln von Experten von Anwälten über Ärzte bis hin zu Universitätsprofessoren.“
„Wer eine fachmänische Lösung für ein medizinisches, rechtliches oder technisches Problem sucht, kann das jetzt auch im Internet tun. Lebenshilfe auf die schnelle, unkomplizierte und vor allem erschwingliche Art bietet die Seite www.justanswer.de. Etwa 1500 Experten stehen per Mail für Fragen zu ca. 200 Fachgebieten rund um die Uhr zur Verfügung."
„Rat gewünscht? Rechtliche, medizinische oder allgemeine Fragen beantworten Experten unter www.justanswer.de."
„JustAnswer, die weltweit führende Online-Plattform für Expertenfragen und -antworten, bietet ab sofort noch mehr Sicherheit und Qualität für Verbraucher."
„Ob Vorbereitung, Notfall oder Reklamation nach dem Urlaub - JustAnswer bietet jederzeit schnelle, kompetente Antworten"
„Die Online-Plattform JustAnswer bringt Ratsuchende und Experten in über 200 Fachgebieten zusammen."
 
 
 

Was unsere Besucher über uns sagen:

 
 
 
  • Ich bedauere, dass ich nicht gleich bei Ihnen gelandet bin. Die Leerung des Cache hat das Problem gelöst. Danke Gerd Schönbuchner Grafrath
< Zurück | Weiter >
  • Ich bedauere, dass ich nicht gleich bei Ihnen gelandet bin. Die Leerung des Cache hat das Problem gelöst. Danke Gerd Schönbuchner Grafrath
  • Endlich ein Experte, der mir wirklich weiterhelfen konnte! DANKE! JustAnswer Kunde Taunusstein
  • Ihre Antwort hat mir sehr geholfen, die richtigen Entscheidungen zu treffen. Dass Sie mir darüber hinaus noch 2 Empfehlungen gegeben haben fand ich super. Vielen Dank! JustAnswer Kunde Freiburg
  • Die ausgearbeiteten Hilfen waren gut strukturiert, leicht verständlich und zu 100% hilfreich für mich. Vielen Dank Markus B. Karlsruhe
  • Sehr schnelle und kompetente Antwort, die für mich bares Geld bedeutet. Vielen Dank! S.Stober K.
  • Herzlichen Dank! Hab durch Ihre Antwort viel Geld gespart! Ben R. Deutschland
  • Sehr schnelle und kompetente Hilfestellung. Besonders für mich als Laien wurde alles sehr verständlich erklärt. Gerne wieder! Rosengl Bad Tölz
 
 
 

Lernen Sie unsere Experten kennen:

 
 
 
  • Tronic

    Tronic

    IT-Specialist

    Zufriedene Kunden:

    2269
    Elektroniker und EDV-Service
< Zurück | Weiter >
  • http://ww2.justanswer.com/uploads/PY/Pyroflash/2011-4-21_104934_tronic.64x64.jpg Avatar von Tronic

    Tronic

    IT-Specialist

    Zufriedene Kunden:

    2269
    Elektroniker und EDV-Service
  • http://ww2.justanswer.com/uploads/rufushoschi/2010-11-08_135947_bild.jpg Avatar von IT-Fachinformatiker

    IT-Fachinformatiker

    Systemadministrator

    Zufriedene Kunden:

    6338
    Software Entwicklung, Projekt Erfahrung, Windows-Netzwerke, Linux-Netzwerke, Windows/Linux-Server
  • http://ww2.justanswer.com/uploads/COMINAROSA/2010-02-03_172238_PASSBILD.JPG Avatar von COMIN IT-Service

    COMIN IT-Service

    Dipl.-Ing.

    Zufriedene Kunden:

    779
    Dipl.Ing (FH) ET, NT, IT
  • http://ww2.justanswer.com/uploads/RaubergerConcep/2010-03-02_102740_Portraet64.jpg Avatar von RaubergerConcept

    RaubergerConcept

    IT-Specialist

    Zufriedene Kunden:

    234
    Mehr als 10 Jahre Erfahrung in Softwareentwicklung und Netzwerktechnik
  • http://ww2.justanswer.com/uploads/LF/lfalkenburg/2015-2-8_01843_.64x64.jpg Avatar von Lutz Falkenburg

    Lutz Falkenburg

    IT-Specialist

    Zufriedene Kunden:

    96
    Seit über 20 Jahren beruflich im IT-/IUK-Bereich tätig. Egal ob EinzelPC der Netzwerk...
  • http://ww2.justanswer.com/uploads/BI/BigDaddyXD/2012-10-24_20126_WhySoSeriousJob.64x64.jpg Avatar von BigDaddyXD

    BigDaddyXD

    Informatiker

    Zufriedene Kunden:

    1588
    Microsoft Certified Professional, Microsoft Certified Desktop Support Technican,...
  • http://ww2.justanswer.com/uploads/PU/Pucky80/2011-5-14_54537_pucky80.64x64.jpg Avatar von Pucky80

    Pucky80

    IT-Systemkaufmann

    Zufriedene Kunden:

    1322
    MCITP (Microsoft Server 2008 Enterprise Administrator)
 
 
 

Ähnliche Fragen in der Kategorie Computer