#

 

 

Dieses Code-Beispiel zeigt, wie man in vba in Access bestimmte Text-Zeilen aus einem PDF Dokument ausliest.

Ablauf:

Zur Anwendung wird der PDF_Text_Reader in die Office Anwendung eingebunden und der Text des PDF Dokuments ausgelesen.

Anschliessend werden alle Text-Zeilen einzeln durchlaufen und auf einen Filter in der Textzeile geprüft.

Wenn das Text-Muster vorhanden ist, dann wird die Zeile weiterverarbeitet.

 

Betrifft: Unter Access, Excel, Word

 

 

Der PDF Text-Reader wird eingebettet mit

    '< get PDF Text >

    Dim pdf_Reader As New Pdf_Text_Reader.pdf_Reader

    sText = pdf_Reader.get_Text(sFilename)

    '</ get PDF Text >

 

 

Bestimmte Zeilen finden.

 

Damit man nur bestimmte Zeilen bearbeiten kann, muss man einen Filter auf die Zeile legen.

Im Beispiel beginnt jede Buchung mit einem Datum 01.02. und endet mit H oder S

Deshalb lautet der Filter

If sLine Like "??.??. *S" Or sLine Like "??.??. *H" Then

..

End If

 

 

Dann werden alle Zeilen einzeln durchlaufen und nur wenn der Zeilenfilter zutrifft, wird die Zeile ausgewertet

    '----< Read as Lines >----

    Dim arrLines

    arrLines = Split(sText, vbLf)

     

    Dim vLine

    For Each vLine In arrLines

        

      Dim sLine As String

      sLine = vLine

        

      If sLine Like "??.??. *S" Or sLine Like "??.??. *H" Then

         '--< Buchung: Zeile1 >----

         '*get first date        

         Dim iPos As Integer

         iPos = InStr(1, sLine, " ", vbTextCompare)

         sDtBuchung = Mid(sLine, 1, iPos - 1) + sJahr

         '--</ Buchung: Zeile1 >----

      End If

 

    Next

    '----</ Read as Lines >----

 

 

 

Vba Code-Seite

In Access

 

Bereich einlesen

 

Im Beispiel zum Einlesen von Bank-Belegen wird nur der Bereich gelesen, welcher von Kontoauszug-Buchungsdaten Beginn bis Ende geht.

Der Bereich beginnt mit alter Kontostand und endet mit neuer Kontostand.

Deshalb muss beim Beginn und Ende des Bereichs ein Steuerzeichen bStart und bEnd gesetzt werden.

If sLine Like "*alter Kontostand *S" Or sLine Like "*alter Kontostand *H" Then

            '< Start Bereich >

            bStart = True

            '</ Start Bereich >

        ElseIf sLine Like "*neuer Kontostand *S" Or sLine Like "*neuer Kontostand *H" Then

            '-< Ende Zeile >-            

            bEnd = True

            Exit For

            '-</ Ende Zeile >-

        Else

 

Anschliessend wird nur eingelesen, wenn diese zwei Bereichs-Steuerzeichen aktiv sind.

