Lista VB Ro
Carti
Surse
Articole
Programe
Legaturi
Pareri

1. Conversii LoWord/HiWord & LoByte/HiByte (2 metode)
   

   
   Function LoWord(lArg)
   	LoWord= lArg And ( lArg Xor &HFFFF0000 )
   End Function
   
   Function HiWord(lArg)
   	If lArg > &H7FFFFFFF Then
   		HiWord = ( lArg And &HFFFF0000 ) \ &H10000
   	Else
   		HiWord = (( lArg And &HFFFF0000 ) \ &H10000) Xor &HFFFF0000
   	End If
   End Function
   
   Function LoByte(lArg)
   	LoByte= lArg Xor ( lArg And &HFF00 )
   End Function
   
   Function HiByte(lArg)
   	LoWord= ( lArg And &HFF00 ) \ &H100
   End Function
   
   sau
   
   Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" ( _
               lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
   
   Function LoWord(ByVal dw As Long) As Integer
           CopyMemory LoWord, dw, 2
   End Function
   
   Function HiWord(ByVal dw As Long) As Integer
           CopyMemory HiWord, ByVal VarPtr(dw) + 2, 2
   End Function
   
   

2. Afisez dialogul 'Printer Setup'
   Pun pe forma un CommonDialog, apoi scriu

   
   On Error Resume Next 'Daca se apasa 'Cancel' va da o eroare
   
   dlgPrintSetup.CancelError = True 
   dlgPrintSetup.Copies = 1
   dlgPrintSetup.FromPage = 1
   dlgPrintSetup.Max = 2
   dlgPrintSetup.Min = 1
   dlgPrintSetup.ToPage = 1
   dlgPrintSetup.HelpFile = "C:\WINDOWS\HELP\Winhlp32.hlp" 
   dlgPrintSetup.HelpCommand = cdlHelpPartialKey
   dlgPrintSetup.HelpContext = 0
   
   dlgPrintSetup.flags = cdlPDPrintSetup + cdlPDHidePrintToFile + cdlPDHelpButton
   
   dlgPrintSetup.ShowPrinter
   If Err = cdlCancel Then ' A fost apasat Cancel 'Cancel'
   '...
   End If
   

3. Obtin/modific latimea unui Drop-Down Combo box

   Exemplu de utilizare:
   Msgbox "Combo1 width = " & GetDropdownWidth(Combo1)
   Call SetDropdownWidth(Combo1, GetDropdownWidth(Combo1) * 2)
   Iar intr-un modul:

   Private Const CB_ERR = -1 
   Private Const CB_SETDROPPEDWIDTH = &H160 
   Private Const CB_GETDROPPEDWIDTH = &H15F  
   Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
      (ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As _
      Long) As Long  
   
   Public Function GetDropdownWidth(cbo As Control) As Long   
   Dim Ret As Long      
   Ret = SendMessage(cbo.hwnd, CB_GETDROPPEDWIDTH, 0, 0)   
   If Ret <> CB_ERR Then GetDropdownWidth = Ret    
   End Function  
   
   Public Sub SetDropdownWidth(cbo As Control, NewWidthPixel As Long)   
   Dim Ret As Long      
   Ret = SendMessage(cbo.hwnd, CB_SETDROPPEDWIDTH, NewWidthPixel, 0)  
   End Sub	
   

4. Ascund si reafisez butonul 'Start' din Windows

   Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
      (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 
   Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, _
      ByVal nCmdShow As Long) As Long
   Private Const SW_HIDE = 0
   Private Const SW_SHOWNORMAL = 1  
   
   Private Sub Command1_Click()   
   Dim Ret         As Long   
   Dim ClassName   As String   
   Dim StartWindow As Long        
   ClassName = Space(256)   
   ClassName = "Shell_TrayWnd"   
   StartWindow = FindWindow(ClassName, vbNullString)    'Hide the start menu bar   
   Ret = ShowWindow(StartWindow, SW_HIDE)   
   MsgBox "The Start Menu is hidden (or should be!)" 
   End Sub  
   
   Private Sub Command2_Click()   
   Dim Ret         As Long   
   Dim ClassName   As String   
   Dim StartWindow As Long        
   ClassName = Space(256)   
   ClassName = "Shell_TrayWnd"   
   StartWindow = FindWindow(ClassName, vbNullString)    
   'Display the start menu bar as normal   
   Ret = ShowWindow(StartWindow, SW_SHOWNORMAL)   
   MsgBox "The Start Menu should now be visible" 
   End Sub
   

