Startseite / Tipps / VB 5/6-Tipp 0021: Status einer DFÜ-Verbindung abfragen

VB 5/6-Tipp 0021: Status einer DFÜ-Verbindung abfragen

 von ActiveVB

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Textfeld "Text1"
' Steuerelement: Beschriftungsfeld "Label1"


' Korrekturen by GFi http://www.ispf.de 14.12.2002

Option Explicit

Private Declare Function RasEnumConnections Lib "RasApi32.dll" _
        Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As _
        Long, lpcConnections As Long) As Long
        
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" _
        Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, _
        lpStatus As Any) As Long

Const RAS_MaxEntryName = 256
Const RAS_MaxDeviceType = 16
Const RAS_MaxDeviceName = 128 'Änderung am 14.12.2002: nicht 32!

'Änderung am 14.12.2002: Für RasEnumConnections Rückgabewert
Private Const ERROR_BUFFER_TOO_SMALL = 603

Private Type RASType
  dwSize As Long
  hRasCon As Long
  szEntryName(RAS_MaxEntryName) As Byte
  szDeviceType(RAS_MaxDeviceType) As Byte
  szDeviceName(RAS_MaxDeviceName) As Byte
End Type

' Die magische Zahl 412...
' dwSize        Long    4 Byte
' hRasCon       Long    4 Byte
' szEntryName   Byte  257 Byte (257, weil 0 mitzählt!)
' szDeviceType  Byte   17 Byte
' szDeviceName  Byte  129 Byte
' ============================
'                     411 Byte
' 411 ist ungerade, daher auf nächte Long Grenze aufrunden
'
' 411 + ((4 - 411 Mod 4)) Mod 4 = 412

Private Type RASStatusType
  dwSize As Long
  RasConnState As Long
  dwError As Long
  szDeviceType(RAS_MaxDeviceType) As Byte
  szDeviceName(RAS_MaxDeviceName) As Byte
End Type

' + GFi Verbindungs Status
Private Enum RasConnState
  RASCS_PAUSED = &H1000&
  RASCS_DONE = &H2000&
  RASCS_OpenPort = 0&
  RASCS_PortOpened = 1&
  RASCS_ConnectDevice = 2&
  RASCS_DeviceConnected = 3&
  RASCS_AllDevicesConnected = 4&
  RASCS_Authenticate = 5&
  RASCS_AuthNotify = 6&
  RASCS_AuthRetry = 7&
  RASCS_AuthCallback = 8&
  RASCS_AuthChangePassword = 9&
  RASCS_AuthProject = 10&
  RASCS_AuthLinkSpeed = 11&
  RASCS_AuthAck = 12&
  RASCS_ReAuthenticate = 13&
  RASCS_Authenticated = 14&
  RASCS_PrepareForCallback = 15&
  RASCS_WaitForModemReset = 16&
  RASCS_WaitForCallback = 17&
  RASCS_Projected = 18&
  
  RASCS_StartAuthentication = 19& ' nur Win 95
  RASCS_CallbackComplete = 20&   ' nurWin 95
  RASCS_LogonNetwork = 21&    ' nur Win 95
 
  RASCS_SubEntryConnected = 22&
  RASCS_SubEntryDisconnected = 23&
  
  RASCS_Interactive = RASCS_PAUSED
  RASCS_RetryAuthentication = RASCS_PAUSED + 1&
  RASCS_CallbackSetByCaller = RASCS_PAUSED + 2&
  RASCS_PasswordExpired = RASCS_PAUSED + 3&
  
  RASCS_Connected = RASCS_DONE
  RASCS_Disconnected = RASCS_DONE + 1&
End Enum

Private Sub Form_Load()
  Timer1.Interval = 200
  Timer1.Enabled = True
End Sub

Private Sub Form_Resize()

Text1.Width = Me.ScaleWidth
If Me.ScaleHeight > Label1.Height Then
  Text1.Height = Me.ScaleHeight - Label1.Height
End If

End Sub