Public Sub Datei_einlesen(ByVal sFilename As String)

    '-----------< Datei_einlesen() >-----------

    '< get PDF Text >

    Dim pdf_Reader As New Pdf_Text_Reader.pdf_Reader

    sText = pdf_Reader.get_Text(sFilename)

    '</ get PDF Text >

 

    '----< Read as Lines >----

    Dim arrLines

    arrLines = Split(sText, vbLf)

 

    Dim bStart As Boolean, bEnd As Boolean

    bStart = False

    bEnd = False

    Dim IDImport As Long

    Dim sKontakt As String, sVorgang As String, sVerwendungszweck As String, sDtBuchung As String, sDtWert As String, sBetrag_Euro As String

    sKontakt = "" : sVorgang = "" : sVerwendungszweck = "" : sDtBuchung = "" : sDtWert = "" : sBetrag_Euro = ""

    Dim sJahr As String

    sJahr = ""

    Dim iLine As Integer, iBuchungszeile As Integer

    iLine = 1

    Dim vLine

    For Each vLine In arrLines

        iLine = iLine + 1

        Dim sLine As String

        sLine = vLine

        If sLine Like "*alter Kontostand *S" Or sLine Like "*alter Kontostand *H" Then

            '< Start Bereich >

            bStart = True

            iBelegzeile = 0

            '</ Start Bereich >

        ElseIf sLine Like "*neuer Kontostand *S" Or sLine Like "*neuer Kontostand *H" Then

            '-< Ende Zeile >-

            '< anfuegen >

            If Not sDtBuchung Like "" Then

                Beleg_anfuegen sKontakt, sVorgang, sVerwendungszweck, sDtBuchung, sDtWert, sBetrag_Euro

            End If

            '</ anfuegen >

            bEnd = True

            Exit For

            '-</ Ende Zeile >-

        Else

            '----< Buchungs-Zeilen >----

            If bStart = False And bEnd = False Then

                '--< Bereich: Beleg-Kopf >--

                If sLine Like "*Kontoauszug*Nr.*/*" Then

                    Dim iPosJahr As Integer

                    iPosJahr = InStr(1, sLine, "/", vbBinaryCompare)

 

                    sJahr = Mid(sLine, iPosJahr + 1)

                End If

                '--</ Bereich: Beleg-Kopf >--

            ElseIf bStart = True And bEnd = False Then

                '--< Bereich: Buchungen >--

                iBuchungszeile = iBuchungszeile + 1

                If sLine Like "??.??. *S" Or sLine Like "??.??. *H" Then

                    '--< Buchung: Zeile1 >----

                    '< vorige Buchung anfuegen >

                    If Not sDtBuchung Like "" Then

                        Beleg_anfuegen sKontakt, sVorgang, sVerwendungszweck, sDtBuchung, sDtWert, sBetrag_Euro

                    End If

                    '</ vorige Buchung anfuegen >

 

                    '< init Buchung >

                    iBuchungszeile = 1

                    sDtBuchung = "" : sDtWert = "" : sKontakt = "" : sVorgang = "" : sVerwendungszweck = "" : sBetrag_Euro = ""

                    '</ init Buchung >

 

                    Dim iPos As Integer

                    iPos = InStr(1, sLine, " ", vbTextCompare)

                    sDtBuchung = Mid(sLine, 1, iPos - 1) + sJahr

                    sLine = Mid(sLine, iPos + 1)

 

                    iPos = InStr(1, sLine, " ", vbTextCompare)

                    sDtWert = Mid(sLine, 1, iPos - 1) + sJahr

                    sLine = Mid(sLine, iPos + 1)

 

                    iPos = InStrRev(sLine, " ", , vbTextCompare)

                    sSoll_Haben = Mid(sLine, iPos + 1)

                    sLine = Mid(sLine, 1, iPos - 1)

 

                    iPos = InStrRev(sLine, " ", , vbTextCompare)

                    sBetrag_Euro = Mid(sLine, iPos + 1)

                    If sSoll_Haben Like "S" Then

                        sBetrag_Euro = "-" & sBetrag_Euro

                    End If

                    sLine = Mid(sLine, 1, iPos - 1)

                    sVorgang = Trim(sLine)

                    '--</ Buchung: Zeile1 >----

                Else

                    '--< Buchung: Zeile2_bis_n >----

                    sLine = Trim(sLine)

                    If iBuchungszeile = 2 Then

                        sKontakt = sLine

                    Else

                        sVerwendungszweck = sVerwendungszweck & vbCrLf & sLine

                    End If

                    '--</ Buchung: Zeile2_bis_n >----

                End If

                '--</ Bereich: Buchungen >--

            End If

        End If

 

    Next

    '----</ Read as Lines >----

 

    '-----------</ Datei_einlesen() >-----------

End Sub

 

 

 

 

Referenz: vba Code

Komplettes Codebeispiel in vba

Option Compare Database

 

 

Private Sub BtnImport_Click()

    Select_File()

End Sub

 

 

'*Reference Microsoft scripting Runtime    http://www.microsoft-programmierer.de/Details?d=1076

