موسوعة أكواد الفيجول بيسك

[ab2222]

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

Dim str As String
Dim x() As String

str = "موقع#ومنتديات#المشاغب"
x() = Split(str, "#")

For Each y In x()
MsgBox y
Next

[ab2222]

هذا الكود لمعرفة مجلد الويندوز

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

[ab2222]

تنفيذ الأمر بعد فترة معينة
لنفرض أنك تريد تنفيذ الأمر تحت الزر المضغوط عليه بعد خمس ثوان من ضغط المستخدم للزر وليس بعد ضغطه للزر فوراً ، هذا المثال يوضح ذلك حيث يقوم بعرض رسالة للمستخدم بعد مرور خمس ثوان على ضغطه الزر :

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 "أهلا بك"
End Sub

[ab2222]

إبطال مفعول زر x الواقع في زاوية الفورم
قم بإضافة الكود التالي في أي مكان فارغ في الفورم الذي تريد منع ظهور علامة X فيه :

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

[ab2222]

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

[ab2222]

فتح ملف نصي تلقائيا في الـمفكرة

قم بإضافة الكود التالي مع تغيير المسار


Private Sub Command1_Click()
Shell "notepad.exe" & " " & "C:\boot.ini", vbNormalFocus
End Sub

[ab2222]

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

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

[ab2222]

هذا الكود يقوم بتوليد 100 رقم بين 0 و 100 (بدون تكرار)
قم بإضافة زر كوماند على الفورم (command1) وقائمة (list1) ، واضف الكود التالي :

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

[ab2222]

هذا الكود يقوم بتحميل جميع خطوط الكمبيوتر المتوفرة عندك في صندوق القائمة المنسدلة 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

[ab2222]

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

قم بإضافة الكود التالي ، ولا تنسى تغيير المسار

كما لا تنسى بعمل أداة نص (text1) وتغيير خاصية multiLine إلى true

Open "c:\windows\desktop\books.txt" For Input As #1
Text1.Text = Input(LOF(1), 1)
Close #1

[ab2222]

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

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

[ab2222]

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

strTempDir = Environ$("temp")
MsgBox strTempDir

[ab2222]

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

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

[ab2222]

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

strFileName = "c:\windows\desktop\book.txt"
lFileSize = FileLen(strFileName)

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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)

[ab2222]

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

Private Sub Command1_Click()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "مساحة الشاشة:" + Str$(intWidth) + " x" + Str$(intHeight), vbMsgBoxRight
End Sub

[ab2222]

لقراءة سطر معين من ملف
أضف 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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

قم بإضافة الكود التالي في أي مكان فارغ ، ثم شغل البرنامج بالضغط على زرF5 ثم قم بتحريك الفأرة على النافذة وشاهد ما يحدث :

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

قم بضبط خاصية 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

[ab2222]

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة 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

[ab2222]

عرض نموذج داخل نموذج آخر
أضف نموذجين 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

[ab2222]

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

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

[ab2222]

هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل 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

[ab2222]

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

[ab2222]

لفتح وإغلاق سواقة الأقراص المدمجة
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

[ab2222]

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

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

[ab2222]

كود يحول الحروف الإنجليزية لأحرف كبيرة
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr$(KeyAscii)))
End Sub

[ab2222]

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

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

[ab2222]

هذا كود لنسخ خلفية سطح المكتب إلى نموذجك ... ارجو ان يعجبكم

اولاً أظف زر امر Command1 الى النموذج وانسخ الكود التالي


Private Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long

'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub

[ab2222]

هذا الكود لتبديل أزرار الفأرة

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

[ab2222]

هذا الكود لإنهاء البرنامج عند النقر على 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

[ab2222]

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

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

[ab2222]

لإخفاء وإظهار شريط المهام 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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

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

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

[Webmaster]

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

[ab2222]

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

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

[ab2222]

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

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

[ab2222]

هذا الكود لمعرفة ما إذا كانت سواقة الأقرص المدمجة المحددة تحتوي على قرص أم لا

Private Declare Function GetVolumeInformation Lib "kernel32" Alias _
"GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Const DRIVE_CDROM = 5

Private Sub Command1_Click()
Dim VolName As String, FSys As String, erg As Long
Dim VolNumber As Long, MCM As Long, FSF As Long
Dim Drive As String, DriveType As Long
VolName = Space(127)
FSys = Space(127)
Drive = "D:" 'Enter the driverletter you want
DriveType& = GetDriveType(Drive$)
erg& = GetVolumeInformation(Drive$, VolName$, 127&, VolNumber&, MCM&, FSF&, FSys$, 127&)
If DriveType& = DRIVE_CDROM Then
If erg& = 0 Then
Print "no CD in the drive)"
Else
Print "CD in the drive)"
End If
End If
End Sub

[ab2222]

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

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

[Irgsous12]

مشكور أخي صح أنا مني خبير ولا جربته بس أهناك علي خبرتك
ما شاء الله تبارك الله

أخي كود تشغيل البرامج ما زبط
وشكرااااااااا

[ab2222]

العفو ياأخي

بس ياليت توضح سؤالك أكثر

[Irgsous12]

أخي لو سمحت تاكد من إظهار كود سطح المكتب راح علي أيقونات سطح
المكتب بسرعه لو سمحت

[ab2222]

أخي الكود صحيح
وأنا طبقته من هنا
ونفع

على العموم حمل المثال هذا

http://www.arabic2.com/show.zip

[absba]

والى الامام اخي الكريم

وننتظر منك المزيد وجزاك الله الف خير

تحياتي

[ab2222]

الله يعافيك يالحمادي
وإن شاء الله تشوفوا المزيد قريبا

[Geosemsem]

شكرا لك أخي الكريم ab2222..

جزاك الله كل خيـــر..

وبالتوفيـق للجميــــع.. :) :)

[Xacker]

مشكور اخوي العزيز على الاكواد الرائعة

[hamany90]

يسلم يمانك على هل الأكواد الرائعة و المميزة و الجديدة بنفس الوقت ..

تقبل تحياتي

حمني90

[molto]

مشكوووووووووور جدآآآآآآآآآآآآآآآآ

[nart]

اشكرك يا ابو شريك

[mizmish]

حاجة عظيمة جدا