Selecteer tussen 3e en 4e ;

Status
Niet open voor verdere reacties.

Crizke

Gebruiker
Lid geworden
11 feb 2013
Berichten
51
Hallo

Ik ben bezig aan een programma dat een textbestand zou moeten overlopen op mijn c-schijf als ik op een knop duw.

Het opent het text bestand en dan zou het rij per rij moeten bekijken als er een "I" vooraf staat.
Bij een "I" moet hij zich positioneren vanaf de 3e " ; " en de getallen selecteren die er staan tot de 4e " ; ".

Als hij dit geselecteerd heeft, moet hij in mijn database hetzelfde bestand zoeken en de checkbox hierbij selecteren en overgaan naar de volgende rij.
De data waarin hij hetzelfde deel moet aan checken staat klaar uit gegevens die uit TabelData op werden gehaald.

Is dit mogelijk ?

Het tekstbestand staat op C:\Home\Private\NewScans.txt

Vb van een rij in dit bestand is...

I;05/29/2013;06:54:35;8710562161218;1;801;1;;1

Hij zou dus 8710562161218 moeten selecteren en dit gaan zoeken in de db...

Procedure vn de database is :

* Bij openen geeft hij formulier weer waarop je kan selecteren op datum. Door het selecteren op datum komt er een query te voorschijn van een tabel.
* De normale procedure was vroeger dat ik elke regel afzonderlijk mijn selectie vanuit het txt-bestand manueel ging doen; dus ik opende het txt bestand, selecteerde hetgeen tssn 3e en 4e " ; " stond en kopieerde dat naar een keuzelijst "SelBarc" en deze gaf mij de juiste selectie door in de tabel te gaan zoeken op EtBarc, ik vinkte deze aan en ging over naar de volgende selectie.

Mijn vraag is dus eigenlijk of ik deze procedure kan automatiseren.
Dus dat het programma zoekt op i, als er een i staat moet hij het getal tssn de 3e en 4e ";" kopieren en vinden in de tabel op EtBarc, de selectie aanvinken en overgaan naar de volgende regel met i ...

Voor enkele regels kan ik dit manueel doen, maar bij een lijst van laat staan 450 regels is dat net iets te veel ;-)

Mvg
 
Kort antwoord: ja, dat kan. Je kunt een tekstbestand met vba openen en uitlezen, en op basis van de ingelezen regels kijken wat er moet gebeuren. In jouw geval zou ik de correcte regels in een matrixvariabele (tmp bijvoorbeeld) zetten, en dan met tmp(3) de gevonden waarde in de tabel laten zetten. Als er meer regels in het tekstbestand zitten, doe je dat met een lus die dan het hele document doorloopt.
Omdat dit geen standaardfunctie is die ik kant en klaar heb liggen, en geen tijd/zin om het helemaal na te bouwen, zou je een voorbeeldje (db + tekst) moeten posten als je er zelf niet uitkomt. Een simpel voorbeeldje:
Code:
Sub ReadFile()
Dim tmpInput As Variant
Dim sInput As String
Dim i As Long

    Open "h:\map1.txt" For Input As #1
    Do While Not EOF(1)
        Input #1, sInput
        tmpInput = Split(sInput, ";")
        MsgBox tmpInput(2)
    Loop

End Sub
 
Kan ik ook bv men tekstbestand via een linked table niet gemakkelijker in de database trekken, en van hier uit verder opbouwen?
 
Tuurlijk, maar dat was je vraag niet :)
Bovendien werkt dat alleen als je tekstbestand een vaste indeling heeft. Dus deze tekst kan wel:
Datum;Tijd;Zaal
18-06-2013;12:30 - 16:00;Oosterparkzaal
18-06-2013;12:30 -13:30;Ondersteuners
18-06-2013;13:45- 14:45;Ondersteuners
18-06-2013;15:00 -16:00;Ondersteuners
20-06-2013;09:00 - 11:45;Middenmeerzaal
20-06-2013;09:00 - 09:45;Managers
20-06-2013;10:00 - 10:45;Managers
20-06-2013;11:00 - 11:45;Managers


Maar deze tekst kan niet:

Datum;Tijd;Zaal
Oosterparkzaal
18-06-2013;12:30 -13:30;Ondersteuners
18-06-2013;13:45- 14:45;Ondersteuners
18-06-2013;15:00 -16:00;Ondersteuners
Middenmeerzaal
20-06-2013;09:00 - 09:45;Managers
20-06-2013;10:00 - 10:45;Managers
20-06-2013;11:00 - 11:45;Managers
 
Ja ik weet het maar ik was even aan het overlopen welke opties ik had :D

