سورس کدهای ویژوال بیسیک 6

این برنامه عدد رو میگیره و متن رو نمایش میده مثلا 13 >Thirteen

Task: Convert an integer number to text. For example, convert 13 to Thirteen. Converts numbers from 0 to 9999999.

Code:

' Convert an integer into an English string
Function English(ByVal N As Long) As String
    Const Thousand = 1000&
    Const Million = Thousand * Thousand
    Const Billion = Thousand * Million
    'Const Trillion = Thousand * Billion

    Dim Buf As String: Buf = ""

    If (N = 0) Then English = "zero": Exit Function

    If (N < 0) Then Buf = "negative ": N = -N

    If (N >= Billion) Then
        Buf = Buf & EnglishDigitGroup(N \ Billion) & " billion"
        N = N Mod Billion
        If (N) Then Buf = Buf & " "
    End If

    If (N >= Million) Then
        Buf = Buf & EnglishDigitGroup(N \ Million) & " million"
        N = N Mod Million
        If (N) Then Buf = Buf & " "
    End If

    If (N >= Thousand) Then
        Buf = Buf & EnglishDigitGroup(N \ Thousand) & " thousand"
        N = N Mod Thousand
        If (N) Then Buf = Buf & " "
    End If

    If (N > 0) Then
        Buf = Buf & EnglishDigitGroup(N)
    End If

    English = Buf
End Function

' Support function to be used only by English()
Private Function EnglishDigitGroup(ByVal N As Integer) As String
    Const Hundred = " hundred"
    Const One = "one"
    Const Two = "two"
    Const Three = "three"
    Const Four = "four"
    Const Five = "five"
    Const Six = "six"
    Const Seven = "seven"
    Const Eight = "eight"
    Const Nine = "nine"
    Dim Buf As String: Buf = ""
    Dim Flag As Integer: Flag = False

    'Do hundreds
    Select Case (N \ 100)
    Case 0: Buf = "":  Flag = False
    Case 1: Buf = One & Hundred: Flag = True
    Case 2: Buf = Two & Hundred: Flag = True
    Case 3: Buf = Three & Hundred: Flag = True
    Case 4: Buf = Four & Hundred: Flag = True
    Case 5: Buf = Five & Hundred: Flag = True
    Case 6: Buf = Six & Hundred: Flag = True
    Case 7: Buf = Seven & Hundred: Flag = True
    Case 8: Buf = Eight & Hundred: Flag = True
    Case 9: Buf = Nine & Hundred: Flag = True
    End Select

    If (Flag) Then N = N Mod 100
    If (N) Then
        If (Flag) Then Buf = Buf & " "
    Else
        EnglishDigitGroup = Buf
        Exit Function
    End If

    'Do tens (except teens)
    Select Case (N \ 10)
    Case 0, 1: Flag = False
    Case 2: Buf = Buf & "twenty": Flag = True
    Case 3: Buf = Buf & "thirty": Flag = True
    Case 4: Buf = Buf & "forty": Flag = True
    Case 5: Buf = Buf & "fifty": Flag = True
    Case 6: Buf = Buf & "sixty": Flag = True
    Case 7: Buf = Buf & "seventy": Flag = True
    Case 8: Buf = Buf & "eighty": Flag = True
    Case 9: Buf = Buf & "ninety": Flag = True
    End Select

    If (Flag) Then N = N Mod 10
    If (N) Then
        If (Flag) Then Buf = Buf & "-"
    Else
        EnglishDigitGroup = Buf
        Exit Function
    End If

    'Do ones and teens
    Select Case (N)
    Case 0: ' do nothing
    Case 1: Buf = Buf & One
    Case 2: Buf = Buf & Two
    Case 3: Buf = Buf & Three
    Case 4: Buf = Buf & Four
    Case 5: Buf = Buf & Five
    Case 6: Buf = Buf & Six
    Case 7: Buf = Buf & Seven
    Case 8: Buf = Buf & Eight
    Case 9: Buf = Buf & Nine
    Case 10: Buf = Buf & "ten"
    Case 11: Buf = Buf & "eleven"
    Case 12: Buf = Buf & "twelve"
    Case 13: Buf = Buf & "thirteen"
    Case 14: Buf = Buf & "fourteen"
    Case 15: Buf = Buf & "fifteen"
    Case 16: Buf = Buf & "sixteen"
    Case 17: Buf = Buf & "seventeen"
    Case 18: Buf = Buf & "eighteen"
    Case 19: Buf = Buf & "nineteen"
    End Select

    EnglishDigitGroup = Buf
End Function

Task: Convert a decimal number to a radian, or a radian to decimal

Code:

Function Rad2Dec(rads As Long)
     Rad2Dec = ((rads * 180) / 3.141592654)
End Function


Function Dec2Rad(decs As Long)
     Dec2Rad = ((decs * 3.141592654) / 180)
End Function

Task: Add a rectangular gradient to a form.

Code:

Sub RectGradient(frm As Form, rs%, gs%, bs%, re%, ge%, be%, smooth As Boolean)

    If frm.WindowState = vbMinimized Then Exit Sub
    frm.BackColor = RGB(re, ge, be)
    If smooth = True Then
        frm.DrawStyle = 6
    Else
        frm.DrawStyle = 0
    End If
    If frm.ScaleWidth <> 255 Then
        frm.ScaleWidth = 255
    End If
    If frm.ScaleHeight <> 255 Then
        frm.ScaleHeight = 255
    End If
    frm.DrawWidth = 5
    frm.Refresh
    ri = (rs - re) / 255
    gi = (gs - ge) / 255
    bi = (bs - be) / 255
    rc = rs: bc = bs: gc = gs
    For X = 255 To 0 Step -1
        DoEvents
        frm.Line ((X / 2), (X / 2))-(frm.ScaleWidth - (X / 2), frm.ScaleHeight - (X / 2)), RGB(rc, gc, bc), B
        rc = rc - ri
        gc = gc - gi
        bc = bc - bi
    Next X
End Sub

'Sample for using this routine
Private Sub Form_Resize()
    RectGradient Form1, 111, 111, 222, 222, 255, 255, True
End Sub

Task: Add a graffiti effect to a form.

Code:

Sub lines(frm As Form)
    If frm.WindowState = vbMinimized Then Exit Sub
    frm.BackColor = vbBlack
    frm.ScaleHeight = 100
    frm.ScaleWidth = 100
    For X = 0 To 300
        DoEvents
        X1 = Int(Rnd * 101)
        X2 = Int(Rnd * 101)
        Y1 = Int(Rnd * 101)
        Y2 = Int(Rnd * 101)
        colo = Int(Rnd * 15)
        frm.Line (X1, Y1)-(X2, Y2), QBColor(colo)
        frm.Line (X1, Y2)-(X2, Y1), QBColor(colo)
        frm.Line (X2, Y1)-(X1, Y2), QBColor(colo)
        frm.Line (Y1, Y2)-(X1, X2), QBColor(colo)
    Next X
End Sub

Private Sub Command1_Click()
Me.Cls
Call lines(Me)
End Sub

Task: Reading / Writing any Registry Key

Declarations:

' module declarations

Public Const READ_CONTROL = &H20000
Public Const STANDARD_RIGHTS_READ = (READ_CONTROL)
Public Const STANDARD_RIGHTS_WRITE = (READ_CONTROL)
Public Const KEY_QUERY_VALUE = &H1
Public Const KEY_SET_VALUE = &H2
Public Const KEY_CREATE_SUB_KEY = &H4
Public Const KEY_ENUMERATE_SUB_KEYS = &H8
Public Const KEY_NOTIFY = &H10
Public Const KEY_CREATE_LINK = &H20
Public Const SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_ALL = &H1F0000
Public Const KEY_READ = ((STANDARD_RIGHTS_READ Or _
   KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) _
   And (Not SYNCHRONIZE))
Public Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or _
   KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or _
   KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY _
   Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) _
   And (Not SYNCHRONIZE))
Public Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))

Public Const ERROR_SUCCESS = 0&