5. Porneste Screen-saver-ul

   Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
      (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
       ByVal lParam As Long) As Long
   
   Private Const WM_SYSCOMMAND = &H112&
   Private Const SC_SCREENSAVE = &HF140&
   
   Private Sub Command1_Click()
     Dim Ret As Long
     Ret = SendMessage(Form1.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
   End Sub
   

6. Modific Wallpaper-ul ecranului

   Public Const SPIF_UPDATEINIFILE = &H1
   Public Const SPI_SETDESKWALLPAPER = 20
   Public Const SPIF_SENDWININICHANGE = &H2
   
   Private Declare Function SystemParametersInfo Lib "User32" _
   Alias "SystemParametersInfoA" _
       (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, _
        ByVal fuWinIni As Long) As Long
   
   Public Sub  SetWallpaper(ByVal pFileName As String)
     Dim Ret as long
     Ret = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, pFileName, _
               SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
   End Sub
   

7. Afisez un raport Access dintr-un mdb

   Dim objAccess As Access.Application
   Set objAccess = CreateObject("access.application")
   With objAccess
      .OpenCurrentDatabase filepath:=App.Path & "\ceva.mdb"
      .DoCmd.OpenReport reportname:="Un_raport", View:=acViewPreview
   End With
   

8. Open/Close pentru CD-ROM

   Private Declare Function MCISendString Lib "winmm.dll" _
        Alias "mciSendStringA" (ByVal lpstrCommand As String, _
   	 ByVal lpstrReturnString As String, ByVal uReturnLength As Long, _
   	 ByVal hwndCallback As Long) As Long
   
   Private Sub cmdOpen_Click()
     Dim Ret    As Long
     Dim RetStr As String
     Ret = MCISendString("set CDAudio door open", RetStr, 127, 0)
   End Sub
   
   Private Sub cmdClose_Click()
     Dim Ret    As Long
     Dim RetStr As String
     Ret = MCISendString("set CDAudio door closed", RetStr, 127, 0)
   End Sub
   

9. Modific textul dintr-un meniu cu o imagine

   Pun intr-o forma 2 picture-box-uri si un meniu apoi,

   Private Declare Function ModifyMenuPic Lib "user32" Alias "ModifyMenuA" _
   	(ByVal hmenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
   	ByVal wIDNewItem As Long, ByVal lpString As Long) As Long
   Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
   Private Declare Function GetSubMenu Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long
   Private Declare Function GetMenuItemID Lib "user32" (ByVal hmenu As Long, ByVal nPos As Long) As Long
   Const MF_BITMAP = 4
   Const MF_BYCOMMAND = 0
   Const MF_BYPOSITION = &H400&
   
   Sub Form_Load()
   Dim hmenu&, hSubmenu&, menuid&, result As Long ' Note the "&" characters
   Me.Show ' make me visible so all is initialized properly
   hmenu = GetMenu(Form1.hwnd) ' get handle to form menu
   hSubmenu = GetSubMenu(hmenu, 0) ' get handle to first submenu
   menuid = GetMenuItemID(hSubmenu, 0) ' get ID of first submenu item
   result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _
        menuid, Picture1.Picture) ' change first submenu item to bitmap
   menuid = GetMenuItemID(hSubmenu, 1) ' get second item ID
   result = ModifyMenuPic(hSubmenu, menuid, MF_BYCOMMAND Or MF_BITMAP, _
        menuid, Picture2.Picture) ' change to bitmap
   End Sub
   

