樱之花

1.

Public Sub GetIP()

Dim KaiShi As Integer

Dim GeShu As Integer

Open "d:\ip.txt" For Input As #1

Do While Not EOF(1)

    Line Input #1, LinShi

    Command1.Tag = Command1.Tag + LinShi

    Print Command1.Tag

Loop

Close #1

If Len(Command1.Tag) > 400 Then

    Command1.Tag = Mid(Command1.Tag, 255, 300)

    KaiShi = InStr(Command1.Tag, "IP Address") + Len("IP Address. . . . . . . . . . . . :")

    GeShu = InStr(Command1.Tag, "Subnet Mask") - KaiShi

    Text1 = Mid(Command1.Tag, KaiShi, GeShu)

Else

    MsgBox ("您没有连接到网络上！！")

End If

Kill "d:\ip.txt"

End Sub

Private Sub Command1_Click()

Call GetIP

End Sub

Private Sub Form_Load()

Do Until (Shell("cmd /c" & " " & "ipconfig >d:\ip.txt") > 0)

Loop

Timer1.Interval = 100

Timer1.Enabled = False

Me.Icon = LoadPicture()

Call GetIP

End Sub

Private Sub Timer1_Timer()

Timer1.Enabled = False

End Sub

***********************************************

2.

WebBrowser.text1,text2控件

Private Sub Form_Load()

WebBrowser.Navigate ("http://www.ip138.com/ip2city.asp") '打开IP138网站

End Sub

Private Sub WebBrowser_DocumentComplete(ByVal pDisp As Object, URL As Variant)

Set webdoc = WebBrowser.Document

y = webdoc.All(0).outerhtml

'--------------------------------------------------获取网页源代码------

Dim sTemp As String

Dim a, b, c, d As Integer

sTemp = y

a = InStrRev(sTemp, "[") + 1

b = InStrRev(sTemp, "]")

Text2.Text = Mid(sTemp, a, b - a)

'--------------------------------------------------取IP字段------

c = InStrRev(sTemp, "：") + 1

d = InStrRev(sTemp, "</CENTER>")

'Text3.Text = Mid(sTemp, c, d - c)

'--------------------------------------------------取地区字段------

End Sub

********************************************************************

3.

Option Explicit
Dim objWMIService As Object
Dim colProcesslist As Object
Dim objProcess As Object
Dim strrec$(), aa$, bb$, tmpstr$, i&, colProcesses

Private Sub Command1_Click()
   On Error Resume Next
   '************ 制作批次档并运行它
   aa = "c:\tmpsch.bat"
   bb = "c:\cbmtmp.txt"
   If Dir(bb) <> "" Then Kill bb
   Open aa For Output As #1
   Print #1, "@echo off"
   Print #1, "nslookup >" & bb
   Print #1, "exit"
   Close #1
   Call Shell("cmd /c " & aa, vbHide)
   i = Timer
   '延时5秒内是否得到文档
   Do
      DoEvents
      If Dir(bb) <> "" Then
         If FileLen(bb) > 0 Then Exit Do
      End If
   Loop Until Timer > i + 5
   If Isrunexe("NSLOOKUP.EXE") Then Call CloseExe("NSLOOKUP.EXE")
   If Isrunexe("cmd.exe") Then Call CloseExe("cmd.exe")
   '******************************************************
   If Dir(bb) <> "" Then
      Open bb For Input As #1
      While Not EOF(1)
         Line Input #1, tmpstr
         If InStr(tmpstr, ":") > 0 And InStr(tmpstr, "Default") > 0 Then Print "服务器名:" & Trim(Mid(tmpstr, InStr(tmpstr, ":") + 1))
         If InStr(tmpstr, ":") > 0 And InStr(tmpstr, "Address") > 0 Then Print "外网IP:" & Trim(Mid(tmpstr, InStr(tmpstr, ":") + 1))
      Wend
      Close #1
   Else
      MsgBox "获取失败"
   End If
End Sub

Public Function Isrunexe(ExeNm As String) As Boolean
   tmpstr = "."
   Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & tmpstr & "\root\cimv2")
   Set colProcesslist = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & ExeNm & "'")
   Isrunexe = IIf(colProcesslist.Count > 0, True, False)
   Set objWMIService = Nothing
   Set colProcesslist = Nothing
End Function

Public Sub CloseExe(ExeNm As String, Optional Qty As Long)
   tmpstr = "."
   Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & tmpstr & "\root\cimv2")
   Set colProcesslist = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & ExeNm & "'")
   If colProcesslist.Count > 0 Then
      For Each objProcess In colProcesslist
         If InStr(UCase(objProcess.ExecutablePath), UCase(ExeNm)) > 0 Then objProcess.Terminate
         If Qty = 1 Then Exit For
      Next
   End If
   Set objWMIService = Nothing
   Set colProcesslist = Nothing
End Sub

Private Sub Form_Load()

End Sub
**************************************************************************

4.

Option Explicit

 Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  Public Declare Function GetIpAddrTable Lib "IPHlpApi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long
    
  Const Max_IP = 5
    
  Type IPINFO
      dwAddr   As Long
      dwIndex   As Long
      dwMask   As Long
      dwBCastAddr   As Long
      dwReasmSize     As Long
      UnUsed1   As Integer
      UnUsed2   As Integer
  End Type
    
  Type MIB_IPADDRTABLE
      dEntrys   As Long
      mIPInfo(Max_IP)   As IPINFO
  End Type
    
  Type IP_Array
      mBuffer   As MIB_IPADDRTABLE
      BufferLen   As Long
  End Type
    
  Sub Main()
      Start
  End Sub
    
  Public Function ConvertAddressToString(longAddr As Long) As String
      Dim MyByte(3)     As Byte
      Dim Cnt     As Long
      CopyMemory MyByte(0), longAddr, 4
      For Cnt = 0 To 3
          ConvertAddressToString = ConvertAddressToString + CStr(MyByte(Cnt)) + "."
      Next Cnt
      ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
  End Function
    
  Public Sub Start()
      Dim Ret     As Long, Tel       As Long
      Dim bBytes()     As Byte
      Dim Listing     As MIB_IPADDRTABLE
      On Error GoTo End1
      GetIpAddrTable ByVal 0&, Ret, True
      If Ret <= 0 Then Exit Sub
      ReDim bBytes(0 To Ret - 1) As Byte
      GetIpAddrTable bBytes(0), Ret, False
      CopyMemory Listing.dEntrys, bBytes(0), 4
      MsgBox "找到   " & Listing.dEntrys & "   个IP地址!", 0, "提示"
      For Tel = 0 To Listing.dEntrys - 1
          CopyMemory Listing.mIPInfo(Tel), bBytes(4 + (Tel * Len(Listing.mIPInfo(0)))), Len(Listing.mIPInfo(Tel))                         '拷贝整个结构到Listing
          MsgBox "IP地址:" & ConvertAddressToString(Listing.mIPInfo(Tel).dwAddr), 0, "提示"
      Next
      End
End1:
      MsgBox "出错！", 0, "提示"
      End
  End Sub

****************************************************