الموضوع: موسوعة من أهم أكواد لغة البرمجة VisualBasic التى قد تفيدكم

[align=center:812713b1a0]بسم الله الرحمن الرحيم وبه نستعين السلام عليكم ورحمة الله وبركاتة

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

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


رجـــــــــاء :

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

البرمجة = فكــــر المبرمج
وليس لغة البرمجة المستخدمة
نبدأعلى بركــــة الله[/align:812713b1a0]
[align=center:812713b1a0][hide:812713b1a0]
[frame="1 80"]إغلاق النظام (ويندوز XP) :
Windows API Call/ Explanation /DDE 766

ضع هذا الكود في الفورم

رمز:

Shutdown Flags

Const EWX_LOGOFF 0

Const EWX_SHUTDOWN 1

Const EWX_REBOOT 2

Const EWX_FORCE 4

Const SE_PRIVILEGE_ENABLED &H2

Const TokenPrivileges 3

Const TOKEN_ASSIGN_PRIMARY &H1

Const TOKEN_DUPLICATE &H2

Const TOKEN_IMPERSONATE &H4

Const TOKEN_QUERY &H8

Const TOKEN_QUERY_SOURCE &H10

Const TOKEN_ADJUST_PRIVILEGES &H20

Const TOKEN_ADJUST_GROUPS &H40

Const TOKEN_ADJUST_DEFAULT &H80

Const SE_SHUTDOWN_NAME SeShutdownPrivilege

Const ANYSIZE_ARRAY 1

Private Type LARGE_INTEGER

lowpart As Long

highpart As Long

End Type

Private Type Luid

lowpart As Long

highpart As Long

End Type

Private Type LUID_AND_ATTRIBUTES

pLuid As Luid

pLuid As LARGE_INTEGER

Attributes As Long

End Type

Private Type TOKEN_PRIVILEGES

PrivilegeCount As Long

Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES

End Type

Private Declare Function InitiateSystemShutdown Lib advapi32.dll Alias InitiateSystemShutdownA (ByVal lpMachineName As String ByVal lpMessage As String ByVal dwTimeout As Long ByVal bForceAppsClosed As Long ByVal bRebootAfterShutdown As Long) As Long

Private Declare Function OpenProcessToken Lib advapi32.dll (ByVal ProcessHandle As Long ByVal DesiredAccess As Long TokenHandle As Long) As Long

Private Declare Function GetCurrentProcess Lib kernel32 () As Long

Private Declare Function LookupPrivilegeValue Lib advapi32.dll Alias LookupPrivilegeValueA (ByVal lpSystemName As String ByVal lpName As String lpLuid As LARGE_INTEGER) As Long

Private Declare Function AdjustTokenPrivileges Lib advapi32.dll (ByVal TokenHandle As Long ByVal DisableAllPrivileges As Long NewState As TOKEN_PRIVILEGES ByVal BufferLength As Long PreviousState As TOKEN_PRIVILEGES ReturnLength As Long) As Long

Private Declare Function GetComputerName Lib kernel32 Alias GetComputerNameA (ByVal lpBuffer As String nSize As Long) As Long

Private Declare Function GetLastError Lib kernel32 () As Long

Public Function InitiateShutdownMachine(ByVal Machine As String Optional Force As Variant Optional Restart As Variant Optional AllowLocalShutdown As Variant Optional Delay As Variant Optional Message As Variant) As Boolean

Dim hProc As Long

Dim OldTokenStuff As TOKEN_PRIVILEGES

Dim OldTokenStuffLen As Long

Dim NewTokenStuff As TOKEN_PRIVILEGES

Dim NewTokenStuffLen As Long

Dim pSize As Long

If IsMissing(Force) Then Force False

If IsMissing(Restart) Then Restart True

If IsMissing(AllowLocalShutdown) Then AllowLocalShutdown False

If IsMissing(Delay) Then Delay 0

If IsMissing(Message) Then Message 

Make sure the Machine-name doesnt start with 

If InStr(Machine ) 1 Then

Machine Right(Machine Len(Machine) - 2)

End If

check if its the local machine thats going to be shutdown

If (LCase(GetMyMachineName) LCase(Machine)) Then

may we shut this computer down?

If AllowLocalShutdown False Then Exit Function

open access token

If OpenProcessToken(GetCurrentProcess() TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY hProc) 0 Then

MsgBox OpenProcessToken Error: & GetLastError()

Exit Function

End If

retrieve the locally unique identifier to represent the Shutdown-privilege name

If LookupPrivilegeValue(vbNullString SE_SHUTDOWN_NAME OldTokenStuff.Privileges(0).pLuid) 0 Then

MsgBox LookupPrivilegeValue Error: & GetLastError()

Exit Function

End If

NewTokenStuff OldTokenStuff

NewTokenStuff.PrivilegeCount 1

NewTokenStuff.Privileges(0).Attributes SE_PRIVILEGE_ENABLED

NewTokenStuffLen Len(NewTokenStuff)

pSize Len(NewTokenStuff)

Enable shutdown-privilege

If AdjustTokenPrivileges(hProc False NewTokenStuff NewTokenStuffLen OldTokenStuff OldTokenStuffLen) 0 Then

MsgBox AdjustTokenPrivileges Error: & GetLastError()

Exit Function

End If

initiate the system shutdown

If InitiateSystemShutdown( & Machine Message Delay Force Restart) 0 Then

Exit Function

End If

NewTokenStuff.Privileges(0).Attributes 0

Disable shutdown-privilege

If AdjustTokenPrivileges(hProc False NewTokenStuff Len(NewTokenStuff) OldTokenStuff Len(OldTokenStuff)) 0 Then

Exit Function

End If

Else

initiate the system shutdown

If InitiateSystemShutdown( & Machine Message Delay Force Restart) 0 Then

Exit Function

End If

End If

InitiateShutdownMachine True

End Function

Function GetMyMachineName() As String

Dim sLen As Long

create a buffer

GetMyMachineName Space(100)

sLen 100

retrieve the computer name

If GetComputerName(GetMyMachineName sLen) Then

GetMyMachineName Left(GetMyMachineName sLen)

End If

End Function

Private Sub Form_Load()

InitiateShutdownMachine GetMyMachineName True True True 60 You initiated a system shutdown...

End Sub

معرفة إصدارة الويندوز الحالية
Windows API Call/ Explanation /DDE 439

ضع هذا الكود في الفورم :

رمز:

Private Declare Function GetVersionEx Lib kernel32 Alias GetVersionExA (lpVersionInformation As OSVERSIONINFO) As Long

