Buchempfehlung
MySQL kurz & gut
MySQL kurz & gut
Das preiswerte Taschen- buch stellt MySQL-rele- vante Inhalte systematisch und knapp dar, sodass es sich optimal zum Nach- schlagen beim Pro- grammieren eignet. [Mehr Infos...]
FreeBASIC-Chat
Es sind Benutzer im FreeBASIC-Chat online.
(Stand:  )
FreeBASIC bei Twitter
Twitter FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!

Code-Beispiel

Code-Beispiele » Internet und Netzwerke

Erreichbarkeit von Servern(LAN/WAN) prüfen(WMI)

Lizenz:Erster Autor:Letzte Bearbeitung:
k. A.Redakteurytwinky 19.04.2012

Es ist keine große Aufgabe, zu prüfen, ob ein anderer Rechner erreichbar ist,
denn dafür gibt es den Ping-Befehl(Shell, Konsolenausgabe einlesen und auswerten..)
Wer es kann, wird natürlich sagen: Das geht doch alles mit TSNE!
Das mag sein, ich habe es noch nicht getestet..
Ich wollte es(egtl. immer schon) mit WMI machen, aber die einzige WMI-Funktion die dafür zuständig schien(Win32_PingStatus) 'wollte auf meinem Rechner nicht funktionieren'..
Doch als ich neulich mal wieder etwas ganz anderes gesucht habe, fand ich die Lösung in einer genauen Beschreibung der Funktion: Sie liefert nämlich nur dann Ergebnisse, wenn auch ein Ziel angegeben wird und bildet somit quasi einen Sonderfall unter den WMI-Funktionen..
..Aber wenn man das weiß, ist es kein Problem die Funktion zu benutzen:

#include once "windows.bi"               'in
#define UNICODE                          'this
#include once "disphelper/disphelper.bi" 'order
#include "vbcompat.bi"
#define green 2
#define red 4
#define light 8

Const strComputer="." 'oder "localhost" oder Environ("ComputerName")
Const impersonate="winmgmts:{impersonationLevel=impersonate}!\\" &strComputer &"\root\cimv2"
Dim As Integer Colour(2)={light+red, light+green}, d=Color
Var strServer="localhost", SelectClass=""
'Address
'BufferSize
'NoFragmentation
'PrimaryAddressResolutionStatus
'ProtocolAddress
'ProtocolAddressResolved
'RecordRoute
'ReplyInconsistency
'ReplySize
'ResolveAddressNames
'ResponseTime
'ResponseTimeToLive
'RouteRecord <Array>
'RouteRecordResolved <Array>
'SourceRoute
'SourceRouteType
'StatusCode, returns an empty string if IP|ServerName cannot be resolved via hosts-file or IP is invalid
'Timeout
'TimeStampRecord <Array>
'TimeStampRecordAddress <Array>
'TimeStampRecordAddressResolved <Array>
'TimestampRoute
'TimeToLive
'TypeofService
Dim As HRESULT hres
Dim As ZString Ptr devAddress, devBufferSize, devNoFragmentation, devPrimaryAddressResolutionStatus
Dim As ZString Ptr devProtocolAddress, devProtocolAddressResolved, devRecordRoute, devReplyInconsistency
Dim As ZString Ptr devReplySize, devResolveAddressNames, devResponseTime, devResponseTimeToLive
Dim As ZString Ptr devRouteRecord, devRouteRecordResolved, devSourceRoute, devSourceRouteType
Dim As ZString Ptr devStatusCode, devTimeout, devTimeStampRecord, devTimeStampRecordAddressResolved
Dim As ZString Ptr devTimestampRoute, devTimeToLive, devTypeofService
DISPATCH_OBJ(wmiSvc)
DISPATCH_OBJ(colPing)
dhInitialize(True)
Input "Check pingstatus of server:", strServer 'defaults internally to Environ("Computername") not "localhost"..
SelectClass=!"Select * From Win32_PingStatus Where Address=\34" &strServer &!"\34"
Print "Pinging " &strServer &".."
Print "w8 plz..";
'configure, whether errors should be displayed or not:
'dhToggleExceptions(TRUE) 'if desired remove the first ' ;-))
hres=dhGetObject(impersonate, NULL, @wmiSvc)
hres=dhGetValue("%o", @colPing, wmiSvc, ".ExecQuery(%s)", SelectClass)
FOR_EACH0(objPing, colPing, NULL)
  hres=dhGetValue("%s", @devAddress, objPing, ".Address")
    hres=dhGetValue("%s", @devBufferSize, objPing, ".BufferSize")
    hres=dhGetValue("%s", @devNoFragmentation, objPing, ".NoFragmentation")
    hres=dhGetValue("%s", @devPrimaryAddressResolutionStatus, objPing, ".PrimaryAddressResolutionStatus")
    hres=dhGetValue("%s", @devProtocolAddress, objPing, ".ProtocolAddress")
    hres=dhGetValue("%s", @devProtocolAddressResolved, objPing, ".ProtocolAddressResolved")
    hres=dhGetValue("%s", @devRecordRoute, objPing, ".RecordRoute")
    hres=dhGetValue("%s", @devReplyInconsistency, objPing, ".ReplyInconsistency")
    hres=dhGetValue("%s", @devReplySize, objPing, ".ReplySize")
    hres=dhGetValue("%s", @devResolveAddressNames, objPing, ".ResolveAddressNames")
    hres=dhGetValue("%s", @devResponseTime, objPing, ".ResponseTime")
    hres=dhGetValue("%s", @devResponseTimeToLive, objPing, ".ResponseTimeToLive")
