---------------------------------------------------------------------------------
كود عمل صليب داخل النموذج :
Private Sub Form_Mouse****(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
---------------------------------------------------------------------------------
كودان لمعالجة المشاكل :
On Error Resume Next
Kill "C:\Exmaple.bmp"
Or
On Error Goto Error
Kill "C:\Exmaple.bmp"
Error:
---------------------------------------------------------------------------------
كود التأكد من وجود ملف :
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
---------------------------------------------------------------------------------
كود جعل الجملة عمودية :
Private Sub Form_Activate()
Dim s As String
For i = 1 To Len(Label1)
s = s & Mid$(Label1, i, 1) & vbCrLf
Next
Label1 = s
End Sub
---------------------------------------------------------------------------------
كود اخفاء مؤشر الفأرة في تطبيق الفيجول بيسك :
قسم التعاريف :
Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long
اخفاء :
x = ShowCursor(False)
اظهار :
x = ShowCursor(True)
---------------------------------------------------------------------------------
كود تحديد دقت عرض الشاشة :
Dim x, y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768")
---------------------------------------------------------------------------------

كود تحريك النموذج Form عن طريق الماوس Mouse :
قم بنسخ الكود التالي للموديول Module :
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
قم بكتابة الكود التالي وليكن عند الحدث MouseDown_Event والخاص مثلا بأداة PictureBox
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
---------------------------------------------------------------------------------
كود تشغيل ملفات الصوت .Wav
بنسخ الكود التالي للموديول Module :
Public Declare Function playa Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Public Sub PlayWav(path As String)
Dim SafeFile As String
file$ = Dir(path$)
If file$ <> "" Then Call playa(WavFile$, SND_FLAG)
End Sub
لتشغيل أي ملف صوت قم بكتابة الأمر التالي، مع تغيير اسم ومسار ملف الصوت المراد تشغيله:
Call PlayWavFile("D:\songs\nsync\pop.wav")
---------------------------------------------------------------------------------
this code is to unload form in crazy way :
Private Sub Form_Unload(Cancel As Integer)
Frm.WindowState = 0
Frm.**** = 0
Frm.Top = 0

For X = 1 To 5000 Step 500
Frm.**** = X
Frm.Top = X
Next X

For Y = 5000 To 1 Step -100
Frm.**** = Y
Frm.Top = Y
Frm.**** = X
Frm.Top = X
Next Y

For z = 0 To 10000 Step 500
Frm.Height = z
Frm.**** = z
Frm.Width = z
Frm.Top = z
Frm.**** = X
Frm.Top = X
Frm.**** = Y
Frm.Top = Y
Next z

For q = 10000 To 4000 Step -100
Frm.Height = q
Frm.**** = q
Frm.Width = q
Frm.Top = q
Next q

For d = 1 To 2000 Step 100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = d

Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = d

Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = d

Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = d
Next d

For k = 2000 To 1 Step -100
Frm.**** = X
Frm.**** = Y
Frm.**** = z
Frm.**** = q
Frm.**** = k

Frm.Height = X
Frm.Height = Y
Frm.Height = z
Frm.Height = q
Frm.Height = k

Frm.Width = X
Frm.Width = Y
Frm.Width = z
Frm.Width = q
Frm.Width = k

Frm.Top = X
Frm.Top = Y
Frm.Top = z
Frm.Top = q
Frm.Top = k
Next k
End
End Sub
---------------------------------------------------------------------------------
كود بدا التشغيل :
في الموديل :
Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegDeleteValue Lib "advapi32.dll" Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal lpValueName As String) 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, ByVal lpData As String, ByVal cbData As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) As Long

Private Const READ_CONTROL = &H20000
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_NOTIFY = &H10
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
Private Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
Private Const KEY_EXECUTE = KEY_READ
Private Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL
Private Const RunPath = "Software\Microsoft\Windows\CurrentVersion\Run"
Private Const HKLM = &H80000002
' استخدم الامر التالي لالغاء التشغيل التلقائي
Public Sub DoNotRun(ProgramName As String)
Dim hKey As Long
Dim Ret As Long

' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)

' حذفها من مسجل النظام.
Ret = RegDeleteValue(hKey, ProgramName)

' إغلاق المفتاح
RegCloseKey hKey
End Sub
Public Sub RunWhenStartup(ProgramName As String, ProgramPath As String)
Dim hKey As Long
Dim Ret As Long

' فتح المفتاح المطلوب
Ret = RegOpenKeyEx(HKLM, RunPath, 0, KEY_ALL_ACCESS, hKey)

' إنشاء قيمة جديدة بإسم البرنامج وعنوانه.
Ret = RegSetValueEx(hKey, ProgramName, 0&, 1, ProgramPath, Len(ProgramPath)) 'LenB(StrConv(TheData, vbFromUnicode)) + 1)

' إغلاق المفتاح
RegCloseKey hKey
End Sub
------------
في الفورم :
RunWhenStartup "عنوان", App.Path & "" & App.EXEName & ".exe"
---------------------------------------------------------------------------------
إنشاء مربع نص وقت تنفيذ البرنامج

Private Sub Form_Load()
Form1.Controls.Add "VB.textbox", "Textcreate", Form1
Form1!Textcreate.Visible = True
End Sub
---------------------------------------------------------------------------------
مسح ما يوجد داخل كل مربعات النص الموجودة على الفورم

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