Private Type OSVERSIONINFO

dwOSVersionInfoSize As Long

dwMajorVersion As Long

dwMinorVersion As Long

dwBuildNumber As Long

dwPlatformId As Long

szCSDVersion As String * 128

End Type

Private Sub Form_Load()

Dim OSInfo As OSVERSIONINFO PId As String

Set the graphical mode to persistent

Me.AutoRedraw True

Set the structure size

OSInfo.dwOSVersionInfoSize Len(OSInfo)

Get the Windows version

Ret& GetVersionEx(OSInfo)

Chack for errors

If Ret& 0 Then MsgBox Error Getting Version Information: Exit Sub

Print the information to the form

Select Case OSInfo.dwPlatformId

Case 0

PId Windows 32s 

Case 1

PId Windows 95/98

Case 2

PId Windows NT 

End Select

Print OS: PId

Print Win version: str$(OSInfo.dwMajorVersion) . LTrim(str(OSInfo.dwMinorVersion))

Print Build: str(OSInfo.dwBuildNumber)

End Sub

معرفة اسم المستخدم :

Windows API Call/ Explanation /DDE 489

ضع هذا الكود في الفورم

رمز:

Private Declare Function GetUserName Lib advapi32.dll Alias GetUserNameA (ByVal lpBuffer As String nSize As Long) As Long



Private Sub Form_Load()

Dim N

Dim UserN As String

UserN Space(144)

N GetUserName(UserN 144)

Text1.Text UserN

End Sub

تغيير دقة العرض للشاشة :

Graphics 404

رمز:

ضع هذا الكود في الموديول



Public Const EWX_LOGOFF 0

Public Const EWX_SHUTDOWN 1

Public Const EWX_REBOOT 2

Public Const EWX_FORCE 4

Public Const CCDEVICENAME 32

Public Const CCFORMNAME 32

Public Const DM_BITSPERPEL &H40000

Public Const DM_PELSWIDTH &H80000

Public Const DM_PELSHEIGHT &H100000

Public Const CDS_UPDATEREGISTRY &H1

Public Const CDS_TEST &H4

Public Const DISP_CHANGE_SUCCESSFUL 0

Public Const DISP_CHANGE_RESTART 1



Type typDevMODE

dmDeviceName As String * CCDEVICENAME

dmSpecVersion As Integer

dmDriverVersion As Integer

dmSize As Integer

dmDriverExtra As Integer

dmFields As Long

dmOrientation As Integer

dmPaperSize As Integer

dmPaperLength As Integer

dmPaperWidth As Integer

dmScale As Integer

dmCopies As Integer

dmDefaultSource As Integer

dmPrintQuality As Integer

dmColor As Integer

dmDuplex As Integer

dmYResolution As Integer

dmTTOption As Integer

dmCollate As Integer

dmFormName As String * CCFORMNAME

dmUnusedPadding As Integer

dmBitsPerPel As Integer

dmPelsWidth As Long

dmPelsHeight As Long

dmDisplayFlags As Long

dmDisplayFrequency As Long

End Type



Declare Function EnumDisplaySettings Lib user32 Alias EnumDisplaySettingsA (ByVal lpszDeviceName As Long ByVal iModeNum As Long lptypDevMode As Any) As Boolean

Declare Function ChangeDisplaySettings Lib user32 Alias ChangeDisplaySettingsA (lptypDevMode As Any ByVal dwFlags As Long) As Long

Declare Function ExitWindowsEx Lib user32 (ByVal uFlags As Long ByVal dwReserved As Long) As Long



ضع هذا الكود في الفورم



Private Sub Command1_Click()

Dim typDevM As typDevMODE

Dim lngResult As Long

Dim intAns As Integer



lngResult EnumDisplaySettings(0 0 typDevM)



With typDevM

.dmFields DM_PELSWIDTH Or DM_PELSHEIGHT

.dmPelsWidth 640 اختر العرض (6408001024 etc)

.dmPelsHeight 480 اختر الطول (480600768 etc)

End With



lngResult ChangeDisplaySettings(typDevM CDS_TEST)

Select Case lngResult

Case DISP_CHANGE_RESTART

intAns MsgBox(You must restart your computer to apply these changes. & _

vbCrLf & vbCrLf & Do you want to restart now? _

vbYesNo vbSystemModal Screen Resolution)

If intAns vbYes Then Call ExitWindowsEx(EWX_REBOOT 0)

Case DISP_CHANGE_SUCCESSFUL

Call ChangeDisplaySettings(typDevM CDS_UPDATEREGISTRY)

MsgBox Screen resolution changed vbInformation Resolution Changed

Case Else

MsgBox Mode not supported vbSystemModal Error

End Select



End Sub

إزالة اسم البرنامج من إدارة المهام (ويندوز98) :
Coding Standards 278

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_Load()

App.TaskVisible False

End Sub

معرفة مسار مجلد النظام في الويندوز :

Windows API Call/ Explanation /DDE 299

رمز:

 

ضع هذا الكود في الفورم



Private Declare Function GetSystemDirectory Lib kernel32 Alias GetSystemDirectoryA (ByVal lpBuffer As String ByVal nSize As Long) As Long



Private Sub Form_Load()

Dim S

Dim SystemD As String

SystemD Space(144)

S GetSystemDirectory(SystemD 144)

Text1.Text SystemD

End Sub

معرفة مسار مجلد الويندوز
Windows API Call/ Explanation /DDE 264

رمز:

ضع هذا الكود في الفورم



Private Declare Function GetWindowsDirectory Lib kernel32 Alias GetWindowsDirectoryA (ByVal lpBuffer As String ByVal nSize As Long) As Long



Private Sub Form_Load()

Dim W

Dim WindowsD As String

WindowsD Space(144)

W GetWindowsDirectory(WindowsD 144)

Text1.Text WindowsD

End Sub

معرفة اللون الذي يمر عليه مؤشر الفأرة :
Windows API Call/ Explanation /DDE 373

رمز:

ضع هذا الكود في الفورم



Option Explicit

Private Type POINTAPI

x As Long

y As Long

End Type

Private Declare Function GetPixel Lib gdi32 (ByVal hdc As Long ByVal x As Long ByVal y As Long) As Long

Private Declare Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As Long

Private Declare Function GetWindowDC Lib user32 (ByVal hwnd As Long) As Long

Private Sub Form_Load()

Timer1.Interval 100

End Sub

Private Sub Timer1_Timer()

Dim tPOS As POINTAPI