Declare Function RegOpenKeyEx Lib "advapi32.dll" _
   Alias "RegOpenKeyExA" (ByVal hKey As Long, _
   ByVal lpSubKey As String, ByVal ulOptions As Long, _
   ByVal samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" _
   Alias "RegQueryValueExA" (ByVal hKey As Long, _
   ByVal lpValueName As String, ByVal lpReserved As Long, _
   lpType As Long, lpData As Any, lpcbData As Long) As Long
Declare Function RegCloseKey Lib "advapi32.dll" _
   (ByVal hKey As Long) As Long


Function sdaGetRegEntry(strKey As String, _
   strSubKeys As String, strValName As String, _
   lngType As Long) As String
'  Demonstration of win32 API's to query
'  the system registry


On Error GoTo sdaGetRegEntry_Err

  Dim lngResult As Long, lngKey As Long
  Dim lngHandle As Long, lngcbData As Long
  Dim strRet As String

  Select Case strKey
    Case "HKEY_CLASSES_ROOT": lngKey = &H80000000
    Case "HKEY_CURRENT_CONFIG": lngKey = &H80000005
    Case "HKEY_CURRENT_USER": lngKey = &H80000001
    Case "HKEY_DYN_DATA": lngKey = &H80000006
    Case "HKEY_LOCAL_MACHINE": lngKey = &H80000002
    Case "HKEY_PERFORMANCE_DATA": lngKey = &H80000004
    Case "HKEY_USERS": lngKey = &H80000003
    Case Else: Exit Function
  End Select
    
  If Not ERROR_SUCCESS = RegOpenKeyEx(lngKey, _
     strSubKeys, 0&, KEY_READ, _
     lngHandle) Then Exit Function
  
  lngResult = RegQueryValueEx(lngHandle, strValName, _
     0&, lngType, ByVal strRet, lngcbData)
  strRet = Space(lngcbData)
  lngResult = RegQueryValueEx(lngHandle, strValName, _
     0&, lngType, ByVal strRet, lngcbData)
  
  If Not ERROR_SUCCESS = RegCloseKey(lngHandle) Then _
     lngType = -1&
    
  sdaGetRegEntry = strRet
  
sdaGetRegEntry_Exit:
  On Error GoTo 0
  Exit Function

sdaGetRegEntry_Err:
  lngType = -1&
  MsgBox Err & ">  " & Error$, 16, _
     "GenUtils/sdaGetRegEntry"
  Resume sdaGetRegEntry_Exit

End Function

Code:

Dim lngType As Long, varRetString As Variant
  Dim lngI As Long, intChar As Integer

  varRetString = sdaGetRegEntry(cboStartKey, _
   txtRegistrationPath, txtRegistrationParameter, _
   lngType)
  
  txtResult = varRetString
  txtDataType = lngType
  txtDataLength = Len(varRetString)
    
  txtHex = ""
  If Len(varRetString) Then
    For lngI = 1 To Len(varRetString)
      intChar = Asc(Mid(varRetString, lngI, 1))
      If intChar > 15 Then
        txtHex = txtHex & Hex(intChar) & " "
      Else
        txtHex = txtHex & "0" & Hex(intChar) & " "
      End If
    Next lngI
  End If

Task: Calls the "Open File Dialog" without need for an OCX

Declarations:

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Code:

'Place the following code in under a command button or in a menu, etc...

    Dim ofn As OPENFILENAME
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = Form1.hWnd
    ofn.hInstance = App.hInstance
    ofn.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "Rich Text Files (*.rtf)" + Chr$(0) + "*.rtf" + Chr$(0)
        ofn.lpstrFile = Space$(254)
        ofn.nMaxFile = 255
        ofn.lpstrFileTitle = Space$(254)
        ofn.nMaxFileTitle = 255
        ofn.lpstrInitialDir = curdir
        ofn.lpstrTitle = "Our File Open Title"
        ofn.flags = 0
        Dim a
        a = GetOpenFileName(ofn)

        If (a) Then
                MsgBox "File to Open: " + Trim$(ofn.lpstrFile)
        Else
                MsgBox "Cancel was pressed"
        End If

Task: Copy the entire contents of a PictureBox to the clipboard

Declarations:

' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 7/10/98
' * Time             : 16:59
' * Module Name      : Clipboard_Module
' * Module Filename  : Clipboard.bas
' **********************************************************************
' * Comments         : Clipboard functions
' *
' *
' **********************************************************************

Option Explicit

' General functions:
Private Type RECT
   Left     As Long
   Top      As Long
   Right    As Long
   Bottom   As Long
End Type

' GDI functions:
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 Const SRCCOPY = &HCC0020 ' (DWORD) dest = source

' Creates a memory DC
Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long

' Creates a bitmap in memory:
Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

' Places a GDI Object into DC, returning the previous one:
Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

' Deletes a GDI Object:
Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

' Clipboard functions:
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CountClipboardFormats Lib "user32" () As Long
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

' Memory functions:
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Public Enum EPredefinedClipboardFormatConstants
   [_First] = 1
   CF_TEXT = 1
   CF_BITMAP = 2
   CF_METAFILEPICT = 3
   CF_SYLK = 4
   CF_DIF = 5
   CF_TIFF = 6
   CF_OEMTEXT = 7
   CF_DIB = 8
   CF_PALETTE = 9
   CF_PENDATA = 10
   CF_RIFF = 11
   CF_WAVE = 12
   CF_UNICODETEXT = 13
   CF_ENHMETAFILE = 14
   CF_HDROP = 15
   CF_LOCALE = 16
   CF_MAX = 17
   [_Last] = 17
End Enum

Code:

Public Function CopyEntirePictureToClipboard(ByRef objFrom As Object) As Boolean
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 7/10/98
   ' * Time             : 16:59
   ' * Module Name      : Clipboard_Module
   ' * Module Filename  : Clipboard.bas
   ' * Procedure Name   : CopyEntirePictureToClipboard
   ' * Parameters       :
   ' *                    ByRef objFrom As Object
   ' **********************************************************************
   ' * Comments         : Copy the entire contents of a PictureBox to the clipboard
   ' *
   ' *
   ' **********************************************************************
   
   Dim lhDC       As Long
   Dim lhBmp      As Long
   Dim lhBmpOld   As Long

   ' Create a DC compatible with the object we're copying
   ' from:
   lhDC = CreateCompatibleDC(objFrom.hdc)
   If (lhDC <> 0) Then
      ' Create a bitmap compatible with the object we're
      ' copying from:
      lhBmp = CreateCompatibleBitmap(objFrom.hdc, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY)
      If (lhBmp <> 0) Then
         ' Select the bitmap into the DC we have created,
         ' and store the old bitmap that was there:
         lhBmpOld = SelectObject(lhDC, lhBmp)

         ' Copy the contents of objFrom to the bitmap:
         BitBlt lhDC, 0, 0, objFrom.ScaleWidth \ Screen.TwipsPerPixelX, objFrom.ScaleHeight \ Screen.TwipsPerPixelY, objFrom.hdc, 0, 0, SRCCOPY

         ' Remove the bitmap from the DC:
         SelectObject lhDC, lhBmpOld

         ' Now set the clipboard to the bitmap:
         EmptyClipboard
         OpenClipboard 0
         SetClipboardData CF_BITMAP, lhBmp
         CloseClipboard

         ' We don't delete the Bitmap here - it is now owned
         ' by the clipboard and Windows will delete it for us
         ' when the clipboard changes or the program exits.
      End If

      ' Clear up the device context we created:
      DeleteObject lhDC
      
      CopyEntirePictureToClipboard = True
      
   Else
      CopyEntirePictureToClipboard = False
      
   End If

End Function

Task: Create a ying yang form

Declarations:

' #VBIDEUtils#************************************************************
' * Programmer Name  : Thomas Detoux
' * Web Site         : http://www.vbasic.org/
' * E-Mail           : Detoux@hol.Fr
' * Date             : 8/12/98
' * Time             : 14:41
' * Module Name      : WingWang_Module
' * Module Filename  : YingYang.bas
' **********************************************************************
' * Comments         : Create YING YANG forms
' *  Sample of call
' *    Call YingYang(Me)
' *
' *
' **********************************************************************

Option Explicit

'Créé une region en forme de rectangle entre les points (X1,Y1) et (X2,Y2)
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Créé une région en forme d'éllipse entre les points (X1,Y1) et (X2,Y2)
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'Combine deux régions pour en créer unr troisième selon le mode nCombineMode
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

'Supprime un objet et libère de la mémoire
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

'Créé une feuille ayant la forme d'une région
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'Constantes pour CombineRgn
Private Const RGN_AND = 1        'Intersection des deux régions
Private Const RGN_OR = 2         'Addition des deux régions
Private Const RGN_XOR = 3        'Difficile à décrire ... essayez
'En fait, c'est un XOR : l'addition des 2 régions
'en retirant les parties communes aux 2 régions
Private Const RGN_DIFF = 4       'Soustraction de la région 2 à la région 1
Private Const RGN_COPY = 5       'Copie la région 1

Private YY As Long

Code:

' #VBIDEUtils#************************************************************
' * Programmer Name  : Thomas Detoux
' * Web Site         : http://www.vbasic.org/
' * E-Mail           : Detoux@hol.Fr
' * Date             : 8/12/98
' * Time             : 14:41
' * Module Name      : WingWang_Module
' * Module Filename  : YingYang.bas
' **********************************************************************
' * Comments         : Create YING YANG forms
' *  Sample of call
' *    Call YingYang(Me)
' *
' *
' **********************************************************************
Public Sub YingYang(obj As Form)
   
   'Déclaration des différents "handles" des différentes "régions" de la feuille, qui, réunies, formeront le Ying Yang
   Dim Cercle        As Long
   Dim Rect          As Long
   Dim PCercleH      As Long
   Dim PCercleB      As Long
   Dim HCercle       As Long
   Dim Cadre         As Long
   Dim TrouB         As Long
   Dim TrouH         As Long
   Dim CercleBis     As Long
   Dim HCercleBis    As Long
   Dim CercleBisBis  As Long
   Dim Ying_Yang     As Long
   Dim YYang         As Long
   
   Dim H             As Long
   Dim L             As Long
   Dim HBord         As Long
   Dim LBord         As Long
   Dim HT            As Long
   Dim LT            As Long
   
   H = obj.Height / Screen.TwipsPerPixelY
   L = obj.Width / Screen.TwipsPerPixelX
   
   HBord = Int(H / 100)
   LBord = Int(L / 100)
   
   HT = Int(H / 10)
   LT = Int(L / 10)
   
   'Création des différentes "régions", et combinaisons entre elles
   'Attention : pour réaliser une combinaison, la variable-région de destination
   'doit déjà avoir été intialisée en lui affectant une région auparavant.
   
   HCercle = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, ((H - (2 * HBord)) / 2) + HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), (H - HBord))
   Cercle = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
   Rect = CreateRectRgn(L / 2, 0, L, H)
   CombineRgn HCercle, Cercle, Rect, RGN_DIFF
   
   HCercleBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
   PCercleB = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, ((H - (2 * HBord)) / 2) + HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), (H - HBord))
   CombineRgn HCercleBis, HCercle, PCercleB, RGN_DIFF
   
   CercleBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
   PCercleH = CreateEllipticRgn(((L - (2 * LBord)) / 4) + LBord, HBord, 3 * (((L - (2 * LBord)) / 4) + LBord), ((H - (2 * HBord)) / 2) + HBord)
   CombineRgn CercleBis, Cercle, PCercleH, RGN_DIFF
   
   CercleBisBis = CreateEllipticRgn(LBord, HBord, L - LBord, H - HBord)
   HCercle = CreateEllipticRgn(0, 0, L, H)
   CombineRgn CercleBisBis, CercleBis, HCercleBis, RGN_DIFF
   
   Ying_Yang = CreateEllipticRgn(0, 0, L, H)
   Cadre = CreateEllipticRgn(0, 0, L, H)
   CombineRgn Ying_Yang, Cadre, CercleBisBis, RGN_DIFF
   
   YYang = CreateEllipticRgn(0, 0, L, H)
   TrouB = CreateEllipticRgn(((L - (2 * LBord)) / 2) + LBord - (LT / 2), ((3 * (H - (2 * HBord)) / 4)) + HBord - (HT / 2), ((L - (2 * LBord)) / 2) + LBord + (LT / 2), ((3 * (H - (2 * HBord)) / 4)) + HBord + (HT / 2))
   CombineRgn YYang, Ying_Yang, TrouB, RGN_OR
   
   YY = CreateEllipticRgn(0, 0, L, H)
   TrouH = CreateEllipticRgn(((L - (2 * LBord)) / 2) + LBord - (LT / 2), ((H - (2 * HBord)) / 4) + HBord - (HT / 2), ((L - (2 * LBord)) / 2) + LBord + (LT / 2), ((H - (2 * HBord)) / 4) + HBord + (HT / 2))
   CombineRgn YY, YYang, TrouH, RGN_DIFF
   
   SetWindowRgn obj.hwnd, YY, True 'Applique la région finale à la feuille
   
   'Suppression des régions
   DeleteObject Cercle
   DeleteObject Rect
   DeleteObject PCercleH
   DeleteObject PCercleB
   DeleteObject HCercle
   DeleteObject Cadre
   DeleteObject TrouB
   DeleteObject TrouH
   DeleteObject CercleBis
   DeleteObject HCercleBis
   DeleteObject CercleBisBis
   DeleteObject Ying_Yang
   DeleteObject YYang

