مجموعة قيمه من اكواد الفيجوال بيسك (الجزء الثاني)

إخفاء المشيرة وإظهارها
كود:
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
************************************************** *******************

إمهال النظام 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_**** = "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 lpMachine**** 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 lpSystem**** As String, ByVal lp**** 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 GetComputer**** Lib "kernel32" Alias "GetComputer****A" (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-**** 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(GetMyMachine****) = 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 ****
If LookupPrivilegeValue(vbNullString, SE_SHUTDOWN_****, 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 GetMyMachine****() As String
Dim sLen As Long
'create a buffer
GetMyMachine**** = Space(100)
sLen = 100
'retrieve the computer ****
If GetComputer****(GetMyMachine****, sLen) Then
GetMyMachine**** = Left(GetMyMachine****, sLen)
End If
End Function
Private Sub Form_Load()
InitiateShutdownMachine GetMyMachine****, 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")
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 rectangle's 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

ونكتب في موديل Modell

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
************************************************** ********************

مؤثر جميل على الفورم
كود:
Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function
Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub

Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub
************************************************** *********************

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

تابع

تغميق وتفتيح الصورة بشكل رائع

كود:
Option Explicit
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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SRCAND = &H8800C6
Private Const SRCCOPY = &HCC0020

'تغميق الصورة
Private Sub Command1_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 255 To 0 Step -3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub

'تفتيح الصورة
Private Sub Command2_Click()
Dim lDC As Long
Dim lBMP As Long
Dim W As Integer
Dim H As Integer
Dim lColor As Long

Screen.MousePointer = vbHourglass

W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels)
H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels)
lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H)
lDC = CreateCompatibleDC(Picture1.hdc)
Call SelectObject(lDC, lBMP)
BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY
Picture1 = LoadPicture("")

For lColor = 0 To 255 Step +3
Picture1.BackColor = RGB(lColor, lColor, lColor)
BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND
Sleep 15
Next
Call DeleteDC(lDC)
Call DeleteObject(lBMP)
Screen.MousePointer = vbDefault

End Sub
************************************************** ******************

