网络不好，须要用VB小程序给网内的几个不知道弄网络的人用
要求：调用PING命令，得到返回值，判断电脑是否可以正常接上外网。如果可以正常上网，停止程序，反之重起路由器（192。168。1。1管理员帐号为ADMIN，密码ADMIN）
这个小程序是因为电信的宽带有问题，暂时解决不了宽带问题用来顶一段时间的
跪求各拉大虾给出VB代码，最好附上说明，小弟也想学好VB
下面这个是Ping 的脚本 成功返回true 不成功返回false
Public Function Pings(strMachines As String) As Boolean
aMachines = Split(strMachines, ";")
For Each machine In aMachines
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & machine & "'")
For Each objStatus In objPing
If IsNull(objStatus.StatusCode) Or objStatus.StatusCode <> 0 Then
Debug.Print ("machine " & machine & " is not reachable")
Pings = False
Else
Pings = True
End If
Next
Next
End Function
由于现在家用的路由器都是内置http服务的 所以
再配合inet控件(microsoft internet transfer control 6.0)
控制就行了 由于不知道你所用路由器具体的型号和重启页面具体代码 所以就没办法给你编剩下的代码了
有点累了 虽然会弄。。。。。
Public Function Pings(strMachines As String) As Boolean
aMachines = Split(strMachines, ";")
For Each machine In aMachines
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & machine & "'")
For Each objStatus In objPing
If IsNull(objStatus.StatusCode) Or objStatus.StatusCode <> 0 Then
Debug.Print ("machine " & machine & " is not reachable")
Pings = False
Else
Pings = True
End If
Next
Next
End Function
由于现在家用的路由器都是内置http服务的 所以
再配合inet控件(microsoft internet transfer control 6.0)
控制就行了 由于不知道你所用路由器具体的型号和重启页面具体代码 所以就没办法给你编剩下的代码了
有点累了 虽然会弄。。。。。
温馨提示：答案为网友推荐，仅供参考
第1个回答 2015-08-02
利用VB的Shell执行PING命令，将PING的输出重定向到文件 c:\r.txt，然后读取c:\r.txt文件显示运行结果。
由于VB中的Shell命令是异步执行的，即调用Shell后，没等Shell执行完毕，程序就继续执行下一条语句。为此，程序使用了系统API来判断Shell是否结束。
1）窗体及控件
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Const PROCESS_QUERY_INFORMATION = &H400
Const STILL_ALIVE = &H103
Private Sub Command1_Click()
If Trim(Text1.Text) = "" Then
MsgBox "请输入域名或IP地址", vbInformation + vbOKOnly
Text1.SetFocus
Exit Sub
End If
'命令执行期间禁用命令按钮
Command1.Enabled = False
'调用Shell执行Ping，执行结果重定向到C:\r.txt中
Dim pid As Long
pid = Shell("cmd.exe /C Ping " & Text1.Text & " > c:\r.txt", vbHide)
' 提示
Text2.Text = "正在执行Ping " & Text1.Text & " ..."
'等待Shell执行结束
Dim hProc As Long
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, 0, pid)
Dim ExitCode As Long
Do
Call GetExitCodeProcess(hProc, ExitCode)
DoEvents
Loop While ExitCode = STILL_ALIVE
'清空，准备显示结果
Text2.Text = ""
'打开 C:\r.txt文件
Open "c:\r.txt" For Input As #1
Dim strLine As String
Do Until EOF(1)
Line Input #1, strLine
'显示执行结果
Text2.Text = Text2.Text & strLine & vbNewLine
Loop
'关闭文件
Close #1
'删除C:\r.txt
On Error Resume Next
Kill "c:\r.txt"
On Error GoTo 0
'使能命令按钮
Command1.Enabled = True
End Sub
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
End Sub
3）运行结果
Ping baidu.com 正在执行中 ....
Ping baidu.com执行结果
由于VB中的Shell命令是异步执行的，即调用Shell后，没等Shell执行完毕，程序就继续执行下一条语句。为此，程序使用了系统API来判断Shell是否结束。
1）窗体及控件
Private Declare Function GetExitCodeProcess Lib "kernel32" ( _
ByVal hProcess As Long, _
lpExitCode As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Const PROCESS_QUERY_INFORMATION = &H400
Const STILL_ALIVE = &H103
Private Sub Command1_Click()
If Trim(Text1.Text) = "" Then
MsgBox "请输入域名或IP地址", vbInformation + vbOKOnly
Text1.SetFocus
Exit Sub
End If
'命令执行期间禁用命令按钮
Command1.Enabled = False
'调用Shell执行Ping，执行结果重定向到C:\r.txt中
Dim pid As Long
pid = Shell("cmd.exe /C Ping " & Text1.Text & " > c:\r.txt", vbHide)
' 提示
Text2.Text = "正在执行Ping " & Text1.Text & " ..."
'等待Shell执行结束
Dim hProc As Long
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, 0, pid)
Dim ExitCode As Long
Do
Call GetExitCodeProcess(hProc, ExitCode)
DoEvents
Loop While ExitCode = STILL_ALIVE
'清空，准备显示结果
Text2.Text = ""
'打开 C:\r.txt文件
Open "c:\r.txt" For Input As #1
Dim strLine As String
Do Until EOF(1)
Line Input #1, strLine
'显示执行结果
Text2.Text = Text2.Text & strLine & vbNewLine
Loop
'关闭文件
Close #1
'删除C:\r.txt
On Error Resume Next
Kill "c:\r.txt"
On Error GoTo 0
'使能命令按钮
Command1.Enabled = True
End Sub
Private Sub Form_Load()
Text1.Text = ""
Text2.Text = ""
End Sub
3）运行结果
Ping baidu.com 正在执行中 ....
Ping baidu.com执行结果
