Import/update txt file vha VBA

Jeg vil her præsentere en løsning med udspring i top-down måde at arbejde sig ned til detaljerne på:

Følgende subrutine hedder naturligvis noget andet i dit projekt og tabelnavn og filnavn kommer andet steds fra:
currentdb.execute er til start udkommenteret, så man kan se sql udtryk i debug vinduet. 'if 0 then' skal også erstattes af det udkommenterede der følger.
Funktionen filerecs tager som parameter, ud over filnavn og tabelnavn en liste af 3par:
    feltnavn i tekstfil,
    feltnavn i tabel
    type eller skip felt
Typen skal bruges for at omklamre feltindhold - f.eks gåseøjne til tekstfelter
filerecs giver et object der kan loopes gennem felter fra filen med.
 


Public Enum frDt
    skip = 0
    Text = 1
    Date = 2
End Enum

Sub usefilerecs()
    Const fn = "D:\home\dev\devel\access\filerecs.txt"
    Const tblN = "Person"
    Debug.Print "update " & tblN & " set Active=0"
    'CurrentDb.Execute "update " & tblN & " set Active=0"
    With fileRecs(fn, tblN, _
                            "dn", frDt.skip, frDt.skip, _
                            "changetype", frDt.skip, frDt.skip, _
                            "cn", "Name", frDt.Text, _
                            "title", "Title", frDt.Text, _
                            "telephoneNumber", "Phone", frDt.Text, _
                            "company", "Organization", frDt.Text, _
                            "mail", "mail", frDt.Text, _
                            "mobile", "IpPhone", frDt.Text)
        While Not .eor
            If 0 Then 'DLookup("mail", tblN, "mail='" & .rec!mail & "'") Then
                Debug.Print .sqlUpdate
            Else
                'CurrentDb.Execute .sqlInsert
                Debug.Print .sqlInsert
            End If
    Wend: End With
End Sub


filerecs initialiserer og returnerer et FileRecsLister object


Function fileRecs(filename, tableName, ParamArray fldUsage()) As FileRecsLister
    Set fileRecs = New FileRecsLister
    fileRecs.openfile filename
    fileRecs.tableName = tableName
    Dim i
    For i = 0 To UBound(fldUsage) Step 3
        fileRecs.fldNames.Add fldUsage(i), fldUsage(i + 1)
        fileRecs.fldUsage.Add fldUsage(i), fldUsage(i + 2): Next
End Function



FileRecsLister er en klasse - (altså insert 'class module' i vba editorens project explorer. Måske skal referencen 'microsoft scripting runtime' tilvælges (menulinie->tool->references)

Option Compare Database
Option Explicit

Public rec As Scripting.Dictionary
Private txtS As Scripting.TextStream
Public fldUsage As Scripting.Dictionary
Public fldNames As Scripting.Dictionary
Public tableName
Private keyV


Private Sub Class_Initialize()
    Set rec = New Scripting.Dictionary
    Set fldUsage = New Scripting.Dictionary
    Set fldNames = New Scripting.Dictionary
End Sub

Sub openfile(filename)
    With New Scripting.FileSystemObject
        Set txtS = .OpenTextFile(filename, ForReading, False)
    End With
End Sub
Property Get eor()
    Dim line, items
    rec.RemoveAll
    eor = txtS.AtEndOfStream
    If Not txtS.AtEndOfStream Then
        Do
            line = txtS.ReadLine
            If Len(line) Then
                items = Split(line, ":")
                rec.Add items(0), Trim(items(1)): End If
        Loop Until Len(line) = 0 Or txtS.AtEndOfStream
    End If
End Property


Function sqlInsert()
    Dim par, value, surr
    For Each keyV In rec.Keys
        If Not fldIsSkipped() Then
            surr = surrounding()
            par = par & fldNames(keyV) & ","
            value = value & surr & rec.item(keyV) & surr & ",": End If: Next
    sqlInsert = "Insert into " & tableName & " (" & par & "Active) values(" & value & "-1)"
End Function

Function sqlUpdate()
    Dim ass, surr
    For Each keyV In rec.Keys
        If Not fldIsSkipped() Then
            surr = surrounding()
            ass = ass & fldNames(keyV) & "=" & surr & rec.item(keyV) & surr & ",": End If: Next
    sqlUpdate = "Update " & tableName & " set " & ass & "Active=-1"
End Function

Private Function fldIsSkipped()
    'If fldUsage.Exists(keyV) Then If fldUsage(keyV) = frlDt.Skip Then fldIsSkipped = True
    If fldUsage.Exists(keyV) Then If fldUsage(keyV) = 0 Then fldIsSkipped = True
End Function

Private Function surrounding$()
    If fldUsage.Exists(keyV) Then
        Select Case fldUsage(keyV)
        Case frDt.Text
            surrounding = """"
        Case frDt.Date
            surrounding = "#"
        End Select: End If
End Function

Lige en tilføjelse - det kan være der er mere i det - at feltet 'dn' skal kunne nedbrydes og dele deraf bruges - jeg kan ikke se hvorfra Department skulle komme.

Desuden vil jeg påpege at det er den tomme linie i filen der bruges som postseperator (Loop Until Len(line) = 0 ...)

Mange tak.

Jeg får brug for et par dage til at kigge på det og så vender jeg tilbage.