Public Sub Select_File()

    '-----------< Select_File() >-----------

    '--< File-Dialog >--

    Dim objFiledialog As FileDialog

    Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)

    objFiledialog.AllowMultiSelect = True

    objFiledialog.ButtonName = "->Select Files"

    objFiledialog.filters.Add "Add Files""*.pdf"

    objFiledialog.title = "Select Files.."

    objFiledialog.InitialView = msoFileDialogViewTiles

    objFiledialog.InitialFileName = CurrentProject.Path

    objFiledialog.AllowMultiSelect = True

    If Not objFiledialog.Show() = True Then

        Exit Sub

    End If

    '--< File-Dialog >--

 

    '-< check >-

    '</ Ordner ist leer >

    If objFiledialog.SelectedItems().Count = 0 Then

        Exit Sub

    End If

    '</ Ordner ist leer >

 

    '-</ check >-

 

    Dim sFilename As String

    Dim sFiles As String

    sFiles = ""

    '----< @Loop: Files >----

 

    Dim iFile As Integer

    For iFile = 1 To objFiledialog.SelectedItems.Count

        '------< Loop.Item  >------

        DoEvents

        '< get selection >

        sFilename = objFiledialog.SelectedItems(iFile)

        '</ get selection >

 

        '--< importieren >--

        Datei_einlesen(sFilename)

        Beleg_Import_speichern(sFilename)

        Daten_Übertragen

        '--</ importieren >--

 

 

    Next

    '----</ @Loop: Files >----

 

    '-----------</ Select_File() >-----------

End Sub

 

Public Sub Datei_einlesen(ByVal sFilename As String)

    '-----------< Datei_einlesen() >-----------

    '< get PDF Text >

    Dim pdf_Reader As New Pdf_Text_Reader.pdf_Reader

    sText = pdf_Reader.get_Text(sFilename)

    '</ get PDF Text >

 

    '----< Read as Lines >----

    Dim arrLines

    arrLines = Split(sText, vbLf)

 

    Dim bStart As Boolean, bEnd As Boolean

    bStart = False

    bEnd = False

    Dim IDImport As Long

    Dim sKontakt As String, sVorgang As String, sVerwendungszweck As String, sDtBuchung As String, sDtWert As String, sBetrag_Euro As String

    sKontakt = "" : sVorgang = "" : sVerwendungszweck = "" : sDtBuchung = "" : sDtWert = "" : sBetrag_Euro = ""

    Dim sJahr As String

    sJahr = ""

    Dim iLine As Integer, iBuchungszeile As Integer

    iLine = 1

    Dim vLine

    For Each vLine In arrLines

        iLine = iLine + 1

        Dim sLine As String

        sLine = vLine

        If sLine Like "*alter Kontostand *S" Or sLine Like "*alter Kontostand *H" Then

            '< Start Bereich >

            bStart = True

            iBelegzeile = 0

            '</ Start Bereich >

        ElseIf sLine Like "*neuer Kontostand *S" Or sLine Like "*neuer Kontostand *H" Then

            '-< Ende Zeile >-

            '< anfuegen >

            If Not sDtBuchung Like "" Then

                Beleg_anfuegen sKontakt, sVorgang, sVerwendungszweck, sDtBuchung, sDtWert, sBetrag_Euro

            End If

            '</ anfuegen >

            bEnd = True

            Exit For

            '-</ Ende Zeile >-

        Else

            '----< Buchungs-Zeilen >----

            If bStart = False And bEnd = False Then

                '--< Bereich: Beleg-Kopf >--

                If sLine Like "*Kontoauszug*Nr.*/*" Then

                    Dim iPosJahr As Integer

                    iPosJahr = InStr(1, sLine, "/", vbBinaryCompare)

 

                    sJahr = Mid(sLine, iPosJahr + 1)

                End If

                '--</ Bereich: Beleg-Kopf >--

            ElseIf bStart = True And bEnd = False Then

                '--< Bereich: Buchungen >--

                iBuchungszeile = iBuchungszeile + 1

                If sLine Like "??.??. *S" Or sLine Like "??.??. *H" Then

                    '--< Buchung: Zeile1 >----

                    '< vorige Buchung anfuegen >

                    If Not sDtBuchung Like "" Then

                        Beleg_anfuegen sKontakt, sVorgang, sVerwendungszweck, sDtBuchung, sDtWert, sBetrag_Euro

                    End If

                    '</ vorige Buchung anfuegen >

 

                    '< init Buchung >

                    iBuchungszeile = 1

                    sDtBuchung = "" : sDtWert = "" : sKontakt = "" : sVorgang = "" : sVerwendungszweck = "" : sBetrag_Euro = ""

                    '</ init Buchung >

 

                    Dim iPos As Integer

                    iPos = InStr(1, sLine, " ", vbTextCompare)

                    sDtBuchung = Mid(sLine, 1, iPos - 1) + sJahr

                    sLine = Mid(sLine, iPos + 1)

 

                    iPos = InStr(1, sLine, " ", vbTextCompare)

                    sDtWert = Mid(sLine, 1, iPos - 1) + sJahr

                    sLine = Mid(sLine, iPos + 1)

 

                    iPos = InStrRev(sLine, " ", , vbTextCompare)

                    sSoll_Haben = Mid(sLine, iPos + 1)

                    sLine = Mid(sLine, 1, iPos - 1)

 

                    iPos = InStrRev(sLine, " ", , vbTextCompare)

                    sBetrag_Euro = Mid(sLine, iPos + 1)

                    If sSoll_Haben Like "S" Then

                        sBetrag_Euro = "-" & sBetrag_Euro

                    End If

                    sLine = Mid(sLine, 1, iPos - 1)

                    sVorgang = Trim(sLine)

                    '--</ Buchung: Zeile1 >----

                Else

                    '--< Buchung: Zeile2_bis_n >----

                    sLine = Trim(sLine)

                    If iBuchungszeile = 2 Then

                        sKontakt = sLine

                    Else

                        sVerwendungszweck = sVerwendungszweck & vbCrLf & sLine

                    End If

                    '--</ Buchung: Zeile2_bis_n >----

                End If

                '--</ Bereich: Buchungen >--

            End If

        End If

 

    Next

    '----</ Read as Lines >----

 

    '-----------</ Datei_einlesen() >-----------