Dim sTmp As String

Dim lColor As Long

Dim lDC As Long



lDC GetWindowDC(0)

Call GetCursorPos(tPOS)

lColor GetPixel(lDC tPOS.x tPOS.y)

Label1.BackColor lColor



sTmp Right$(000000 & Hex(lColor) 6)

Caption R: & Right$(sTmp 2) & G: & Mid$(sTmp 3 2) & B: & Left$(sTmp 2)

End Sub

رسم دوائر ملونة جميلة باستخدام مؤشر الفأرة :
Coding Standards 414

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

Form1.Cls

End Sub

Private Sub Form_MouseMove(Button As Integer Shift As Integer X As Single Y As Single)

Dim i As Integer

i Rnd * 15

If Button 1 Then

Me.Circle (X Y) 200 QBColor(i)

End If

End Sub

معرفة العناوين تحت مؤشر الفأرة :
Windows API Call/ Explanation /DDE 348

رمز:

 

ضع هذا الكود في الفورم



Private Declare Function GetForegroundWindow Lib user32 () As Long

Private Declare Function GetWindowTextLength Lib user32 _

Alias GetWindowTextLengthA (ByVal hwnd As Long) As Long

Private Declare Function GetWindowText Lib user32 _

Alias GetWindowTextA (ByVal hwnd As Long ByVal lpString As String _

ByVal cch As Long) As Long

Private Declare Function SetWindowText Lib user32 _

Alias SetWindowTextA (ByVal hwnd As Long _

ByVal lpString As String) As Long

Private Declare Function FindWindow& Lib user32 _

Alias FindWindowA (ByVal lpClassName As String _

ByVal lpWindowName As String)

Private Declare Function GetWindow& Lib user32 _

(ByVal hwnd As Long ByVal wCmd As Long)

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 Declare Function SendMessageByString& Lib user32 _

Alias SendMessageA (ByVal hwnd As Long ByVal wMsg As Long _

ByVal wParam As Long ByVal lParam As String)

Private Declare Function GetCursorPos& Lib user32 _

(lpPoint As POINTAPI)

Private Declare Function WindowFromPoint& Lib user32 _

(ByVal x As Long ByVal y As Long)

Private Declare Function ChildWindowFromPoint& Lib user32 _

(ByVal hwnd As Long ByVal x As Long ByVal y 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)

Private Declare Function UpdateWindow& Lib user32 (ByVal hwnd As Long)

Const SWP_NOACTIVATE &H10

Const SWP_NOREDRAW &H8

Const SWP_NOSIZE &H1

Const SWP_NOZORDER &H4

Const SWP_NOMOVE &H2

Const HWND_TOPMOST -1

Const HWND_BOTTOM 1

Const SWP_HIDEWINDOW &H80

Const WM_SETTEXT &HC

Const WM_GETTEXT &HD

Const WM_CHAR &H102

Const WM_CLEAR &H303

Const GW_CHILD 5

Const GW_HWNDNEXT 2

Const EM_SETPASSWORDCHAR &HCC

Const EM_GETPASSWORDCHAR &HD2

Const EN_CHANGE &H300

Dim Abort LastWindow& LastCaption$

Private Type POINTAPI

x As Long

y As Long

End Type

Function GetCaption(hwnd) As String

Dim capt As String TChars As String

capt$ Space$(255)

TChars$ GetWindowText(hwnd capt$ 255)

GetCaption Left$(capt$ TChars$)

End Function



Function GetText(hwnd) As String

Dim GetTrim As Long TrimSpace As String GetString As String

GetTrim Sendmessagebynum(hwnd 14 0& 0&)

TrimSpace$ Space$(GetTrim)

GetString SendMessageByString(hwnd 13 GetTrim 1 TrimSpace$)



GetText TrimSpace$

End Function



Private Sub Form_Load()

Call SetWindowPos(Form1.hwnd HWND_TOPMOST 0& 0& 0& _

0& SWP_NOMOVE Or SWP_NOSIZE)

End Sub



Private Sub Form_Unload(Cancel As Integer)

Abort 1

End Sub



Private Sub Timer1_Timer()

Dim mypoint As POINTAPI A As Long B As Long

Call GetCursorPos(mypoint)

A& WindowFromPoint(mypoint.x mypoint.y)

B& ChildWindowFromPoint(A& mypoint.x mypoint.y)

If A& Form1.hwnd Then Exit Sub

Label1.Caption GetCaption(A&)

Label2.Caption GetText(A&)

End Sub

رسم خطين متقاطعين حسب حركة مؤشر الفأرة :
Coding Standards 294

رمز:

ضع هذا الكود في الفورم



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 

 

 



إضافة حدث عند الضغط على زر الفأرة الأيمن :

 Coding Standards 380 

 

ضع هذا الكود في الفورم



Private Sub Form_MouseDown(Button As Integer Shift As Integer X As Single Y As Single) 



IF BUTTON2 THEN 

msgbox الزر الأيمن للماوس 

END IF 

End Sub

التحكم في حركة مؤشر الفأرة :
Windows API Call/ Explanation /DDE 310

رمز:

 

ضع هذا الكود في الفورم



Private Type POINTAPI

x As Long

y As Long

End Type

Private Declare Function ClientToScreen Lib user32 (ByVal hwnd As Long lpPoint As POINTAPI) As Long

Private Declare Function SetCursorPos Lib user32 (ByVal x As Long ByVal y As Long) As Long

Private Declare Function GetDeviceCaps Lib gdi32 (ByVal hdc As Long ByVal nIndex As Long) As Long



Dim P As POINTAPI

Private Sub Form_Load()



Command1.Caption Screen Middle

Command2.Caption Form Middle

API uses pixels

Me.ScaleMode vbPixels

End Sub

Private Sub Command1_Click()

Get information about the screens width

P.x GetDeviceCaps(Form1.hdc 8) / 2

Get information about the screens height

P.y GetDeviceCaps(Form1.hdc 10) / 2

Set the mouse cursor to the middle of the screen

ret SetCursorPos(P.x P.y)

End Sub

Private Sub Command2_Click()

P.x 0

P.y 0

Get information about the forms left and top

ret ClientToScreen&(Form1.hwnd P)

P.x P.x Me.ScaleWidth / 2

P.y P.y Me.ScaleHeight / 2

Set the cursor to the middle of the form

ret SetCursorPos&(P.x P.y)

End Sub

SendMessage API :
Coding Standards 299

رمز:

 

ضع هذا الكود في الموديول



