hai Fikar: Option Explicit
Private Const IP_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Const INADDR_NONE As Long = &HFFFFFFFF
Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
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 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_addr Lib "WSOCK32.DLL" (ByVal s As String) As
Long
Private Declare Function GetComputerName Lib "kernel32" Alias
"GetComputerNameA" (ByVal Buffer As String, Size As Long) As Long
Function GetIPAddress(range)
If SocketsInitialize() Then
GetIPAddress = GetIPFromHostName(GetPcName)
End If
SocketsCleanup
End Function
Private Function IPToText(ByVal IPAddress As String) As String
IPToText = CStr(Asc(IPAddress)) & "." & CStr(Asc(Mid$(IPAddress, 2, 1)))
& "." & CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & CStr(Asc(Mid$(IPAddress, 4,
1)))
End Function
Public Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function
Public Function GetPcName() As String
Dim strBuf As String * 16, strPcName As String, lngPc As Long
lngPc = GetComputerName(strBuf, Len(strBuf))
If lngPc <> 0 Then
strPcName = Left(strBuf, InStr(strBuf, vbNullChar) - 1)
GetPcName = strPcName
Else
GetPcName = vbNullString
End If
End Function
Public Sub SocketsCleanup()
If WSACleanup() <> 0 Then
MsgBox "Windows Sockets error occurred in Cleanup.", vbExclamation
End If
End Sub
Public Function GetIPFromHostName(ByVal sHostName As String) As String
Dim nbytes As Long
Dim ptrHosent As Long
Dim ptrName As Long
Dim ptrAddress As Long
Dim ptrIPAddress As Long
Dim sAddress As String
sAddress = Space$(4)
ptrHosent = gethostbyname(sHostName & vbNullChar)
If ptrHosent <> 0 Then
ptrName = ptrHosent
ptrAddress = ptrHosent + 12
CopyMemory ptrName, ByVal ptrName, 4
CopyMemory ptrAddress, ByVal ptrAddress, 4
CopyMemory ptrIPAddress, ByVal ptrAddress, 4
CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
GetIPFromHostName = IPToText(sAddress)
End If
End Function
On 1/8/09, anak jalanan <[email protected]> wrote:
>
> Dear all pakar XL,
> Mau tanya nich, ada yang bisa kasih macro untuk nge-check IP address?
> Fungsinya persis kayak "ping" di command prompt....
>
> Wassalam
> Thanks B4
>
> FIKAR
>
get ipku.xls
Description: MS-Excel spreadsheet
