اكواد فيجوال بيسك

اسم الموضوع

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

Private Sub Form_Load() MSComm1.Settings = "9600,N,8,1" ' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح For i = 1 To 10 MSComm1.CommPort = i On Error GoTo N MSComm1.PortOpen = True N: If MSComm1.PortOpen = True Then Exit For End If Next End Sub Private Sub MSComm1_OnComm() If MSComm1.CommEvent Then MsgBox " وصول إتصال لك " End If End Sub

لإخفاء البرنامج من قائمة إنهاء المهام 

'Module File هذا الجزء في ملف برمجي Public Declare Function GetCurrentProcessId _ Lib "kernel32" () As Long Public Declare Function GetCurrentProcess _ Lib "kernel32" () As Long Public Declare Function RegisterServiceProcess _ Lib "kernel32" Private Sub Command1_Click() Dim pid As Long Dim reserv As Long ' لإخفاء البرنامج من قائمة إنهاء المهام pid = GetCurrentProcessId() regserv = RegisterServiceProcess(pid, RSP_SIMPLE_SERVICE) End Sub Private Sub Command2_Click() Dim pid As Long Dim reserv As Long 'لإعادة البرنامج في قائمة إنهاء المهام pid = GetCurrentProcessId() regserv = RegisterServiceProcess(pid, _ RSP_UNREGISTER_SERVICE) End Sub

معرفة إذا كان الرقم زوجي أو فردي 

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

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

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

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

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

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

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)

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

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

لقراءة سطر معين من ملف 

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 'أضف Text1 و Command1 ثم أضف الكود التالي

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

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

تحريك اداة الشكل 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

تغيير الصورة من ملونة الى متدرجة باللون الرمادي

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

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

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

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

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

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

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

غلق الفورم بشكل انزلاق لليمين ثم للأسفل 

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

قطع الاتصال بالانترنت بمعرفة اسم الاتصال بدون استخدام 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

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

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

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

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

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

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

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

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

لإخفاء برنامجك من قائمة 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

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

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

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

ate 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

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

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

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

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

معرفة عدد الكلمات في مربع النص

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

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

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

عرض نموذج داخل نموذج آخر 

'اضف 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

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

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

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

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

بيسك ، هل تريد زر أمر يكون مشابه لأزرار مبرمجي فيجوال سي ++ 

'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

طريقة الضغط على زر الامر برمجيا بطريقة مرئية 

'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

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

'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

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

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

توسيط أداة التحكم وسط النموذج ( مثلا 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

طباعة محتويات 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

لمعرفة عدد الاسطر في مربع النص 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

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

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

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

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

اجعل برنامجك فوق الجميع 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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

كيف تقوم بتعيين مفتاح لبرنامجك (Hotkey) 

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

نسخ خلفية سطح المكتب إلى نموذجك

'انسخ هذ الكودالى قسم التصريحات العامة Private Declare Function PaintDesktop Lib "user32" _ (ByVal hdc As Long) As Long 'انسخ هذ الكودالى حدث النقر في زر الامر Private Sub Command1_Click() PaintDesktop Form1.hdc End Sub

أنشاء وتنسيق وطبع وثيقة وورد من داخل برنامج بنقرة زر الامر

Private Sub Command1_Click() 'تعريف المتغيرات Dim objWord As New Word.Application 'تشغيل مايكروسوفت وورد objWord.Visible = True 'ينشئ وثيقة جديدة objWord.Documents.Add ' يضيف النص لوثيقة وورد objWord.Selection.TypeText "اكتب النص الذي سيضاف لوثيقة مستند وورد" 'يختار كل النص objWord.Selection.WholeStory ' تغيير حجم الخط objWord.Selection.Font.Size = 100 ' لتغيير لون الخط objWord.Selection.Font.Color = wdColorRed ' لدفع المستخدم لحفظ الوثيقة objWord.Documents.Save 'يطبع الوثيقة objWord.PrintOut Set objWord = Nothing End Sub

قلب الصور عمودياً أو افقيا او نسخها

Private Sub Command1_Click() 'الوضع الطبيعي النسخ Picture2.PaintPicture Picture1.Picture, 0, 0, _ Picture1.Width, Picture1.Height, 0, 0, _ Picture1.Width, Picture1.Height, vbSrcCopy End Sub Private Sub Command2_Click() 'الوضع الافقي Picture2.PaintPicture Picture1.Picture, 0, 0, _ Picture1.Width, Picture1.Height, Picture1.Width, _ 0, -Picture1.Width, Picture1.Height, vbSrcCopy End Sub Private Sub Command3_Click() 'الوضع العمودي Picture2.PaintPicture Picture1.Picture, 0, 0, _ Picture1.Width, Picture1.Height, 0, Picture1.Height, _ Picture1.Width, -Picture1.Height, vbSrcCopy End Sub Private Sub Command4_Click() 'لقلب الصورة Picture2.PaintPicture Picture1.Picture, 0, 0, _ Picture1.Width, Picture1.Height, Picture1.Width, _ Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy End Sub

لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط 

Dim startdate As String Dim differenceofdate Dim TRACEDATE As String Dim newdate Dim chk If GetSetting(App.Title, "Startup", "counter", "") = "" Then SaveSetting App.Title, "Startup", "counter", 1 SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy") SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy") lblcnt.Caption = "1" ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك " End Else TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "") chk = DateDiff("d", CDate(TRACEDATE), Now) If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED. MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود" End Else startdate = GetSetting(App.Title, "Startup", "Started", "") differenceofdate = DateDiff("d", startdate, Now) If differenceofdate <> 0 Then lblcnt.Caption = differenceofdate + 1 SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY") SaveSetting App.Title, "Startup", "counter", differenceofdate + 1 End If If differenceofdate = 0 Then lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "") End If End If End If End Sub