Declare Function ReleaseCapture Lib user32 () As Long

Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd As Long ByVal wMsg As Long ByVal wParam As Long lParam As Any) As Long

Public Const HTCAPTION 2

Public Const WM_NCLBUTTONDOWN &HA1



ضع هذا الكود في الفورم



Private Sub Form_MouseDown(Button As Integer Shift As Integer X As Single Y As Single)

ReleaseCapture

SendMessage hwnd WM_NCLBUTTONDOWN HTCAPTION 0&

End Sub

تحريك صورة مع مؤشر الفأرة :
Coding Standards 384

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_MouseMove(Button As Integer Shift As Integer X As Single Y As Single)

Picture1.Move X - 200 Y - 200

End Sub

معرفة مسار مجلد الـ Temp :
Windows API Call/ Explanation /DDE 219

رمز:

 

ضع هذا الكود في الموديول



Declare Function GetTempPath Lib kernel32 Alias GetTempPathA (ByVal nBufferLength As Long ByVal lpBuffer As String) As Long



ضع هذا الكود في الفورم



Public Function TheTempDir() As String

Dim lpBuffer As String

Dim TempPath As Long

lpBuffer Space(255)

TempPath GetTempPath(255 lpBuffer)

TheTempDir Left(lpBuffer TempPath)

End Function

Private Sub Command1_Click()

Text1.Text TheTempDir

End Sub

معرفة الوقت الذي مضى على تشغيل الويندوز بالدقيقة :
Windows API Call/ Explanation /DDE 412

رمز:

 

ضع هذا الكود في الفورم



Private Declare Function GetTickCount Lib Kernel32 () As Long



Private Sub Command1_Click()

Print Format(GetTickCount / 10000 / 6 0)

End Sub

معرفة دقة عرض الشاشة :
Windows API Call/ Explanation /DDE 267

رمز:

 

ضع هذا الكود في الفورم



Private Declare Function GetTickCount Lib Kernel32 () As Long



Private Sub Command1_Click()

Print Format(GetTickCount / 10000 / 6 0)

End Sub

إفراغ سلة المحذوفات :
Windows API Call/ Explanation /DDE 345

رمز:

 

ضع هذا الكود في الفورم



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

SHEmptyRecycleBin Me.hwnd vbNullString 0

SHUpdateRecycleBinIcon

End Sub

معرفة اسم الكمبيوتر :
Windows API Call/ Explanation /DDE 339

رمز:

 

ضع هذا الكود في الفورم



Private Const MAX_COMPUTERNAME_LENGTH As Long 31

Private Declare Function GetComputerName Lib kernel32 Alias GetComputerNameA (ByVal lpBuffer As String nSize As Long) As Long

Private Sub Form_Load()

Dim dwLen As Long

Dim strString As String

Create a buffer

dwLen MAX_COMPUTERNAME_LENGTH 1

strString String(dwLen X)

Get the computer name

GetComputerName strString dwLen

get only the actual data

strString Left(strString dwLen)

Show the computer name

MsgBox strString

End Sub

استخدام مساعد الأوفيس :
Coding Standards 304

رمز:

 

ضع هذا الكود في الفورم



Dim Genie As IAgentCtlCharacter

Private Sub Command1_Click()

Genie.Show

End Sub

Private Sub Command2_Click()

Genie.Hide

End Sub



Private Sub Command3_Click()

Genie.Play Congratulate

End Sub



Private Sub Command4_Click()

Genie.Play Pleased

End Sub



Private Sub Command5_Click()

Genie.Play lookup

End Sub



Private Sub Command6_Click()

Genie.Play Think

End Sub



Private Sub Form_Load()

Dim Filename

Filename ضع مسار المساعد هنا وغالباً ما يكون في المسار التالي windowsmsagentchar

على سبيل المثال

c:windowsmsagentchargenie.acs

Agent1.Characters.Load CharacterID:Genie LoadKey:Filename

Set Genie Agent1.Characters(Genie)

End Sub

قراءة رقم الهارد ديسك :
Coding Standards 456

رمز:

 

ضع هذا الكود في الفورم



استخدام المكتبة 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

تشغيل حافظ الشاشة عن طريق ال API Coding Standards 274 :

رمز:

 

ضع هذا الكود في الفورم



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



Private Sub Command1_Click()

Call SendMessage(Me.hwnd WM_SYSCOMMAND SC_SCREENSAVE 0)

End Sub

عرض الزمن والتاريخ :
Coding Standards 415

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_Load()

Timer1.Interval 1000

End Sub



Private Sub Timer1_Timer()

Label1 Time & Date

End Sub

الفرق بين تاريخين باليوم :
Coding Standards 475

رمز:

 

ضع هذا الكود في الفورم



Private Sub Command1_Click()

On Error GoTo 1

Dim Form1Date As Date

Dim Form2Date As Date

Form1Date Text1.Text

Form2Date Text2.Text

Text3.Text DateDiff(d Text1.Text Text2.Text) & يوم

Exit Sub

1 MsgBox (من فضلك أدخل التاريخ بشكل صحيح)

End Sub

معرفة الشهر الحالي :
Coding Standards 202

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

Mmonth Mid(Date 4 2)

Print MonthName(Mmonth)

End Sub

معرفة اليوم الحالي :
Coding Standards 191

رمز:

 

ضع هذا الكود في الفورم



Private Sub Command1_Click()

Dim Dday As Integer

Dday Weekday(Date)

If Dday 1 Then Print الأحد

If Dday 2 Then Print الاثنين

If Dday 3 Then Print الثلاثاء

If Dday 4 Then Print الأربعاء

If Dday 5 Then Print الخميس

If Dday 6 Then Print الجمعة

If Dday 7 Then Print السبت

End Sub

التحكم في رفع وخفض الصوت :
Sound/MP3 282

رمز:

ضع هذا الكود في الفورم



Private Declare Function waveOutSetVolume Lib Winmm.dll (ByVal DevID As Integer ByVal Vol As Long) As Long



Sub SetVol(Volume As Long)

Dim Vol&

Vol CLng(&H & Hex(Volume 65536))

waveOutSetVolume 0 Vol

End Sub



Private Sub Command1_Click()

SetVol Text1.Text

End Sub



Private Sub Form_Load()

Text1.Text ضع قيمة عددية تنحصر ما بين 0 و 65536

End Sub

تشغيل ملف صوتي من نوع mdi :
Sound/MP3 262

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_Load()

MMControl1.Visible False

MMControl1.DeviceType sequencer

