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
|