لتبديل أزرار الفأرة

Const SPI_SETMOUSEBUTTONSWAP = 33 Const SPIF_UPDATEINIFILE = &H1 Private Declare Function SystemParametersInfo Lib "user32.dll" Alias _ "SystemParametersInfoA" (ByVal uAction As Long, ByVal uiParam As Long, _ pvParam As Any, ByVal fWinIni As Long) As Long Private Sub Form_Load() SystemParametersInfo SPI_SETMOUSEBUTTONSWAP, 1, 0, SPIF_UPDATEINIFILE End Sub

لإنهاء البرنامج عند النقر على Esc في لوحة المفاتيح مهما كان موقع التركيز بين الأدوات.....

'Load انسخ هذا الكود لحدث تحميل النموذج Private Sub Form_Load() Form1.KeyPreview = True End Sub 'KeyPress انسخ هذا الكود لحدث النموذج Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = 27 Then End End If End Sub 'KeyPress بدلاً من كود الحدث KeyDownويمكن ايضاًوضع الكود التالي في الحدث Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyEscape Then End End Sub

لاختبار وجود بطاقة إخراج الصوت

Private Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long Private Sub Command1_Click() 'Get the number of installed waveout devices ret& = waveOutGetNumDevs If ret& > 0 Then MsgBox "يوجد بطاقة لإخراج الصوت مثبتة على هذا الجهاز" Else MsgBox "للأسف لايوجد بطاقة لإخراج الصوت على هذا الجهاز" End If End Sub

كلمة مرور لنموذج في برنامجك

rivate Sub Form_Load() 'تعريف المتغيرات Dim s As Integer Dim passw As String 'اعطاء قيمة اولية s = 1 'بدية التكرار واختبار ووضع كلمة المرور Do Until (s = 5 Or passw = "هنا ضع كلمة المرور") 'عرض مربع الادخال لكتابة كلمة المرور passw = InputBox("ادخل كلمة المرور الى قاعدة البيانات", "كلمة مرور مطلوبة") 'مقدار زيادة لستمرار التكرار s = s + 1 Loop If s = 5 Then 'عرض رسالة للمستخدم بعد التكرار دون تحقق الشرط MsgBox "كلمة المرور التي ادخلتها خاطئة... الرجاء حاول مرة أخرى", vbOKOnly, "خطأ في كلمة المرور" End 'عرض النموذج بعد التأكد من تحقق الشرط Form1.Show "form1" 'خروج من التكرار End If End Sub

لإخفاء وإظهار شريط المهام Taskbar

Private Const SWP_HIDEWINDOW = &H80 Private Const SWP_SHOWWINDOW = &H40 Private Declare Function FindWindow Lib "user32" _ Alias "FindWindowA" (ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long 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 Sub Command1_Click() Dim Thwnd As Long Thwnd = FindWindow("Shell_traywnd", "") Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_HIDEWINDOW) End Sub ' لإظهار شريط المهام Private Sub Command2_Click() Dim Thwnd As Long Thwnd = FindWindow("Shell_traywnd", "") Call SetWindowPos(Thwnd, 0, 0, 0, 0, 0, SWP_SHOWWINDOW) End Sub

لحصر الماوس داخل النموذج (وتستطيع ان تحصرها داخل أي أداة أخرى)

Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, _ lpRect As RECT) As Long Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, _ lpPoint As Any) As Long Private Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long Sub RestrictMouseRegion(Optional ByVal hWnd As Long = 0) Dim recTargetWindow As RECT If hWnd Then GetClientRect hWnd, recTargetWindow ClientToScreen hWnd, recTargetWindow ClientToScreen hWnd, recTargetWindow.Right ClipCursor recTargetWindow Else ClipCursor ByVal 0& End If End Sub Private Sub Form_Load() RestrictMouseRegion (Me.hWnd) End Sub Private Sub Form_Unload(Cancel As Integer) RestrictMouseRegion End Sub