End Sub

با این کد میتونیدزبان کیبورد رو از فارسی به انگلیسی و برعکس تغییر بدید خیلی تو برنامه ها بدرد میخوره

Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long

Private Sub Text1_Click()
LoadKeyboardLayout "00000429", 1 'FA
End Sub

Private Sub Text2_Click()
LoadKeyboardLayout "00000409", 1 'EN
End Sub

:winksmiley02:

Task: Change size and location of controls On your form

' #VBIDEUtils#************************************************************
' * Programmer Name  : Mikhail Shmukler
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 13/10/98
' * Time             : 10:24
' * Module Name      : class_Elastic
' * Module Filename  : Elastic.cls
' **********************************************************************
' * Comments         :
' * This class can change size and location of controls On your form
' * 1. Resize form
' * 2. Change screen resolution
' * Assumes:1. Add Elastic.cls
' *         2. Add declaration 'Private El as New class_Elastic'
' *         3. Insert string like 'El.init Me' (formload event)
' *         4. Insert string like 'El.FormResize Me' (Resize event)
' *         5. Press 'F5' and resize form ....
'
'****************************************************************

Option Explicit
Private nFormHeight      As Integer
Private nFormWidth       As Integer
Private nNumOfControls   As Integer
Private nTop()           As Integer
Private nLeft()          As Integer
Private nHeight()        As Integer
Private nWidth()         As Integer
Private nFontSize()      As Integer
Private nRightMargin()   As Integer
Private bFirstTime       As Boolean

Sub Init(frm As Form, Optional nWindState As Variant)
   
   Dim I          As Integer
   Dim bWinMax    As Boolean
   
   bWinMax = Not IsMissing(nWindState)
   
   nFormHeight = frm.Height
   nFormWidth = frm.Width
   nNumOfControls = frm.Controls.Count - 1
   bFirstTime = True
   ReDim nTop(nNumOfControls)
   ReDim nLeft(nNumOfControls)
   ReDim nHeight(nNumOfControls)
   ReDim nWidth(nNumOfControls)
   ReDim nFontSize(nNumOfControls)
   
   ReDim nRightMargin(nNumOfControls)
   On Error Resume Next
   For I = 0 To nNumOfControls
      If TypeOf frm.Controls(I) Is Line Then
         nTop(I) = frm.Controls(I).Y1
         nLeft(I) = frm.Controls(I).X1
         nHeight(I) = frm.Controls(I).Y2
         nWidth(I) = frm.Controls(I).X2
      Else
         nTop(I) = frm.Controls(I).Top
         nLeft(I) = frm.Controls(I).Left
         nHeight(I) = frm.Controls(I).Height
         nWidth(I) = frm.Controls(I).Width
         nFontSize(I) = frm.FontSize
         nRightMargin(I) = frm.Controls(I).RightMargin
      End If
   Next
   
   If bWinMax Or frm.WindowState = 2 Then ' maxim
      frm.Height = Screen.Height
      frm.Width = Screen.Width
   Else
      frm.Height = frm.Height * Screen.Height / 7290
      frm.Width = frm.Width * Screen.Width / 9690
   End If
   
   bFirstTime = True
   
