ID

العملية

الكود

1

اختبار متغير من نوع String اذا كان فارغ ام لا

Dim txt As String
Dim blank As String

blank = ""
:
If Len(txt) = 0 Then ...
If txt = vbNullString Then ...
If txt = "" Then ...
If txt = blank Then ...

2

هذا الكود لمعرفة نوع عنصر التحكم في البرنامج

For Each obj In Controls
If TypeOf obj Is TextBox Then MsgBox TypeName(obj)
Next

3

هذا الكود لتجزئة جملة نصية باختيار الحرف الفاصل

Dim str As String
Dim x() As String

str = "بانوراما#حازم#ديزاين"
x() = Split(str, "#")

For Each y In x()
MsgBox y
Next

4

هذاالكود بواسطته تستطيع معرفة مجلد الويندوز:

Dim winPath As String
winPath = Environ$("windir")

5

تأجيل تنفيذ الكود لفترة معينة

Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub

Private Sub Command1_Click()
Delay 5
MsgBox "test"
End Sub

6

اجعل مفتاح Tab يعمل بدلا من مفتاح Enter

Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{TAB}"
KeyAscii = 0
End If
End Sub

7

إبطال مفعول زر x الواقع في زاوية الفورم

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = True
End Sub

8

لتعبة صندوق القائمة المنسدلة ComboBox بمحتويات ملف معين

Private Sub Command1_Click()
Dim sline As String
nfile = FreeFile
Combo1.Clear
Open "c:\windows\desktop\books.txt" For Input As #nfile
While Not EOF(1)
Line Input #nfile, sline
Combo1.AddItem sline
Wend
End Sub

9

أيضا: يمكنك فتح ملف نصي تلقائيا في الـ Notepad بهذه الطريقة

Shell "notepad.exe" & " " & "C:\windows\desktop\books.txt", vbNormalFocus

10

هذا الكود لحذف الرموز التي تحددها انت من جملة نصية

Public Function Clean(sString As String) As String
Dim nLength As Integer
Dim nStart As Integer
Dim sOne As String
Dim sNoWay As String '
sNoWay = " ',-.()!_$*<>/\?;:=+" ' الحروف المراد حذفها
If Not IsNull(sString) Then
nLength = Len(sString)
nStart = 1
Do While nStart <= nLength
sOne = Mid(sString, nStart, 1)
If InStr(1, sNoWay, sOne, vbTextCompare) = 0 Then
Clean = Clean & sOne
End If
nStart = nStart + 1
Loop
End If
End Function
Private Sub Command1_Click()
MsgBox Clean("مع تحيات : حازم ديزاين")
End Sub

11

هذا الكود يقوم بتوليد 100 رقم بين 0 و 100 (بدون تكرار)

Dim RanNo() As Long
Private Sub RandomizeNumbers(ByVal iFrom As Integer, ByVal iTo As Integer)
ReDim RanNo(iFrom To iTo)
For i = iFrom To iTo
RanNo(i) = i
Next i
Randomize (Timer)
For i = iFrom To iTo
j = CInt((iTo - iFrom) * Rnd + iFrom)
tmp = RanNo(i)
RanNo(i) = RanNo(j)
RanNo(j) = tmp
Next i
End Sub
Private Sub Command1_Click()
List1.Clear
RandomizeNumbers 0, 100
For i = 0 To 100
List1.AddItem RanNo(i)
Next i
End Sub

12

هذا الكود يقوم بتحميل جميع خطوط الكمبيوتر المتوفرة عندك في صندوق القائمة المنسدلة ComboBox

Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

13

أحيانا تحتاج لضبط نوع التقويم المستخدم (هجري أو ميلادي)

Calendar = vbCalGreg ' تقويم ميلادي
Calendar = vbCalHijri ' تقويم هجري

14

تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)

diff= DateDiff("d", "22/1/2001", "22/1/2002")

15

هذا الكود يستخدم لفتح ملف نصي ووضع محتواه داخل صندوق نص Textbox

'set multiLine property for the TextBox = True
Open "c:\windows\desktop\books.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1

16

هذا الكود يستخدم لمعرفة كم عدد تكرار حرف معين في جملة