End Sub

 

 

 

Public Sub Beleg_anfuegen(ByVal sKontakt As String, sVorgang As String, sVerwendungszweck As String, sDtBuchung As String, sDtWert As String, sBetrag_Euro As String)

    '-----------< Beleg_anfuegen() >-----------

    '< korrektur >

    sVerwendungszweck = Replace(sVerwendungszweck, vbCrLf, "", 1, 1, vbBinaryCompare)

    '</ korrektur >

 

    Dim recBuchung As Recordset

    Set recBuchung = CurrentDb.OpenRecordset("SELECT TOP 1 * FROM _tbl_Import_Belege", dbOpenDynaset)

    

    recBuchung.AddNew

    recBuchung("Kontakt") = sKontakt

    recBuchung("Vorgang") = sVorgang

    recBuchung("Verwendungszweck") = sVerwendungszweck

    recBuchung("DtBuchung") = sDtBuchung

    recBuchung("DtWert") = sDtWert

    recBuchung("Betrag_Euro") = sBetrag_Euro

    recBuchung.Update

 

    recBuchung.Close

    Set recBuchung = Nothing

    '-----------</ Beleg_anfuegen() >-----------

End Sub

 

Public Sub Beleg_Import_speichern(ByVal sFilename As String)

    '-----------< Beleg_anfuegen() >-----------

    '< correct >

    Dim iPos As Integer

    iPos = InStrRev(sFilename, "\", -1, vbBinaryCompare)

    sFilename = Mid(sFilename, iPos + 1)

    '</ correct >

 

    Dim IDBeleg As Long

    Dim intAnzahl_Buchungen As Integer

    intAnzahl_Buchungen = DCount("IDBeleg""tbl_Import_Belege")

 

    '< anfuegen >

    Dim recBeleg As Recordset

    Set recBeleg = CurrentDb.OpenRecordset("SELECT TOP 1 * FROM tbl_Import_Belege WHERE Belegname like '" & sFilename & "'", dbOpenDynaset)

    If recBeleg.EOF Then

        recBeleg.AddNew

    Else

        recBeleg.Edit

    End If

 

    recBeleg("dtImport") = Now

    recBeleg("Belegname") = sFilename

    recBeleg("Anzahl_Buchungen") = intAnzahl_Buchungen

    recBeleg.Update

 

    recBeleg.Close

    Set recBeleg = Nothing

    '</ anfuegen >

    

    

    '< aktualisieren >

    ctlList_Importe.Requery

    '</ aktualisieren >

    '-----------</ Beleg_anfuegen() >-----------

End Sub

 

 

 

Mobile

.

0123movie.net