End Sub

Sub FormResize(frm As Form)
   
   Dim I             As Integer
   Dim nCaptionSize  As Integer
   Dim dRatioX       As Double
   Dim dRatioY       As Double
   Dim nSaveRedraw   As Long
   
   On Error Resume Next
   nSaveRedraw = frm.AutoRedraw
   
   frm.AutoRedraw = True
   
   If bFirstTime Then
      bFirstTime = False
      Exit Sub
   End If
   
   If frm.Height < nFormHeight / 2 Then frm.Height = nFormHeight / 2
   
   If frm.Width < nFormWidth / 2 Then frm.Width = nFormWidth / 2
   nCaptionSize = 400
   dRatioY = 1# * (nFormHeight - nCaptionSize) / (frm.Height - nCaptionSize)
   dRatioX = 1# * nFormWidth / frm.Width
   On Error Resume Next ' for comboboxes, timeres and other nonsizible controls
   
   For I = 0 To nNumOfControls
      If TypeOf frm.Controls(I) Is Line Then
         frm.Controls(I).Y1 = Int(nTop(I) / dRatioY)
         frm.Controls(I).X1 = Int(nLeft(I) / dRatioX)
         frm.Controls(I).Y2 = Int(nHeight(I) / dRatioY)
         frm.Controls(I).X2 = Int(nWidth(I) / dRatioX)
      Else
         frm.Controls(I).Top = Int(nTop(I) / dRatioY)
         frm.Controls(I).Left = Int(nLeft(I) / dRatioX)
         frm.Controls(I).Height = Int(nHeight(I) / dRatioY)
         frm.Controls(I).Width = Int(nWidth(I) / dRatioX)
         frm.Controls(I).FontSize = Int(nFontSize(I) / dRatioX) + Int(nFontSize(I) / dRatioX) Mod 2
         frm.Controls(I).RightMargin = Int(nRightMargin(I) / dRatioY)
      End If
   Next
   
   frm.AutoRedraw = nSaveRedraw
   
End Sub

Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 13/10/98
' * Time             : 10:24
' * Module Name      : Form_Module
' * Module Filename  : Form.bas
' **********************************************************************
' * Comments         : Display forms within a form
' * 
' **********************************************************************

SetParent(Me.hWnd, Form1.hWnd)

Task: File I/O using API calls

Declarations

Option Explicit

'Reads input from the file
Declare Function ReadFile Lib "kernel32" _
    (ByVal hFile As Long, lpBuffer As Any, _
    ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _
    ByVal lpOverlapped As Long) As Long

'Closes the file
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

'Outputs to the file
Private Declare Function WriteFile Lib "kernel32" _
    (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, _
    lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long

'Opens the file (grabs a file handle)
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _
    (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _
    ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, _
    ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _
    ByVal hTemplateFile As Long) As Long

'Output the data on hold to the file
Declare Function FlushFileBuffers Lib "kernel32" _
    (ByVal hFile As Long) As Long

'Find out how big the file is
Declare Function GetFileSize Lib "kernel32" _
    (ByVal hFile As Long, lpFileSizeHigh As Long) As Long

Const GENERIC_WRITE = &H40000000
Const GENERIC_READ = &H80000000
Const FILE_ATTRIBUTE_NORMAL = &H80
Const CREATE_ALWAYS = 2
Const OPEN_ALWAYS = 4
Const INVALID_HANDLE_VALUE = -1
 
'This array type must be used to print and read to the file
Type FileString
   Value As Integer
End Type

Private minFileCount As Integer     'Number of files open
Private mblFileInput() As Boolean   'If the file has been read in yet
Private mlgFileCursor() As Long     'The current position of the cursor in the file
Private mlgFileHandles() As Long    'List of file handles opened
Private mstFileData() As String     'Data inputted from a file

Code

'----------
'Main: Main code startup
'----------
Public Sub Main()
On Error GoTo ErrorHandler
    
    Dim linFile As Integer  'File number to reference file
    Dim lstInput As String  'Input from file
    
    'Grab a file number using a function to simplify the API call
    linFile = OpenFile("C:\Filename.txt")
    If linFile = -1 Then Err.Raise 1234, , "OpenFile failed"
    
    'Print text to the file
    PrintLine linFile, "Hello World"
        
    'Close the file
    If CloseFile(linFile) = -1 Then Err.Raise 1234, , "CloseFile failed"
    
    'Open the file
    linFile = OpenFile("C:\Filename.txt")
    If linFile = -1 Then Err.Raise 1234, , "OpenFile failed"
    
    'Input the text from the file
    InputLine linFile, lstInput
    
    'Close the file
    If CloseFile(linFile) = -1 Then Err.Raise 1234, , "CloseFile failed"

    Exit Sub
    
ErrorHandler:
    App.LogEvent "modMain.CECMain():" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Sub

'----------
'PrintLine: Output text to a file
'----------
Private Sub PrintLine(ByVal inFile As Integer, ByVal stOutput As String)
On Error GoTo ErrorHandler

    Dim x As Integer            'Iterative
    Dim linLen As Integer       'Length of string
    Dim llgFileHandle As Long   'File Handle to reference file by
    Dim llgSuccess As Long      'If the Write was successful
    Dim llgBytesWritten As Long 'Number of bytes written
    Dim llgBytesToWrite As Long 'Length of string
    Dim lfsOut() As FileString  'ASCII Chars to output

    'Check for valid filename
    If Not ((inFile > 0) And (inFile <= minFileCount)) Then
        Err.Raise 123, , "Bad File Number"
    End If

    'Convert the string to an array of character #s
    linLen = Len(stOutput)
    ReDim lfsOut(linLen + 1)
    For x = 1 To linLen
        lfsOut(x - 1).Value = Asc(Mid$(stOutput, x, 1))
    Next x
    
    'Append Carriage Return + Line Feed
    lfsOut(linLen).Value = Asc(vbCr)
    lfsOut(linLen + 1).Value = Asc(vbLf)

    'Get the number of bytes to write
    llgBytesToWrite = (UBound(lfsOut) + 1) * LenB(lfsOut(0))

    'Grab the file handle
    llgFileHandle = mlgFileHandles(inFile - 1)

    'Write the data to the file
    llgSuccess = WriteFile(llgFileHandle, lfsOut(LBound(lfsOut)), _
        llgBytesToWrite, llgBytesWritten, 0)

    Exit Sub
    
ErrorHandler:
    App.LogEvent "modMain.PrintLine(" & inFile & "," & stOutput & "):" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Sub

'----------
'OpenFile: Open a file and store the File Handle
'----------
Private Function OpenFile(ByVal stFileName As String) As Integer
On Error GoTo ErrorHandler

    Dim linFile As Integer  'File number
    Dim x As Integer        'Iterative variable
    Dim llgFile As Long     'File Handle
    
    'Open the file
    llgFile = CreateFile(stFileName, GENERIC_WRITE Or GENERIC_READ, _
        0, 0, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)

    'If the file handle is valid
    If llgFile <> -1 Then
        'Look to see if there are empty spaces in the file list
        For x = 1 To minFileCount - 1
            If mlgFileHandles(x) = 0 Then
                linFile = x
                Exit For
            End If
        Next x
        'If there are empty spaces then fill one
        If linFile = 0 Then linFile = minFileCount
        'If no empty spaces then make a new one
        If linFile = minFileCount Then
            ReDim Preserve mlgFileHandles(linFile)
            ReDim Preserve mblFileInput(linFile)
            ReDim Preserve mstFileData(linFile)
            ReDim Preserve mlgFileCursor(linFile)
        End If
        mlgFileHandles(linFile) = llgFile
        'Increment the counter
        If linFile = minFileCount Then minFileCount = minFileCount + 1
        linFile = linFile + 1
    Else
        linFile = -1
    End If
    OpenFile = linFile
'
    Exit Function
    
ErrorHandler:
    App.LogEvent "modMain.OpenFile(" & stFileName & "):" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Function

'----------
'CloseFile: Close a file and free up the file handle
'----------
Private Function CloseFile(ByVal inFile As Integer) As Integer
On Error GoTo ErrorHandler
    
    Dim llgFile As Long     'File Handle
    Dim llgResult As Long   'Result of operations

    llgFile = mlgFileHandles(inFile - 1)

    'Flush the file buffers to force writing of the data.
    llgResult = FlushFileBuffers(llgFile)
    'Close the file.
    llgResult = CloseHandle(llgFile)
    mlgFileHandles(inFile - 1) = 0
    mblFileInput(inFile - 1) = False
    mstFileData(inFile - 1) = ""
    mlgFileCursor(inFile - 1) = 0
    'If it is the last file in the list take back the arrays 1
    If (inFile = minFileCount) Then
        minFileCount = minFileCount - 1
        If inFile <> 1 Then
            ReDim Preserve mlgFileHandles(minFileCount - 1)
            ReDim Preserve mblFileInput(minFileCount - 1)
            ReDim Preserve mstFileData(minFileCount - 1)
            ReDim Preserve mlgFileCursor(minFileCount - 1)
        End If
    End If

    Exit Function
    
ErrorHandler:
    App.LogEvent "modMain.CloseFile(" & inFile & "):" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Function

'----------
'InputLine: Input a line of text from a file
'----------
Public Sub InputLine(ByVal inFile As Integer, stInput As String)
On Error GoTo ErrorHandler

    Dim lblCr As Boolean    'A Carriage return was found
    Dim lblLf As Boolean    'A Line feed was found
    Dim x As Integer        'Iterative variable
    Dim llgCursor As Long   'Current cursor position in file
    Dim lstChar As String   'Current character at current position
    Dim lstFile As String   'File string inputted
    
    'Empty the inputted string
    stInput = ""

    'Read in the entire file if it hasn't already been done
    If Not (mblFileInput(inFile - 1)) Then
        InputFile inFile
    End If
    
    'If the file read didn't take, error out.
    If Not (mblFileInput(inFile - 1)) Then Err.Raise 123, , "File Input Failed"
    
    'Set up the positioning variables
    llgCursor = mlgFileCursor(inFile - 1)
    lstFile = mstFileData(inFile - 1)
    If llgCursor = 0 Then llgCursor = 1
    
    'Read in until a vbCrLf is found
    For x = llgCursor To Len(lstFile)
        lstChar = Mid$(lstFile, x, 1)
        Select Case lstChar
            Case vbCr: lblCr = True
            Case vbLf: lblLf = True
            Case Else: lblCr = False: lblLf = False
        End Select
        If lblCr And lblLf Then
            Exit For
        ElseIf Not (lblCr Or lblLf) Then
            stInput = stInput & lstChar
        End If
    Next x
    
    'Save the cursor for next time
    mlgFileCursor(inFile - 1) = x

    Exit Sub
    
ErrorHandler:
    App.LogEvent "modMain.InputLine(" & inFile & "," & stInput & "):" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Sub

'----------
'PrintLine: Output text to a file
'----------
Private Sub InputFile(ByVal inFile As Integer)
On Error GoTo ErrorHandler

    Dim x As Integer            'Iterative variable
    Dim y As Integer            'Iterative variable
    Dim z As Integer            'Iterative variable
    Dim llgFile As Long         'File Handle
    Dim llgSizeHigh As Long     'Biggest file size??
    Dim llgSuccess As Long      'If operation was successful = 1
    Dim llgBytesRead As Long    'Number of bytes read successfully
    Dim llgBytesToRead As Long  'Number of bytes to read from the file
    Dim lstChar1 As String      'Character1 if 2 chars were read in
    Dim lstChar2 As String      'Character2 if 2 chars were read in
    Dim lstFile As String       'Entire file string
    Dim lfsIn() As FileString   'File character # input array
          
    'Grab the file handle from the list
    llgFile = mlgFileHandles(inFile - 1)

    'Find out how big the file is
    llgBytesToRead = GetFileSize(llgFile, llgSizeHigh)
    'Set the array up to read that many bytes
    ReDim lfsIn(llgBytesToRead)
    'Read in all the data in the file
    llgSuccess = ReadFile(llgFile, lfsIn(LBound(lfsIn)), _
                        llgBytesToRead, llgBytesRead, 0)
    'Make sure it's not empty
    y = lfsIn(0).Value
    'Loop through and get all the data
    While (y <> 0) And (x <= UBound(lfsIn))
        y = lfsIn(x).Value
        'If 2 chars were read in, y = char1 + char2
        'char1 = Chr#, char2 = Chr#*256
        If y > 256 Then
            'Figure out what the second character is
            For z = 1 To 256
                If y < (z * 256) Then
                    lstChar1 = y - ((z - 1) * 256)
                    lstChar2 = (y - lstChar1) / 256
                    lstFile = lstFile & Chr(lstChar1) & Chr(lstChar2)
                    Exit For
                End If
            Next z
        'If 1 char was read in, y = Chr#
        ElseIf y > 0 Then
            lstFile = lstFile & Chr(y)
        End If
       x = x + 1
    Wend

    'If it was all successful then save the file data in the module variables
    If llgSuccess = 1 Then
        mstFileData(inFile - 1) = lstFile
        mblFileInput(inFile - 1) = True
    End If
    
    Exit Sub
    
ErrorHandler:
    App.LogEvent "modMain.InputFile(" & inFile & "):" & Err.Description & ":" & Err.Number, 1
    Err.Clear
End Sub

Task: Make any VB form stay always on top of every other Window form.

Declarations

'------------------------------'
'         CaptiveX TM.         '
'   Writen by nofx (op-ivy)    '
'http://www.sharpnet.net/~nofx/'
'or visit us on EFNET #captivex'
'             P.S.             '
'           Have Fun           '
'------------------------------'

#If Win32 Then
Public Const HWND_TOPMOST& = -1
#Else
Public Const HWND_TOPMOST& = -1
#End If 'WIN32

#If Win32 Then
 Const SWP_NOMOVE& = &H2
 Const SWP_NOSIZE& = &H1
#Else
 Const SWP_NOMOVE& = &H2
 Const SWP_NOSIZE& = &H1
#End If 'WIN32

#If Win32 Then
 Declare Function SetWindowPos& Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
#Else
 Declare Sub SetWindowPos Lib "user" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)
#End If 'WIN32

Code

Function StayOnTop(Form As Form) 'EX: Call StayOnTop(Me)
Dim lFlags As Long
Dim lStay As Long

lFlags = SWP_NOSIZE Or SWP_NOMOVE
lStay = SetWindowPos(Form.hWnd, HWND_TOPMOST, 0, 0, 0, 0, lFlags)
End Function

Task: Returns true if the number is a prime number

'
' Returns true if the number is a prime number.
' false if it is not.
'
' This should work reasonably well for small
' numbers (32-bits or less).  For larger numbers
' the Rabin-Miller test should be used.
'
Public Function IsPrime(ByVal n As Long) As Boolean
   Dim i As Long
   
   IsPrime = False
   
   If n <> 2 And (n And 1) = 0 Then Exit Function 'test if div 2
   If n <> 3 And n Mod 3 = 0 Then Exit Function 'test if div 3
   For i = 6 To Sqr(n) Step 6
      If n Mod (i - 1) = 0 Then Exit Function
      If n Mod (i + 1) = 0 Then Exit Function
   Next
   
   IsPrime = True

End Function

Task: Keep mouse inside a form

Declarations:

Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long

Code:

' #VBIDEUtils#************************************************************
' * Programmer Name  : Waty Thierry
' * Web Site         : www.geocities.com/ResearchTriangle/6311/
' * E-Mail           : waty.thierry@usa.net
' * Date             : 13/10/98
' * Time             : 10:24
' * Module Name      : Form_Module
' * Module Filename  : Form.bas
' **********************************************************************
' * Comments         : Keep mouse inside a form
' *
' **********************************************************************

'Get the screens Twips per pixel (form's scalemode must be Twips)
lngX = Screen.TwipsPerPixelX
lngY = Screen.TwipsPerPixelY

'Set cursor region to that of form
With NewRect
    .Left = Me.Left / lngX
    .Top = Me.Top / lngY
    .Right = .Left + Me.Width / lngX
    .Bottom = .Top + Me.Height / lngY
End With
lngReturn = ClipCursor(NewRect)

Task: Gives detailed information about your printer,taken from MSKB.

Declarations:

Option Explicit

Private Const NULLPTR = 0&
' Constants for DEVMODE
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
' Constants for DocumentProperties
Private Const DM_MODIFY = 8
Private Const DM_COPY = 2
Private Const DM_IN_BUFFER = DM_MODIFY
Private Const DM_OUT_BUFFER = DM_COPY
' Constants for dmOrientation
Private Const DMORIENT_PORTRAIT = 1
Private Const DMORIENT_LANDSCAPE = 2
' Constants for dmPrintQuality
Private Const DMRES_DRAFT = (-1)
Private Const DMRES_HIGH = (-4)
Private Const DMRES_LOW = (-2)
Private Const DMRES_MEDIUM = (-3)
' Constants for dmTTOption
Private Const DMTT_BITMAP = 1
Private Const DMTT_DOWNLOAD = 2
Private Const DMTT_DOWNLOAD_OUTLINE = 4
Private Const DMTT_SUBDEV = 3
' Constants for dmColor
Private Const DMCOLOR_COLOR = 2
Private Const DMCOLOR_MONOCHROME = 1

Private Type DEVMODE
    dmDeviceName(1 To CCHDEVICENAME) As Byte
    dmSpecVersion As Integer
    dmDriverVersion As Integer
    dmSize As Integer
    dmDriverExtra As Integer
    dmFields As Long
    dmOrientation As Integer
    dmPaperSize As Integer
    dmPaperLength As Integer
    dmPaperWidth As Integer
    dmScale As Integer
    dmCopies As Integer
    dmDefaultSource As Integer
    dmPrintQuality As Integer
    dmColor As Integer
    dmDuplex As Integer
    dmYResolution As Integer
    dmTTOption As Integer
    dmCollate As Integer
    dmFormName(1 To CCHFORMNAME) As Byte
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type

Private Declare Function OpenPrinter Lib "winspool.drv" Alias _
        "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
        ByVal pDefault As Long) As Long

Private Declare Function DocumentProperties Lib "winspool.drv" _
        Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
        ByVal hPrinter As Long, ByVal pDeviceName As String, _
        pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) _
        As Long

Private Declare Function ClosePrinter Lib "winspool.drv" _
        (ByVal hPrinter As Long) As Long

Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" _
        (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Code:

Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = Trim(OriginalStr)
End Function

Function ByteToString(ByteArray() As Byte) As String
    Dim TempStr As String
    Dim I As Integer

    For I = 1 To CCHDEVICENAME
        TempStr = TempStr & Chr(ByteArray(I))
    Next I
    ByteToString = StripNulls(TempStr)
End Function

Function GetPrinterSettings(szPrinterName As String, hdc As Long) _
            As Boolean
    Dim hPrinter As Long
    Dim nSize As Long
    Dim pDevMode As DEVMODE
    Dim aDevMode() As Byte
    Dim TempStr As String

    If OpenPrinter(szPrinterName, hPrinter, NULLPTR) Then
        nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
                NULLPTR, NULLPTR, 0)
        ReDim aDevMode(1 To nSize)
        nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
                aDevMode(1), NULLPTR, DM_OUT_BUFFER)
        Call CopyMemory(pDevMode, aDevMode(1), Len(pDevMode))

        List1.Clear   ' empty the ListBox
        List1.AddItem "Printer Name: " & _
                ByteToString(pDevMode.dmDeviceName)

        If pDevMode.dmOrientation = DMORIENT_PORTRAIT Then
            TempStr = "PORTRAIT"
        ElseIf pDevMode.dmOrientation = DMORIENT_LANDSCAPE Then
            TempStr = "LANDSCAPE"
        Else
            TempStr = "UNDEFINED"
        End If
        List1.AddItem "Orientation: " & TempStr

        Select Case pDevMode.dmPrintQuality
            Case DMRES_DRAFT
                TempStr = "DRAFT"
            Case DMRES_HIGH
                TempStr = "HIGH"
            Case DMRES_LOW
                TempStr = "LOW"
            Case DMRES_MEDIUM
                TempStr = "MEDIUM"
            Case Else   ' positive value
                TempStr = CStr(pDevMode.dmPrintQuality) & " dpi"
        End Select
        List1.AddItem "Print Quality: " & TempStr

        Select Case pDevMode.dmTTOption
            Case DMTT_BITMAP    ' default for dot-matrix printers
                TempStr = "TrueType fonts as graphics"
            Case DMTT_DOWNLOAD  ' default for HP printers that use PCL
                TempStr = "Downloads TrueType fonts as soft fonts"
            Case DMTT_SUBDEV    ' default for PostScript printers
                TempStr = "Substitute device fonts for TrueType fonts"
            Case Else
                TempStr = "UNDEFINED"
        End Select
        List1.AddItem "TrueType Option: " & TempStr

        ' Windows NT drivers often return COLOR from Monochrome printers
        If pDevMode.dmColor = DMCOLOR_MONOCHROME Then
            TempStr = "MONOCHROME"
        ElseIf pDevMode.dmColor = DMCOLOR_COLOR Then
            TempStr = "COLOR"
        Else
            TempStr = "UNDEFINED"
        End If
        List1.AddItem "Color or Monochrome: " & TempStr

        If pDevMode.dmScale = 0 Then
            TempStr = "NONE"
        Else
            TempStr = CStr(pDevMode.dmScale)
        End If
        List1.AddItem "Scale Factor: " & TempStr

        List1.AddItem "Y Resolution: " & pDevMode.dmYResolution & " dpi"
        List1.AddItem "Copies: " & CStr(pDevMode.dmCopies)
        ' Add any other items of interest ...

        Call ClosePrinter(hPrinter)
        GetPrinterSettings = True
    Else
        GetPrinterSettings = False
    End If
End Function

Private Sub Command1_Click()
    If GetPrinterSettings(Printer.DeviceName, Printer.hdc) = False Then
        List1.AddItem "No Settings Retrieved!"
    End If
End Sub


'Required one command button & one listbox

Task: UnRAR - Extract file from RAR archives from directly within Visual Basic. Full support for password protected RARs.

Declarations:

Option Explicit

' Title:    UnRAR VB6 BAS Module
' Author:   Leigh Bowers (Compulsion Software)
' Email:    compulsion@esheep.freeserve.co.uk
' Version:  1.01
' Date:     16th April 1999
' Revised:  15th June 1999
' Requires: UnRAR.DLL (supplied)
' License:  Freely Distributable

' Notes:-

' Please give me a small mention if you use all or part
' of this code in one of your VB programs ;-)

' Created utilising information contained within the
' UnRARDLL.txt & TechNote.txt files (as supplied with
' the full WinRAR package).

' Open Mode Constants

Private Const RAR_OM_LIST As Byte = 0
Private Const RAR_OM_EXTRACT As Byte = 1

' Error Constants

Private Const ERAR_NO_MEMORY As Byte = 11
Private Const ERAR_BAD_DATA As Byte = 12
Private Const ERAR_BAD_ARCHIVE As Byte = 13
Private Const ERAR_EOPEN As Byte = 15
Private Const ERAR_UNKNOWN_FORMAT As Byte = 14
Private Const ERAR_SMALL_BUF As Byte = 20
Private Const ERAR_ECLOSE As Byte = 17
Private Const ERAR_END_ARCHIVE As Byte = 10
Private Const ERAR_ECREATE As Byte = 16
Private Const ERAR_EREAD As Byte = 18
Private Const ERAR_EWRITE As Byte = 19

' Operation Constants

Private Const RAR_SKIP As Byte = 0
Private Const RAR_TEST As Byte = 1
Private Const RAR_EXTRACT As Byte = 2

' Volume Constants

Private Const RAR_VOL_ASK As Byte = 0
Private Const RAR_VOL_NOTIFY As Byte = 1

' User Defined Types

Private Type RARHeaderData
    ArcName As String * 260
    FileName As String * 260
    Flags As Long
    PackSize As Long
    UnpSize As Long
    HostOS As Long
    FileCRC As Long
    FileTime As Long
    UnpVer As Long
    Method As Long
    FileAttr As Long
    CmtBuf As String    ' Pointer (char *CmtBuf in C)
    CmtBufSize As Long
    CmtSize As Long
    CmtState As Long
End Type

Private Type RAROpenArchiveData
    ArcName As String   ' Pointer (char *ArcName in C)
    OpenMode As Long
    OpenResult As Long
    CmtBuf As String    ' Pointer (char *CmtBuf in C)
    CmtBufSize As Long
    CmtSize As Long
    CmtState As Long
End Type

' RAR DLL Declares

Public Declare Function RAROpen Lib "UnRAR.dll" Alias "RAROpenArchive" (ByRef RAROpenData As RAROpenArchiveData) As Long
Public Declare Function RARClose Lib "UnRAR.dll" Alias "RARCloseArchive" (ByVal HandleToArchive As Long) As Long
Public Declare Function RARReadHdr Lib "UnRAR.dll" Alias "RARReadHeader" (ByVal HandleToArcRecord As Long, ByRef ArcHeaderRead As RARHeaderData) As Long
Public Declare Function RARProcFile Lib "UnRAR.dll" Alias "RARProcessFile" (ByVal HandleToArcHeader As Long, ByVal Operation As Long, ByVal DestPath As String, ByVal DestName As String) As Long
Public Declare Sub RARSetChangeVolProc Lib "UnRAR.dll" (ByVal HandleToArchive As Long, ByVal Mode As Long)
Public Declare Sub RARSetPassword Lib "UnRAR.dll" (ByVal HandleToArchive As Long, ByVal Password As String)

Code:

Function RARExtract(ByVal sRARArchive As String, ByVal sDestPath As String, Optional ByVal sPassword As String) As Integer

' Description:-
' Exrtact file(s) from RAR archive.

' Parameters:-
' sRARArchive   = RAR Archive filename
' sDestPath     = Destination path for extracted file(s)
' sPassword     = Password [OPTIONAL]

' Returns:-
' Integer       = 0  Failed (no files, incorrect PW etc)
'                 -1 Failed to open RAR archive
'                 >0 Number of files extracted
    
Dim lHandle As Long
Dim lStatus As Long
Dim uRAR As RAROpenArchiveData
Dim uHeader As RARHeaderData
Dim iFileCount As Integer
    
    RARExtract = -1
    
    ' Open the RAR

    uRAR.ArcName = sRARArchive
    uRAR.OpenMode = RAR_OM_EXTRACT
    lHandle = RAROpen(uRAR)

    ' Failed to open RAR ?

    If uRAR.OpenResult <> 0 Then Exit Function
    
    ' Password ?
    
    If sPassword <> "" Then
        RARSetPassword lHandle, sPassword
    End If
    
    ' Extract file(s)...
    
    iFileCount = 0

    ' Is there at lease one archived file to extract ?
    lStatus = RARReadHdr(lHandle, uHeader)

    Do Until lStatus <> 0

        ' Process (extract) the current file within the archive
        If RARProcFile(lHandle, RAR_EXTRACT, "", sDestPath + uHeader.FileName) = 0 Then
            iFileCount = iFileCount + 1
        End If
        ' Is there another archived file in this RAR ?
        lStatus = RARReadHdr(lHandle, uHeader)

    Loop

    ' Close the RAR

    RARClose lHandle

    ' Return

    RARExtract = iFileCount

End Function

Task: Changes the Windows Wallpaper

Declarations:

Private Declare Function SystemParametersInfo Lib "user32"Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

Code:

Call SystemParametersInfo(20, vbNull, File, vbNull)

'(Sub SetWallpaper(File As String)     'extra
'On Error Resume Next
'Call SystemParametersInfo(20, vbNull, File, vbNull)
'End Sub)

Code:

Private Sub Command1_Click()
' Add It To a ButtoN !
ForeColor = 0: x = CurrentX: y = CurrentY
For i = 1 To 100
        Print "YOUR TEXT HERE" ' Text Here
        x = x + 1: y = y + 1: CurrentX = x: CurrentY = y
Next
ForeColor = &HFFFF& 'Change Color Here
Print "YOUR TEXT HERE" ' Text Goes Here
End Sub

Task: Changing the Windows Theme from VB

Code:

'Changing the theme is not too much of a problem as long as you have another theme to change to:

 

Dim ThemeFile As String
Dim TheCOM As String
Dim RET As Long
ThemeFile = "C:\program files\Plus!\<THEME NAME>"
TheCOM = """C:\program files\Plus!\themes.exe"" /s " + """" + thfile + """"
RET = Shell(TheCOM, 4)

Task: Use the Microsoft Internet Control to determine when a web page was last modified.

Code:

'set a reference to the Microsoft Internet Control and then use the code below.

    Dim strHeader As String
    
    'set protocol to HTTP
    Inet1.Protocol = icHTTP
    
    'open URL
    Inet1.OpenURL ("http://www.softafzar.net")
    
    ' Retrieve the date page was last modified
    strHeader = Inet1.GetHeader("Last-modified")
    
    MsgBox strHeader

کد بزرگ نوشتن حرف اول در ویژوال بیسیک مثلا hey how ya doin >> Hey How Ya Doin

Task: Capitalizes you text (e.g. you type "hey how ya doin", it returns "Hey How Ya Doin". Only 3 lines. Better than the other 2. Instructions included.

Code:

Private Sub Convert_Click()
goesto.Caption = StrConv(comesfrom.Text, vbProperCase)
End Sub

Task: Picture load in effect - "Mercury Rising"

Code:

'Code Name : Load the picture into Picture Box with a "Mercury Rising" effect
'Author    : Looi Tuck Wai
'Date      : 13/8/1999
'Control   : 2 Picture Box (Picture1 & Picture2),1  Command Button (CmdMercury)
'Code      :

Option Explicit   

Private Sub CmdMercury_Click()
    Const TubeWidth = 80
    Dim XTube As Long, Offset As Long, XPicture As Long, Erg As Double
        
    Erg = 3.14159265358979 / 2 * (TubeWidth / 2)
    For Offset = 0 To Picture1.ScaleWidth - 1
        If Offset - TubeWidth >= 0 Then Picture2.PaintPicture Picture1.Picture, Offset - TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - TubeWidth, 0, 1, Picture1.ScaleHeight
        For XTube = 1 To TubeWidth
            XPicture = Mercury(XTube * (TubeWidth * 2)) * Erg
            If Offset + XPicture < Picture1.ScaleWidth Then
                Picture2.PaintPicture Picture1.Picture, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - XPicture, 0, 1, Picture1.ScaleHeight
            Else
                Picture2.PaintPicture Picture1.Picture, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight, Offset - XTube + TubeWidth, 0, 1, Picture1.ScaleHeight
            End If
        Next XTube
    Next Offset

End Sub

Private Sub Form_Load()
    Picture2.Width = Picture1.Width
    Picture2.Height = Picture1.Height
End Sub

Private Function Mercury(X As Double)
    X = X - 1
    If X < 1 And X > -1 Then
        Mercury = Atn(-X / Sqr(-X * X + 1)) + 2 * Atn(1)
    Else
        Mercury = 0
    End If
End Function

Task: Returns a string specifying File name without path and extension

Code:

Public Function GetFileNameWOExt(ByVal strSource As String) As String
On Error GoTo Error_Handler
Dim lngBegin As Long
Dim lngToRight As Long
lngBegin = VBA.InStr(1, VBA.StrReverse(strSource), "\", vbTextCompare)
lngToRight = VBA.InStr(1, VBA.StrReverse(strSource), ".", vbTextCompare)
GetFileNameWOExt = VBA.Left(VBA.Right(strSource, lngBegin - 1), lngBegin - lngToRight - 1)
Exit Function
Error_Handler:
    GetFileNameWOExt = ""
End Function

سلام
این کد کاربردی ادرس جاری رو پیدا میکنه رو توی textbox نمایش میده

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Const WM_GETTEXT = &HD
Dim Address As String

Private Sub Timer1_Timer()
    On Error Resume Next
    Dim Hwnd As Long
    Dim i As Integer
    Hwnd = FindWindow("CabinetWClass", vbNullString)
    If Hwnd <> 0 Then
        Hwnd = FindWindowEx(Hwnd, 0, "WorkerW", vbNullString)
        Hwnd = FindWindowEx(Hwnd, 0, "ReBarWindow32", vbNullString)
        Hwnd = FindWindowEx(Hwnd, 0, "ComboBoxEx32", vbNullString)
        Dim r As Long
        Dim s As String
        s = String(201, Chr(0))
        r = SendMessageByString(Hwnd, WM_GETTEXT, 200, s)
        If Left(s, r) = "My Computer" Then Exit Sub
        Address = Left(s, r)
    End If
    Text1.Text = Address
End Sub

Task: Comprehensive e-mail address syntax validation check

Public Function ValidateEMail(ByVal strAddress As String) As Boolean
' Purpose: Validate a given e-mail address.
' In:           strAddress          - string to be validated
' Out:
' Returns: True if strAddress is a valid e-mail address; False otherwise.
' Date: 8/23/1999
' Programmer: Ian Lent and Melvin Tucker 
' Last Modified:
    Dim lngIndex As Long            ' Position in strAddress
    Dim lngCountAt As Long          ' Number of "@"
    Dim lngLastDotPos As Long       ' Position of the previous dot in the string
    Dim strCurrentChar As String    ' Buffer that holds the contents of the string one char at a time.
    
    On Error GoTo Fail_Validation
    
    ValidateEMail = True            ' Prove me wrong!
    strAddress = Trim(strAddress)
    lngLastDotPos = 0
    lngCountAt = 0
    
    ' If the address isn't at least this (a@b.com) long,
    ' it's not a valid address.
    If Len(strAddress) < 7 Then GoTo Fail_Validation
    
    ' Check for certain generably allowable characters in the leading position.
    ' If found, it's not a valid address.
    strCurrentChar = Left$(strAddress, 1)
    If strCurrentChar = "." Or strCurrentChar = "@" Or strCurrentChar = "_" Or _
        strCurrentChar = "-" Then GoTo Fail_Validation
    
    ' Check the string for non-allowable characters.
    For lngIndex = 1 To Len(strAddress)
        strCurrentChar = Mid$(strAddress, lngIndex, 1)
    
        ' Count the number of "@".
        If strCurrentChar = "@" Then lngCountAt = lngCountAt + 1
        
        ' If there are two consecutive dots, it's not a valid address.
        If strCurrentChar = "." Then
            If lngIndex = lngLastDotPos + 1 Then
                GoTo Fail_Validation
            Else
                lngLastDotPos = lngIndex
            End If
        End If
        
        Select Case Asc(strCurrentChar)
            ' These characters are not allowable in e-mail addresses.
            Case 1 To 44, 47, 58 To 63, 91 To 94, 96, 123 To 127, 128 To 255
                GoTo Fail_Validation
        End Select
    Next lngIndex
    
    ' If there isn't one, and only one "@", then it's not a valid address.
    If lngCountAt <> 1 Then GoTo Fail_Validation
            
    ' If the extension isn't a known one, it's not a valid address.
    Select Case Right$(strAddress, 4)
        Case ".com", ".org", ".net", ".edu", ".mil", ".gov"
            ' Yes, it's valid.
        Case Else
            GoTo Fail_Validation
    End Select
    
ValidateEMail_Exit:
    Exit Function
    
Fail_Validation:
    ValidateEMail = False
    GoTo ValidateEMail_Exit
End Function

Task: Delete Files by File Date

'Uses Date Picker Control
'PurgeResp = DTPicker.value
'Need to set values for DestDrive and DestPath

Dim MyFile, MyStamp, DestDrive, DestPath
MyFile = Dir(DestDrive + DestPath + "\*.txt")'Change Extension 
Do
MyStamp = FileDateTime(DestDrive + DestPath + "\" + MyFile) 
MyStamp = DateValue(Left$(MyStamp, 10))
    If MyStamp < PurgeResp Then Kill(DestDrive + DestPath + "\" + MyFile)
MyFile = Dir
If MyFile = "" Then Exit Do
Loop
MsgBox "Selected files purged.", vbOKOnly, "Purge Files"

Task: Find Your Ip

Declarations:

Winsock2.bas
Option Explicit

Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS       As Long = 0
Public Const WS_VERSION_REQD     As Long = &H101
Public Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD    As Long = 1
Public Const SOCKET_ERROR        As Long = -1

Public Type HOSTENT
   hName      As Long
   hAliases   As Long
   hAddrType  As Integer
   hLen       As Integer
   hAddrList  As Long
End Type

Public Type WSADATA
   wVersion      As Integer
   wHighVersion  As Integer
   szDescription(0 To MAX_WSADescription)   As Byte
   szSystemStatus(0 To MAX_WSASYSStatus)    As Byte
   wMaxSockets   As Integer
   wMaxUDPDG     As Integer
   dwVendorInfo  As Long
End Type


Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
   (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
   
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Public Declare Function gethostname Lib "WSOCK32.DLL" _
   (ByVal szHost As String, ByVal dwHostLen As Long) As Long
   
Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
   (ByVal szHost As String) As Long
   
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Public Function GetIPAddress() As String

   Dim sHostName    As String * 256
   Dim lpHost    As Long
   Dim HOST      As HOSTENT
   Dim dwIPAddr  As Long
   Dim tmpIPAddr() As Byte
   Dim i         As Integer
   Dim sIPAddr  As String
   
   If Not SocketsInitialize() Then
      GetIPAddress = ""
      Exit Function
   End If
   If gethostname(sHostName, 256) = SOCKET_ERROR Then
      GetIPAddress = ""
      MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
              " has occurred. Unable to successfully get Host Name."
      SocketsCleanup
      Exit Function
   End If
   sHostName = Trim$(sHostName)
   lpHost = gethostbyname(sHostName)
    
   If lpHost = 0 Then
      GetIPAddress = ""
      MsgBox "Windows Sockets are not responding. " & _
              "Unable to successfully get Host Name."
      SocketsCleanup
      Exit Function
   End If
   CopyMemory HOST, lpHost, Len(HOST)
   CopyMemory dwIPAddr, HOST.hAddrList, 4
   ReDim tmpIPAddr(1 To HOST.hLen)
   CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
   For i = 1 To HOST.hLen
      sIPAddr = sIPAddr & tmpIPAddr(i) & "."
   Next
   GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
   
   SocketsCleanup
    
End Function

Public Function HiByte(ByVal wParam As Integer)

    HiByte = wParam \ &H100 And &HFF&
 
End Function
Public Function LoByte(ByVal wParam As Integer)

    LoByte = wParam And &HFF&

End Function
Public Sub SocketsCleanup()

    If WSACleanup() <> ERROR_SUCCESS Then
        MsgBox "Socket error occurred in Cleanup."
    End If
    
End Sub

Public Function SocketsInitialize() As Boolean

   Dim WSAD As WSADATA
   Dim sLoByte As String
   Dim sHiByte As String
   
   If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
      MsgBox "The 32-bit Windows Socket is not responding."
      SocketsInitialize = False
      Exit Function
   End If
   
   
   If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        MsgBox "This application requires a minimum of " & _
                CStr(MIN_SOCKETS_REQD) & " supported sockets."
        
        SocketsInitialize = False
        Exit Function
   End If
   
   
   If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
     (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
      HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
      
      sHiByte = CStr(HiByte(WSAD.wVersion))
      sLoByte = CStr(LoByte(WSAD.wVersion))
      
      MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
             " is not supported by 32-bit Windows Sockets."
      
      SocketsInitialize = False
      Exit Function
      
   End If
    SocketsInitialize = True
End Function

Code:

Private Sub Form_Load()
   Text1.Text = GetIPAddress()
   If Text1.Text = "127.0.0.1" Then
Label1.Caption = "You are of Line"
   Else
Label1.Caption = "You are on Line"
   End If
End Sub

Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, _
ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Const SC_MOVE = &HF010&
Private Const MF_BYCOMMAND = &H0&
 
Private Sub Command1_Click()
    lhSysMenu = GetSystemMenu(Me.hwnd, False)
    lRetVal = RemoveMenu(lhSysMenu, SC_MOVE, MF_BYCOMMAND)
End Sub

Private Sub CmdNew_Click()
 Adodc1.Recordset.AddNew
End Sub
Private Sub CmdNew_Click()
 CommonDialog1.Filter = "(*.JPG)|*.JPG"
  If CommonDialog1.Filename <> "" Then
   Image1.LoadPicture = (CDMain.Filename)
  End If
End Sub
  
Private Sub CmdSave_Click()
 Call CmdOpen
 Adodc1.Recordset.Update
 Adodc1.Refresh
End Sub