VpnDial/src/RasConnection.bas

Attribute VB_Name = "RasConnection"
' http://66.249.93.104/search?q=cache:3OXmidHYkbIJ:vbmysql.com/forums/index.php%3Ft%3Dmsg%26goto%3D9474%26rid%3D0+visual+basic+RasGetProjectionInfo&hl=de&client=firefox

Option Explicit

'API constants
Private Const RAS_MaxEntryName = 256
Private Const RAS_MaxDeviceType = 16
Private Const RAS_MaxDeviceName = 128
Private Const RAS_MaxIpAddress = 15
Private Const RASP_PppIp = &H8021&

'API type definitions
Private Type RASCONN
   dwSize As Long
   hRasConn As Long
   szEntryName(RAS_MaxEntryName) As Byte
   szDeviceType(RAS_MaxDeviceType) As Byte
   szDeviceName(RAS_MaxDeviceName) As Byte
End Type

Private Type RASPPPIP
   dwSize As Long
   dwError As Long
   szIpAddress(RAS_MaxIpAddress) As Byte
   szServerAddress(RAS_MaxIpAddress) As Byte
End Type


'API function declarations
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, _
                                                                                           lpcb As Long, _
                                                                                           lpcConnections As Long) As Long
                                                                                           
Private Declare Function RasGetProjectionInfo Lib "rasapi32.dll" Alias "RasGetProjectionInfoA" (ByVal hRasConn As Long, _
                                                                                               ByVal rasprojection As Long, _
                                                                                               lpprojection As Any, _
                                                                                               lpcb As Long) As Long

Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" ( _
    ByVal hRasConn As Long) As Long
    

Private Function sTrimNulls(ByVal sStr As String) As String
   If InStr(sStr, Chr(0)) > 0 Then
       sTrimNulls = Left(sStr, InStr(sStr, Chr(0)) - 1)
   Else
       sTrimNulls = sStr
   End If
End Function


Private Function lRetrieveConnectionHandler() As Long
   Dim lRetCode As Long
   Dim lSize As Long
   Dim tConnections(255) As RASCONN
   Dim lConnections As Long
   
   'init
   tConnections(0).dwSize = 412
   lSize = (UBound(tConnections) + 1) * tConnections(0).dwSize
   lRetrieveConnectionHandler = 0
   
   'retreive connections
   lRetCode = RasEnumConnections(tConnections(0), lSize, lConnections)
   
   'check return code
   If lRetCode = 0 Then
       'call successfull -> any connections?
       If lConnections > 0 Then
           'at least one connection -> retrieve handler of first connection
           lRetrieveConnectionHandler = tConnections(0).hRasConn
       End If
   End If
End Function


Private Function getIpInfo(conName As String) As RASPPPIP
   Dim lConnection As Long
   Dim lProjection As Long
   Dim tIpInfo As RASPPPIP
   Dim lSize As Long
   Dim lRetCode As Long
   
   'init
   lProjection = RASP_PppIp
   tIpInfo.dwSize = 40
   lSize = tIpInfo.dwSize
   
   'retrieve connection
   lConnection = RasRetrieveConnectionHandler(conName)
   If lConnection = 0 Then
       Exit Function
   End If

   'retrieve projection information
   lRetCode = RasGetProjectionInfo(lConnection, lProjection, tIpInfo, lSize)
   
   'check return code
   'If lRetCode = 0 Then
        getIpInfo = tIpInfo
   'End If
   
End Function


Public Function DetermineServerIP(conName As String) As String
   
   Dim tIpInfo As RASPPPIP
   
   DetermineServerIP = vbNullString
   
   tIpInfo = getIpInfo(conName)
   
   'MsgBox "abc"
   
'   If Not tIpInfo Is Nothing Then
       'call successfull -> get IP address
       DetermineServerIP = sTrimNulls(StrConv(tIpInfo.szServerAddress, vbUnicode))