MMControl1.FileName (c:FileName.mid)

MMControl1.Command open

MMControl1.Command play

End Sub

تشغيل ملف صوتي من نوع ram :
Sound/MP3 291

رمز:

 

ضع هذا الكود في الفورم

ولاحظ أنه يحتاج إلى الأداة الموجودة مع الريل بلاير



Private Sub Command1_Click()

RealAudio1.Source c:AFR.ram

RealAudio1.DoPlay

End Sub

التجسس على لوحة المفاتيح :
Windows API Call/ Explanation /DDE 367

رمز:

 

ضع هذا الكود في الموديول



Public Const DT_CENTER &H1

Public Const DT_WORDBREAK &H10

Type RECT

Left As Long

Top As Long

Right As Long

Bottom As Long

End Type

Declare Function DrawTextEx Lib user32 Alias DrawTextExA (ByVal hDC As Long ByVal lpsz As String ByVal n As Long lpRect As RECT ByVal un As Long ByVal lpDrawTextParams As Any) As Long

Declare Function SetTimer Lib user32 (ByVal hwnd As Long ByVal nIDEvent As Long ByVal uElapse As Long ByVal lpTimerFunc As Long) As Long

Declare Function KillTimer Lib user32 (ByVal hwnd As Long ByVal nIDEvent As Long) As Long

Declare Function GetAsyncKeyState Lib user32 (ByVal vKey As Long) As Integer

Declare Function SetRect Lib user32 (lpRect As RECT ByVal X1 As Long ByVal Y1 As Long ByVal X2 As Long ByVal Y2 As Long) As Long

Global Cnt As Long sSave As String sOld As String Ret As String

Dim Tel As Long

Function GetPressedKey() As String

For Cnt 32 To 128

Get the keystate of a specified key

If GetAsyncKeyState(Cnt) 0 Then

GetPressedKey Chr$(Cnt)

Exit For

End If

Next Cnt

End Function

Sub TimerProc(ByVal hwnd As Long ByVal nIDEvent As Long ByVal uElapse As Long ByVal lpTimerFunc As Long)

Ret GetPressedKey

If Ret sOld Then

sOld Ret

sSave sSave sOld

End If

End Sub



ضع هذا الكود في الفورم



Private Sub Form_Load()

Me.Caption Key Spy

Create an API-timer

SetTimer Me.hwnd 0 1 AddressOf TimerProc

End Sub

Private Sub Form_Paint()

Dim R As RECT

Const mStr Start this project go to another application type something switch back to this application and unload the form. If you unload the form a messagebox with all the typed keys will be shown.

Clear the form

Me.Cls

API uses pixels

Me.ScaleMode vbPixels

Set the rectangles values

SetRect R 0 0 Me.ScaleWidth Me.ScaleHeight

Draw the text on the form

DrawTextEx Me.hDC mStr Len(mStr) R DT_WORDBREAK Or DT_CENTER ByVal 0&

End Sub

Private Sub Form_Resize()

Form_Paint

End Sub

Private Sub Form_Unload(Cancel As Integer)

Kill our API-timer

KillTimer Me.hwnd 0

Show all the typed keys

MsgBox sSave

End Sub

إخفاء المشيرة وإظهارها :
Windows API Call/ Explanation /DDE 170

رمز:

 

ضع هذا الكود في الفورم



Private Declare Function ShowCursor Lib user32 (ByVal bShow As Long) As Long



Private Sub Command1_Click()

X ShowCursor(False)

End Sub



Private Sub Command2_Click()

X ShowCursor(True)

End Sub

مفاتيح اختصار :
Windows API Call/ Explanation /DDE 197

رمز:

 

ضع هذا الكود في الفورم



Private Const MOD_ALT &H1

Private Const MOD_CONTROL &H2

Private Const MOD_SHIFT &H4

Private Const PM_REMOVE &H1

Private Const WM_HOTKEY &H312

Private Type POINTAPI

x As Long

y As Long

End Type

Private Type Msg

hWnd As Long

Message As Long

wParam As Long

lParam As Long

time As Long

pt As POINTAPI

End Type

Private Declare Function RegisterHotKey Lib user32 (ByVal hWnd As Long ByVal id As Long ByVal fsModifiers As Long ByVal vk As Long) As Long

إيقاف الفأرة ولوحة المفاتيح عن العمل :
Windows API Call/ Explanation /DDE 262

رمز:

 

ضع هذا الكود في الفورم



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 1000

BlockInput False

End Sub

كرات صغيرة تتبع مؤشر الفأرة :
Jokes/ Humor 283

رمز:

 

ضع هذا الكود في الفورم



Private Type POINTAPI

x As Long

y As Long

End Type

Private Declare Function GetActiveWindow Lib user32 () As Long

Private Declare Function GetWindowDC Lib user32 (ByVal hwnd As Long) As Long

Private Declare Function Ellipse Lib gdi32 (ByVal hdc As Long ByVal X1 As Long ByVal Y1 As Long ByVal X2 As Long ByVal Y2 As Long) As Long

Private Declare Function TextOut Lib gdi32 Alias TextOutA (ByVal hdc As Long ByVal x As Long ByVal y As Long ByVal lpString As String ByVal nCount As Long) As Long

Private Declare Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As Long

Private Sub Form_Load()

Timer1.Interval 100

Timer1.Enabled True

Timer2.Interval 100

Timer2.Enabled True

Form1.Hide

End Sub

Sub Timer1_Timer()

Dim Position As POINTAPI

GetCursorPos Position



Ellipse GetWindowDC(0) Position.x - 7 Position.y - 7 Position.x 5 Position.y 5

End Sub

حصر مؤشر الفأرة داخل نطاق معين :
Windows API Call/ Explanation /DDE 221

رمز:

 

ضع هذا الكود في الفورم



Private Declare Sub ClientToScreen Lib user32 (ByVal hwnd As Long lpPoint As POINT)

Private Declare Sub ClipCursor Lib user32 (lpRect As Any)

Private Declare Sub OffsetRect Lib user32 (lpRect As RECT ByVal X As Long ByVal Y As Long)

Private Declare Sub GetClientRect Lib user32 (ByVal hwnd As Long lpRect As RECT)

Private Type RECT

Left As Integer

Top As Integer

Right As Integer

Bottom As Integer

End Type

Private Type POINT

X As Long

Y As Long

End Type





Private Sub Command1_Click() هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم

Dim Client As RECT

Dim Up As POINT

ClientToScreen Me.hwnd Up

GetClientRect Me.hwnd Client