لإضافة عروض الفلاش لبرنامجك

Private Sub Command1_Click() Dim s As String s = App.Path If Mid(s, Len(s), 1) <> "\" Then s = s + "\" ShockwaveFlash1.Movie = s + "a4.swf" End Sub

لتحريك النموذج من أي نقطة فيه بدون الاعتماد على شريط العنوان

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 Declare Sub ReleaseCapture Lib "User32" () Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, _ Y As Single) Const WM_NCLBUTTONDOWN = &HA1 Const HTCAPTION = 2 If Button = 1 Then ReleaseCapture SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If End Sub

لتشفير وفك تشفير نص .

Private Sub Command1_Click() For i = 1 To Len(Text1.Text) st1 = Mid(Text1.Text, i, 1) as1 = Asc(st1) ch1 = Chr(255 - as1) st = st + ch1 Next Text1.Text = st End Sub

لإظهار وإخفاء الأيقونات (الرموز) على سطح المكتب

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 ShowWindow Lib "user32" (ByVal hWnd As Long, _ ByVal nCmdShow As Long) As Long Private Sub Command1_Click() 'لإخفاء الأيقونات على سطح المكتب Dim hWnd As Long hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hWnd, 0 End Sub Private Sub Command2_Click() 'لإظهار الأيقونات على سطح المكتب Dim hWnd As Long hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hWnd, 5 End Sub

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

Option Explicit Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Const WS_EX_LAYOUTRTL = &H400000 Private Const GWL_EXSTYLE = (-20) Public Sub SetRtoL(Ctl As Control) Ctl.Visible = False SetWindowLong Ctl.hwnd, GWL_EXSTYLE, GetWindowLong(Ctl.hwnd, GWL_EXSTYLE) Or WS_EX_LAYOUTRTL Ctl.Visible = True End Sub

يحرك لك الفورم لمكان معينة

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 Private Sub Command1_Click() r = MoveWindow(Me.hwnd, 90, 90, 300, 250, 1) End Sub

توسيط اسم الفورم في الوسط

Public Sub CenterC(frm As Form) Dim SpcF As Integer 'How many spaces can fit Dim clen As Integer 'caption length Dim oldc As String 'oldcaption Dim i As Integer 'not important ' 'remove any spaces at the ends of the caption ' 'very easy if you read it carefully oldc = frm.Caption Do While Left(oldc, 1) = Space(1) DoEvents oldc = Right(oldc, Len(oldc) - 1) Loop Do While Right(oldc, 1) = Space(1) DoEvents oldc = Left(oldc, Len(oldc) - 1) Loop clen = Len(oldc) If InStr(oldc, "!") <> 0 Then If InStr(oldc, " ") <> 0 Then clen = clen * 1.5 Else clen = clen * 1.4 End If Else If InStr(oldc, " ") <> 0 Then clen = clen * 1.4 Else clen = clen * 1.3 End If End If ' ''see how many characters can fit SpcF = frm.Width / 61.2244 ''how many space can fit it the caption SpcF = SpcF - clen 'How many spaces can fit-How much space the ' 'caption takes up ' ''Now the tricky part If SpcF > 1 Then DoEvents 'speed up the program frm.Caption = Space(Int(SpcF / 2)) + oldc Else 'if the form is too small for spaces frm.Caption = oldc End If End Sub Private Sub Form_Resize() If Me.Width = oldsize Then 'if the width hasn't changed Exit Sub 'then dont mess with it Else CenterC Me oldsize = Me.Width End If End Sub Private Sub Form_Load() CenterC Me oldsize = Me.Width End Sub

يجعلك عندما تقرب الماوس فوق التست يبتعد ( يتحرك )

Private Sub Text1_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) If Text1.Top = 600 Then ' Move it to the bottom For i = 600 To Form1.Height - 2 * Text1.Height Step Screen.TwipsPerPixelY Text1.Top = i ' Change the command button's top property to i Next i ' Reapeat Else ' Move it to the top For i = Form1.Height - 2 * Text1.Height To 600 Step -Screen.TwipsPerPixelY Text1.Top = i Next i End If End Sub

جعل الفورم أبعاد ثلاثية اضف كوماند للفورم

