module1.bas

局域网唤醒vb源码局域网唤醒vb源码局域网唤醒vb源码局域网唤醒vb源码

Attribute VB_Name = "Module1"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/08/03
'描    述：通过网卡MAC地址唤醒电脑
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************

Public Declare Function GetTickCount Lib "kernel32" () As Long

Private Const IP_SUCCESS As Long = 0
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const ERROR_SUCCESS As Long = 0

Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Long
wMaxUDPDG As Long
dwVendorInfo As Long
End Type

Private Declare Function gethostbyname Lib "wsock32.dll" _
(ByVal hostname As String) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(xDest As Any, _
xSource As Any, _
ByVal nbytes As Long)

Private Declare Function lstrlenA Lib "kernel32" _
(lpString As Any) As Long

Private Declare Function WSAStartup Lib "wsock32.dll" _
(ByVal wVersionRequired As Long, _
lpWSADATA As WSADATA) As Long

Private Declare Function WSACleanup Lib "wsock32.dll" () As Long

Private Declare Function inet_ntoa Lib "wsock32.dll" _
(ByVal addr As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" _
(ByVal RetVal As String, _
ByVal Ptr As Long) As Long

Private Declare Function gethostname Lib "wsock32.dll" _
(ByVal szHost As String, _
ByVal dwHostLen As Long) As Long

Public AbortThis As Boolean
Public PCs


Public Function hex2ascii(ByVal hextext As String) As String
    For Y = 1 To Len(hextext)
    num = Mid(hextext, Y, 2)
    Value = Value & Chr(Val("&h" & num))
    Y = Y + 1
    Next Y
    
    hex2ascii = Value
End Function

Function GetIPFromHostName(ByVal sHostName As String) As String

    '通过主机名转为 IP 地址
    
    Dim nbytes As Long
    Dim ptrHosent As Long '主机地址结构
    Dim ptrName As Long '名称地址指针
    Dim ptrAddress As Long '地址地址指针
    Dim ptrIPAddress As Long
    Dim ptrIPAddress2 As Long
    
    ptrHosent = gethostbyname(sHostName & vbNullChar)
    
    If ptrHosent <> 0 Then
        ptrAddress = ptrHosent + 12
        '获取 IP 地址
        CopyMemory ptrAddress, ByVal ptrAddress, 4
        CopyMemory ptrIPAddress, ByVal ptrAddress, 4
        CopyMemory ptrIPAddress2, ByVal ptrIPAddress, 4
        
        GetIPFromHostName = GetInetStrFromPtr(ptrIPAddress2)
    End If

End Function


Function GetStrFromPtrA(ByVal lpszA As Long) As String

    GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
    Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)

End Function


Function GetInetStrFromPtr(Address As Long) As String

    GetInetStrFromPtr = GetStrFromPtrA(inet_ntoa(Address))

End Function

Function ReadMacs(ByVal FIlename As String) As String
    On Error GoTo ERR_Control
    Set FS = CreateObject("Scripting.FileSystemObject")
    If FS.FileExists(FIlename) Then
        whichfile = (FIlename)
        Set thisfile = FS.OpenTextFile(whichfile, 1, False)
        While Not thisfile.AtEndOfStream
            thisline = Trim$(thisfile.ReadLine)
            If Len(thisline) > 11 Then ReadMacs = ReadMacs & thisline & ","
        Wend
        If Len(ReadMacs) > 1 Then ReadMacs = Left$(ReadMacs, Len(ReadMacs) - 1)
    Else
        MsgBox ("MACS.TXT 列表文件不存在!")
    End If

ERR_Control:
    If Err <> 0 Then MsgBox (Err.Description)

End Function