'   End If
   
End Function

Public Function DetermineClientIP(conName As String) As String
   
   Dim tIpInfo As RASPPPIP
   
   DetermineClientIP = vbNullString
   
   tIpInfo = getIpInfo(conName)
   
   'check return code
   'If lRetCode = 0 Then
       'call successfull -> get IP address
       DetermineClientIP = sTrimNulls(StrConv(tIpInfo.szIpAddress, vbUnicode))
   'End If
   
End Function


Public Function RasDisconnect(conName As String) As Boolean

    ' Does this work? Better use this:?
    ' http://www.activevb.de/tipps/vb6tipps/tipp0009.html
    ' rasdial "dachboden" /d

    'Deklaration: Lokale Prozedur-Variablen
    Dim i As Long
    Dim lngBuffer As Long
    Dim lngEntries As Long
    Dim lngResult As Long

    Dim strRASConName As String
    Dim lngRASCon As Long

    ReDim udtRASCon(255) As RASCONN

    'DFÜ-Verbindungen ermitteln
    udtRASCon(0).dwSize = 412
    lngBuffer = 256 * udtRASCon(0).dwSize
    lngResult = RasEnumConnections(udtRASCon(0), lngBuffer, lngEntries)

    For i = 0 To lngEntries - 1
        strRASConName = StrConv(udtRASCon(i).szEntryName(), vbUnicode)
        strRASConName = Left$(strRASConName, InStr(strRASConName, _
        vbNullChar) - 1)

        'DFÜ-Verbindung beenden
        If strRASConName = conName Then
            lngRASCon = udtRASCon(i).hRasConn
            'MsgBox lngRASCon
            lngResult = RasHangUp(lngRASCon)
            'InternetHangUp lngRASCon, 0
            'MsgBox lngResult
            
            If lngResult = 0 Then
                RasDisconnect = True
            End If
            
        End If
    Next i
End Function

Private Function RasRetrieveConnectionHandler(conName As String) As Long
   Dim lRetCode As Long
   Dim lSize As Long
   Dim tConnections(255) As RASCONN
   Dim lConnections As Long
   
   Dim i As Long
   Dim cConnection As RASCONN
   Dim strRASConName As String
   
   'init
   tConnections(0).dwSize = 412
   lSize = (UBound(tConnections) + 1) * tConnections(0).dwSize
   RasRetrieveConnectionHandler = 0
   
   'retreive connections
   lRetCode = RasEnumConnections(tConnections(0), lSize, lConnections)
   
   'check return code
   If lRetCode = 0 Then
       'call successfull -> any connections?
       If lConnections > 0 Then
            For i = 0 To lConnections - 1
               'lRetrieveConnectionHandler = tConnections(0).hRasConn
               cConnection = tConnections(i)
                strRASConName = StrConv(cConnection.szEntryName(), vbUnicode)
                strRASConName = Left$(strRASConName, InStr(strRASConName, vbNullChar) - 1)
                'MsgBox strRASConName
               If strRASConName = conName Then
                    'MsgBox cConnection.hRasConn
                    RasRetrieveConnectionHandler = cConnection.hRasConn
               End If
            Next i
       End If
   End If
End Function

Public Function RasIsOnline(conName As String) As Boolean
    Dim handle As Long
    handle = RasRetrieveConnectionHandler(conName)
    'MsgBox handle
    If handle <> 0 Then RasIsOnline = True