'   hres=dhGetValue("%s", @devRouteRecord, objPing, ".RouteRecord")
'   hres=dhGetValue("%s", @devRouteRecordResolved, objPing, ".RouteRecordResolved")
    hres=dhGetValue("%s", @devSourceRoute, objPing, ".SourceRoute")
    hres=dhGetValue("%s", @devSourceRouteType, objPing, ".SourceRouteType")
    hres=dhGetValue("%s", @devStatusCode, objPing, ".StatusCode")
    hres=dhGetValue("%s", @devTimeout, objPing, ".Timeout")
'   hres=dhGetValue("%s", @devTimeStampRecord, objPing, ".TimeStampRecord")
'   hres=dhGetValue("%s", @devTimeStampRecordAddress, objPing, ".TimeStampRecordAddress")
'   hres=dhGetValue("%s", @devTimeStampRecordAddressResolved, objPing, ".TimeStampRecordAddressResolved")
    hres=dhGetValue("%s", @devTimestampRoute, objPing, ".TimestampRoute")
    hres=dhGetValue("%s", @devTimeToLive, objPing, ".TimeToLive")
    hres=dhGetValue("%s", @devTypeofService, objPing, ".TypeofService")
  Print !"\rAddress:" &*devAddress
  Print "BufferSize:" &*devBufferSize
  Print "NoFragmentation:" &*devNoFragmentation
  Print "PrimaryAddressResolutionStatus:" &*devPrimaryAddressResolutionStatus
  Print "ProtocolAddress:" &*devProtocolAddress
  Print "ProtocolAddressResolved:" &*devProtocolAddressResolved
  Print "RecordRoute:" &*devRecordRoute
  Print "ReplyInconsistency:" &*devReplyInconsistency
  Print "ReplySize:" &*devReplySize
  Print "ResolveAddressNames:" &*devResolveAddressNames
  Print "ResponseTime:" &*devResponseTime
  Print "ResponseTimeToLive:" &*devResponseTimeToLive