Sub ThreeDForm(frmForm As Form) Const cPi = 3.1415926 Dim intLineWidth As Integer intLineWidth = 5 ' 'save scale mode Dim intSaveScaleMode As Integer intSaveScaleMode = frmForm.ScaleMode frmForm.ScaleMode = 3 Dim intScaleWidth As Integer Dim intScaleHeight As Integer intScaleWidth = frmForm.ScaleWidth intScaleHeight = frmForm.ScaleHeight ' 'clear form frmForm.Cls ' 'draw white lines frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF ' 'draw grey lines frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, _ intScaleHeight), &H808080, BF frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, _ intScaleHeight), &H808080, BF ' 'draw triangles(actually circles) at corners Dim intCircleWidth As Integer intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth) frmForm.FillStyle = 0 frmForm.FillColor = QBColor(15) frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), _ intCircleWidth, QBColor(15), -3.1415926, -3.90953745777778 '-180 * _ cPi / 180, -224 * cPi / 180 frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), _ intCircleWidth, QBColor(15), -0.78539815, -1.5707963 ' -45 * _ cPi / 180, -90 * cPi / 180 ' 'draw black frame frmForm.Line (0, intScaleHeight)-(0, 0), 0 frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0 frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0 frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0 frmForm.ScaleMode = intSaveScaleMode End Sub Private Sub cmdDraw_Click() ThreeDForm Me End Sub

التحكم في الجهاز عن طريق فجوال

' Display the Control Panel Call Shell("rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus) 'Display the Accessibility Properties Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl", vbNormalFocus) 'Display Add/Remove Programs Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl", vbNormalFocus) 'Show the Display Settings (Background) Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus) 'Show the Display Settings (Screensaver) Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", vbNormalFocus) 'Show the Display Settings (Appearance) Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", vbNormalFocus) 'Show the Display Settings (Settings) Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", vbNormalFocus) 'Display Internet Properties Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl", vbNormalFocus) 'Display Regional Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl", vbNormalFocus) 'Display the Joystick Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", vbNormalFocus) 'Display the Mouse Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", vbNormalFocus) 'Display the Keyboard Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", vbNormalFocus) 'Display Printers Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @2", vbNormalFocus) 'Display Fonts Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @3", vbNormalFocus) 'Display Multimedia Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl", vbNormalFocus) 'Display Modem Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", vbNormalFocus) 'Display Dial-Up Networking Wizard (on Win9x) Call Shell("rundll32.exe rnaui.dll,RnaWizard", vbNormalFocus) 'Display System Properties Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl", vbNormalFocus) 'Run 'Add New Hardware' Wizard (on Win9x) Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", vbNormalFocus) 'Display 'Add New Printer' Wizard (on Win9x) Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus) 'Display Themes Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL themes.cpl", vbNormalFocus) 'Display Time/Date Settings Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus)

لتعطيل القائمة التي تظهر عند النقر بالزر اليمين وأنت موجود في TextBox 
ضع هذا الكود في Module

Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As LongPublic Const GWL_WNDPROC = -4 Public Const WM_RBUTTONUP = &H205 Public lpPrevWndProc As Long Private lngHWnd As Long Public Sub Hook(hWnd As Long) lngHWnd=hWnd lpPrevWndProc = SetWindowLong(lngHWnd, GWL_WNDPROC, AddressOf WindowProc) End Sub Public Sub UnHook() Dim lngReturnValue As Long lngReturnValue = SetWindowLong(lngHWnd, GWL_WNDPROC, lpPrevWndProc) End Sub Function WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case uMsg Case WM_RBUTTONUP 'Do nothing 'Or popup you own menu Case Else WindowProc = CallWindowProc(lpPrevWndProc, hw, uMsg, wParam, lParam) End Select End Function ------------------------------------------------------------------------------------------- طريقة الاستخدام .... ------------------------------------------------------------------------------------------- Call Hook(Text1.hWnd) ' لتعطيل القائمة Call UnHook(Text1.hWnd) ' لارجاعها للوضع الطبيعي .. ويفضل وضعه عند قبل انهاء البرنامج ----------------------------------------------------------------------------------

دالة التقريب لاقرب جزء من المائة 

Private Sub Command1_Click() MsgBox Round(12.8815, 2) End Sub Function Round(nValue As Double, nDigits As _ Integer) As Double Round = Int(nValue * (10 ^ nDigits) + _ 0.5) / (10 ^ nDigits) End Function

كود يصنع ابعاد ثلاثية للليبل و التست 