End Function
1	joko	1.1	Attribute VB_Name = "RasConnection"
2			' http://66.249.93.104/search?q=cache:3OXmidHYkbIJ:vbmysql.com/forums/index.php%3Ft%3Dmsg%26goto%3D9474%26rid%3D0+visual+basic+RasGetProjectionInfo&hl=de&client=firefox
3
4			Option Explicit
5
6			'API constants
7			Private Const RAS_MaxEntryName = 256
8			Private Const RAS_MaxDeviceType = 16
9			Private Const RAS_MaxDeviceName = 128
10			Private Const RAS_MaxIpAddress = 15
11			Private Const RASP_PppIp = &H8021&
12
13			'API type definitions
14			Private Type RASCONN
15			dwSize As Long
16			hRasConn As Long
17			szEntryName(RAS_MaxEntryName) As Byte
18			szDeviceType(RAS_MaxDeviceType) As Byte
19			szDeviceName(RAS_MaxDeviceName) As Byte
20			End Type
21
22			Private Type RASPPPIP
23			dwSize As Long
24			dwError As Long
25			szIpAddress(RAS_MaxIpAddress) As Byte
26			szServerAddress(RAS_MaxIpAddress) As Byte
27			End Type
28
29
30			'API function declarations
31	joko	1.2	Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, _
32	joko	1.1	lpcb As Long, _
33			lpcConnections As Long) As Long
34
35	joko	1.2	Private Declare Function RasGetProjectionInfo Lib "rasapi32.dll" Alias "RasGetProjectionInfoA" (ByVal hRasConn As Long, _
36	joko	1.1	ByVal rasprojection As Long, _
37			lpprojection As Any, _
38			lpcb As Long) As Long
39
40	joko	1.2	Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" ( _
41	joko	1.1	ByVal hRasConn As Long) As Long
42
43
44			Private Function sTrimNulls(ByVal sStr As String) As String
45			If InStr(sStr, Chr(0)) > 0 Then
46			sTrimNulls = Left(sStr, InStr(sStr, Chr(0)) - 1)
47			Else
48			sTrimNulls = sStr
49			End If
50			End Function
51
52
53			Private Function lRetrieveConnectionHandler() As Long
54			Dim lRetCode As Long
55			Dim lSize As Long
56			Dim tConnections(255) As RASCONN
57			Dim lConnections As Long
58
59			'init
60			tConnections(0).dwSize = 412
61			lSize = (UBound(tConnections) + 1) * tConnections(0).dwSize
62			lRetrieveConnectionHandler = 0
63
64			'retreive connections
65			lRetCode = RasEnumConnections(tConnections(0), lSize, lConnections)
66
67			'check return code
68			If lRetCode = 0 Then
69			'call successfull -> any connections?
70			If lConnections > 0 Then
71			'at least one connection -> retrieve handler of first connection
72			lRetrieveConnectionHandler = tConnections(0).hRasConn
73			End If
74			End If
75			End Function
76
77
78	joko	1.3	Private Function getIpInfo(conName As String) As RASPPPIP
79	joko	1.1	Dim lConnection As Long
80			Dim lProjection As Long
81			Dim tIpInfo As RASPPPIP
82			Dim lSize As Long
83			Dim lRetCode As Long
84
85			'init
86			lProjection = RASP_PppIp
87			tIpInfo.dwSize = 40
88			lSize = tIpInfo.dwSize
89
90			'retrieve connection
91	joko	1.3	lConnection = RasRetrieveConnectionHandler(conName)
92	joko	1.1	If lConnection = 0 Then
93			Exit Function
94			End If
95
96			'retrieve projection information
97			lRetCode = RasGetProjectionInfo(lConnection, lProjection, tIpInfo, lSize)
98
99			'check return code
100			'If lRetCode = 0 Then
101			getIpInfo = tIpInfo
102			'End If
103
104			End Function
105
106
107	joko	1.3	Public Function DetermineServerIP(conName As String) As String
108	joko	1.1
109			Dim tIpInfo As RASPPPIP
110
111			DetermineServerIP = vbNullString
112
113	joko	1.3	tIpInfo = getIpInfo(conName)
114	joko	1.1
115			'MsgBox "abc"
116
117			' If Not tIpInfo Is Nothing Then
118			'call successfull -> get IP address
119			DetermineServerIP = sTrimNulls(StrConv(tIpInfo.szServerAddress, vbUnicode))
120			' End If
121
122			End Function
123
124	joko	1.3	Public Function DetermineClientIP(conName As String) As String
125	joko	1.1
126			Dim tIpInfo As RASPPPIP
127
128			DetermineClientIP = vbNullString
129
130	joko	1.3	tIpInfo = getIpInfo(conName)
131	joko	1.1
132			'check return code
133			'If lRetCode = 0 Then
134			'call successfull -> get IP address
135			DetermineClientIP = sTrimNulls(StrConv(tIpInfo.szIpAddress, vbUnicode))
136			'End If
137
138			End Function
139
140
141			Public Function RasDisconnect(conName As String) As Boolean
142
143			' Does this work? Better use this:?
144			' http://www.activevb.de/tipps/vb6tipps/tipp0009.html
145			' rasdial "dachboden" /d
146
147			'Deklaration: Lokale Prozedur-Variablen
148			Dim i As Long
149			Dim lngBuffer As Long
150			Dim lngEntries As Long
151			Dim lngResult As Long
152
153			Dim strRASConName As String
154			Dim lngRASCon As Long
155
156			ReDim udtRASCon(255) As RASCONN
157
158			'DFÜ-Verbindungen ermitteln
159			udtRASCon(0).dwSize = 412
160			lngBuffer = 256 * udtRASCon(0).dwSize
161			lngResult = RasEnumConnections(udtRASCon(0), lngBuffer, lngEntries)
162
163			For i = 0 To lngEntries - 1
164			strRASConName = StrConv(udtRASCon(i).szEntryName(), vbUnicode)
165			strRASConName = Left$(strRASConName, InStr(strRASConName, _
166			vbNullChar) - 1)
167
168			'DFÜ-Verbindung beenden
169			If strRASConName = conName Then
170			lngRASCon = udtRASCon(i).hRasConn
171			'MsgBox lngRASCon
172			lngResult = RasHangUp(lngRASCon)
173			'InternetHangUp lngRASCon, 0
174			'MsgBox lngResult
175
176			If lngResult = 0 Then
177			RasDisconnect = True
178			End If
179
180			End If
181			Next i
182			End Function
183
184	joko	1.2	Private Function RasRetrieveConnectionHandler(conName As String) As Long
185			Dim lRetCode As Long
186			Dim lSize As Long
187			Dim tConnections(255) As RASCONN
188			Dim lConnections As Long
189
190			Dim i As Long
191			Dim cConnection As RASCONN
192			Dim strRASConName As String
193
194			'init
195			tConnections(0).dwSize = 412
196			lSize = (UBound(tConnections) + 1) * tConnections(0).dwSize
197			RasRetrieveConnectionHandler = 0
198
199			'retreive connections
200			lRetCode = RasEnumConnections(tConnections(0), lSize, lConnections)
201
202			'check return code
203			If lRetCode = 0 Then
204			'call successfull -> any connections?
205			If lConnections > 0 Then
206			For i = 0 To lConnections - 1
207			'lRetrieveConnectionHandler = tConnections(0).hRasConn
208			cConnection = tConnections(i)
209			strRASConName = StrConv(cConnection.szEntryName(), vbUnicode)
210			strRASConName = Left$(strRASConName, InStr(strRASConName, vbNullChar) - 1)
211			'MsgBox strRASConName
212			If strRASConName = conName Then
213			'MsgBox cConnection.hRasConn
214			RasRetrieveConnectionHandler = cConnection.hRasConn
215			End If
216			Next i
217			End If
218			End If
219			End Function
220	joko	1.1
221	joko	1.2	Public Function RasIsOnline(conName As String) As Boolean
222			Dim handle As Long
223			handle = RasRetrieveConnectionHandler(conName)
224			'MsgBox handle
225			If handle <> 0 Then RasIsOnline = True
226			End Function
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26