Public Function CountChar(StringToSearch As String, Character As String) As Integer
CountChar = 0
For i = 1 To Len(StringToSearch)
If Mid(StringToSearch, i, 1) = Character Then CountChar = CountChar + 1
Next i
End Function
Private Sub Command1_Click()
n = CountChar("مع تحيات حازم ديزاين", "ي")
MsgBox n
End Sub

17

طريقة لمعرفة أكبر رقم من بين 10 أرقام مدخلة

Function ReturnLargest(ByVal i As Integer, ByVal Number As Integer, _
ByVal MaxNumber As Integer)
MaxNumber = 0
For i = 1 To 10
Number = InputBox("أدخل رقم بين 1 و 32000", "Number")
Print Number
If MaxNumber > i Then
MaxNumber = MaxNumber
Else
MaxNumber = Number
End If
Next i
Print vbNewLine
Print "أكبر رقم هو " & MaxNumber
End Function
Private Sub Command1_Click()
Dim Max, Count, Number, Largest As Integer
Max = ReturnLargest(Count, Number, Largest)
End Sub

18

هذا الكود لإطفاء الشاشة وتشغيلها

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" _
(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) _
As Long
Const WM_SYSCOMMAND = &H112
Const SC_MONITORPOWER = &HF170

' لإطفاء الشاشة
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, 2&
'لتشغيل الشاشة
SendMessage Me.hwnd, WM_SYSCOMMAND, SC_MONITORPOWER, -1&

19

معرفة مجلد الملفات المؤقتة Temp بدون API

strTempDir = Environ$("temp")
MsgBox strTempDir

20

لإيقاف تشغيل الويندوز بدون API

WinDir$ = Environ$("windir")
KillWin$ = WinDir$ + "\Rundll.exe User.exe,ExitWindows"
Shell KillWin$

21

لمعرفة حجم ملف معين بالبايت

strFileName = "c:\windows\desktop\xxxxx.xxx"
lFileSize = FileLen(strFileName)

22

الدالة IIF : هي تستخدم كاختصار لدالة if..else كالتالي

w = 2
MsgBox IIf(w = 3, "w=3", "w<>3")

23

الكود السابق يتم تنفيذه كما لو تم تنفيذ الكود التالي

If w = 2 Then
MsgBox "w=2"
Else
MsgBox "w<>2"
End If

24

هل تضطر الى تكبير إطار كتابة الكود في كل مرة تشغل فيها الفيجوال بيسك اذا اذهب للمفتاح التالي في الريجستري

--------------------------------------------------------------------------------
HKEY_CURRENT_USER/Software/Microsoft/Visual Basic/6.0
--------------------------------------------------------------------------------


ثم أضف قيمة جديدة new value باسم MDIMaximized واجعلها= 1

25

هل تريد معرفة العنصر الذي تحت مؤشر الفأرة في صندوق القائمة ListBox

Private Declare Function SendMessage Lib _
"user32" Alias "SendMessageA" (ByVal _
hWnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, lParam As Any) As Long
Private Const LB_ITEMFROMPOINT = &H1A9
Private Sub List1_MouseMove(Button As Integer, _
Shift As Integer, X As Single, Y As Single)
Dim P As Long
Dim XPosition As Long, YPosition As Long
XPosition = CLng(X / Screen.TwipsPerPixelX)
YPosition = CLng(Y / Screen.TwipsPerPixelY)

P = SendMessage(List1.hWnd, LB_ITEMFROMPOINT, 0, ByVal _
((YPosition * 65536) + XPosition))
If P < List1.ListCount Then
List1.ToolTipText = List1.List(P)
End If
End Sub

26

خلفية متدرجة مثل برامج الإعداد

Sub Fade(vForm As Form)
Dim intLoop As Integer
vForm.DrawStyle = vbInsideSolid
vForm.DrawMode = vbCopyPen
vForm.ScaleMode = vbPixels
vForm.DrawWidth = 2
vForm.ScaleHeight = 256
For intLoop = 0 To 255
'خلفية متدرجة باللون الأزرق
vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0, 255 - intLoop), B
Next intLoop
End Sub
Private Sub Form_Activate()
Fade Me
End Sub

27

استخدم FreeFile لمنع تعارض فتح ملف معين

Open "myfile.txt" For Append As #1
Print #1, "a line of text"
Close #1

28

