| 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 |
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" (lprasconn As Any, _ |
| 32 |
lpcb As Long, _ |
| 33 |
lpcConnections As Long) As Long |
| 34 |
|
| 35 |
Private Declare Function RasGetProjectionInfo Lib "rasapi32.dll" Alias "RasGetProjectionInfoA" (ByVal hRasConn As Long, _ |
| 36 |
ByVal rasprojection As Long, _ |
| 37 |
lpprojection As Any, _ |
| 38 |
lpcb As Long) As Long |
| 39 |
|
| 40 |
Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" ( _ |
| 41 |
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 |
Private Function getIpInfo(conName As String) As RASPPPIP |
| 79 |
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 |
lConnection = RasRetrieveConnectionHandler(conName) |
| 92 |
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 |
Public Function DetermineServerIP(conName As String) As String |
| 108 |
|
| 109 |
Dim tIpInfo As RASPPPIP |
| 110 |
|
| 111 |
DetermineServerIP = vbNullString |
| 112 |
|
| 113 |
tIpInfo = getIpInfo(conName) |
| 114 |
|
| 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 |
Public Function DetermineClientIP(conName As String) As String |
| 125 |
|
| 126 |
Dim tIpInfo As RASPPPIP |
| 127 |
|
| 128 |
DetermineClientIP = vbNullString |
| 129 |
|
| 130 |
tIpInfo = getIpInfo(conName) |
| 131 |
|
| 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 |
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 |
|
| 221 |
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 |
Parent Directory
| 
Revision Log