Code:
Private Sub Titl050_Click()

    '*** Eerst alle selecties wissen
    
    Dim Y1Datm As String

    Y1Datm = Month(Me.SelDatm) & "/" & Day(Me.SelDatm) & "/" & Year(Me.SelDatm) & " " & Me.SelUur
    
    StrFilter = ""
            
    If IsNull(Me.SelDatm) = False Then
        StrFilter = StrFilter & "[EtDtTy] >= #" & Y1Datm & "#"
    End If
    
    If IsNull(Me.SelSta) = False Then
        StrFilter = StrFilter & " AND EtStnr = " & Me.SelSta
    End If
        
    If IsNull(Me.SelArt) = False Then
        StrFilter = StrFilter & " AND EtArnr = '" & Me.SelArt & "'"
    End If
            
    If IsNull(Me.SelBarc) = False Then
        StrFilter = StrFilter & " AND EtBarc = '" & Me.SelBarc & "'"
    End If
        
    If Me.SelSelect = True Then
        StrFilter = StrFilter & " AND EtAfdr = True"
    End If
    
    If Left(StrFilter, 4) = " AND" Then
        StrFilter = Mid(StrFilter, 5)
    End If

    If StrFilter <> "" Then
        strSQL = "Update QEtiket set EtAfdr = False where " & StrFilter
    Else
        strSQL = "Update QEtiket set EtAfdr = False"
    End If
    
    CurrentDb.Execute (strSQL)
    Me.SFEtiketten.Requery
    
    '*** Open Text bestand New_Scanning
    
    TmpDir = "C:\LSA\SCAN"
    
    Open TmpDir & NEW_SCANNING.txt For Input As #50
    
    If Left(data, 1) = "I" Then
            LineStart = "Y"
    End If

    
    ' Open NEW_SCANNING.txt, "C:\LSA\SCAN
    ' Select * From NEW_SCANNING.txt
    ' If I = True Then
        ' Select between ";" & Search TETiket, EtBarc & Me.EtAfdr.Value = True
            ' If Me.EtBarc.Value = >1 Then
            ' Me.EtBarc.Value = True For Newest
        ' Else GoTo EndIf
        ' Loop
    ' End If
        
    ' GoTo MoveNext
        
End Sub

Zo ziet men sub er tot nu toe uit... En heb wat medelijden want het trekt op nix op dit moment :D

Het bovenste deel verwijderd alle selecties, en het einde heb ik als remark even erbij gezet want dit zijn de dingen die het zou moeten doen :-)
 
Ik snap je code niet helemaal. En dan vooral het eerste stuk:
Code:
    strFilter = ""
    If IsNull(Me.SelDatm) = False Then
        strFilter = strFilter & "[EtDtTy] >= #" & Y1Datm & "#"
    End If
    If IsNull(Me.SelSta) = False Then
        strFilter = strFilter & " AND EtStnr = " & Me.SelSta
    End If
1. strFilter wordt niet gedeclareerd in de procedure, maar wel leeggemaakt. Betekent dit dat je hem vanuit een andere routine al aanmaakt en vult?
2. Als strFilter leeg is, heeft dit geen enkele zin: strFilter = strFilter &
3. Als Me.SelDatm leeg is, gaat dit niet werken: strFilter = strFilter & " AND EtStnr = ". Er is dan immers nog geen filter (leeggemaakt en Me.SelDatm is leeg), dus je mag hier nooit AND in zetten
Punt 3 geldt ook voor de rest van de code, al zal bij het oplopen van het aantal checks de kans op een leeg filter afnemen.

Wat betreft de input: die gaat zo inderdaad niet werken. Waarom je 50 gebruikt i.p.v. 1 zullen we maar onder dichterlijke vrijheid rangschikken, want de waarde maakt natuurlijk niet zoveel uit. Mits je het goed doet. Ik heb met een kleurtje aangegeven wat er bij jou fout is.

Code:
    TmpDir = "C:\LSA\SCAN"
    Open TmpDir & [COLOR="#0000FF"][B]"\[/B][/COLOR]NEW_SCANNING.txt[COLOR="#0000FF"][B]"[/B][/COLOR] For Input As #50
[B][COLOR="#0000FF"]    Do While Not EOF(50)
        Input #50, Data[/B][/COLOR]
        If Left(Data, 1) = "I" Then
            LineStart = "Y"
        End If
    Loop
[COLOR="#0000FF"][B]    Close TmpDir & "\NEW_SCANNING.txt"[/B][/COLOR]
 
Laatst bewerkt:
Dat eerste deel is een procedure achter een knop "Delete", Dit zorgt ervoor dat als er iets aangevinkt is dit uitgevinkt wordt zodat je altijd met een lijst begint waarin niets is aangevinkt...

Code:
Option Compare Database

Private Sub Form_Open(Cancel As Integer)