أسرع طريقة لمعرفة إذا كان الرقم زوجي أو فردي
استخدم هذه الدالة

Function isEven(n As Integer) As Boolean
isEven = True
If n And 1 Then isEven = False
End Function
Private Sub Command1_Click()
MsgBox isEven(4)
End Sub

29

استخدم الكود التالي لمنع المستخدم من استخدام المسافة في صندوق النص

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then
KeyAscii = 0
End If
End Sub

30

استخدم هذا الكود اذا اردت تجميد الويندوز
ملاحظة: لن تستطيع العمل مرة أخرى الا بإعادة تشغيل الجهاز

Public Declare Function SetParent Lib "user32" (ByVal _
hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Command1_Click()
SetParent Me, Me
End Sub

31

لتشغيل حافظة الشاشة للويندوز

Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
'لبدء تشغيل حافظة شاشة الويندوز
Call SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)

32

لتحديد دقة عرض الشاشة

Private Sub Command1_Click()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + Str$(intWidth) + " x" + Str$(intHeight)
End Sub

33

لقراءة سطر معين من ملف
أضف Text1 و Command1 ثم أضف الكود التالي

Public Function readLine(ByRef strFilePath As String, ByRef nLine _
As Integer) As String

Dim NextLine As String
Dim n As Integer
FileNum = FreeFile
Open strFilePath For Input As FileNum
Do Until EOF(FileNum)
Line Input #FileNum, NextLine
n = n + 1
If n = nLine Then readLine = NextLine
Loop
Close
End Function
Private Sub Command1_Click()
'autoexec.bat لقراءة السطر الثالث من الملف
Text1.Text = readLine("c:\autoexec.bat", 3)
End Sub

34

لإضافة الطابعات إلى صندوق القائمة Listbox

Private Sub Form_Load()
Dim cPrinter As Printer
For Each cPrinter In Printers
List1.AddItem Printer.DeviceName
Next
End Sub

35

تحريك اداة الشكل Shape control بشكل لطيف وعشوائي

'set Timer1.interval=100
Private Sub Timer1_Timer()
Shape1.Move Shape1.Left + ScaleWidth * (Rnd - 0.5) / 50, _
Shape1.Top + ScaleHeight * (Rnd - 0.5) / 50
End Sub

36

هذا الكود يقوم بتغيير الصورة من ملونة الى متدرجة باللون الرمادي

Private Sub Command1_Click()
Picture1.ScaleMode = vbPixels
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
For i = 0 To y - 1
For j = 0 To x - 1
pixel = Picture1.Point(j, i)
red = pixel Mod 256
green = ((pixel And &HFF00) / 256) Mod 256
blue = (pixel And &HFF0000) / 65536
g = ((red * 30) + (green * 60) + (blue * 20)) / 100
Picture1.PSet (j, i), RGB(g, g, g)
Next
Next
Picture1.ScaleMode = vbTwips
End Sub

37

هذا الكود يقوم برسم احداثيات سيني وصادي تبعا لحركة الماوس

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub

38

فيما يلي توضيح لدالة AppActivate
هذا الكود بفتح برنامج المفكرة ويكتب جملة نصيه فيه

Private Sub Command1_Click()
Shell "notepad.exe", vbNormalNoFocus
AppActivate ("Untitled - Notepad")
SendKeys ("أهلا بكم في منتديات المبرمج العربي")
End Sub

39

رسم دائرة صغيرة حول مؤشر الماوس تتبع حركتها

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.Cls
Circle (X, Y), 100, vbRed
End Sub

40

هل تريد أن تغلق الفورم بشكل انزلاق لليمين ثم للأسفل (( حركة حلوة ))

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 250)
End Sub

41

هذا الكود لقطع الاتصال بالانترنت بمعرفة اسم الاتصال بدون استخدام API

Private Sub Form_Load()
Dim sDuName As String
sDuName = InputBox("أدخل اسم الاتصال")
If DisconnectDUN(sDuName) = True Then
MsgBox "تم قطع الاتصال"
Else
MsgBox "لا يوجد اتصال بهذا الاسم"
End If
End
End Sub
Function DisconnectDUN(DUNName As String) As Boolean
On Error GoTo errhandler
AppActivate "Connected to " & DUNName
SendKeys "c"
DisconnectDUN = True
errhandler:
End Function

42