OffsetRect Client Up.X Up.Y

Up.X Client.Left

Up.Y Client.Top

ClipCursor Client

End Sub





Private Sub Command2_Click() هذا الايعاز يحرر حركة الماوس

ClipCursor ByVal 0&

End Sub



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

كما يمكنك حصرها داخل أي أداة أخرى

me.hwnd باستبدال الكلمة

أو غيرها text1.hwnd label1.hwnd باسم

تنفيذ أوامر عند الضغط على F9 أو F10 :
Coding Standards 235

ضع هذا الكود في الفورم

رمز:

Private Sub Form_KeyDown(KeyCode As Integer Shift As Integer)

If KeyCode 120 Then

Email InputBox(Enter Your Name : تحياتي)

End If



If KeyCode 121 Then

Email InputBox(Enter Your E-mail : تحياتي)

End If

End Sub

طباعة صفحة إنترنت :
Windows API Call/ Explanation /DDE 180

رمز:

تأكد من وجود الملف MSHTML.DLL في مجلد ال system



Public Declare Function OpenProcess Lib kernel32 _

(ByVal dwDesiredAccess As Long _

ByVal bInheritHandle As Long _

ByVal dwProcessId As Long) As Long

Public Declare Function GetExitCodeProcess Lib kernel32 _

(ByVal hProcess As Long lpExitCode As Long) As Long

Public Declare Function CloseHandle Lib kernel32 _

(ByVal hObject As Long) As Long

Public Declare Function GetSystemDirectory Lib kernel32 Alias

GetSystemDirectoryA _

(ByVal lpBuffer As String ByVal nSize As Long) As Long



Public Const PROCESS_QUERY_INFORMATION &H400

Public Const STATUS_PENDING &H103&



Public Sub PrintHtmlFile(cHtmlFile As String)

Dim hProcess As Long

Dim ProcessId As Long

Dim ExitCode As Long

Dim cWinSysDir As String

cWinSysDir String(254 )

Call GetSystemDirectory(cWinSysDir Len(cWinSysDir))

cWinSysDir Trim(Left(cWinSysDir InStr(cWinSysDir Chr(0)) - 1))

If Dir(cWinSysDir & MSHTML.DLL) Then

ProcessId Shell(rundll32.exe & cWinSysDir &

MSHTML.DLLPrintHTML & Chr(34) & cHtmlFile & Chr(34) vbNormalFocus)

hProcess OpenProcess(PROCESS_QUERY_INFORMATION False ProcessId)

Do

Call GetExitCodeProcess(hProcess ExitCode)

DoEvents

Loop While ExitCode STATUS_PENDING

Call CloseHandle(hProcess)

End If

End Sub

إضافة أجهزة الطباعة في قائمة منسدلة :
Coding Standards 202

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_Load()

Dim cPrinter As Printer

For Each cPrinter In Printers

Combo1.AddItem Printer.DeviceName

Next

End Sub

التأكد من عمل البرنامج من على الـ CD-ROM :
Windows API Call/ Explanation /DDE 224

رمز:

ضع هذا الكود في الفورم



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

طباعة نص :
Coding Standards 213

رمز:

 

ضع هذا الكود في الفورم



Private Sub Command1_Click()

Printer.Print text1.text

End Sub

نسخة مشتركة من البرنامج (تعمل عدد معين من المرات) :
Coding Standards 266

رمز:

 

ضع هذا الكود في الفورم



Private Sub Form_Load()

retvalue GetSetting(A 0 Runcount)

GD$ Val(retvalue) 1

SaveSetting A 0 RunCount GD$

If GD$ 3 Then الرقم (3) يحدد عدد مرات التشغيل

MsgBox (انتهت مدة تشغيل البرنامج ،،، قم بشراء النسخة الكاملة من المنتج)

Unload Me

End If

End Sub

منع النسخ واللصق (طريقة بدائية لمنع الملفات من النسخ) :
Coding Standards 221

رمز:

ضع هذا الكود في الفورم



Private Sub Form_Load()

Timer1.Interval 1

End Sub



Private Sub Timer1_Timer()

R Clipboard.GetText

If Len(R) 0 Then

Clipboard.Clear

End If

End Sub

إبطال مفعول الزر × في النافذة :
Custom Controls/ Forms/ Menus 212

رمز:

ضع هذا الكود في الفورم



Private Sub Form_QueryUnload(Cancel As Integer UnloadMode As Integer)

Cancel True

End Sub

إلغاء تفعيل زر الإغلاق في أعلى النافذة :
Custom Controls/ Forms/ Menus 193

رمز:

ضع هذا الكود في الموديول



Public Declare Function GetSystemMenu Lib user32 (ByVal hwnd As Long ByVal bRevert As Long) As Long 



Public Declare Function RemoveMenu Lib user32 (ByVal hMenu As Long ByVal nPosition As Long ByVal wFlags As Long) As Long 



Public Const MF_BYPOSITION &H400&



ضع هذا الكود في الفورم



Public Sub DisableCloseWindowButton(frm As Form) 



Dim hSysMenu As Long 



Get the handle to this windows system menu 

hSysMenu GetSystemMenu(frm.hwnd 0) 



Remove the Close menu item This will also disable the close button 

RemoveMenu hSysMenu 6 MF_BYPOSITION 



Lastly we remove the seperator bar 

RemoveMenu hSysMenu 5 MF_BYPOSITION 



End Sub



Private Sub Form_Load() 

DisableCloseWindowButton Me 

End Sub

إلغاء تفعيل زر التكبير في أعلى النافذة :
Custom Controls/ Forms/ Menus 187

رمز:

ضع هذا الكود في الفورم



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

Const WS_MAXIMIZEBOX &H10000

Const GWL_STYLE (-16)

Const SWP_FRAMECHANGED &H20

Const SWP_NOMOVE &H2

Const SWP_NOSIZE &H1



Dim nStyle As Long

nStyle GetWindowLong(Me.hWnd GWL_STYLE)

Call SetWindowLong(Me.hWnd GWL_STYLE nStyle And Not WS_MAXIMIZEBOX)

SetWindowPos Me.hWnd 0 0 0 0 0 SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE

End Sub

منع استخدام المسافة في مربع النص :
Coding Standards 197

رمز:

ضع هذا الكود في الفورم



Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii 32 Then

KeyAscii 0

End If

End Sub

جعل النموذج في المقدمة :
Custom Controls/ Forms/ Menus 195

رمز:

 

ضع هذا الكود في الفورم



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

مربع نص ثلاثي الأبعاد :
Coding Standards 315

رمز:

ضع هذا الكود في الفورم



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

السماح بإدخال تاريخ فقط في مربع النص :
Coding Standards 255

رمز:

ضع هذا الكود في الفورم



Dim i As Integer

Dim t1 As String

Dim t2 As String

Public Sub AutoDate(TextBoxName As TextBox ByVal keyasci As Integer)

If Val(keyasci) 8 Then

If TextBoxName.Text Empty Then

i 0

Else

i i - 1

End If

Exit Sub

End If

i i 1

If i 3 Then

t1 Mid(TextBoxName.Text 1 2)

t2 Mid(TextBoxName.Text 3 1)

TextBoxName.Text Trim$(t1) & / & t2

TextBoxName.SelStart 4

t2 Empty

ElseIf i 6 Then

t1 Mid(TextBoxName.Text 1 5)

t2 Mid(TextBoxName.Text 6 1)

TextBoxName.Text Trim$(t1) & / & t2

TextBoxName.SelStart 7

End If

If i 11 Then Exit Sub

End Sub

Public Function DateValidation(TextBoxName As TextBox) As Boolean

If IsDate(Trim$(TextBoxName.Text)) False Then

MsgBox Enter valid date in dd/mm/yyyy format. vbInformation System Info..

TextBoxName.SetFocus

DateValidation False

ElseIf Not Len(Trim$(TextBoxName.Text)) 10 Then

MsgBox Enter valid date in dd/mm/yyyy format. vbInformation System Info..

TextBoxName.SetFocus

DateValidation False

Else

DateValidation True

End If

End Function

Private Sub Text1_KeyPress(KeyAscii As Integer)

Call AutoDate(Text1 0)

End Sub

Private Sub Text1_LostFocus()

Call DateValidation(Text1)

End Sub

طباعة النص على النموذج بألوان مختلفة :
Coding Standards 184

رمز:

 

ضع هذا الكود في الفورم



Sub Form_Paint()

Dim i As Integer X As Integer Y As Integer

Dim C As String

Cls

For i 0 To 91

X CurrentX

Y CurrentY

C Chr(i)

Line -(X TextWidth(C) Y TextHeight(C)) _

QBColor(Rnd * 16) BF

CurrentX X

CurrentY Y

ForeColor RGB(Rnd * 256 Rnd * 256 Rnd * 256)

Print منتدى بروكين أيس

Next

End Sub

السماح بكتابة أرقام فقط في مربع النص :
Coding Standards 226

رمز:

ضع هذا الكود في الفورم



Private Sub Text1_KeyPress(KeyAscii As Integer)

If KeyAscii Asc(0) Or KeyAscii Asc(9) Then

KeyAscii 0

End If

End Sub

كود بسيط لجعل النموذج في المقدمة :
Custom Controls/ Forms/ Menus 169

رمز:

ضع هذا الكود في الفورم



Private Declare Sub 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)

Private Sub Form_Load()

Timer1.Interval 1

End Sub

Private Sub Timer1_Timer()

SetWindowPos Form1.hwnd -1 0 0 0 0 3

End Sub

السماح بكتابة حروف إنجليزية فقط في مربع النص :
Coding Standards 179

رمز:

ضع هذا الكود في الفورم



Private Sub Text1_KeyPress(KeyAscii As Integer)

If (KeyAscii Asc(a) And KeyAscii Asc(z)) Or (KeyAscii Asc(A) And KeyAscii Asc(Z)) Then

Else

KeyAscii 0

End If

End Sub

تحويل حالة الأحرف من صغيرة إلى كبيرة :
String Manipulation 146

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

x Text1.Text

y UCase(Left(x Len(x)))

Text1.Text y

End Sub

Private Sub Command2_Click()

x Text1.Text

y LCase(Left(x Len(x)))

Text1.Text y

End Sub

مسح محتويات أكثر من مربع نص :
Coding Standards 154

رمز:

 

ضع هذا الكود في الفورم



Public Sub ClearTextBoxes(frm As Form)

Dim c As Control

For Each c In frm

If TypeOf c Is TextBox Then c.Text 

Next c

End Sub

Private Sub Command1_Click()

Call ClearTextBoxes(Form1)

End Sub

تغيير لون الخلفية للنص بشكل مستمر :
Coding Standards 180

رمز:

ضع هذا الكود في الفورم



Private Sub Timer1_Timer()

Static Col1 Col2 Col3 As Integer

Static c1 C2 C3 As Integer

If (Col1 0 Or Col1 250) And (Col2 0 Or Col2 250) _

And (Col3 0 Or Col3 250) Then

c1 Int(Rnd * 3)

C2 Int(Rnd * 3)

C3 Int(Rnd * 3)

End If

If c1 1 And Col1 0 Then Col1 Col1 - 10

If C2 1 And Col2 0 Then Col2 Col2 - 10

If C3 1 And Col3 0 Then Col3 Col3 - 10

If c1 2 And Col1 250 Then Col1 Col1 10

If C2 2 And Col2 250 Then Col2 Col2 10

If C3 2 And Col3 250 Then Col3 Col3 10

Label1.BackColor RGB(Col1 Col2 Col3)

End Sub

خلفية وامضة للنص :
Coding Standards 206

رمز:

ضع هذا الكود في الفورم



Private Sub Timer1_Timer()

Static COL

COL COL 10

If COL 510 Then COL 0

Label1.BackColor RGB(Abs(COL - 255) 0 0)

Label2.BackColor RGB(0 Abs(COL - 255) 0)

Label3.BackColor RGB(0 0 Abs(COL - 255))

Label4.BackColor RGB(Abs(COL - 0) 180 180)

Label5.BackColor RGB(Abs(COL - 200) 30 180)

End Sub

أكواد نسخ قص لصق :
Coding Standards 188

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

Clipboard.Clear

Clipboard.SetText text1

End Sub



Private Sub Command2_Click()

Clipboard.Clear

Clipboard.SetText text1

text1 

End Sub



Private Sub Command3_Click()

text1 Clipboard.GetText

End Sub

عكس اتجاه النص :
String Manipulation 139

رمز:

ضع هذا الكود في الفورم



Public Function reversestring(revstr As String) As String

Dim doreverse As Long

reversestring 

For doreverse Len(revstr) To 1 Step -1

reversestring reversestring & Mid$(revstr doreverse 1)

Next

End Function



Private Sub Command1_Click()

Dim strResult As String

strResult reversestring(Text1.Text)

Text2.Text strResult