'Set form's AutoRedraw property toTrue Sub PaintControl3D(frm As Form, Ctl As Control) ' This Sub draws lines around controls to make them 3d ' darkgrey, upper - horizontal frm.Line (Ctl.Left, Ctl.Top - 15)-(Ctl.Left + _ Ctl.Width, Ctl.Top - 15), &H808080, BF ' darkgrey, left - vertical frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _ Ctl.Top + Ctl.Height), &H808080, BF ' white, right - vertical frm.Line (Ctl.Left + Ctl.Width, Ctl.Top)- _ (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF ' white, lower - horizontal frm.Line (Ctl.Left, Ctl.Top + Ctl.Height)- _ (Ctl.Left + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF End Sub Sub PaintForm3D(frm As Form) ' This Sub draws lines around the Form to make it 3d ' white, upper - horizontal frm.Line (0, 0)-(frm.ScaleWidth, 0), &HFFFFFF, BF ' white, left - vertical frm.Line (0, 0)-(0, frm.ScaleHeight), &HFFFFFF, BF ' darkgrey, right - vertical frm.Line (frm.ScaleWidth - 15, 0)-(frm.ScaleWidth - 15, _ frm.Height), &H808080, BF ' darkgrey, lower - horizontal frm.Line (0, frm.ScaleHeight - 15)-(frm.ScaleWidth, _ frm.ScaleHeight - 15), &H808080, BF End Sub 'DEMO USAGE 'Add 1 label and 1 textbox Private Sub Form_Load() Me.AutoRedraw = True PaintForm3D Me PaintControl3D Me, Label1 'Label1 is name of label PaintControl3D Me, Text1 'Text1 is name of textbox End Sub

لإيقاف لوحة المفاتيح والماوس عن العمل وإعادتها للعمل مرة اخرى

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Sub Form_Activate() DoEvents ' إيقاف لوحة المفاتيح والماوس عن العمل BlockInput True ' الانتظار عشر ثواني Sleep 10000 ' إعادة لوحة المفاتيح والماوس للعمل مرة أخرى BlockInput False End Sub

اختبار إذا كان البرنامج لا يشتغل من القرص المدمج فإنه يقوم بإنهائه

Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _ (ByVal nDrive As String) As Long Private Sub Form_Load() Dim driveType As Long driveType = GetDriveType(Mid(App.Path, 1, 3)) If driveType <> 5 Then 'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج End End If End Sub

تحويل اي حرف إلى حرف ASCII 

Dim temp as String temp=asc(text1.text) MsgBox temp

تأثيرات مروعة على الفورم 

'Declarations Sub XFormBlueFade(vForm As Object) On Error Resume Next 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 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormFireFade(vForm As Object) 'This code works best when called in the ' ' paint event On Error Resume Next 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(255, 255 - intLoop, 0), B 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormGreenFade(vForm As Object) On Error Resume Next 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, 255 - intLoop, 0), B 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormIceFade(vForm As Object) On Error Resume Next 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, 255 - intLoop, 255), B 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormPurpleFade(vForm As Object) On Error Resume Next 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(25, 0, 100 - intLoop), B 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormRedFade(vForm As Object) On Error Resume Next 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(255 - intLoop, 0, 0), B 'Draw boxes With specified color of loop Next intLoop End Sub Sub XFormSilverFade(vForm As Object) On Error Resume Next 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(255 - intLoop, 255 - intLoop, 255 - intLoop), B 'Draw boxes With specified color of loop Next intLoop End Sub Private Sub Form_Paint() Call XFormBlueFade(Me)'Makes it Fade Blue End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormFireFade(Me)'Makes it FIRE!! My FAV End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormGreenFade(Me)'Makes it Fade Green End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormIceFade(Me)'Makes it Fade ICE End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormPurpleFade(Me)'Makes it Fade Purple End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormRedFade(Me)'Makes it Fade Red End Sub 'You Can only have 1 of these Commands i ' n the Form Private Sub Form_Paint() Call XFormSilverFade(Me)'Makes it Fade Silver End Sub

اصنع مربعات النصوص بنفسك 

'textbox1 form textbox6 'Initialize each TextBox with a border s ' tyle or special effect, 'and foreground and background colors 'TextBox1 initially uses a borderstyle TextBox1.Text = "Single Style" TextBox1.BorderStyle = fmBorderStyleSingle TextBox1.BorderColor = RGB(255, 128, 128)'Color - Salmon TextBox1.ForeColor = RGB(255, 255, 0)'Color - Yellow TextBox1.BackColor = RGB(0, 128, 64)'Color - Green #2 'TextBoxes 2 through 6 initially use spe ' cial effects TextBox2.Text = "Flat" TextBox2.SpecialEffect = fmSpecialEffectFlat TextBox2.ForeColor = RGB(64, 0, 0) 'Color - Brown TextBox2.BackColor = RGB(0, 0, 255) 'Color - Blue 'Ensure the background style for TextBox ' 2 is initially opaque. TextBox2.BackStyle = fmBackStyleOpaque TextBox3.Text = "Etched" TextBox3.SpecialEffect = fmSpecialEffectEtched TextBox3.ForeColor = RGB(128, 0, 255)'Color - Purple TextBox3.BackColor = RGB(0, 255, 255)'Color - Cyan 'Define BorderColor for later use (when ' borderstyle=fmBorderStyleSingle) TextBox3.BorderColor = RGB(0, 0, 0) 'Color - Black TextBox4.Text = "Bump" TextBox4.SpecialEffect = fmSpecialEffectBump TextBox4.ForeColor = RGB(255, 0, 255)'Color - Magenta TextBox4.BackColor = RGB(0, 0, 100) 'Color - Navy blue TextBox5.Text = "Raised" TextBox5.SpecialEffect = fmSpecialEffectRaised TextBox5.ForeColor = RGB(255, 0, 0) 'Color - Red TextBox5.BackColor = RGB(128, 128, 128) 'Color - Gray TextBox6.Text = "Sunken" TextBox6.SpecialEffect = fmSpecialEffectSunken TextBox6.ForeColor = RGB(0, 64, 0) 'Color - Olive TextBox6.BackColor = RGB(0, 255, 0) 'Color - Green #1