'*** Ophalen Taal + Titels

    Call OphTaal(Taal, Nummer)
    Call Titels(Me.Name, Taal, Nummer, "F")
        
    Me.SelDatm = Date
    Me.SelUur = "00:00:00"
    Me.SelSelect = False
        
    UpdFilter
        
End Sub
Private Sub SelArt_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelBarc_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelDatm_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelPrg_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelSelect_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelSta_AfterUpdate()
    UpdFilter
End Sub

Private Sub selSysL_AfterUpdate()
    UpdFilter
End Sub

Private Sub SelUur_AfterUpdate()
    UpdFilter
End Sub
Public Function UpdFilter()
    
    Dim Y1Datm As String
    
'*** Update van filter op logging gegevens
    
    Y1Datm = Month(Me.SelDatm) & "/" & Day(Me.SelDatm) & "/" & Year(Me.SelDatm) & " " & Me.SelUur
    
    StrFilter = ""
            
    If IsNull(Me.SelDatm) = False Then
        StrFilter = StrFilter & "[EtDtTy] >= #" & Y1Datm & "#"
    End If
    
    If IsNull(Me.SelSta) = False Then
        StrFilter = StrFilter & " AND EtStnr = " & Me.SelSta
    End If
        
    If IsNull(Me.SelArt) = False Then
        StrFilter = StrFilter & " AND EtArnr = '" & Me.SelArt & "'"
    End If
            
    If IsNull(Me.SelBarc) = False Then
        StrFilter = StrFilter & " AND EtBarc = '" & Me.SelBarc & "'"
    End If
        
    If Me.SelSelect = True Then
        StrFilter = StrFilter & " AND EtAfdr = True"
    End If
    
    If Left(StrFilter, 4) = " AND" Then
        StrFilter = Mid(StrFilter, 5)
    End If
            
    Me.SFEtiketten.Form.Filter = StrFilter
    Me.SFEtiketten.Form.FilterOn = True

End Function

Private Sub Titl021_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    strSQL = "Select * from QAfdEtiket"
    Set Rst = CurrentDb.OpenRecordset(strSQL)

    If Rst.EOF = True Then
        Call Boodschappen("00023", Boodschap, Titel)
        MsgBox Boodschap, vbInformation + vbOKOnly, Titel
        Exit Sub
    End If
    
    strSQL = "Delete from TAfdEtiket"
    CurrentDb.Execute (strSQL)
    
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 1"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 2"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 3"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 4"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 5"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 6"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 7"
    CurrentDb.Execute (strSQL)
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 8"
    CurrentDb.Execute (strSQL)
    
    Me.Visible = False

    DoCmd.OpenReport "REtiketten(A4)", acViewPreview

End Sub

Private Sub Titl021_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Call MenuColor(Me.Name, "Titl021")

End Sub

Private Sub Titl050_Click()

    '*** Eerst alle selecties wissen
    
    Dim Y1Datm As String

    Y1Datm = Month(Me.SelDatm) & "/" & Day(Me.SelDatm) & "/" & Year(Me.SelDatm) & " " & Me.SelUur
    
    StrFilter = ""
            
    If IsNull(Me.SelDatm) = False Then
        StrFilter = StrFilter & "[EtDtTy] >= #" & Y1Datm & "#"
    End If
    
    If IsNull(Me.SelSta) = False Then
        StrFilter = StrFilter & " AND EtStnr = " & Me.SelSta
    End If
        
    If IsNull(Me.SelArt) = False Then
        StrFilter = StrFilter & " AND EtArnr = '" & Me.SelArt & "'"
    End If
            
    If IsNull(Me.SelBarc) = False Then
        StrFilter = StrFilter & " AND EtBarc = '" & Me.SelBarc & "'"
    End If
        
    If Me.SelSelect = True Then
        StrFilter = StrFilter & " AND EtAfdr = True"
    End If
    
    If Left(StrFilter, 4) = " AND" Then
        StrFilter = Mid(StrFilter, 5)
    End If

    If StrFilter <> "" Then
        strSQL = "Update QEtiket set EtAfdr = False where " & StrFilter
    Else
        strSQL = "Update QEtiket set EtAfdr = False"
    End If
    
    CurrentDb.Execute (strSQL)
    Me.SFEtiketten.Requery
    
    '*** Open Text bestand New_Scanning
    
    Dim txtBarc As String
    Dim FullBarc As String
    delime = ";"
    TmpDir = "C:\LSA\SCAN\"
    
    Open TmpDir & "NEW_SCANNING.txt" For Input As #50
    Do While Not EOF(50)
        Input #50, data
        If Left(data, 1) = "I" Then
            LineStart = "Y"
        End If
        If LineStart = True Then
            Left(data, 23) = txtBarc
    End If
    
    FullBarc = "Select * FROM txtBarc until ;"
            
    Me.SelBarc.Value = FullBarc
    Loop
    Close TmpDir & "\NEW_SCANNING.txt"
        
        ' Select between ";" & Search TETiket, EtBarc & Me.EtAfdr.Value = True
            ' If Me.EtBarc.Value = >1 Then
            ' Me.EtBarc.Value = True For Newest
        ' Else GoTo EndIf
        ' Loop
               