'  Print "RouteRecord:" &*devRouteRecord 'cannot yet recognize arrays :-((
'  Print "RouteRecordResolved:" &*devRouteRecordResolved 'cannot yet recognize arrays :-((
  Print "SourceRoute:" &*devSourceRoute
  Print "SourceRouteType:" &*devSourceRouteType
  Color Colour(Abs(*devStatusCode="0"))
  Print "StatusCode:" &*devStatusCode
  Color d
  Print "Timeout:" &*devTimeout
'  Print "devTimeStampRecord:" &*devdevTimeStampRecord 'cannot yet recognize arrays :-((
'  Print "TimeStampRecordAddress:" &*devTimeStampRecordAddress 'cannot yet recognize arrays :-((
'  Print "TimeStampRecordAddressResolved:" &*devTimeStampRecordAddressResolved 'cannot yet recognize arrays :-((
  Print "TimestampRoute:" &*devTimestampRoute
  Print "TimeToLive:" &*devTimeToLive
  Print "TypeofService:" &*devTypeofService
NEXT_(objPing)
SAFE_RELEASE(wmiSvc)
SAFE_RELEASE(colPing)
dhUninitialize(True)
Print "Eniki..";
GetKey

Dieser Code ist nur zum Ausprobieren und Erkennen, ob mehr damit möglich ist, als ich benötige..
Fakt ist, Win32_StatusCode liefert in .StatusCode "0" zurück, wenn(und nur dann) das Ziel erreichbar ist..
.Statuscode liefert auch Fehlermeldungen oder ist gar leer(z.B. wenn das zu prüfende Ziel nicht via hosts. aufgelöst werden kann).
Doch nun zum Programm: Es liefert einen Errorlevel 1, wenn das Ziel erreichbar ist und 0, wenn nicht..

#include once "windows.bi"               'in
#define UNICODE                          'this
#include once "disphelper/disphelper.bi" 'order
#include "vbcompat.bi"
Const strComputer="." 'oder "localhost" oder Environ("ComputerName")
Const impersonate="winmgmts:{impersonationLevel=impersonate}!\\" &strComputer &"\root\cimv2"
Const red=4, green=2, light=8
Dim As Integer Colour(2)={light+red, green}, d=Color, Status=0
Dim As String strServer="localhost", SelectClass=""
Dim As HRESULT hres
Dim As ZString Ptr devStatusCode, devProtocolAddress
DISPATCH_OBJ(wmiSvc)
DISPATCH_OBJ(colPing)
dhInitialize(True)
    Input "Check pingstatus of server:", strServer 'defaults internally to Environ("Computername") not localhost..
    SelectClass=!"Select StatusCode,ProtocolAddress  From Win32_PingStatus Where Address=\34" &strServer &!"\34"
    Print "Pinging " &strServer &".."
    Print "w8 plz..";
    'configure, whether errors should be displayed or not:
    'dhToggleExceptions(TRUE) 'if desired remove the first ' ;-))
    hres=dhGetObject(impersonate, NULL, @wmiSvc)
    hres=dhGetValue("%o", @colPing, wmiSvc, ".ExecQuery(%s)", SelectClass)
    FOR_EACH0(objPing, colPing, NULL)
        hres=dhGetValue("%s", @devStatusCode, objPing, ".StatusCode")
        hres=dhGetValue("%s", @devProtocolAddress, objPing, ".ProtocolAddress")
        Status=Abs(*devStatusCode="0")
      Color Colour(Status)
          Print !"\rStatusCode:" &*devStatusCode
          If *devProtocolAddress<>"" Then Print "ProtocolAddress:" &*devProtocolAddress
      Color d
    NEXT_(objPing)
SAFE_RELEASE(wmiSvc)
SAFE_RELEASE(colPing)
dhUninitialize(True)
Print "Eniki..";
GetKey
End Status

Zusätzlich ist die Ausgabe noch farbig: grün=erreichbar, rot=unerreichbar ;-))
Fröhliches Checken
Gruß
ytwinky


Zusätzliche Informationen und Funktionen
  • Das Code-Beispiel wurde am 19.04.2012 von Redakteurytwinky angelegt.
  • Die aktuellste Version wurde am 19.04.2012 von Redakteurytwinky gespeichert.
  Bearbeiten Bearbeiten  

  Versionen Versionen