تحيه حسب الوقت 

Private Sub Form_Load() If Time <= "11:30 AM" Then MsgBox ("Good Morning YourNameHere!") End End If If Time > "11:30 AM" And Time < "5:00 PM" Then MsgBox ("Good Afternoon YourNameHere!") End End If If Time > "5:00 PM" Then MsgBox ("Good Evening YourNameHere!") End End If If Time >= "12:01 AM" Then MsgBox ("Good Morning YourNameHere!") End End If End Sub

نوعية القرص (قرص مرن،سي دي،..

'Declarations Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Public Const DRIVE_CDROM = 5 Public Const DRIVE_FIXED = 3 Public Const DRIVE_RAMDISK = 6 Public Const DRIVE_REMOTE = 4 Public Const DRIVE_REMOVABLE = 2 'وهذا في الفورم Dim strDrive As String Dim strMessage As String Dim intCnt As Integer For intCnt = 65 To 86 strDrive = Chr(intCnt) Select Case GetDriveType(strDrive + ":\") Case DRIVE_REMOVABLE rtn = "Floppy Drive" Case DRIVE_FIXED rtn = "Hard Drive" Case DRIVE_REMOTE rtn = "Network Drive" Case DRIVE_CDROM rtn = "CD-ROM Drive" Case DRIVE_RAMDISK rtn = "RAM Disk" Case Else rtn = "" End Select If rtn <> "" Then strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn End If Next intCnt MsgBox (strMessage)

تأثيرات على الفورم 

Public Sub Pause(Duration As Long) '//i didn't write this so i can't docume ' nt it Dim Current As Long Current = Timer Do Until Timer - Current >= Duration DoEvents Loop End Sub Public Sub SlideRight(FirstForm As Form, SecondForm As Form) '//the second form is the one that does ' the transition SecondForm.Show '//show the form SecondForm.Top = FirstForm.Top '//make the .Top equal for both form SecondForm.Height = FirstForm.Height '//make the .Height equal SecondForm.Width = FirstForm.Width '//make the .Width equal SecondForm.Left = SecondForm.Width * -1 '//make .Left negative Do Until SecondForm.Left = 0 '//do the loop until the form is all the ' way to the right SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh) Pause 0.3 '//pause Loop End Sub Public Sub SlideDown(FirstForm As Form, SecondForm As Form) '//the second form is the one that does ' the transition SecondForm.Show '//show the form SecondForm.Top = FirstForm.Height * -1 'make .Top negative SecondForm.Height = FirstForm.Height '//make the .Height equal SecondForm.Width = FirstForm.Width '//make the .Width equal SecondForm.Left = FirstForm.Left '//make the .Left equal Do Until SecondForm.Top = 0 '//do the loop until the form is all the ' way to the bottom SecondForm.Top = SecondForm.Top + 15 Pause 0.3 Loop End Sub Public Sub SlideLeft(FirstForm As Form, SecondForm As Form) '//the second form is the one that does ' the transition SecondForm.Show SecondForm.Top = FirstForm.Top SecondForm.Height = FirstForm.Height SecondForm.Width = FirstForm.Width SecondForm.Left = FirstForm.Width '//put on right side of screen Do Until SecondForm.Left = 0 SecondForm.Left = SecondForm.Left - 15 Pause 0.3 Loop End Sub Public Sub SlideUp(FirstForm As Form, SecondForm As Form) '//the second form is the one that does ' the transition SecondForm.Show SecondForm.Top = FirstForm.Height '//put form to bottom of screen SecondForm.Height = FirstForm.Height SecondForm.Width = FirstForm.Width SecondForm.Left = FirstForm.Left Do Until SecondForm.Top = 0 SecondForm.Top = SecondForm.Top - 15 Pause 0.3 Loop End Sub

فورم دائري 

Sub formcircle (frm As Form, Size As Integer) For e% = Size% - 1 To 0 Step -1 frm.Left = frm.Left - e% frm.Top = frm.Top + (Size% - e%) Next e% For e% = Size% - 1 To 0 Step -1 frm.Left = frm.Left + (Size% - e%) frm.Top = frm.Top + e% Next e% For e% = Size% - 1 To 0 Step -1 frm.Left = frm.Left + e% frm.Top = frm.Top - (Size% - e%) Next e% For e% = Size% - 1 To 0 Step -1 frm.Left = frm.Left - (Size% - e%) frm.Top = frm.Top - e% Next e% End Sub

أسماء المجلدات الرئيسية والفرعية في قائمة 

'Declarations Sub Listdir(path) Dim d(1000) Dir1.path = path For lop = 0 To Dir1.ListCount - 1 d(cnt) = Dir1.List(lop) cnt = cnt + 1 Next lop For lop = 0 To cnt - 1 List1.AddItem d(lop) cur_depth = cur_depth + 1 listdir d(lop) Next lop cur_depth = curr_depth - 1 End Sub 'ضع هذا في الفورم Listdir(اسم المجلد)

كلام متحرك في TITLEBAR 

Private Sub Timer1_Timer() On Error Resume Next If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0 Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag)) Timer1.Tag = Val(Timer1.Tag) + 1 If Me.Caption = "" Then If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0 Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag)) Timer1.Tag = Val(Timer1.Tag) + 1 End If End Sub Private Sub Form_Load() Timer1.Enabled = True End Sub

