VBA Tipp: Word Tabellen auslesen

Aus DBWiki
Wechseln zu: Navigation, Suche

Aufgabenstellung

Ich möchte mit Access 97 eine in Word 97 befindliche Tabelle auslesen und die Daten spaltenweise in Acess Tabellen schreiben.

Die beiden Tabellen heißen hier tbl_Erste_Spalte und tbl_Zweite_Spalte um die Übersicht zu erhöhen. Bei folgendem Beispiel, sind die Zeilen auf 50 beschränkt, was aber natürlich beliebig erweitert werden kann. Weiterhin muss auch die Funktion Suchen/Ersetzen(Replace) eingebunden werden und es muss auch ein Verweis auf die 'Microsoft WORD Object Library' gesetzt sein.

Lösung

Public Function Wordanalyse(Pfad As String)
Dim Wrd As Word.Application
Dim Doc As Word.Document
 
Dim Tmp(50) As String
Dim Tmp2(50) As String
Dim Tmp3(50) As String
Dim Tmp4(50) As String
 
'Itaratoren
Dim I As Long
Dim J As Long
Dim K As Long
 
'Z = Zwischenwert
Dim Z_Wert As String
 
'Die Aktuelle Datenbank
Dim db As Database
Dim rs1  As Recordset
Dim rs2  As Recordset
 
Set db = CurrentDb()
 
'Tabellen werden geleert
db.Execute "DELETE * FROM tbl_Erste_Spalte;"
db.Execute "DELETE * FROM tbl_Zweite_Spalte;"
 
Set rs1 = db.OpenRecordset("Select * from tbl_Erste_Spalte", dbOpenDynaset)
Set rs2 = db.OpenRecordset("Select * from tbl_Zweite_Spalte", dbOpenDynaset)
 
'Schauen, ob Word schon läuft
On Error Resume Next '
   Set Wrd = GetObject(, "Word.Application")
    If Err.Number <> 0 Then
      Set Wrd = CreateObject("Word.Application")
    Else
        Wrd.Activate
        Wrd.Visible = False
    End If
On Error Goto 0   'Debugging wieder einschalten
'Word im "Nur Lesen"-Modus öffnen
Wrd.Documents.Open FileName:=Pfad, ReadOnly:=True
 
'Erste Spalte einlesen
i = 1 ' Ist die erste Zeile
K = 0
 
Do While i < 50 ' Maximale Anzahl der gelesenen Zeilen
     'Tabellen Zeilenumbrüche entfernen
     Tmp(i) = Nz(Replace(Wrd.ActiveDocument.Tables(1).Cell(i, 1).Range, "?", ""))
          ' Das Tables(1) -> Steht für die erste Tabelle im Dokument
          J = 1
 
     Do While J <= Len(Tmp(i))
       If Asc(Mid(Tmp(i), J, 1)) >= 64 Then ' Keine Sonderzeichen lesen
          Z_Wert = Z_Wert & Mid(Tmp(i), J, 1)
        End If
        J = J + 1
     Loop
 
     If Nz(Z_Wert) Then
        Tmp2(K) = Z_Wert
        K = K + 1
     End If
 
    Z_Wert = ""
    i = i + 1
 
Loop
 
For i = 0 To UBound(Tmp2)
If Nz(Tmp2(i)) Then
    If Tmp2(i) <> Tmp2(i - 1) Then
        rs1.AddNew
        rs1!Ergebnis = Trim(Tmp2(i))
        rs1.Update
    End If
End If
 
Next i
 
'Zweite Spalte
i = 1
K = 0
 
Do While i < 50
     'Tabellen Zeilenumbrüche entfernen
     Tmp3(i) = Nz(Replace(Wrd.ActiveDocument.Tables(1).Cell(i, 2).Range, "?", ""))
          J = 1
 
     Do While J <= Len(Tmp3(i))
       If Asc(Mid(Tmp3(i), J, 1)) >= 64 Then
          Z_Wert = Z_Wert & Mid(Tmp3(i), J, 1)
        End If
 
        J = J + 1
     Loop
 
     If Nz(Z_Wert) Then
        Tmp4(K) = Z_Wert
        K = K + 1
     End If
 
    Z_Wert = ""
    i = i + 1
 
Loop
For i = 0 To UBound(Tmp4)
If Nz(Tmp4(i)) Then
    If Tmp4(i) <> Tmp4(i - 1) Then
        rs2.AddNew
        rs2!Ergebnis = Trim(Tmp4(i))
        rs2.Update
    End If
End If
Next i
On Error Resume Next
rs1.Close
rs2.Close
Set Wrd = Nothing
Set rs1 = Nothing
Set rs2 = Nothing
End Function
Wiki hinweis.png Hinweis: Es werden keine Sonderzeichen eingelesen aufgrund der Zeilenumbrüche innerhalb der Wordtabellen. Falls doch Sonderzeichen benötigt werden, wird empfohlen, den Ascii Code für dieses Zeichen zu ermitteln und an die ermittelte Stelle einzusetzen:
' Keine Sonderzeichen lesen außer einem Punkt(".")
If Asc(Mid(Tmp(i), J, 1)) >= 64 Or Asc(Mid(Tmp(i), J, 1))= 46 Then

Aufruf

Call Wordanalyse("C:\MeinWordDoc")