End Sub

Dit is de lay-out van het formulier waarin ik aan het werk ben.

Ik ben op dit moment aan het werken in Private Sub Titl050_Click()

Zoals je kan zien heb ik je aanpassingen al bijgewerkt en heb ik er ook nog enkele dingen achter gevoegd.

Ik kan het ook zip'en maar ik denk niet dat je daar veel aan zal hebben :-)

Mvg en bedankt
 
Zou ik hier bv geen split functie voor kunnen gebruiken??? Zodat hij arrays maakt met ; als tab ofzo?
 
Ik verbaas me een beetje (lees: behoorlijk) over de code die je zo her en der laat uitvoeren. Zo heb je in de procedure <Titl021_MouseDown> (wat zowiezo al een riskante trigger is) 8 toevoegqueries staan, die allemaal hetzelfde doen, met een kleine variatie in het criterium.
Code:
    strSQL = "INSERT INTO TAfdEtiket (EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval) " _
           & "SELECT EtStnr, ARNUMR, AROMSH, ARPRIJS, EtBarc, EtLevn, EtSvak, EtArlv, EtEhpr, EtEhmt, EtCnvt, EtAfdr, EtDatm, EtDval FROM QAfdEtiket Where EtEthv >= 1"
Voor het overzicht laat ik alleen de overige criteria zien, want de query is verder identiek:
Code:
Where EtEthv >= 2"
Where EtEthv >= 3"
Where EtEthv >= 4"
Where EtEthv >= 5"
Where EtEthv >= 6"
Where EtEthv >= 7"
Where EtEthv >= 8"
Dus als je de muisknop indrukt op dit object, wordt dezelfde query 8 keer uitgevoerd, waarbij EtEthv=6 dan 6 keer wordt toegevoegd ( filter >=1 t/m filter >=6) en EtEthv=3 slechts 3 keer. Je zult daar vast een betekenis mee hebben, maar als je >=1 één keer uitvoert, heb je ze allemaal al toegevoegd.
De Array oplossing staat in berichtje #2.
 
Ja van die overige code weet ik eigenlijk heel weinig van waarom dit zo gebeurd. Het programma bestond al en ik moest het enkel aanpassen... Daarmee dat ik er weinig van weet omdat het geen eigen ontwerp is.

Dus de array heb ik dan via bericht 2. Is er een bepaald iets dat ik nog moet besluiten om de selectie tussen 3e en 4e ; te nemen?
Bv strsql = "Select * from ... )
 
Als de array gevuld is op basis van de puntkomma, dan haal je met met tmpInput(0) de eerste waarde op, met tmpInput(1) de tweede en met tmpInput(2) de derde. En zo verder. Ik zou zeggen: gebruik het venster Direct om de inhoud van de varriabele te controleren als je in de Stap modus werkt.
 
Code:
Private Sub Titl050_Click()

    strSQL = "Update QEtiket set EtAfdr = False"
   
    CurrentDb.Execute (strSQL)
    Me.SFEtiketten.Requery
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
    '*** Open Text bestand New_Scanning en selecteer Barcode
    
    On Error Resume Next
    
    TmpDir = "C:\LSA\SCAN\NEW_SCANNING.txt"
    
    Open TmpDir For Input As #50
    
    Dim tmpInput As Variant
    Dim sInput As String
    Dim I As Long

    Do While Not EOF(50)
        Input #50, sInput
        tmpInput = Split(sInput, ";")
            
            If tmpInput(0) = "I" Then
                Y0Barc = tmpInput(3)
                    
                    strSQL = "Update QEtiket set EtAfdr = True where barcode = '" & Y0Barc & "'"
                    CurrentDb.Execute (strSQL)
                    
            End If
    
    Loop
    
    '*** tmpInput(3) is selectie tssn 3e en 4e puntkomma
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    Close TmpDir
               
    Me.SFEtiketten.Requery
               
End Sub

De oplossing voor alles ... :-)

Enkel komt er na als eerste nog een ja-nee msgbox tussen die zegt dat bij het verder gaan alle selecties worden gewist... En enkel als er "ja" gedrukt wordt mag het uitgevoerd worden...

Tnx 4 the help :-)
 
Ik zie geen delete query. Wel een hoop lege regels in je code die de leesbaarheid nou niet bepaald verhogen ;)
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan