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

بازدید176.6kپست ها136آخرین فعالیت7 سال پیش
0

این برنامه عدد رو میگیره و متن رو نمایش میده مثلا 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
``````
0
``````Task: Convert a decimal number to a radian, or a radian to decimal
``````

Code:

``````Function Rad2Dec(rads As Long)
End Function

Dec2Rad = ((decs * 3.141592654) / 180)
End Function
``````
0
``````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
``````
0
``````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
``````
0
``````Task: Reading / Writing any Registry Key
``````

Declarations:

``````' module declarations

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 SYNCHRONIZE = &H100000
Public Const STANDARD_RIGHTS_ALL = &H1F0000
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, _
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
``````
0
``````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
``````
0
``````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
``````
0
``````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 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)

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 TrouB
DeleteObject TrouH
DeleteObject CercleBis
DeleteObject HCercleBis
DeleteObject CercleBisBis
DeleteObject Ying_Yang
DeleteObject YYang

End Sub
``````
0

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

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

Private Sub Text1_Click()
End Sub

Private Sub Text2_Click()
End Sub
``````

:winksmiley02:

0
``````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
' **********************************************************************
' * This class can change size and location of controls On your form
' * 1. Resize form
' * 2. Change screen resolution
' *         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
``````
0
``````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)
``````
0
``````Task: File I/O using API calls
``````

Declarations

``````Option Explicit

Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, lpBuffer As Any, _
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 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 = ""

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 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
'Set the array up to read that many bytes
'Read in all the data in the file
'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
``````
0
``````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
``````
0
``````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
``````
0
``````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)
``````
0
``````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_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
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 TempStr As String

If OpenPrinter(szPrinterName, hPrinter, NULLPTR) Then
nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
NULLPTR, NULLPTR, 0)
nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _

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

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_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"
' 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
End If
End Sub

'Required one command button & one listbox
``````
0
``````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)

' 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

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 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)

' 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 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

End If

' Extract file(s)...

iFileCount = 0

' Is there at lease one archived file to extract ?

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 ?

Loop

' Close the RAR

RARClose lHandle

' Return

RARExtract = iFileCount

End Function
``````
0
``````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)
``````
0

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
``````
0
``````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)
``````
0
``````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.

'set protocol to HTTP
Inet1.Protocol = icHTTP

'open URL
Inet1.OpenURL ("http://www.softafzar.net")

``````
0

کد بزرگ نوشتن حرف اول در ویژوال بیسیک مثلا 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
``````
0
``````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

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
``````
0
``````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
``````
0

سلام
این کد کاربردی ادرس جاری رو پیدا میکنه رو توی 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

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
End If
End Sub
``````
0

`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
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!
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.
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)

' 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.
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
``````
0

`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"
``````
0

`Task: Find Your Ip`

Declarations:

``````Winsock2.bas
Option Explicit

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
hLen       As Integer
End Type

wVersion      As Integer
wHighVersion  As Integer
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" _

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)

Dim sHostName    As String * 256
Dim lpHost    As Long
Dim HOST      As HOSTENT
Dim i         As Integer

If Not SocketsInitialize() Then
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
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
MsgBox "Windows Sockets are not responding. " & _
"Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
For i = 1 To HOST.hLen
Next

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 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

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 _

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()
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
``````
0
``````Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, _
ByVal bRevert As Long) 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()
End Sub
``````
0
``````Private Sub CmdNew_Click()
End Sub
Private Sub CmdNew_Click()
CommonDialog1.Filter = "(*.JPG)|*.JPG"
If CommonDialog1.Filename <> "" Then
End If
End Sub

Private Sub CmdSave_Click()
Call CmdOpen