von marcel_at_work » So, 08.09.2013 18:20
Hallöchen Robert,
hier ist mal die gesamte Prozedur, die Datenbank wird aber außerhalb initialisiert.
Code: Alles auswählen
Sub XMLimport()
Dim sCurrentLine, sFile, sText, sImportFilename As String
Dim nFileNo, nCurrentLine, nCountClient As Integer
nCountClient = 0
nCurrentLine = 0
'Definition des Dateinamens
sImportFilename = sSystemPath & "toImport\Zeitkarten.xml"
'*********************************************************************************************************************************************************
'Auslesen des XMLbackupCount (Zählerstand der gesicherten XML-Dateien im Backup-Verzeichnis)
oResultLog.beforeFirst()
Do While oResultLog.Next()
If oResultLog.getString(2) = "XMLbackupCount" Then nXMLbackupCount = oResultLog.getString(3)
Loop
'nXMLbackupCount hochzählen und Sicherungskopie der zu importierenden XML-Datei erstellen
nXMLbackupCount = nXMLbackupCount + 1
FileCopy(sImportFilename,sSystemPath & "backups\XML\timecard [" & Format(nXMLbackupCount,"0000") & "].xml")
'aktualisierten Wert von nXMLbackupCount in die logs-Tabelle übertragen
oResultLog.beforeFirst()
Do While oResultLog.Next()
If oResultLog.getString(2) = "XMLbackupCount" Then
oResultLog.updateString(3, nXMLbackupCount)
oResultLog.updateRow()
End If
Loop
'*********************************************************************************************************************************************************
'Ermittlung eines freien Datei-Handles
nFileNo = Freefile
'Datei öffnen (Lesemodus)
Open sImportFilename For Input As nFileNo
'Schleifendurchlauf, bis Dateiende erreicht ist
Do While not eof(nFileNo)
'zeilenweises Einlesen
Line Input #nFileNo, sCurrentLine
sCurrentLine = trim(sCurrentLine) 'gibt den String ohne führende und nachfolgende Leerzeichen zurück
nCurrentLine = nCurrentLine + 1 'Zähler für die eingelesenen Zeilen
'*****************************************************************************************************************************************************
'Alarmmeldungen:
'Um Schäden an der Datenbank zu vermeiden, wird hier der Importvorgang abgebrochen, wenn...
'... der XML-Header fehlerhaft ist
If nCurrentLine = 1 And sCurrentLine <> "<?xml version='1.0' encoding='UTF-8' standalone='yes' ?>" Then
MsgBox Chr(13) & "Die zu importierende Datei ist beschädigt oder in einem nicht unterstützten Format." & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
'... die zu importierende Datei keinen 'TimeTracker'-TAG enthält
ElseIf nCurrentLine = 2 And sCurrentLine <> "<TimeTracker>" Then
MsgBox Chr(13) & "Die zu importierende Datei ist beschädigt oder in einem nicht unterstützten Format." & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
'... die zu importierende Datei keinen 'Timecards'-TAG enthält
ElseIf nCurrentLine = 10 And sCurrentLine <> "<Timecards>" Then
MsgBox Chr(13) & "Bei der zu importierenden Datei handelt es sich NICHT um 'Zeitkarten.xml'. " & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
End If
'*****************************************************************************************************************************************************
'Extrahierung und Zwischenspeicherung der jeweiligen TAG-Inhalte
If sCurrentLine <>"" Then
If Instr(sCurrentLine,"<Client Name=""") = 1 Then
nCountClient = nCountClient + 1
sClientName = findPartString(sCurrentLine,"<Client Name=""",""" Type=""",1)
sClientType = findPartString(sCurrentLine,""" Type=""",""">",1)
'sClientName = convertToUnicode(sClientName)
msgbox sClientName
'------>
'Überprüfung, ob in der Tabelle "clients" schon Einträge vorhanden sind...
'------>
oResultClients.Command = "SELECT ID, name, type FROM clients WHERE name = '" & sClientName & "'"
oResultClients.Execute
if oResultClients.first() = True then msgbox oResultClients.getString(2)
If oResultClients.First = True Then
'... falls JA, wird hier die Tabelle auf Übereinstimmung durchsucht
nClientID = oResultClients.getString(1)
'msgbox nClientID
'... falls NICHT, wird ein neuer Datensatz angelegt
Else
oResultClients.Command = "SELECT ID, name, type FROM clients ORDER BY ID"
oResultClients.Execute
oResultClients.last()
oResultClients.moveToInsertRow()
oResultClients.updateString(2, sClientName)
oResultClients.updateString(3, sClientType)
oResultClients.insertRow()
oResultClients.moveToCurrentRow()
oResultClients.Last()
End If
ElseIf Instr(sCurrentLine,"<Project Name=""") = 1 Then
sProjectName = findPartString(sCurrentLine,"<Project Name=""",""" Type=""",1)
sProjectType = findPartString(sCurrentLine,""" Type=""",""" Code=""",1)
sProjectCode = findPartString(sCurrentLine,""" Code=""",""">",1)
ElseIf Instr(sCurrentLine,"<Task Name=""") = 1 Then
sTaskName = findPartString(sCurrentLine,"<Task Name=""",""" Type=""",1)
sTaskType = findPartString(sCurrentLine,""" Type=""",""" Code=""",1)
sTaskCode = findPartString(sCurrentLine,""" Code=""",""" Location=""",1)
sTaskLocation = findPartString(sCurrentLine,""" Location=""",""">",1)
ElseIf Instr(sCurrentLine,"<Description>") = 1 Then
sTaskDescription = findPartString(sCurrentLine,"<Description>","</Description>",1) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<noch ausarbeiten!
ElseIf Instr(sCurrentLine,"<Timecard Start=""") = 1 Then
sTimecardStart = findPartString(sCurrentLine,"<Timecard Start=""",""" Final=""",1)
sTimecardFinal = findPartString(sCurrentLine,""" Final=""",""" Workbreak=""",1)
nTimecardWorkbreak = CDbl(findPartString(sCurrentLine,""" Workbreak=""",""">",1))/3600
ElseIf Instr(sCurrentLine,"<Details>") = 1 Then
sTimecardDetails = findPartString(sCurrentLine,"<Details>","</Details>",1)
ElseIf Instr(sCurrentLine,"<Description>") = 1 Then
sTimecardDescription = findPartString(sCurrentLine,"<Description>","</Description>",1) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<noch ausarbeiten!
End If
'sText = sText & sCurrentLine & Chr(13)
End If
Loop
'Datei schließen
Close #nFileNo
'*********************************************************************************************************************************************************
'Erstellung einer Sicherungskopie der SQLite-Datenbank
call databaseBackup()
'Msgbox sText
'Msgbox sClientName & Chr(13) & sClientTyp
'Msgbox sProjectName & Chr(13) & sProjectType & Chr(13) & sProjectCode
'Msgbox sTaskName & Chr(13) & sTaskType & Chr(13) & sTaskCode & Chr(13) & sTaskLocation & Chr(13) & sTaskDescription
'Msgbox sTimecardStart & Chr(13) & sTimecardFinal & Chr(13) & nTimecardWorkbreak & Chr(13) & sTimecardDetails & Chr(13) & sTimecardDescription
End Sub
sClientName wird nach Zuweisung aus sCurrentline (in der Mitte des Codes) in die Messagebox geladen.
LG,
Marcel
Hallöchen Robert,
hier ist mal die gesamte Prozedur, die Datenbank wird aber außerhalb initialisiert.
[code]
Sub XMLimport()
Dim sCurrentLine, sFile, sText, sImportFilename As String
Dim nFileNo, nCurrentLine, nCountClient As Integer
nCountClient = 0
nCurrentLine = 0
'Definition des Dateinamens
sImportFilename = sSystemPath & "toImport\Zeitkarten.xml"
'*********************************************************************************************************************************************************
'Auslesen des XMLbackupCount (Zählerstand der gesicherten XML-Dateien im Backup-Verzeichnis)
oResultLog.beforeFirst()
Do While oResultLog.Next()
If oResultLog.getString(2) = "XMLbackupCount" Then nXMLbackupCount = oResultLog.getString(3)
Loop
'nXMLbackupCount hochzählen und Sicherungskopie der zu importierenden XML-Datei erstellen
nXMLbackupCount = nXMLbackupCount + 1
FileCopy(sImportFilename,sSystemPath & "backups\XML\timecard [" & Format(nXMLbackupCount,"0000") & "].xml")
'aktualisierten Wert von nXMLbackupCount in die logs-Tabelle übertragen
oResultLog.beforeFirst()
Do While oResultLog.Next()
If oResultLog.getString(2) = "XMLbackupCount" Then
oResultLog.updateString(3, nXMLbackupCount)
oResultLog.updateRow()
End If
Loop
'*********************************************************************************************************************************************************
'Ermittlung eines freien Datei-Handles
nFileNo = Freefile
'Datei öffnen (Lesemodus)
Open sImportFilename For Input As nFileNo
'Schleifendurchlauf, bis Dateiende erreicht ist
Do While not eof(nFileNo)
'zeilenweises Einlesen
Line Input #nFileNo, sCurrentLine
sCurrentLine = trim(sCurrentLine) 'gibt den String ohne führende und nachfolgende Leerzeichen zurück
nCurrentLine = nCurrentLine + 1 'Zähler für die eingelesenen Zeilen
'*****************************************************************************************************************************************************
'Alarmmeldungen:
'Um Schäden an der Datenbank zu vermeiden, wird hier der Importvorgang abgebrochen, wenn...
'... der XML-Header fehlerhaft ist
If nCurrentLine = 1 And sCurrentLine <> "<?xml version='1.0' encoding='UTF-8' standalone='yes' ?>" Then
MsgBox Chr(13) & "Die zu importierende Datei ist beschädigt oder in einem nicht unterstützten Format." & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
'... die zu importierende Datei keinen 'TimeTracker'-TAG enthält
ElseIf nCurrentLine = 2 And sCurrentLine <> "<TimeTracker>" Then
MsgBox Chr(13) & "Die zu importierende Datei ist beschädigt oder in einem nicht unterstützten Format." & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
'... die zu importierende Datei keinen 'Timecards'-TAG enthält
ElseIf nCurrentLine = 10 And sCurrentLine <> "<Timecards>" Then
MsgBox Chr(13) & "Bei der zu importierenden Datei handelt es sich NICHT um 'Zeitkarten.xml'. " & Chr(13) & "Um Schäden an der Datenbank zu vermeiden, wird der Importvorgang hiermit abgebrochen. " & Chr(13) & Chr(13), 16, "Achtung!"
Exit Sub
End If
'*****************************************************************************************************************************************************
'Extrahierung und Zwischenspeicherung der jeweiligen TAG-Inhalte
If sCurrentLine <>"" Then
If Instr(sCurrentLine,"<Client Name=""") = 1 Then
nCountClient = nCountClient + 1
sClientName = findPartString(sCurrentLine,"<Client Name=""",""" Type=""",1)
sClientType = findPartString(sCurrentLine,""" Type=""",""">",1)
'sClientName = convertToUnicode(sClientName)
msgbox sClientName
'------>
'Überprüfung, ob in der Tabelle "clients" schon Einträge vorhanden sind...
'------>
oResultClients.Command = "SELECT ID, name, type FROM clients WHERE name = '" & sClientName & "'"
oResultClients.Execute
if oResultClients.first() = True then msgbox oResultClients.getString(2)
If oResultClients.First = True Then
'... falls JA, wird hier die Tabelle auf Übereinstimmung durchsucht
nClientID = oResultClients.getString(1)
'msgbox nClientID
'... falls NICHT, wird ein neuer Datensatz angelegt
Else
oResultClients.Command = "SELECT ID, name, type FROM clients ORDER BY ID"
oResultClients.Execute
oResultClients.last()
oResultClients.moveToInsertRow()
oResultClients.updateString(2, sClientName)
oResultClients.updateString(3, sClientType)
oResultClients.insertRow()
oResultClients.moveToCurrentRow()
oResultClients.Last()
End If
ElseIf Instr(sCurrentLine,"<Project Name=""") = 1 Then
sProjectName = findPartString(sCurrentLine,"<Project Name=""",""" Type=""",1)
sProjectType = findPartString(sCurrentLine,""" Type=""",""" Code=""",1)
sProjectCode = findPartString(sCurrentLine,""" Code=""",""">",1)
ElseIf Instr(sCurrentLine,"<Task Name=""") = 1 Then
sTaskName = findPartString(sCurrentLine,"<Task Name=""",""" Type=""",1)
sTaskType = findPartString(sCurrentLine,""" Type=""",""" Code=""",1)
sTaskCode = findPartString(sCurrentLine,""" Code=""",""" Location=""",1)
sTaskLocation = findPartString(sCurrentLine,""" Location=""",""">",1)
ElseIf Instr(sCurrentLine,"<Description>") = 1 Then
sTaskDescription = findPartString(sCurrentLine,"<Description>","</Description>",1) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<noch ausarbeiten!
ElseIf Instr(sCurrentLine,"<Timecard Start=""") = 1 Then
sTimecardStart = findPartString(sCurrentLine,"<Timecard Start=""",""" Final=""",1)
sTimecardFinal = findPartString(sCurrentLine,""" Final=""",""" Workbreak=""",1)
nTimecardWorkbreak = CDbl(findPartString(sCurrentLine,""" Workbreak=""",""">",1))/3600
ElseIf Instr(sCurrentLine,"<Details>") = 1 Then
sTimecardDetails = findPartString(sCurrentLine,"<Details>","</Details>",1)
ElseIf Instr(sCurrentLine,"<Description>") = 1 Then
sTimecardDescription = findPartString(sCurrentLine,"<Description>","</Description>",1) '<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<noch ausarbeiten!
End If
'sText = sText & sCurrentLine & Chr(13)
End If
Loop
'Datei schließen
Close #nFileNo
'*********************************************************************************************************************************************************
'Erstellung einer Sicherungskopie der SQLite-Datenbank
call databaseBackup()
'Msgbox sText
'Msgbox sClientName & Chr(13) & sClientTyp
'Msgbox sProjectName & Chr(13) & sProjectType & Chr(13) & sProjectCode
'Msgbox sTaskName & Chr(13) & sTaskType & Chr(13) & sTaskCode & Chr(13) & sTaskLocation & Chr(13) & sTaskDescription
'Msgbox sTimecardStart & Chr(13) & sTimecardFinal & Chr(13) & nTimecardWorkbreak & Chr(13) & sTimecardDetails & Chr(13) & sTimecardDescription
End Sub
[/code]
sClientName wird nach Zuweisung aus sCurrentline (in der Mitte des Codes) in die Messagebox geladen.
LG,
Marcel