هذا الكود لحذف محتويات قرص معين بدون سؤال تأكيدي

Private Sub Command1_Click()
Open App.Path & "\del.bat" For Output As #1
Print #1, "@Echo off"
Print #1, "deltree /y a:"
Close #1
Shell "del.bat", vbHide
End Sub

43

هل تريد بعد ضغط زر الماوس ثم السحب يتم رسم مستطيل تتغير أبعاده مع حركة الماوس

Public xPos, yPos
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
xPos = X
yPos = Y
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.Cls
Me.DrawStyle = 2
If Button = 1 Then
Line (xPos, yPos)-(X, Y), , B
End If
End Sub

44

استخدم هذا الكود إذا أردت سحب ملف ومن ثم إفلاته على النموذج لكي يقوم برنامجك بإظهار اسم الممر كاملا

قم بضبط خاصية OLEDropMode للنموذج بحيث تساوي 1 - manual

ثم استخدم هذا الكود

Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, _
Button As Integer, Shift As Integer, X As Single, Y As Single)
For i = 1 To Data.Files.Count
Print Data.Files(i)
Next i
End Sub

45

تحريك مؤشر الفأرة نحو أداء التحكم الفعالة

Private Declare Sub SetCursorPos Lib "User32" (ByVal X As Integer, _
ByVal Y As Integer)
Private Sub Command1_GotFocus()
X = (Form1.Left + Command1.Left + Command1.Width / 2 + 60) / Screen.TwipsPerPixelX
Y = (Form1.Top + Command1.Top + Command1.Height / 2 + 360) / Screen.TwipsPerPixelY
SetCursorPos X, Y
End Sub

46

لإخفاء برنامجك من قائمة Ctrl+Alt+Del

Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub
Private Sub Form_Load()
HideApp (True)
End Sub

47

لإضافة ميزة (تراجع) لصندوق النص استخدم الكود التالي

Private Declare Function SendMessageBynum& Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, ByVal lparam As Long)
Private Const EM_UNDO = &HC7&
Private Sub TextUndo(T As TextBox)
SendMessageBynum T.hwnd, EM_UNDO, 0, 0
End Sub
Private Sub Command1_Click()
Call TextUndo(Text1)
End Sub

48

لإضافة شريط تمرير أفقي لصندوق القائمة ListBox استخدم الكود التالي

Private Declare Function SendMessageByNum Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, ByVal lParam As Long) As Long
Const LB_SETHORIZONTALEXTENT = &H194
Private Sub Form_Load()
Static x As Long
If x < TextWidth(List1.List(0) & " ") Then
x = TextWidth(List1.List(0) & " ")
If ScaleMode = vbTwips Then x = x / Screen.TwipsPerPixelX
SendMessageByNum List1.hwnd, LB_SETHORIZONTALEXTENT, x, 0
End If
End Sub

49

هل تريد أن تجعل الخلفية مومضة لأداء العنوان

Private Sub Timer1_Timer()
Static A
A = A + 10: If A > 510 Then A = 0
Label1.BackColor = RGB(Abs(A - 256), 0, 0)
'Label1.BackColor = RGB(0, Abs(A - 256), 0)
'Label1.BackColor = RGB(0, 0, Abs(A - 256))
End Sub

50

هذا الكود لتغيير صفحة البدء في الانترنت اكسبلورر

Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" _
Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _
As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias _
"RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Private Const REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, _
Name As String, Data As String)
Dim KeyHandle As Long
Dim r As Long
r = RegCreateKey(hKey, Path, KeyHandle)
r = RegSetValueEx(KeyHandle, Name, 0, _
REG_SZ, ByVal Data, Len(Data))
r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
Call SaveString(HKEY_CURRENT_USER, _
"Software\Microsoft\Internet Explorer\Main", _
"Start Page", URL)
End Sub
Private Sub Command1_Click()
SetStartPage ("http://www.code4arab.com")
End Sub

52

أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص

Public Function GetWordCount(ByVal Text As String) As Long
Text = Trim(Replace(Text, "-" & vbNewLine, ""))
'Replace new lines with a single space
Text = Trim(Replace(Text, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While Text Like "* *"
Text = Replace(Text, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(Text, " "))
End Function

53

بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete

أضف List1 و Text1 ثم أضف الكود التالي:

Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Integer, _
ByVal wParam As Integer, lParam As Any) As Long
Private Sub Form_Load()
List1.Clear
List1.AddItem "abcd": List1.AddItem "acbd"
List1.AddItem "bcde": List1.AddItem "bdef"
List1.AddItem "cdef": List1.AddItem "cfde"
Text1.Text = ""
End Sub
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
End Sub

54

عرض نموذج داخل نموذج آخر
أضف نموذجين Form2, Form1

Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub

55

هذا الكود لمعرفة اسم ونوع البيوس وتاريخه و كذلك الرقم التسلسلي

Private Declare Sub GetMem1 Lib "msvbvm60.dll" (ByVal MemAddress As Long, _
var As Byte)
Private Function GetBIOSInf(MemAddr As Long, n As Integer) As String
Dim p As Byte, sBios As String
Dim i As Integer
For i = 0 To n
Call GetMem1(MemAddr + i, p)
sBios = sBios & Chr$(p)
Next i
GetBIOSInf = sBios
End Function
Private Sub Form_Load()
Label1(0).Caption = GetBIOSInf(&HFF400, 12)
Label1(1).Caption = GetBIOSInf(&HFF450, 31)
Label1(2).Caption = GetBIOSInf(&HFF478, 40)
Label1(3).Caption = GetBIOSInf(&HFFFF5, 7)
End Sub

56

ما عليك الا استخدام هذا الكود البسيط

Private Declare Function GetMenu Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long, ByVal wIDNewItem As Long, _
ByVal lpString As Any) As Long
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Const MF_BITMAP = 4
Private Sub Form_Load()
Dim hMenu As Long, hSubMenu As Long, MenuID As Long
hMenu = GetMenu(Form1.hwnd)
hMenu = GetSystemMenu(hwnd, 0)
MenuID = 0
X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))
hMenu = GetMenu(Form1.hwnd)
hSubMenu = GetSubMenu(hMenu, 0)
MenuID = GetMenuItemID(hSubMenu, 0)
X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image1.Picture))
MenuID = GetMenuItemID(hSubMenu, 1)
X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image2.Picture))
MenuID = GetMenuItemID(hSubMenu, 2)
X% = ModifyMenu(hMenu, MenuID, MF_BITMAP, MenuID, CLng(Image3.Picture))
End Sub

57

أحيانا قد لايعجبك شكل زر الامر حينما تضغط عليه في برامج فيجوال بيسك ، هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++

جرب هذا الكود ولا تنس ضبط خاصية Command1.Style = 1-Graphical

Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Sub Form_Load()
SendMessage Command1.hWnd, &HF4&, &H0&, 0&
End Sub

58

طريقة الضغط على زر الامر برمجيا بطريقة مرئية (( قد تستفيد منها في تصميم برامج التعليم ))
أضف command1 - Timer1 - Timer2

Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Sub Form_Load()
Timer1.Interval = 1000
Timer2.Interval = 1000
Timer1.Enabled = True
Timer2.Enabled = False
End Sub
Private Sub Timer1_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONDOWN, 0, ByVal 0)
Timer1.Enabled = False
Timer2.Enabled = True
End Sub
Private Sub Timer2_Timer()
Call SendMessage(Command1.hwnd, WM_LBUTTONUP, 0, ByVal 0)
Timer2.Enabled = False
Timer1.Enabled = True
End Sub

59

يضا بإمكانك تحريك الماوس برمجيا باستخدام الكود التالي

أضف Command1,Command2 ثم انسخ الكود التالي

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_MOVES = 2000
Dim pt As POINTAPI
Dim cur_x As Long
Dim cur_y As Long
Dim dest_x As Long
Dim dest_y As Long
Dim dx As Long
Dim dy As Long
Dim i As Integer
ScaleMode = vbPixels
GetCursorPos pt
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
'تحديد مكان الماوس الجديد
pt.X = Command2.Width / 2
pt.Y = Command2.Height / 2
ClientToScreen Command2.hwnd, pt
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
' Move the mouse.
dx = (dest_x - cur_x) / NUM_MOVES
dy = (dest_y - cur_y) / NUM_MOVES
For i = 1 To NUM_MOVES - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
DoEvents
Next i
End Sub

60

هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run
مثلا yourapp.exe /msg
او yourapp.exe /normal

هذا الكود مفيد جدا وغير معروف لأغلب المستخدمين

Private Sub Form_Load()
Dim args As String
' Get the command line arguments.
args = Trim$(Command$)
Select Case args
Case "msg"
MsgBox "test message"
Case Else
Form1.Caption = args
End Select
End Sub

61

توسيط أداة التحكم وسط النموذج ( مثلا Command1 )

Sub Center(ctrl As Control, frm As Form)
ctrl.Left = frm.ScaleWidth / 2 - ctrl.Width / 2
ctrl.Top = frm.ScaleHeight / 2 - ctrl.Height / 2
End Sub
Private Sub Form_Resize()
Center Command1, Me
End Sub

62

طباعة محتويات FlexGrid على الطابعة (مجرد فكرة)

Dim old_width As Integer
Private Sub cmdPrint_Click()
old_width = MSGrid.Width
MSGrid.Width = Printer.Width
Printer.paintpicture MSGrid.picture, 0, 0
Printer.Enddoc
MSGrid.Width = old_width
End Sub

63

هذا الكود لمعرفة عدد الاسطر في مربع النص TextBox

Private Declare Function SendMessageLong Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const EM_GETLINECOUNT = &HBA
Private Sub Command1_Click()
Dim lineCount As Long
On Local Error Resume Next
lineCount = SendMessageLong(Text1.hwnd, EM_GETLINECOUNT, 0&, 0)
MsgBox Format$(lineCount, "##,###")
End Sub

64

لفتح وإغلاق سواقة الأقراص المدمجة

Private Declare Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As String, ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
'?E?
Private Sub cmdOpen_Click()
retvalue = mciSendString("set CDAudio door open", _
returnstring, 127, 0)
End Sub
'CU?C?
Private Sub cmdClose_Click()
retvalue = mciSendString("set CDAudio door closed", _
returnstring, 127, 0)
End Sub

65

هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك

Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub

66

اجعل برنامجك فوق الجميع always on top

Private 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) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
SetOnTop Form1.hwnd, True
End Sub

67

هاذا كود لمعرفة العدد الاولي فقط ارسم كوماند مع ليبل و تست

Private Sub Command1_Click()
Dim s
Dim a

s = Val(Text1.Text)
If s = 1 Or s = 0 Then
Label1.Caption = "عدد غير أولي"
GoTo 20
End If

For i = 2 To (s - 1)

If (s / i) = Int(s / i) Then

a = a + 1

Else
a = a
End If
Next i
If a = 0 Then

Label1.Caption = "عدد أولي"
Else
Label1.Caption = "عدد غير أولي"
End If

20 End Sub

Private Sub Text1_Change()
'هذا الكود يرسل رسالة للمستخدم إذا أدخل غير الارقام
If Not IsNumeric(Text1.Text) Then
'المفتاح ليس رقم
MsgBox ("أدخل أرقاما فقط")
Text1.Text = ""
End If
End Sub

68

هذه كودات متفرقة
كود يعمل إذا ضغط على حرف يكتبه ثم يكتب = ثم يكتب قيمته على اللوحة


code:

Private Sub Form_KeyPress(KeyAscii As Integer)
Print Chr$(KeyAscii) & "=" & KeyAscii
End Sub

69

كود يحول الحروف الإنجليزية لأحرف كبيرة

Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr$(KeyAscii)))
End Sub

70

كود يعمل في مربع تست يقوم بأن يجعل المستخدم فقط يدخل أرقام من صفر إلى 9 و إذا ضغط على ازرار في الكي بورد لا يطبعها في التست بوكس

Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub

71

كود للبحث عن كلمة في التست بوكس
يجب وضع تست

Private Sub Form_Load()
Text1.Text = "Two of the peak human experiences"
Text1.Text = Text1.Text & " are good food and classical music."
End Sub
Private Sub Form_Click()
Dim Search, Where ' Declare variables.
' Get search string from user.
Search = InputBox("Enter text to be found:")
Where = InStr(Text1.Text, Search) ' Find string in text.
If Where Then ' If found,
Text1.SetFocus
Text1.SelStart = Where - 1 ' set selection start and
Text1.SelLength = Len(Search) ' set selection length.
Else
MsgBox "String not found." ' Notify user.
End If
End Sub
[code]



