vb@rchiv
VB Classic
VB.NET
ADO.NET
VBA
C#
Mails senden, abrufen und decodieren - ganz easy ;-)  
 vb@rchiv Quick-Search: Suche startenErweiterte Suche starten   Impressum  | Datenschutz  | vb@rchiv CD Vol.6  | Shop Copyright ©2000-2024
 
zurück
Rubrik: VBA Allgemein   |   VB-Versionen: VBA02.08.01
Netzwerkadressen

Funktion zum Ermitteln der Physischen Adresse sowie der IP-Adresse und des Hostnamens.

Autor:   Microsys KramerBewertung:     [ Jetzt bewerten ]Views:  21.515 
www.access-paradies.deSystem:  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

Dieser Tipp wurde bereits 21.515 mal aufgerufen.

Voriger Tipp   |   Zufälliger Tipp   |   Nächster Tipp

Über diesen Tipp im Forum diskutieren
Haben Sie Fragen oder Anregungen zu diesem Tipp, können Sie gerne mit anderen darüber in unserem Forum diskutieren.

Neue Diskussion eröffnen

nach obenzurück


Anzeige

Kauftipp Unser Dauerbrenner!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.
 
   

Druckansicht Druckansicht Copyright ©2000-2024 vb@rchiv Dieter Otter
Alle Rechte vorbehalten.
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.

Diese Seiten wurden optimiert für eine Bildschirmauflösung von mind. 1280x1024 Pixel