Private Declare Function CreateRoundRectRgn Lib "gdi32" (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 CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long

Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
Const RGN_DIFF = 4
Dim lOriginalForm As Long
Dim ltheHole As Long
Dim lNewForm As Long
Dim lFwidth As Single
Dim lFHeight As Single
Dim lborder_width As Single
Dim ltitle_height As Single

On Error GoTo Trap
lFwidth = ScaleX(Width, vbTwips, vbPixels)
lFHeight = ScaleY(Height, vbTwips, vbPixels)
lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
lborder_width = (lFHeight - ScaleWidth) / 2
ltitle_height = lFHeight - lborder_width - ScaleHeight
Select Case AreaType
Case "Elliptic"
ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RectAngle"
ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RoundRect"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
Case "Circle"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
Case Else
MsgBox "Unknown Shape!!"
Exit Function
End Select
lNewForm = CreateRectRgn(0, 0, 0, 0)
CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF
SetWindowRgn hWnd, lNewForm, True
Me.Refresh
fMakeATranspArea = True
Exit Function
Trap:
MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.De******ion
End Function

Private Sub Form_Load()
Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 208
lParam(3) = 50
lParam(4) = 50
lParam(5) = 666
lParam(6) = 555
'Call fMakeATranspArea("RoundRect", lParam())
'Call fMakeATranspArea("RectAngle", lParam())
'Call fMakeATranspArea("Circle", lParam())
Call fMakeATranspArea("Elliptic", lParam())
End Sub
---------------------------------------------------------------------------------
رسم دوائر ملونة رائعة جداً باستخدام الماوس


Private Sub Command1_Click()
Form1.Cls
End Sub
Private Sub Form_Mouse****(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
---------------------------------------------------------------------------------
كود بسيط لجعل الفورم في المقدمة

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
---------------------------------------------------------------------------------
تحريك Label بشكل طولي

Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Label1.**** 2000, Label1.Top - 100
If Label1.Top < 0 Then
Label1.Top = Form1.Height
End If
End Sub
---------------------------------------------------------------------------------
حريك 2 Label مع تغيير ألوانهما

Private Sub Form_Load()
Timer1.Interval = 100
Timer2.Interval = 100
Label1 = "Welcome"
Label2 = "Good Bey"
End Sub

Private Sub Timer1_Timer()
Label1.ForeColor = QBColor(Rnd * 15)
Label1.**** = Label1.**** + 10
End Sub

Private Sub Timer2_Timer()
Label2.ForeColor = QBColor(Rnd * 10)
Label2.**** = Label2.**** - 10
End Sub
---------------------------------------------------------------------------------
ظهور الـ Label في أماكن عشوائية وبألوان عشوائية

Private Sub Form_Load()
Timer1.Interval = 250
End Sub

Private Sub Timer1_Timer()
Randomize
Label1.ForeColor = QBColor(Rnd * 13)
Label1.**** = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Label1.**** Rnd * 10000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
ظهور الفورم بأحجام وألوان عشوائية، تخاريف

Private Sub Form_Load()
Timer1.Interval = 250
End Sub

Private Sub Timer1_Timer()
Randomize
Me.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.**** Rnd * 12000, Rnd * 9000, Rnd * 12000, Rnd * 9000
End Sub
---------------------------------------------------------------------------------
كود بسيط لالتقاط صورة للشاشة في الحافظة

Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub Command1_Click()
keybd_event vbKeySnapshot, 0, 0, 0
DoEvents
End Sub
---------------------------------------------------------------------------------
السماح بكتابة حروف إنجليزية فقط في مربع النص
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
---------------------------------------------------------------------------------
السماح بكتابة أرقام فقط داخل مربع النص
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii < Asc("0") Or KeyAscii > Asc("9") Then
KeyAscii = 0
End If
End Sub
---------------------------------------------------------------------------------
السماح بإدخال تاريخ فقط في مربع النص
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
---------------------------------------------------------------------------------
التقاط صورة للشاشة


Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

'Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With

'Create the picture
R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

'Return the new picture
Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal ****Src As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

'Create a compatible device context
hDCMemory = CreateCompatibleDC(hDCSrc)
'Create a compatible bitmap
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
'Select the compatible bitmap into our compatible device context
hBmpPrev = SelectObject(hDCMemory, hBmp)

'Raster capabilities?
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
'Does our picture use a palette?
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
'What's the size of that palette?
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Set the palette version
LogPal.palVersion = &H300
'Number of palette entries
LogPal.palNumEntries = 256
'Retrieve the system palette entries
R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
'Create the palette
hPal = CreatePalette(LogPal)
'Select the palette
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
'Realize the palette
R = RealizePalette(hDCMemory)
End If

'Copy the source image to our compatible device context
R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, ****Src, TopSrc, vbSrcCopy)

'Restore the old bitmap
hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Select the palette
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If

'Delete our memory DC
R = DeleteDC(hDCMemory)

Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
'Create a picture object from the screen
Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub

************************************************** ********************

إمهال النظام 60 ثانية قبل إغلاقه

' 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 doesn't start with ''
If InStr(Machine, "") = 1 Then
Machine = Right(Machine, Len(Machine) - 2)
End If
'check if it's the local machine that's 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 = ****(GetMyMachineName, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachineName, True, True, True, 60, "You initiated a system shutdown..."
End Sub

************************************************** *******************

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

Private Sub Command1_Click()
Dim x, y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768")