Private Sub Timer1_Timer()
  DFÜStatus
End Sub

Private Function StripNull(ByRef strNullTerminatedstring) As String

StripNull = Left(strNullTerminatedstring, InStr(1, strNullTerminatedstring, Chr(0)) - 1)

End Function

Private Function DFÜStatus() As Boolean
  ' Änderung am 14.12.2002:  Dim RAS(255) As RASType
  ' Warum gleich 255???
  '
  ' Die Funktion RasEnumConnections gibt einen Fehler zurück,
  ' wenn der Speicher nicht reicht. Daher...
  Dim RAS() As RASType
  
  ' entspricht in C++ Pointer anlegen
    
  Dim RASStatus As RASStatusType
  Dim lg&, lpcon&, Result&
  
  ' Änderung am 14.12.2002:
  Dim i As Long

  ReDim RAS(1)
  
  ' Änderung am 14.12.2002: RAS(0).dwSize = 412 Falsch!
  ' Der Fehler ist von Microsoft übernommen und weltweit verbreitet worden.
  
  RAS(0).dwSize = LenB(RAS(0)) + (4 - (LenB(RAS(0)) Mod 4)) Mod 4
  
  ' Änderung am 14.12.2002:  lg = 256 * RAS(0).dwSize
  ' lg ist ein Rückgabewert von der Funktion und wird nicht gesetzt!
  
  Result = RasEnumConnections(RAS(0), lg, lpcon)
  
  ' Änderung am 14.12.2002:
  If (Result = ERROR_BUFFER_TOO_SMALL) And (lpcon > 0) Then

    ' Fehler, zuwenig Speicher.
    ' In diesem Fall einfach das Array vergrößern.
    
    ReDim Preserve RAS(UBound(RAS()) + 1)
    Result = RasEnumConnections(RAS(0), lg, lpcon)
    
    ' Kommentar am 14.12.2002: man könnte dies auch in eine While Wend
    ' Schleife setzen. Ich bin mir allerdings nicht sicher,
    ' ob das Funktioniert und ob es je mehr als eine Verbindung
    ' geben kann. Die Funktion ist jedenfalls dafür ausgelegt.
    
  End If
  
  ' Änderung am 14.12.2002:  Funktionsrückkehr ohne Fehler!
  If Result = 0 Then
    If lpcon = 0 Then
        Label1.Caption = "Offline" '###
        Text1 = ""
        DFÜStatus = False
    Else
        
      ' 'Änderung am 14.12.2002: RASStatus.dwSize = 160 ' Falsch!
      ' Der Fehler ist von Microsoft übernommen und weltweit verbreitet worden.
      
      RASStatus.dwSize = LenB(RASStatus) + (4 - (LenB(RASStatus) Mod 4)) Mod 4
                
      ' Änderung am 14.12.2002: Alle Verbindungen durchgehen...
      For i = 0 To lpcon - 1
             
        ' Änderung am 14.12.2002: RAS(0).hRasCon enhält das Handle der 1. DFü-Verbindung
        Result = RasGetConnectStatus(RAS(i).hRasCon, RASStatus)
        
        ' Änderung am 14.12.2002:  GFi RASStatus.RasConnState vergleich mit Enum RasConnState
        If RASStatus.RasConnState = RasConnState.RASCS_Connected Then
           Label1.Caption = "Online"  '###
           ' Änderung am 14.12.2002: Weitere Informationen ausgeben
           Text1 = StripNull(StrConv(RAS(i).szDeviceType, vbUnicode)) _
                   & " Verbindung: '" & _
                   StripNull(StrConv(RAS(i).szEntryName, vbUnicode)) _
                   & "' über " & _
                   StripNull(StrConv(RAS(i).szDeviceName, vbUnicode)) & vbCrLf
           DFÜStatus = True
        Else
           Label1.Caption = "DFÜ-Einwahl oder -Trennen" '###
           DFÜStatus = False
        End If
      
      Next i
    
    End If
  End If
End Function

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 15 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.