能否用VB6编写一个网络接通与断开的电子开关?
在工作中,有时希望断开电脑与宽带网的连接,常常要拨插网线插头很麻烦,哪位高手能用VB6编写一个网络接通与断开的电子开关?
下面是拨号网络的断开的开关,可惜不能用在宽带网上,能否在这上面改一改?
提示:在窗体上先拖一个按钮.
Option Explicit
Private Declare Function RasHangUp Lib "RasApi32.DLL " Alias "RasHangUpA " _
(ByVal hRasConn As Long) As Long
Private Declare Function RasEnumConnections _
Lib "RasApi32.DLL " Alias "RasEnumConnectionsA " _
(lprasconn As Any, lpcb As Long,lpcConnections As Long) As Long
Const RAS95_MaxEntryName = 256
Const RAS95_MaxDeviceName = 128
Const RAS_MaxDeviceType = 16
Private Type RASCONN95
'set dwsize to 412
dwSize As Long
hRasConn As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Sub Command1_Click()
Dim lngRetCode As Long
Dim lpcb As Long
Dim lpcConnections As Long
Dim intArraySize As Integer
Dim intLooper As Integer
ReDim lprasconn95(intArraySize) As RASCONN95
lprasconn95(0).dwSize = 412
lpcb = 256 * lprasconn95(0).dwSize
lngRetCode = RasEnumConnections(lprasconn95(0), lpcb, lpcConnections)
If lngRetCode = 0 Then
If lpcConnections > 0 Then
For intLooper = 0 To lpcConnections - 1
RasHangUp lprasconn95(intLooper).hRasConn
Next intLooper
Else
MsgBox "没有拨号网络连接！ ", vbInformation
End If
End If
End Sub
[解决办法]
Option Explicit
Private Type RASCONN 'version 4.0
dwSize As Long
hRasConn As Long
szEntryName(256) As Byte
szDeviceType(16) As Byte
szDeviceName(129) As Byte 'extra byte added for alignment in VB5
End Type
Private Type RASCONNSTATUS 'version 4.0
dwSize As Long
rasState As RASCONNSTATE
dwError As Long
szDeviceType(16) As Byte
szDeviceName(130) As Byte 'two extra bytes added for alignment in VB5
End Type
'Enumerates intermediate states to a connection.
Private Const RASCS_PAUSED As Long = &H1000
Private Const RASCS_DONE As Long = &H2000
Public Enum RASCONNSTATE
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
RASCS_CallbackComplete = 20
RASCS_LogonNetwork = 21
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 Const ERROR_INVALID_HANDLE As Long = 6
Private Declare Function RasGetErrorString Lib "RasAPI32.dll " Alias "RasGetErrorStringA " (ByVal errorNum As Long, ByVal errorString As String, ByVal lenString As Long) As Long
Private Declare Function RasEnumConnections Lib "RasAPI32.dll " Alias "RasEnumConnectionsA " (ByRef lpRasCon As RASCONN, ByRef lpcb As Long, ByRef lpNumConnections As Long) As Long
Private Declare Function RasHangUp Lib "RasAPI32.dll " Alias "RasHangUpA " (ByVal hRasConnection As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasAPI32.dll " Alias "RasGetConnectStatusA " (ByVal hRasConnection As Long, ByRef state As RASCONNSTATUS) As Long
Private Declare Sub Sleep Lib "kernel32.dll " (ByVal dwMilliseconds As Long)
Private Declare Function timeGetTime Lib "winmm.dll " () As Long
Private fCancel As Boolean
Private Sub Form_Load()
cmdCancel.Enabled = False
End Sub
Private Sub cmdCancel_Click()
fCancel = True
End Sub
Private Sub cmdEnumConn_Click()
Dim rasConInf(64) As RASCONN ' this code can handle up to 64 active RAS connections (impossible???)
Dim nRet As Long
Dim sizeBuf As Long
Dim numConnections As Long
Dim i As Long
Dim errorString As String
Dim rasState As RASCONNSTATUS
Dim lastState As RASCONNSTATE
cmdEnumConn.Enabled = False ' must handle reentrancy
cmdCancel.Enabled = True ' allow user to cancel hangup after enumerating connections
fCancel = False
rasConInf(0).dwSize = Len(rasConInf(0))
sizeBuf = rasConInf(0).dwSize * 64
nRet = RasEnumConnections(rasConInf(0), sizeBuf, numConnections)
If nRet <> 0 Then
'display error string in message box
errorString = Space$(128)
Call RasGetErrorString(nRet, errorString, 128)
MsgBox "RasEnumConnections failed: Error = " & errorString
Else
If numConnections < 1 Then
lstConnections.Clear
lstConnections.AddItem "No Active RAS Conections! "
Else
'List the active RAS connections on the listbox
With lstConnections
.Clear
.AddItem "The following RAS connections are currently active: "
For i = 0 To numConnections - 1
.AddItem "**************************************************************** "
.AddItem "Connection # " & i + 1
.AddItem "Entry name: " & BytesToString(rasConInf(i).szEntryName)
.AddItem "Device type: " & BytesToString(rasConInf(i).szDeviceType)
.AddItem "Device name: " & BytesToString(rasConInf(i).szDeviceName)
.AddItem "**************************************************************** "
i = i + 1
Next
'Pause for a moment for effect ;-)
.AddItem " "
.AddItem "Waiting 5 seconds before hanging up... "
For i = 4 To 1 Step -1
Pause 1000
If fCancel Then
.AddItem "Cancelled Hangup! "
'Exit Sub
GoTo Finished
End If
.AddItem i & "... "
Next
'Now hang up all connections
.AddItem " "
.AddItem "HANGING UP ALL ACTIVE CONNECTIONS!... "
.Refresh
For i = 0 To numConnections - 1
Screen.MousePointer = vbHourglass
.AddItem "================================================================= "
.AddItem "Hanging Up Connection # " & i + 1
Call RasHangUp(rasConInf(i).hRasConn)
'set stateflag to unitialized
lastState = -1
Do 'need to give RAS API time to clean up
'this algorithm is suggested in the MSDN docs for RasHangUp()
rasState.dwSize = LenB(rasState)
nRet = RasGetConnectStatus(rasConInf(i).hRasConn, rasState)
If nRet <> 0 Then
If nRet = ERROR_INVALID_HANDLE Then
'succesfully hung-up and waited until RAS API safely deallocated resources
.AddItem "Finished deallocating RAS API resources - safe to close application "
Exit Do
Else
'display error string in message box
errorString = Space$(128)
Call RasGetErrorString(nRet, errorString, 128)
MsgBox "RasGetConnectStatus failed: Error = " & errorString, vbInformation, App.Title
.AddItem "Error Number: " & nRet
.AddItem "size of RasConnState UDT: " & rasState.dwSize & " bytes "
Exit Do
End If
Else
'if state has changed give user feedback
If lastState <> rasState.rasState Then
lastState = rasState.rasState
.AddItem "RAS State = " & lastState
.Refresh
End If
'wait
Call Sleep(0)
End If
Loop
.AddItem "================================================================= "
Screen.MousePointer = vbDefault
Next
End With
End If
End If
Finished:
cmdEnumConn.Enabled = True
cmdCancel.Enabled = False
End Sub
Private Function BytesToString(ByRef bytes() As Byte) As String
Dim i As Long
Dim char As String
On Error GoTo ArrayNotInitialized
For i = 0 To UBound(bytes)
char = (Chr(bytes(i)))
If char <> vbNullChar Then
BytesToString = BytesToString & char
Else
Exit For
End If
Next
Exit Function
ArrayNotInitialized:
BytesToString = " "
End Function
Sub Pause(ByVal mSecs As Long, Optional bYield As Boolean = True)
Dim startTime As Long
startTime = timeGetTime()
Do While timeGetTime < startTime + mSecs
If bYield Then
DoEvents
End If
Loop
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'don 't allow exit while using RAS API
If cmdCancel.Enabled = True Then Cancel = True
End Sub
Private Sub lstConnections_Click()
End Sub
转自http://cache.baidu.com/c?word=%B6%CF%BF%AA%3B%CD%F8%C2%E7%3B%B5%C4%3Bapi&url=http%3A//www%2Eyuanshengkj%2Ecom/topic%2Easp%3Ftopic%5Fid%3D1127&p=8e74cd16d9c044ff57ec97665a418e&user=baidu