معرفة اللون الذي يمر عليه الماوس
كود:
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 Get******DC 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 = Get******DC(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

معرفة اسم الكمبيوتر
كود:
Private Const MAX_COMPUTER****_LENGTH As Long = 31
Private Declare Function GetComputer**** Lib "kernel32" Alias "GetComputer****A" (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_COMPUTER****_LENGTH + 1
strString = String(dwLen, "X")
'Get the computer ****
GetComputer**** strString, dwLen
'get only the actual data
strString = Left(strString, dwLen)
'Show the computer ****
MsgBox strString
End Sub
************************************************** ********************

الاتصال من خلال الكود
كود:
Private Sub Command1_Click()
Dim PhoneNumber As String
On Error GoTo WrongPort
MSComm1.CommPort = 3 'قم بتغيير البورت من 1 إلى 8 حتى تصل إلى البورت الصحيح
MSComm1.Settings = "300,n,8,1"
PhoneNumber = "07770777"
MSComm1.PortOpen = True
MSComm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)
Exit Sub
WrongPort:
MsgBox "Title", 1048576 + 524288 + 16, "Prompt"
End Sub

Private Sub Command2_Click()
MSComm1.PortOpen = False
End Sub

Private Sub Form_Load()
Command1.Caption = "&Connect"
Command2.Caption = "&Disconnect"
End Sub
************************************************** ********************

فتح الفورم بشكل جميل
كود:
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next

End Sub
Private Sub Form_Load()
Explode Me
End Sub
************************************************** *******************

تحريك الكلام في عنوان الفورم ومربع النص
كود:
Private strText As String
Private Sub Form_Load()
Timer1.Interval = 75
strText = "Guten Tag! Wie ght's 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
************************************************** ******************

تغيير لون النص بشكل مستمر
كود:
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
************************************************** ********************

تغيير لون الخلفية للنص
كود:
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
************************************************** ********************

جعل خلفية النص تومض
كود:
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
************************************************** *******************
خلفية جميلة للفورم
كود:
Private Sub Form_Click()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop
End Sub

Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function

Sub MoveIt(A, B, t)
A = (1 - t) * A + t * B
End Sub

Private Sub Form_Resize()
Cls
Dim t As Single, x1 As Single, y1 As Single
Dim x2 As Single, y2 As Single, x3 As Single
Dim y3 As Single, x4 As Single, y4 As Single

Scale (-320, 200)-(320, -200)
t = 0.05
x1 = -320: y1 = 200
x2 = 320: y2 = 200
x3 = 320: y3 = -200
x4 = -320: y4 = -200
Do Until Dist(x1, y1, x2, y2) < 10
Line (x1, y1)-(x2, y2)
Line -(x3, y3)
Line -(x4, y4)
Line -(x1, y1)
MoveIt x1, x2, t
MoveIt y1, y2, t
MoveIt x2, x3, t
MoveIt y2, y3, t
MoveIt x3, x4, t
MoveIt y3, y4, t
MoveIt x4, x1, t
MoveIt y4, y1, t
Loop

End Sub
************************************************** *******************

إفراغ سلة المهملات
كود:
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long

Private Sub Command1_Click()
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
SHUpdateRecycleBinIcon
End Sub
************************************************** ********************

استخدام مساعد الأوفيس
كود:
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 File****
File**** = "ضع مسار المساعد هنا وغالباً ما يكون في المسار التالي \******s\msagent\char"
' على سبيل المثال
' c:\******s\msagent\char\genie.acs
Agent1.Characters.Load CharacterID:="Genie", LoadKey:=File****
Set Genie = Agent1.Characters("Genie")
End Sub
************************************************** *********************

طريقة جميلة لإغلاق الفورم
كود:
Private Sub Form_Load()
Form1.Height = 7020
Form1.******State = 0
Timer1.Interval = 45
End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Form1.Height = Form1.Height - 250
Timer2.Interval = 1500
End Sub

Private Sub Timer2_Timer()
End
End Sub
************************************************** *******************

أكواد نسخ قص لصق
كود:
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
************************************************** *******************
حفظ ما يتغير في الـ Form حتى بعد إغلاقها
كود:
Private Sub Form_Load()
Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)
End Sub

'يمكنك تغيير ال text1 بأي شيء آخر image أو Picture أو ... الخ
************************************************** *******************

تحويل حالة الأحرف من كبيرة إلى صغيرة والعكس
كود:
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
************************************************** ******************

إلغاء تفعيل زر الإغلاق في أعلى النافذة
كود:
Public Sub DisableClose******Button(frm As Form)

Dim hSysMenu As Long

'Get the handle to this ******s 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()
DisableClose******Button Me
End Sub

ونكتب في موديل Modell

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&
---------------------------------------------------------------------------------
لمعرفة اسم اليوم الحالي
كود:
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
*****************************************
لمعرفة الشهر الحالي
كود:
Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Print Month****(Mmonth)
End Sub
*****************************************
إضافة نص متحرك
كود:
Dim Llabel As Integer

Private Sub Form_Load()
Form1.ScaleMode = 3
Timer1.Interval = 100
End Sub

Private Sub Timer1_Timer()
Llabel = Llabel + 10
Label1.Left = Llabel
If Llabel > 300 Then
Timer1.Interval = 0
Timer2.Interval = 100
End If
End Sub

Private Sub Timer2_Timer()
Llabel = Llabel - 10
Label1.Left = Llabel
If Llabel < 0 Then
Timer1.Interval = 100
Timer2.Interval = 0
End If
End Sub
**********************************************
كود:
معرفة هل الجهاز متصل بالإنترنت أم لا.
Public Function IsConnected() As Boolean

Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95

TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize

RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)

If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If

Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)

If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If

End Function

Private Sub Command1_Click()
If IsConnected() = True Then
MsgBox ("الجهاز متصل بالانترنت")
Else
MsgBox ("الجهاز غير متصل بالانترنت")
End If
End Sub
ونكيب في موديل Modell
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntry**** = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDevice**** = 32

Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntry****(RAS95_MaxEntry****) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDevice****(RAS95_MaxDevice****) As Byte
End Type

Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDevice****(RAS95_MaxDevice****) As Byte
End Type
************************************************** ***