End Sub

كلمات متحركة في عنوان النموذج ومربع النص :
Coding Standards 274

رمز:

 

ضع هذا الكود في الفورم



Private strText As String

Private Sub Form_Load()

Timer1.Interval 75

strText Guten Tag! Wie ghts Ihnen? Ich hoffe Ihnen alles Gutes!

strText Space(50) & strText

End Sub

Private Sub Timer1_Timer()

strText Mid(strText 2) & Left(strText 1)

Text1.Text strText

Me.Caption strText

End Sub

تغيير لون النص بشكل مستمر :
Coding Standards 162

رمز:

Private Sub Timer1_Timer()

Static Col1 Col2 Col3 As Integer

Static c1 C2 C3 As Integer

If (Col1 0 Or Col1 250) And (Col2 0 Or Col2 250) And (Col3 0 Or Col3 250) Then

c1 Int(Rnd * 3)

C2 Int(Rnd * 3)

C3 Int(Rnd * 3)

End If

If c1 1 And Col1 0 Then Col1 Col1 - 10

If C2 1 And Col2 0 Then Col2 Col2 - 10

If C3 1 And Col3 0 Then Col3 Col3 - 10

If c1 2 And Col1 250 Then Col1 Col1 10

If C2 2 And Col2 250 Then Col2 Col2 10

If C3 2 And Col3 250 Then Col3 Col3 10

Label1.ForeColor RGB(Col1 Col2 Col3)

End Sub

Private Sub Form_Load()

Timer1.Interval 100

End Sub

حساب عدد حروف مربع نص :
Coding Standards 138

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

MsgBox (عدد الحروف Str(Len(Text1.Text)))

End Sub

إنشاء زر ومربع نص بواسطة الكود :
Object Oriented Programming (OOP) 155

رمز:

ضع هذا الكود في الفورم



Private WithEvents btnObj As CommandButton

Private WithEvents txtObj As TextBox





Private Sub btnObj_Click()

On Error Resume Next

Set txtObj Controls.Add(VB.textbox txtObj)

With txtObj

.Visible True

.RightToLeft True

.Alignment 2

.Width 2000

.Text السلام عليكم

.Top 2000

.Left 1000

End With

End Sub



Private Sub Form_Load()

Set btnObj Controls.Add(VB.CommandButton btnObj)

With btnObj

.Visible True

.Width 2000

.Caption Click

.Top 1000

.Left 1000

End With

End Sub

إضافة صورة في RichText :
OLE/ COM/ DCOM/ Active-X 166

رمز:

Option Explicit



Private Sub Form_Click()

RichTextBox1.SelStart 3

RichTextBox1.SelText [new hi there]

End Sub



Private Sub Form_DblClick()

Dim lpobj As OLEObject

Dim szfilename As String

szfilename App.Path & ttt444.bmp put some valid file name here

Set lpobj RichTextBox1.OLEObjects.Add( szfilename)

lpobj.DisplayType rtfDisplayContent

if you un comment the following line you will go to edit mode:

lpobj.DoVerb

End Sub



Private Sub Form_Load()

Me.RichTextBox1.Text Hi there

End Sub

ترجمة النجوم في كلمات السر إلى حروف :
Windows API Call/ Explanation /DDE 274

رمز:

ضع هذا الكود في الفورم



Private Declare Function WindowFromPoint Lib user32 (ByVal xPoint As Long ByVal yPoint As Long) As Long

Private Declare Function GetCursorPos Lib user32 (lpPoint As POINTAPI) As Long

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 lParam As Any) As Long

Private Declare Sub Sleep Lib kernel32 (ByVal dwMilliseconds As Long)



Private Sub Form_Load()

Timer1.Interval 10

End Sub



Private Sub Timer1_Timer()

Const EM_SETPASSWORDCHAR &HCC

Dim coord As POINTAPI



s GetCursorPos(coord)

x coord.x

y coord.y



h WindowFromPoint(x y)



Dim NewChar As Integer

NewChar CLng(0)

retval SendMessage(h EM_SETPASSWORDCHAR ByVal NewChar 0)

End Sub

تهيئة القرص المرن :
Windows API Call/ Explanation /DDE 188

رمز:

ضع هذا الكود في الفورم



Private Declare Function SHFormatDrive Lib shell32 _

(ByVal hwndOwner As Long ByVal iDrive As Long _

ByVal iCapacity As Long ByVal iFormatType As Long) As Long



Const SHFMT_DRV_A 0

Const SHFMT_DRV_B 1



Const SHFMT_ID_DEFAULT &HFFFF

Const SHFMT_OPT_QUICKFORMAT 0

Const SHFMT_OPT_FULLFORMAT 1



Const SHFMT_OPT_SYSONLY 2

Const SHFMT_ERROR -1

Const SHFMT_CANCEL -2

Const SHFMT_NOFORMAT -3



Private Sub Command1_Click()

Dim Res As Long

Res SHFormatDrive(Form1.hwnd SHFMT_DRV_A SHFMT_ID_DEFAULT _

SHFMT_OPT_QUICKFORMAT)



Select Case Res

Case SHFMT_ERROR

MsgBox Error Formating Drive vbCritical

Case SHFMT_CANCEL

MsgBox You have select to Cancel your format vbInformation

Case SHFMT_NOFORMAT

MsgBox Not Format vbInformation

Case Else

MsgBox Format Done

End Select

End Sub

نسخ ملف :
Files/ File Controls/ Input/ Output 158

رمز:

ضع هذا الكود في الفورم



Private Sub Command1_Click()

FileCopy c:Autoexec.bat d:Autoexec.bat

End Sub

معرفة نوع محرك الأقراص (محرك أقراص مرنة / صلبة / سي دي روم ... الخ) :
Windows API Call/ Explanation /DDE 159
[code]

ضع هذا الكود في الفورم



Private Declare Function GetDriveType Lib kernel32 Alias GetDriveTypeA (ByVal nDrive As String) As Long



Private Sub Command1_Click()

Me.AutoRedraw True

Select Case GetDriveType(Text1.Text & :)

Case 2

Form1.Caption قرص مرن

Case 3

Form1.Caption قرص صلب

Case Is 4

Form1.Caption Remote

Case Is 5

Form1.Caption Cd-Rom

Case Is 6

Form1.Caption Ram disk

Case Else

Form1.Caption غير معين

End Select

End Sub



Private Sub Form_Load()

Command1.Caption أدخل رمز القرص الذي تريد معرفته

End Sub









معرفة معلومات عن القرص :
<