10. Modific caracterul de marcare dintr-un meniu cu o imagine - sau adaugarea unei imagini la un element dintr-un meniu (metoda I-a)

    Se poate folosi aceasi imagine atit pentru marcat cit si pentru nemarcat.

    Private Type BITMAP
      bmType As Long
      bmWidth As Long
      bmHeight As Long
      bmWidthBytes As Long
      bmPlanes As Integer
      bmBitsPixel As Integer
      bmBits As Long
    End Type
    Private hBitmapChecked As Long
    Private hBitmapUnchecked As Long
    Private Const MF_BYPOSITION = &H400&
    Private Const MF_BYCOMMAND = &H0&
    Private Const SRCCOPY = &HCC0020
    Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, _
         ByVal nPos As Long) As Long
    Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" _
         (ByVal hObject As Long, ByVal nCount As Long, _
         lpObject As Any) As Long
    Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
    Private Declare Function CreateBitmapIndirect Lib "gdi32" _
         (lpBitmap As BITMAP) As Long
    Private Declare Function CreateCompatibleDC Lib "gdi32" _
         (ByVal hdc As Long) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
         ByVal hObject As Long) As Long
    Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long,_
         ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
         ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, _
         ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Private Declare Function SetMenuItemBitmaps Lib "user32" _
         (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
         ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" _
         (ByVal hObject As Long) As Long
    
    Private Sub Form_Activate()
    Dim hMenu As Long
    Dim x As Long
    Dim bm As BITMAP
    Dim hdc As Long
    Dim hOld As Long
    hMenu = GetMenu(Me.hwnd) ' get top-level menu
    If hMenu Then hMenu = GetSubMenu(hMenu, 0) ' get menu for first item
    x = GetMenuCheckMarkDimensions()
    GetObjectAPI Picture1.Image, Len(bm), bm ' get general bitmap specs
    bm.bmHeight = (x \ &HFFFF&) And &HFFFF& ' update size
    bm.bmWidth = x And &HFFFF&
    bm.bmBits = 0
    hBitmapChecked = CreateBitmapIndirect(bm) ' create new bitmaps
    hBitmapUnchecked = CreateBitmapIndirect(bm)
    hdc = CreateCompatibleDC(Picture1.hdc) ' set up device context to use
    hOld = SelectObject(hdc, hBitmapChecked) ' copy bitmap...
    BitBlt hdc, 0, 0, bm.bmWidth, bm.bmHeight, Picture1.hdc, 0, 0, SRCCOPY
    x = SelectObject(hdc, hBitmapUnchecked) ' copy bitmap...
    BitBlt hdc, 0, 0, bm.bmWidth, bm.bmHeight, Picture2.hdc, 0, 0, SRCCOPY
    hOld = SelectObject(hdc, hOld) ' restore original setup
    DeleteDC hdc ' clean up scratch area
    x = SetMenuItemBitmaps(hMenu, 0, MF_BYPOSITION, hBitmapUnchecked, _
         hBitmapChecked)
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
    ' be sure to clean up memory properly!
    If hBitmapChecked Then DeleteObject hBitmapChecked
    If hBitmapUnchecked Then DeleteObject hBitmapUnchecked
    End Sub
    

11. Modific caracterul de marcare dintr-un meniu cu o imagine - sau adaugarea unei imagini la un element dintr-un meniu (metoda a II-a)

    Private Type MENUITEMINFO
        cbSize As Long
        fMask As Long
        fType As Long
        fState As Long
        wid As Long
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
        dwTypeData As Long
        cch As Long
    End Type
    
    Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
    Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" 
       (ByVal hMenu As Long, ByVal un As Long, ByVal bypos As Long, 
       lpcMenuItemInfo As MENUITEMINFO) As Long
    
    Private Const MF_BITMAP = &H4&
    Private Const MFT_BITMAP = MF_BITMAP
    Private Const MIIM_TYPE = &H10
    
    Private Sub Form_Load()
    Dim main_menu As Long
    Dim sub_menu As Long
    Dim menu_info As MENUITEMINFO
    Dim i As Integer
    
        main_menu = GetMenu(hwnd)
        sub_menu = GetSubMenu(main_menu, 0)
        For i = 0 To 2
            With menu_info
                .cbSize = Len(menu_info)
                .fMask = MIIM_TYPE
                .fType = MFT_BITMAP
                .dwTypeData = picFace(i).Picture
            End With
            SetMenuItemInfo sub_menu, i, True, menu_info
        Next i
    End Sub
    

12. Schimb valorile marcat/nemarcat pt. un check-box

    Evident o solutie este

    if Check1 = vbChecked Then
      Check1 = vbUnchecked
    Else
      Check1 = vbChecked
    End If
    

    Dar pentru ca Check1 = Not Check1 nu merge se poate face mai simplu:

    Check1 = (Not Check1) + 2

13. Restrictionez un text-box doar la cifre

    Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
                                (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
                                  (ByVal hwnd As Long, ByVal nIndex As Long, _
                                  ByVal dwNewLong As Long) As Long
    
    Public Const GWL_STYLE = (-16)
    
    Public Const ES_NUMBER = &H2000
    
    SetWindowLong txtItins.hwnd, GWL_STYLE, _
                              GetWindowLong(txtItins.hwnd, GWL_STYLE) Or _
                              ES_NUMBER
    

14. Sterge un fisier si-l pune in Recycle Bin

    Utilizare:

    Private Sub Command1_Click()
    Dim MyBool As Boolean
    MyBool = DelToRecycBin("c:\Myfile.txt")
    If MyBool = True Then
       MsgBox "Fisierul a fost sters! Il puteti recupera din Recycle Bin."
    Else
       MsgBox "Eroare la stergere!"
    End If
    End Sub
    

    Iar intr-un modul se pune:

    Private Type SHFILEOPSTRUCT
       hwnd As Long
       wFunc As Long
       pFrom As String
       pTo As String
       fFlags As Integer
       fAnyOperationsAborted As Boolean
       hNameMappings As Long
       lpszProgressTitle As String
    End Type
    Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" _
       (lpFileOp As SHFILEOPSTRUCT) As Long
    Private Const F0_DELETE = &H3
    Private Const F0F_ALLOWUNDO = &H40
    Private Const FOF_CREATEPROGRESSDLG As Long = &H0
    
    Public Function DelToRecycBin(FileName As String) As Boolean
    Dim FileOperation As SHFILEOPSTRUCT
    Dim lReturn As Long
    On Error GoTo DelToRecycBin_Err
    With FileOperation
        .wFunc = F0_DELETE
        .pFrom = FileName
        .fFlags = F0F_ALLOWUNDO + F0F_CREATEPROGRESSDLG
    End With
    lReturn = SHFileOperation(FileOperation)
    If lReturn <> 0 Then
        DelToRecycBin = False
    Else
        DelToRecycBin = True
    End If
    Exit Function
    DelToRecycBin_Err:
    DelToRecycBin = False
    MsgBox Err.Description
    End Function
    
    

15. Golesc Recycle Bin-ul

    Merge doar pe Win 98 sau pe Win 95 cu IE 4.0.

    Private Declare Function SHEmptyRecycleBin Lib "shell32" Alias "SHEmptyRecycleBinA" _
       (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
    
    Private Sub Form_Load()
    Call EmptyBin
    End Sub
    
    Private Sub EmptyBin(Optional drvBin As String)
    Dim r As Long
    Dim flags As Long
    If drvBin = "" Then
        drvBin = vbNullString 'sterge toate Cosurile de gunoi
    End If
    ' flags values
    ' 1. SHERB_NOCONFIRMATION  - No confirmation dialog box
    ' 2. SHERB_NOPROGRESSUI  - No progress indicator, i.e. flying rubbish AVI
    ' 3. SHERB_NOSOUND - No confirmation sound
    r = SHEmptyRecycleBin(Me.hwnd, drvBin, flags)
    End Sub
    

16. Calculez CRC32

    '// At top level of a module, always include to be sure that all variables have the right type
    Option Explicit
    Option Compare Text
    
    '// Then declare this array variable Crc32Table
    Private Crc32Table(255) As Long
    
    '// Then all we have to do is writing public functions like these...
    Public Function InitCrc32(Optional ByVal Seed As Long = &HEDB88320, _
      Optional ByVal Precondition As Long = &HFFFFFFFF) As Long
    
       '// Declare counter variable iBytes, counter variable iBits, value variables lCrc32 and lTempCrc32
       Dim iBytes As Integer, iBits As Integer, lCrc32 As Long, lTempCrc32 As Long
    
       '// Turn on error trapping
       On Error Resume Next
    
       '// Iterate 256 times
       For iBytes = 0 To 255
    
          '// Initiate lCrc32 to counter variable
          lCrc32 = iBytes
    
          '// Now iterate through each bit in counter byte
          For iBits = 0 To 7
             '// Right shift unsigned long 1 bit
             lTempCrc32 = lCrc32 And &HFFFFFFFE
             lTempCrc32 = lTempCrc32 \ &H2
             lTempCrc32 = lTempCrc32 And &H7FFFFFFF
    
             '// Now check if temporary is less than zero and then mix Crc32 checksum with Seed value
             If (lCrc32 And &H1) 0 Then
                lCrc32 = lTempCrc32 Xor Seed
             Else
                lCrc32 = lTempCrc32
             End If
          Next
    
          '// Put Crc32 checksum value in the holding array
          Crc32Table(iBytes) = lCrc32
       Next
    
       '// After this is done, set function value to the precondition value
       InitCrc32 = Precondition
    
    End Function
    
    '// The function above is the initializing function, now we have to write the computation function
    Public Function AddCrc32(ByVal Item As String, ByVal Crc32 As Long) As Long
    
       '// Declare following variables
       Dim bCharValue As Byte, iCounter As Integer, lIndex As Long
       Dim lAccValue As Long, lTableValue As Long
    
       '// Turn on error trapping
       On Error Resume Next
    
       '// Iterate through the string that is to be checksum-computed
       For iCounter = 1 To Len(Item)
    
          '// Get ASCII value for the current character
          bCharValue = Asc(Mid$(Item, iCounter, 1))
    
          '// Right shift an Unsigned Long 8 bits
          lAccValue = Crc32 And &HFFFFFF00
          lAccValue = lAccValue \ &H100
          lAccValue = lAccValue And &HFFFFFF
    
          '// Now select the right adding value from the holding table
          lIndex = Crc32 And &HFF
          lIndex = lIndex Xor bCharValue
          lTableValue = Crc32Table(lIndex)
    
          '// Then mix new Crc32 value with previous accumulated Crc32 value
          Crc32 = lAccValue Xor lTableValue
       Next
    
       '// Set function value the the new Crc32 checksum
       AddCrc32 = Crc32
    
    End Function
    
    '// At last, we have to write a function so that we can get the Crc32 checksum value at any time
    Public Function GetCrc32(ByVal Crc32 As Long) As Long
       '// Turn on error trapping
       On Error Resume Next
    
       '// Set function to the current Crc32 value
       GetCrc32 = Crc32 Xor &HFFFFFFFF
    
    End Function
    
    '// And for testing the routines above...
    Public Sub Main()
    
       Dim lCrc32Value As Long
    
       On Error Resume Next
       lCrc32Value = InitCrc32()
       lCrc32Value = AddCrc32("This is the original message!", lCrc32Value)
       Debug.Print Hex$(GetCrc32(lCrc32Value))
    
    End Sub
    

17. Obtin numele utilizatorului curent

    Private Declare Function w32_WNetGetUser Lib "mpr.dll" Alias "WNetGetUserA" _
      (ByVal lpszLocalName As String, ByVal lpszUserName As String, _
      lpcchBuffer As Long) As Long
    
    Private Sub Form_Load()
    Dim lpUserName As String, lpnLength As Long, lResult As Long
    lpUserName = String(256, Chr$(0))
    lResult = w32_WNetGetUser(vbNullString, lpUserName, 256)
    If lResult = 0 Then
    lpUserName = Left$(lpUserName, InStr(1, lpUserName, Chr$(0)) - 1)
    MsgBox "Numele utilizatorului conectat este: " + lpUserName + ".", _
       vbInformation + vbOKOnly, App.Title
    Else
    MsgBox "Nu gasesc !", vbExclamation + vbOKOnly, App.Title
    End If
    End Sub
    

18. Determina adresa IP si numele calculatorului cu 'winsock.dll'

    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$, HostLen&) As Long
       Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
     
       Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
        Function hibyte(ByVal wParam As Integer)
     
           hibyte = wParam \ &H100 And &HFF&
     
       End Function
     
       Function lobyte(ByVal wParam As Integer)
     
           lobyte = wParam And &HFF&
     
       End Function
     
       Sub SocketsInitialize()
       Dim WSAD As WSADATA
       Dim iReturn As Integer
       Dim sLowByte As String, sHighByte As String, sMsg As String
     
           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
     
       Sub SocketsCleanup()
       Dim lReturn As Long
     
           lReturn = WSACleanup()
     
           If lReturn <> 0 Then
               MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup """
               End
           End If
     
       End Sub
    
    Private Sub Command1_Click()
       Dim hostname As String * 256
       Dim hostent_addr As Long
       Dim host As HOSTENT
       Dim hostip_addr As Long
       Dim temp_ip_address() As Byte
       Dim i As Integer
       Dim ip_address As String
     
           If gethostname(hostname, 256) = SOCKET_ERROR Then
               MsgBox "Windows Sockets error " & Str(WSAGetLastError())
           Else
               hostname = Trim$(hostname)
           End If
     
           hostent_addr = gethostbyname(hostname)
     
           If hostent_addr = 0 Then
               MsgBox "Winsock.dll is not responding."
           End If
     
           RtlMoveMemory host, hostent_addr, LenB(host)
           RtlMoveMemory hostip_addr, host.hAddrList, 4
     
           ReDim temp_ip_address(1 To host.hLength)
           RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
     
           For i = 1 To host.hLength
               ip_address = ip_address & temp_ip_address(i) & "."
           Next
           ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
     
           MsgBox hostname
           MsgBox ip_address
     
    End Sub
    
    Private Sub Form_Load()
           SocketsInitialize
    End Sub
    
    Private Sub Form_Unload(Cancel As Integer)
       SocketsCleanup
    End Sub