IP-Adresse und 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 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 Dieser Tipp wurde bereits 21.517 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevISDN 1.0 Überwachung aller eingehender Anrufe! Die DLL erkennt alle über die CAPI-Schnittstelle eingehenden Anrufe und teilt Ihnen sogar mit, aus welchem Ortsbereich der Anruf stammt. Weitere Highlights: Online-Rufident, Erkennung der Anrufbehandlung u.v.m. Tipp des Monats März 2024 Dieter Otter UTF-8 Konvertierung von Dateien und Strings VB6 selbst verfügt über keine Funktionen zur UTF-8 Konvertierung von Daten. Mit Hilfe des ADODB.Stream-Objekts lassen sich diese fehlenden Funktionen aber schnell nachrüsten. sevAniGif (VB/VBA) Anzeigen von animierten GIF-Dateien Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |