Rubrik: VBA Allgemein | VB-Versionen: VBA | 02.08.01 |
Netzwerkadressen Funktion zum Ermitteln der Physischen Adresse sowie der IP-Adresse und des Hostnamens. | ||
Autor: Microsys Kramer | Bewertung: | Views: 21.542 |
www.access-paradies.de | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
IP-Adresse und Hostnamen
Die nachfolgenden Routinen ermittelt Ihre lokale IP-Adresse und den Hostnamen.
Erstellen Sie ein neues Modul und fügen Sie nachfolgenden Code ein:
Option Explicit Private Const WS_VERSION_REQD = &H101 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ _ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD _ And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1 Private Const WSADescription_Len = 256 Private Const WSASYS_Status_Len = 128 Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type Private Type WSADATA wversion As Integer wHighVersion As Integer szDescription(0 To WSADescription_Len) As Byte szSystemStatus(0 To WSASYS_Status_Len) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End Type Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" ( _ ByVal wVersionRequired&, _ lpWSAData As WSADATA) As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Declare Function gethostname Lib "WSOCK32.DLL" ( _ ByVal Hostname$, _ ByVal HostLen%) As Long Private Declare Function gethostbyname Lib "WSOCK32.DLL" ( _ ByVal Hostname$) As Long Private Declare Function gethostbyaddr Lib "WSOCK32.DLL" ( _ ByVal addr$, _ ByVal laenge%, _ ByVal typ%) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" ( _ hpvDest As Any, _ ByVal hpvSource&, _ ByVal cbCopy&) Public Function HostByAddr$(ByVal addr$) Dim host As HOSTENT Dim a$, hostent_addr&, n% a$ = Chr$(Val(zeichennext$(addr$, "."))) a$ = a$ + Chr$(Val(zeichennext$(addr$, "."))) a$ = a$ + Chr$(Val(zeichennext$(addr$, "."))) a$ = a$ + Chr$(Val(addr$)) hostent_addr& = gethostbyaddr(a$, Len(a$), 2) If hostent_addr& = 0 Then HostByAddr$ = "" Exit Function End If RtlMoveMemory host, hostent_addr&, LenB(host) Dim c As String * 5 a$ = "": n% = 0 Do RtlMoveMemory ByVal c, host.hName + n%, 1 If Left$(c, 1) = Chr$(0) Then Exit Do a$ = a$ + Left$(c, 1): n% = n% + 1 Loop HostByAddr$ = a$ End Function Public Function HostByName$(na$, Optional adapter% = 0) Dim host As HOSTENT Dim temp_ip_address() As Byte Dim hostent_addr&, i%, hostip_addr&, ip_address$ hostent_addr& = gethostbyname(na$) If hostent_addr& = 0 Then HostByName$ = "" Exit Function End If RtlMoveMemory host, hostent_addr&, LenB(host) For i% = 0 To adapter% ' Wenn schon eher ein Eintrag 0 ist, dann ist ' Adapter-Wert zu groß! RtlMoveMemory hostip_addr&, host.hAddrList + 4 * i%, 4 If hostip_addr& = 0 Then HostByName$ = "" Exit Function End If Next ReDim temp_ip_address(1 To host.hLength) RtlMoveMemory temp_ip_address(1), hostip_addr&, _ host.hLength ip_address$ = "" For i = 1 To host.hLength ip_address$ = ip_address$ & temp_ip_address(i) & "." Next ip_address$ = Left$(ip_address$, Len(ip_address$) - 1) HostByName$ = ip_address$ End Function Public Function MyHostName$() Dim Hostname As String * 256 If gethostname(Hostname, 256) = SOCKET_ERROR Then MsgBox "Windows Sockets error " & _ Str(WSAGetLastError()) Exit Function Else MyHostName$ = zeichennext$(Trim$(Hostname), _ Chr$(0)) End If End Function Public Sub SocketsInitialize() Dim WSAD As WSADATA Dim iReturn%, sHighByte$, sLowByte$, sMsg$ iReturn% = WSAStartup(WS_VERSION_REQD, WSAD) If iReturn% <> 0 Then MsgBox "Winsock.dll is not responding." End End If If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or _ (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And _ hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then sHighByte$ = Trim$(Str$(hibyte(WSAD.wversion))) sLowByte$ = Trim$(Str$(lobyte(WSAD.wversion))) sMsg$ = "Windows Sockets version " & sLowByte$ & _ "." & sHighByte$ sMsg$ = sMsg$ & " is not supported by winsock.dll " MsgBox sMsg$ End End If If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then sMsg$ = "This application requires a minimum of " sMsg$ = sMsg$ & Trim$(Str$(MIN_SOCKETS_REQD)) & _ " supported sockets." MsgBox sMsg$ End End If End Sub Public Sub SocketsCleanup() Dim lReturn& lReturn& = WSACleanup() If lReturn& <> 0 Then MsgBox "Socket error " & Trim$(Str$(lReturn&)) & _ " occurred in Cleanup " End End If End Sub Private Function lobyte(ByVal wParam As Integer) lobyte = wParam And &HFF& End Function Private Function hibyte(ByVal wParam As Integer) hibyte = wParam \ &H100 And &HFF& End Function Private Function zeichennext$(a$, ch$) Dim ai% ai% = InStr(a$, ch$) If ai% = 0 Then zeichennext$ = a$: a$ = "" Else zeichennext$ = Left$(a$, ai% - 1) a$ = Mid$(a$, ai% + Len(ch$)) End If End Function
Physische Adresse
Die nachfolgenden Routinen ermitteln die Physische Adresse.
Erstellen Sie ein neues Modul und fügen Sie nachfolgenden Code ein:
Option Explicit Private Const NCBASTAT = &H33 Private Const NCBNAMSZ = 16 Private Const NCBRESET = &H32 Private Const HEAP_GENERATE_EXCEPTIONS = &H4 Private Const HEAP_ZERO_MEMORY = &H8 Private Type NCB ncb_command As Byte ' Integer ncb_retcode As Byte ' Integer ncb_lsn As Byte ' Integer ncb_num As Byte ' Integer ncb_buffer As Long ' String ncb_length As Integer ncb_callname As String * NCBNAMSZ ncb_name As String * NCBNAMSZ ncb_rto As Byte ' Integer ncb_sto As Byte ' Integer ncb_post As Long ncb_lana_num As Byte ' Integer ncb_cmd_cplt As Byte ' Integer ncb_reserve(9) As Byte ' Reserved, must be 0 ncb_event As Long End Type Private Type ADAPTER_STATUS adapter_address(5) As Byte ' As String * 6 rev_major As Byte ' Integer reserved0 As Byte ' Integer adapter_type As Byte ' Integer rev_minor As Byte ' Integer duration As Integer frmr_recv As Integer frmr_xmit As Integer iframe_recv_err As Integer xmit_aborts As Integer xmit_success As Long recv_success As Long iframe_xmit_err As Integer recv_buff_unavail As Integer t1_timeouts As Integer ti_timeouts As Integer Reserved1 As Long free_ncbs As Integer max_cfg_ncbs As Integer max_ncbs As Integer xmit_buf_unavail As Integer max_dgram_size As Integer pending_sess As Integer max_cfg_sess As Integer max_sess As Integer max_sess_pkt_size As Integer name_count As Integer End Type Private Type NAME_BUFFER Name As String * NCBNAMSZ name_num As Integer name_flags As Integer End Type Private Type ASTAT adapt As ADAPTER_STATUS NameBuff(30) As NAME_BUFFER End Type Private Declare Function Netbios Lib "netapi32.dll" ( _ pncb As NCB) As Byte Private Declare Function GetProcessHeap Lib "kernel32" () As Long Private Declare Function HeapAlloc Lib "kernel32" ( _ ByVal hHeap As Long, _ ByVal dwflags As Long, _ ByVal dwBytes As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" _ Alias "RtlMoveMemory" ( _ hpvDest As Any, _ ByVal hpvSource As Long, _ ByVal cbCopy As Long) Private Declare Function HeapFree Lib "kernel32" ( _ ByVal hHeap As Long, _ ByVal dwflags As Long, _ lpMem As Any) As Long Function PhysischeAdresse() Dim myNcb As NCB Dim bRet As Byte myNcb.ncb_command = NCBRESET bRet = Netbios(myNcb) myNcb.ncb_command = NCBASTAT myNcb.ncb_lana_num = 0 myNcb.ncb_callname = "* " Dim myASTAT As ASTAT, tempASTAT As ASTAT Dim pASTAT As Long myNcb.ncb_length = Len(myASTAT) Debug.Print "err1 " & Err.LastDllError pASTAT = HeapAlloc(GetProcessHeap(), _ HEAP_GENERATE_EXCEPTIONS Or HEAP_ZERO_MEMORY, _ myNcb.ncb_length) If pASTAT = 0 Then Debug.Print "memory allcoation failed!" Exit Function End If myNcb.ncb_buffer = pASTAT bRet = Netbios(myNcb) Debug.Print "err2 " & Err.LastDllError CopyMemory myASTAT, myNcb.ncb_buffer, Len(myASTAT) PhysischeAdresse = "0" & _ Hex(myASTAT.adapt.adapter_address(0)) & "-" & _ Hex(myASTAT.adapt.adapter_address(1)) _ & "-" & Hex(myASTAT.adapt.adapter_address(2)) & "-" _ & Hex(myASTAT.adapt.adapter_address(3)) _ & "-" & Hex(myASTAT.adapt.adapter_address(4)) & "-" _ & Hex(myASTAT.adapt.adapter_address(5)) HeapFree GetProcessHeap(), 0, pASTAT End Function