v.b.6 codes(3)

لتحديد دقة عرض الشاشة
...........
Private Sub Command1_Click()
Dim intWidth As Integer
Dim intHeight As Integer
intWidth = Screen.Width \ Screen.TwipsPerPixelX
intHeight = Screen.Height \ Screen.TwipsPerPixelY
MsgBox "Screen Resolution:" + Str$(intWidth) + " x" + Str$(intHeight)
End Sub
.........................................................................................
منع المستخدم من استخدام المسافة في صندوق النص
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 32 Then
KeyAscii = 0
End If
End Sub
..........................................................................................
رسم احداثيات سيني وصادي تبعا لحركة الماوس
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub
..........................................................................................
رسم دائرة صغيرة حول مؤشر الماوس تتبع حركتها
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.Cls
Circle (X, Y), 100, vbRed
End Sub
.........................................................................................
قطع الاتصال بالانترنت بمعرفة اسم الاتصال بدون استخدام API
Private Sub Form_Load()
Dim sDuName As String
sDuName = InputBox("أدخل اسم الاتصال")
If DisconnectDUN(sDuName) = True Then
MsgBox "تم قطع الاتصال"
Else
MsgBox "لا يوجد اتصال بهذا الاسم"
End If
End
End Sub
Function DisconnectDUN(DUNName As String) As Boolean
On Error GoTo errhandler
AppActivate "Connected to " & DUNName
End Function
..........................................................................................
الكود الذي يقوم بقراءة رقم الهاردسك
Private Sub Command1_Click()
Dim obj_FSO As Object, obj_Drive As Object
Set obj_FSO = CreateObject("Scripting.FileSystemObject")
Set obj_Drive = obj_FSO.GetDrive("c:\")
MsgBox obj_Drive.SerialNumber
Set obj_FSO = Nothing
Set obj_Drive = Nothing
End Sub
..........................................................................................
كود الاتصال التليفوني
Private Declare Function tapiRequestMakeCall Lib "TAPI32.DLL" (ByVal Dest As String, ByVal AppName As String, ByVal CalledParty As String, ByVal Comment As String) As Long
Private Sub Command1_Click()
a = tapiRequestMakeCall((1014557524), "Program Name", (Name), "Addition Comments")
End Sub
..........................................................................................
افراغ سلة المهملات
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long
Private Sub Form_Load()
'الإفراغ
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
'التحديث
SHUpdateRecycleBinIcon
End Sub
...........................................................................................
اظهار نافزت الخطأ البيضاء
Private Declare Sub FatalAppExit Lib "kernel32" Alias "FatalAppExitA" (ByVal uAction As Long, ByVal lpMessageText As String)
Private Sub Form_Load()
FatalAppExit 0, "Contactez le revendeur de ce programme" & vbLf & vbLf & "(Cette source provient de http://www.vbfrance.com/)"
End Sub
...........................................................................................