استقبال مكالمة هاتفية 

Private Sub Form_Load() MSComm1.Settings = "9600,N,8,1" ' لوب للتشييك على عشرة منافذ وإستخراج رقم منفذ المودوم الصحيح For i = 1 To 10 MSComm1.CommPort = i On Error GoTo N MSComm1.PortOpen = True N: If MSComm1.PortOpen = True Then Exit For End If Next End Sub Private Sub MSComm1_OnComm() If MSComm1.CommEvent Then MsgBox " وصول إتصال لك " End If End Sub

تلاشي النوافذ 

'ضع هذه الأكواد داخل اداة timer وأجعل الخاصية interval ب1 If Me.Height > 405 Then Me.Height = Me.Height - 200 Me.Top = Me.Top + 100 Else Form1.Visible = True Unload Me End If

كيف أقرأ أي كلمة تكون تحت موقع الفأرة 

'أضف أداة Timer ثم استخدم الشيفرة التالية Private Type POINTAPI x As Long y As Long End Type Private Declare Function SendMessage Lib "user32" _ Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg _ As Long, ByVal wParam As Long, ByVal lParam As Any) _ 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 Private Declare Function GetCursorPos Lib "user32" _ (lpPoint As POINTAPI) As Long Private Declare Function WindowFromPoint Lib _ "user32" (ByVal xPoint As Long, ByVal yPoint _ As Long) As Long Private Function WinText(hwnd As Long) As String Dim Trm&, Buf$ Trm = SendMessage(hwnd, 14, 0&, 0&) Buf = String(Trm, " ") SendMessageByString hwnd, 13, Trm + 1, Buf WinText = Buf End Function Private Sub Form_Load() Timer1.Interval = 50 End Sub Private Sub Timer1_Timer() Dim lng_hWnd&, pt As POINTAPI GetCursorPos pt lng_hWnd = WindowFromPoint(pt.x, pt.y) Label1 = WinText(lng_hWnd) End Sub

أخفاء المجلدات و الملفات عن طريق فجوال بيسك 

'SetAttr pathname, attributes 'folder SetAttr "c:\x", vbHidden 'file SetAttr "c:\file.txt", vbHidden

شفرة التعامل مع الأداة AVI

Private Sub Command1_Click() Dim z: Dim zz zz = " c:boxGrolierspace1.avi" ' أكتب هنا مسا ر ملف الفيديو MMControl1.DeviceType = "AVIVideo" z = App.Path 'تستخدم هذه الشفرة إذا كان ملف الفيديو في نفس مسار المشروع zz = z + "" + "5.avi" ' تكمل السابقة MMControl1.FileName = zz MMControl1.hWndDisplay = Form1.hWnd ' هذه تستخدم لتحديد المكان الذي سيظهر فيه الفيديو MMControl1.Command = "open" MMControl1.Command = "prev" MMControl1.Command = "play" End Sub Private Sub MMControl1_Done(NotifyCode As Integer) If MMControl1.Position = MMControl1.Length Then Dim z: Dim zz zz = " c:boxGrolierspace2.avi" ' أكتب هنا مسا ر ملف الفيديو MMControl1.DeviceType = "AVIVideo" z = App.Path 'تستخدم هذه الشفرة إذا كان ملف الفيديو في نفس مسار المشروع zz = z + "" + "5.avi" ' تكمل السابقة MMControl1.FileName = zz MMControl1.hWndDisplay = Form1.hWnd ' هذه تستخدم لتحديد المكان الذي سيظهر فيه الفيديو MMControl1.Command = "open" MMControl1.Command = "prev" MMControl1.Command = "play" End If End Sub

إبطال عمل Ctrl+c 

'فى موديول Public Const WM_KEYDOWN = &H100 Public Const WM_CHAR = &H102 Public Const GWL_WNDPROC = (-4) Public Declare Function SetWindowLong Lib "user32" Alias _ "SetWindowLongA" (ByVal hwnd As Long, ByVal _ nIndex As Long, ByVal dwNewLong As Long) _ As Lo 'فى الفورم Private Sub Form_Load() hPrevWndProc = SetWindowLong(RichTextBox1.hwnd, _ GWL_WNDPROC, AddressOf WindowProc) End Sub

