cyberkey
Mar 31, 2010, updated at 11:24:20 (UTC)
view4854
view7
0
Goto Top

Wie binde ich ein Recordset ein?

GermansolvedQuestionVB for ApplicationsDevelopment

Ich habe leider nur begrenztes VBA/VBS wissen..

Hallo,

auf der Seite: http://www.office-loesung.de/ftopic59453_0_0_asc.php

habe ich ein paar Dinge dazu gelesen. Aber verstehe nicht wie ich das in meine Projekt mit einbinden soll.

Ich habe einen Button in jeder Zeile eines Endlosformulars, dieser ist mit einem Code verbunden.

Bisher musste ich für jede Zeile diesen Button klicken damit einzeln für jede zeile der Code ausgeführt wird.
Es handelt sich um eine IP Liste... Jede IP hat einen Button "Ping" mit je Variablen die auf das jeweilige Feld IP verweisen.


Wie kann ich es anstellen das alle, ich sag mal "Buttons" hintereinander gedrückt werden... bzw. der Button Code je Zeile 1mal ausgeführt wird? (Hintereinander)

Habe gelesen das es mit dem im Link beschriebenen verfahren möglich sien soll.. habe nur leider kein verständnis dafür :/

Über Anregungen/Hilfe wär ich sehr Dankbar.
gruß Cyberkey


Im Anhang der Code und Bild:

Private Sub IPall_Click()
Dim strTarget, strPingResults, objShell, objExec
On Error Resume Next
strTarget = Me.IPall 'IP address or hostname  
Set objShell = CreateObject("WScript.Shell")  
Set objExec = objShell.Exec("ping -n 1 -w 5 " & strTarget)  
strPingResults = LCase(objExec.StdOut.ReadAll)
If InStr(strPingResults, "Antwort von") > 0 Then  
    'MsgBox ("Geht")  
    'MsgBox "# " & strPingResults & " #", vbCritical, "Ergebnis"  
    'MsgBox "Ergebnis: " & strPingResults  

    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE Ip_adressen SET Status=1 WHERE IPall='" & strTarget & "'"  
    Me.Refresh
Else
    'MsgBox ("Geht nicht")  
    DoCmd.SetWarnings False
    DoCmd.RunSQL "UPDATE Ip_adressen SET Status=0 WHERE IPall='" & strTarget & "'"  
    Me.Refresh
End If
DoCmd.SetWarnings True
Me!Wake.SetFocus
End Sub

a1ef32c5170f85a8b3c96d93455c8f5e
comment-contentCommentShareShare
Share on Facebook Share on Twitter Share on Reddit Share on Linkedin

Content-Key: 139603

Url: https://administrator.de/contentid/139603

Printed on: April 25, 2024 at 11:04 o'clock

7 Comments
Latest comment
Goto Top
Mitglied: 76109
76109 Mar 31, 2010 at 13:31:19 (UTC)
Goto Top
Hallo Cyberkey!

Sinngemäß das Ganze in etwa so:
Option Compare Text

Private Sub Button_Click()
    Dim RS As Object
    
    Set RS = Application.CurrentDb.OpenRecordset("Select * From [Ip_adressen]")  
    
    With RS
        Do Until .EOF
            If Not IsNull(.Fields("IPall")) Then  
                .Edit
                .Fields("Status") = GetPingStatus(.Fields("IPall").Value)  
                .Update
            End If
           .MoveNext
        Loop
    End With
    
    Set RS = Nothing

   'Me.Refresh   
End Sub

Private Function GetPingStatus(ByRef IP) As Long
    Dim objShell As Object, objExec As Object, Result As String
    
    On Error Resume Next
    
    Set objShell = CreateObject("WScript.Shell")  
    Set objExec = objShell.Exec("ping -n 1 -w 5 " & IP)  
    
    Do Until objExec.Status:  Loop  'Warten  
   
    Result = objExec.StdOut.ReadAll
    
    If InStr(Result, "Antwort von") > 0 Then GetPingStatus = 1  