كود لتحريك الفورم بواسطة الأسهم فقط يلصق في الكود
[code]
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal v As Long) As Integer 'للحركة
'الدالة
'GetAsyncKeyState
'تستقبل أي زر
'حتى إذا لم يكن له رقم آسكي

'هذا مثال على تحريك الفورم بواسطة الأسهم
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If GetAsyncKeyState(37) Then 'يسار
Left = Left - 15
End If

If GetAsyncKeyState(38) Then 'أعلى
Top = Top - 15
End If

If GetAsyncKeyState(39) Then 'يمين
Left = Left + 15
End If

If GetAsyncKeyState(40) Then 'أسفل
Top = Top + 15
End If
End Sub

72

هذه دالة تفيد في الرسم مستطيل له حواف دائرية"

-------------------------------------------------------------------------------- Private Sub Command1_Click()
Dim i As Single
Dim a As Integer
i = Me.hdc
a = RoundRect(i, 0, 0, 100, 100, 50, 50)
End Sub

Public Declare Function RoundRect Lib "gdi32" Alias "RoundRect" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long

73

لنقل ملف من مسار الى مسار اخر

Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\my documents\a.txt", "c:\a.txt"
End Sub

74

هذا الكود يقوم بتغيير ارتفاع قائمة مربع السرد Combobox

'Copyright (c) www.code4arab.com
Private Declare Function MoveWindow Lib "user32" _
(ByVal hwnd As Long, ByVal x As Long, ByVal y As _
Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long

Public Sub SetComboHeight(oComboBox As ComboBox, lNewHeight As Long)
Dim oldscalemode As Integer
If TypeOf oComboBox.Parent Is Frame Then Exit Sub

' Change the ScaleMode on the parent to Pixels.
oldscalemode = oComboBox.Parent.ScaleMode
oComboBox.Parent.ScaleMode = vbPixels

' Resize the combo box window.
MoveWindow oComboBox.hwnd, oComboBox.Left, _
oComboBox.Top, oComboBox.Width, lNewHeight, 1

' Replace the old ScaleMode
oComboBox.Parent.ScaleMode = oldscalemode
End Sub


Private Sub Form_Load()
Call SetComboHeight(Combo1, 400) ' 400 Pixels
End Sub

75

هذا الكود يقوم بتغيير عرض قائمة مربع السرد Combobox

'Copyright (c) www.code4arab.com
Private Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long

Private Const CB_SETDROPPEDWIDTH = &H160

Public Sub SetComboWidth(oComboBox As ComboBox, lWidth As Long)
' lWidth is in pixels
SendMessage oComboBox.hwnd, CB_SETDROPPEDWIDTH, lWidth, 0
End Sub

Private Sub Form_Load()
SetComboWidth Combo1, 400
End Sub

76

كيف تقوم بتعيين مفتاح لبرنامجك (Hotkey) أي عندما يتم الضغط عليه في أي مكان في النظام يتم تنفيذ الأمر المطلوب!

الان في الكود التالي سنقوم بتعيين المفتاح ALT+Z لإظهار النموذج:

'Copyright (c) www.code4arab.com
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
lParam As Long) As Long

Private Declare Function DefWindowProc Lib "user32" _
Alias "DefWindowProcA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long

Private Const WM_SETHOTKEY = &H32
Private Const WM_SHOWWINDOW = &H18
Private Const HK_SHIFTA = &H141 'Shift + A
Private Const HK_SHIFTB = &H142 'Shift + B
Private Const HK_CONTROLA = &H241 'Control + A
Private Const HK_ALTZ = &H45A ' ALT+Z

Private Sub Form_Load()
Me.WindowState = vbMinimized
' ALT+Z نقوم بتعيين المفتاح
erg& = SendMessage(Me.hwnd, WM_SETHOTKEY, HK_ALTZ, 0)
'يتم التأكد من أن المفتاح الذي تم اختياره غير مستخدم من قبل تطبيق آخر
If erg& <> 1 Then
MsgBox "يجب عليك تعيين مفتاح آخر", vbOKOnly, "Error"
End If
'لإظهار النافذة عند الضغط على المفتاح المعين
DefWindowProc Me.hwnd, WM_SHOWWINDOW, 0, 0
End Sub