إظهار نافذة الخطأ البيضاء 

Private Declare Sub FatalAppExit Lib "kernel32" Alias "FatalAppExitA" (ByVal uAction As Long, ByVal lpMessageText As String) Private Sub Form_Load() FatalAppExit 0, "Contactez le revendeur de ce programme" & vbLf & vbLf & "(Cette source provient de http://www.vbfrance.com/)" End Sub

إفراغ سلة المحذوفات

'إفراغ سلة المحذوفات Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long Private Sub Form_Load() 'الإفراغ SHEmptyRecycleBin Me.hwnd, vbNullString, 0 'التحديث SHUpdateRecycleBinIcon End Sub

اتصل تليفونيا

Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long Private Sub Command1_Click() a = tapiRequestMakeCall((1014557524), "Program Name", (Name), "Addition Comments") End Sub

اخفاء واظهار زر ابدء

Const SW_SHOWNORMAL = 1 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 ShowWindow Lib "user32" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Const SW_HIDE = 0 Public Function hideStartButton() 'This Function Hides the Start Button' OurParent& = FindWindow("Shell_TrayWnd", "") OurHandle& = FindWindowEx(OurParent&, 0, "Button", _ vbNullString) ShowWindow OurHandle&, SW_HIDE End Function Public Function showStartButton() 'This Function Shows the Start Button' OurParent& = FindWindow("Shell_TrayWnd", "") OurHandle& = FindWindowEx(OurParent&, 0, "Button", _ vbNullString) ShowWindow OurHandle&, SW_SHOWNORMAL End Function Private Sub Command1_Click() hideStartButton End Sub Private Sub Command2_Click() showStartButton End Sub

اظهار واخفاء مؤشر الماوس

'فى الموديول Public Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long 'Command1 + command2 Private Sub Command1_Click() Dim x As Long x = ShowCursor(True) 'اظهار المؤشر End Sub Private Sub Command2_Click() Dim x As Long x = ShowCursor(False) 'اخفاء المؤشر End Sub

اعداد الطابعة

Dim X As Integer Private Sub Command2_Click() Printer.Print “October; War” End Sub

الاصوات في فيجوال بيسك

Private Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long Private Const SND_SYNC = &H0 ' play synchronously (default) Private Const SND_ASYNC = &H1 ' play asynchronously Private Const SND_LOOP = &H8 ' loop the sound until next sndPlaySound Private Const SND_NOSTOP = &H10 ' don't stop any currently playing sound Private Sub Command1_Click() res = sndPlaySound(App.Path & "\97", SND_ASYNC) 'لتشغيل ملف ويعود التنفيذ للبرنامج بمجرد بدء تشغيل ملف الصوت End Sub Private Sub Command2_Click() res = sndPlaySound(App.Path & "\97", SND_SYNC) 'تشغيل ملف صوت ولا يعود التحكم للبرنامج إلا بعد الإنتهاء من تشغيل ملف الصوت بالكامل End Sub Private Sub Command3_Click() rse = sndPlaySound(App.Path & "\97", SND_LOOP Or SND_ASYNC) 'ولتشغيل الملف بشكل تكراري End Sub Private Sub Command4_Click() res = sndPlaySound(App.Path & "\97.wav", SND_NOSTOP Or SND_ASYNC) 'ولتشغيل الملف بشرط أنه لا يكون هناك ملف صوتي آخر قيد التشغيل End Sub Private Sub Form_Load() End Sub

الدخول للانترنت عن طريق الكود

'modeul Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Public Const conSwN 'command1 Private Sub Command1_Click() ShellExecute hwnd, "open", "http://arafa.4mg.com/ash.htm", vbNullString, vbNullString, conSwNormal End Sub

الكود الذي يقوم بقراءة رقم الهاردسك 

'استخدام المكتبة Microsoft Scripting Runtime Private Sub Command1_Click() Dim obj_FSO As Object, obj_Drive As Object Set obj_FSO = CreateObject("Scripting.FileSystemObject") Set obj_Drive = obj_FSO.GetDrive("c:\") MsgBox obj_Drive.SerialNumber Set obj_FSO = Nothing Set obj_Drive = Nothing End Sub

النسخ الاحتياطي للبيانات

'لعمل الفولدر Private Sub CMDmak_Click() 'MkDir "D:\BACKUP" 'MkDir "D:\BACKUP\SITRAWI" End Sub 'لنسخ الملف Private Sub CMDBAK_Click() SOURCE = "D:\hus\Aig.bmp" dESTN = "D:\BACKUP\SITRAWI\AIG.BMp" FileCopy SOURCE, dESTN End Sub