End Function

Gruß Dieter

[edit] Codezeile 32 hinzugefügt, warten bis Ping ausgeführt wurde [/edit]
Member: Cyberkey
Cyberkey Apr 01, 2010 at 07:12:38 (UTC)
Goto Top
Wunderbar !! ^^
Danke Dieter !
läuft 1a ;)
Mitglied: 76109
76109 Apr 01, 2010 at 07:16:02 (UTC)
Goto Top
Hallo Cyberkey!

Zitat von @Cyberkey:
Wunderbar !! ^^
Danke Dieter !
läuft 1a ;)
Prima! Hast Du die Änderung in Codezeile 32 auch schon mit übernommen?

Gruß Dieter
Mitglied: 76109
76109 Apr 02, 2010 at 07:48:51 (UTC)
Goto Top
Hallo Cyberkey!

Im Gegensatz zu VBA-Shell gibt WScript-Shell ja einen Fehlercode zurück, wodurch sich das Ganze etwas optimieren ließe und die DOS-Fenster auch wegfallen.
Private Const PingCmd = "ping -n 1 -w 5 "  

Private Sub Button_Click()
    Dim RS As Object, WshShell As Object
    
    Set WshShell = CreateObject("WScript.Shell")  

    Set RS = Application.CurrentDb.OpenRecordset("Select * From [Ip_adressen]")  
    
    With RS
        Do Until .EOF
            If Not IsNull(.Fields("IPall")) Then  
                .Edit
                .Fields("Status") = WshShell.Run(PingCmd & .Fields("IPall").Value, 0, True) Xor 1  
                .Update
            End If
           .MoveNext
        Loop
    End With
    
    Set RS = Nothing:  Set WshShell = Nothing
End Sub
Wobei sich der Rückgabewert 0=True und 1=False durch ein XOR in 1=True und 0=False umkehren läßt

Gruß Dieter
Member: Cyberkey
Cyberkey Apr 02, 2010 at 15:06:00 (UTC)
Goto Top
Hallo Dieter,
das stimmt!
Die Dos Fenster waren wirklich eine sehr unschöne Lösung!

Der Code sieht etwas kompliziert aus @ VBS CODE .. hab ich so nochnie gemacht.

Aber es ist eine gute Lösung!

Danke für die fleißige extra Arbeit^^
gruß Cyberkey

Werde das so bald wie möglich ins Projekt einfügen.
Member: Cyberkey
Cyberkey Apr 06, 2010 at 09:53:24 (UTC)
Goto Top
Hallo Dieter,
ich habe noch ein Problem erkannt.
Es wird nicht nach jeder Zeile aktualisiert sondern erst nach dem "Job". vll. bischen buggy.
Desweiteren sieht man nur unten "Berechnung läuft" das etwas passiert.. Ungedultige Nutzer könnten so X mal auf den Button klicken.
Werde den beim Job wohl Deaktivieren müssen.


Gruß Cyberkey

EDIT: das mit dem Button ist gelöst.. blos das ".Update" funktioniert nicht so richtig
Mitglied: 76109
76109 Apr 06, 2010 at 13:19:22 (UTC)
Goto Top
Hallo Cyberkey!

Zitat von @Cyberkey:
EDIT: das mit dem Button ist gelöst.. blos das ".Update" funktioniert nicht so richtig
Das Update sollte schon funktionieren. Ansonsten fällt mir leider nichts dazu einface-wink
Eventuell das Me.Refesh irgendwie mit einfügen?

Gruß Dieter
GermansolvedQuestionVB for ApplicationsDevelopment
Hotly discussed
gleixnerdCheck of ZFW Firewallgleixnerd - 5 CommentsjstrickerWireguard VPN on UDM Pro behind Fritzbox - Handshake did not completejstricker - 3 Comments