Private Sub Command1_Click()
Dim X
Dim DialUpConnectName As String
'قم بتحديد اسم الاتصال الذي تود الاتصال به
DialUpConnectName = "Sts"
X = Shell("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1)
DoEvents
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة
'"123(enter)"
SendKeys "{enter}", True
DoEvents
End Sub
كود خاص لمعرفة كلمة السر لملفات Access 97
*كود برمجي*
--------------------------------------------------------------------------------
Option Explicit
Private zChar As String
Dim n As Long, s1 As String * 1, s2 As String * 1
Dim lsClave As String
Dim mask As String
Private Sub Command1_Click()
' يجب ان تضيف عنصر commonDialog الى برنامجك واسمه هنا DD
DD.Filter = "Microsoft Access Database|*.mdb"
DD.DefaultExt = "mdb"
DD.ShowOpen
zChar = DD.FileTitle
mask = Chr(78) & Chr(134) & Chr(251) & Chr(236) & _
Chr(55) & Chr(93) & Chr(68) & Chr(156) & _
Chr(250) & Chr(198) & Chr(94) & Chr(40) & Chr(230) & Chr(19)
Open zChar For Binary As #1
Seek #1, &H42
For n = 1 To 14
s1 = Mid(mask, n, 1)
s2 = Input(1, 1)
If (Asc(s1) Xor Asc(s2)) <> 0 Then
lsClave = lsClave & Chr(Asc(s1) Xor Asc(s2))
End If
Next
Close 1
MsgBox lsClave & "كلمة السر هــي"
End Sub
--------------------------------------------------------------------------------
معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
MsgBox Format(GetTickCount, "0")
End Sub
--------------------------------------------------------------------------------
كود لمعرفة كلمات السر على هيئة نجوم *****
*كود برمجي*
--------------------------------------------------------------------------------
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 Timer1_Timer()
Const EM_SETPASSWORDCHAR = &HCC
Dim coord As POINTAPI
'نقوم هنا بمعرفة احداثى الفأرة
s = GetCursorPos(coord)
x = coord.x
y = coord.y
'المكتوب بها كلمة المرور(textbox)نقوم هنا بمعرفة مقبض آداة التحرير
h = WindowFromPoint(x, y)
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub
--------------------------------------------------------------------------------
كود لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Activate()
Dim a As String
Do While Not Data1.Recordset.EOF = True
a = Data1.Recordset.Fields("name").Value
' هنا تمثل اسم الحقل في قاعدة البيانات name كلمة
List1.AddItem a
Data1.Recordset.MoveNext
Loop
End Sub
--------------------------------------------------------------------------------
كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة
*كود برمجي*
--------------------------------------------------------------------------------
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 FRM '
End If
End Sub
--------------------------------------------------------------------------------
يقوم بتحويل شكل التكست واليبل الى 3d
*كود برمجي*
--------------------------------------------------------------------------------
'Set form's 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
ملاحظة في البداية لبد من انشاء تكست وليبل
--------------------------------------------------------------------------------
كود الاظهار النص بشكل عمودي
*كود برمجي*
--------------------------------------------------------------------------------
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 CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
ومن ثم حدد سار الملف مثال
Private Sub Command1_Click()
dim x
x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL")
--------------------------------------------------------------------------------
كود لاستدعاء ملف من نوع mid
*كود برمجي*
--------------------------------------------------------------------------------
قم بوضع اداة
mmcontrol1
m و
اجعل نامي
Private Sub Form_Load()
m.DeviceType = "sequencer"
m.FileName = ("e:\Holiday3.mid")
m.Command = "open"
m.Command = "play"
END SUB
--------------------------------------------------------------------------------
كود لتحميل فلاش من نوع SWF
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
s.Movie = ("E:\Projects\Howl.swf")
End Sub
--------------------------------------------------------------------------------
كود لوضع مقطع الفيديو في بكتشر
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
--------------------------------------------------------------------------------
الزر الأيمن للماوس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IF BUTTON=2 THEN
msgbox "الزر الأيمن للماوس"
END IF
End Sub
--------------------------------------------------------------------------------
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub COMMAND1_CLICK()
DIM SS AS STRING
SS="123456789"
IF INSTR(SS,CHR(KEYASCII)=0 THEN
KEYASCII=0
END IF
End Sub
--------------------------------------------------------------------------------
عمل مسح ملفات للقرص المرن
*كود برمجي*
--------------------------------------------------------------------------------
kill"A:\*.*"
--------------------------------------------------------------------------------
عرض صندوق حوار Open With
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim x As Long
x = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL C:\vbzoom.log")
End Sub
--------------------------------------------------------------------------------
حساب عدد سطور ملف نصى
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Open "c:\autoexec.bat" For Input As #1
Count:
n = n + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = n
Exit Sub
Else
GoTo Count:
End If
Close
End Sub
--------------------------------------------------------------------------------
فحص المنافذ
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = Text1.Text
Winsock1.Listen
Text2.Text = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
Text2.Text = "المنفذ مفتوح"
Else
Text2.Text = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
*كود برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا كود لتشفير وفك تشفير نص
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
For i = 1 To Len(Text1.Text)
st1 = Mid(Text1.Text, i, 1)
as1 = Asc(st1)
ch1 = Chr(255 - as1)
st = st + ch1
Next
Text1.Text = st
End Sub
--------------------------------------------------------------------------------
هذا الكود لإضافة عروض الفلاش لبرنامجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim s As String
s = App.Path
If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
ShockwaveFlash1.Movie = s + "a4.swf"
End Sub
--------------------------------------------------------------------------------
لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
*كود برمجي*
--------------------------------------------------------------------------------
Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk
If GetSetting(App.Title, "Startup", "counter", "") = "" Then
SaveSetting App.Title, "Startup", "counter", 1
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
lblcnt.Caption = "1"
ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
End
Else
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
chk = DateDiff("d", CDate(TRACEDATE), Now)
If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
End
Else
startdate = GetSetting(App.Title, "Startup", "Started", "")
differenceofdate = DateDiff("d", startdate, Now)
If differenceofdate <> 0 Then
lblcnt.Caption = differenceofdate + 1
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
End If
If differenceofdate = 0 Then
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
End If
End If
End If
End Sub
--------------------------------------------------------------------------------
هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
'الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, 0, _
Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
0, -Picture1.Width, Picture1.Height, vbSrcCopy
End Sub
Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, 0, Picture1.Height, _
Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
Private Sub Command4_Click()
'لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.Width, Picture1.Height, Picture1.Width, _
Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy
End Sub
--------------------------------------------------------------------------------
كود لنسخ خلفية سطح المكتب إلى نموذجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub
--------------------------------------------------------------------------------
تحويل اي حرف إلى حرف ASCII
*كود برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(text1.text)
MsgBox temp
--------------------------------------------------------------------------------
تحيه حسب الوقت
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If Time <= "11:30 AM" Then
MsgBox ("Good Morning YourNameHere!")
End
End If
If Time > "11:30 AM" And Time < "5:00 PM" Then
MsgBox ("Good Afternoon YourNameHere!")
End
End If
If Time > "5:00 PM" Then
MsgBox ("Good Evening YourNameHere!")
End
End If
If Time >= "12:01 AM" Then
MsgBox ("Good Morning YourNameHere!")
End
End If
End Sub
--------------------------------------------------------------------------------
نوعية القرص (قرص مرن،سي دي،.....)
*كود برمجي*
--------------------------------------------------------------------------------
'التصاريح
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
'الكود
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer
For intCnt = 65 To 86
strDrive = Chr(intCnt)
Select Case GetDriveType(strDrive + ":\")
Case DRIVE_REMOVABLE
rtn = "Floppy Drive"
Case DRIVE_FIXED
rtn = "Hard Drive"
Case DRIVE_REMOTE
rtn = "Network Drive"
Case DRIVE_CDROM
rtn = "CD-ROM Drive"
Case DRIVE_RAMDISK
rtn = "RAM Disk"
Case Else
rtn = ""
End Select
If rtn <> "" Then
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage)
--------------------------------------------------------------------------------
مؤثر على الفورم
*كود برمجي*
--------------------------------------------------------------------------------
Public Sub Pause(Duration As Long)
'//i didn't write this so i can't docume
' nt it
Dim Current As Long
Current = Timer
Do Until Timer - Current >= Duration
DoEvents
Loop
End Sub
Public Sub SlideRight(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show '//show the form
SecondForm.Top = FirstForm.Top '//make the .Top equal for both form
SecondForm.Height = FirstForm.Height '//make the .Height equal
SecondForm.Width = FirstForm.Width '//make the .Width equal
SecondForm.Left = SecondForm.Width * -1 '//make .Left negative
Do Until SecondForm.Left = 0
'//do the loop until the form is all the
' way to the right
SecondForm.Left = SecondForm.Left + 15 '//add 15 (duh)
Pause 0.3 '//pause
Loop
End Sub
Public Sub SlideDown(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show '//show the form
SecondForm.Top = FirstForm.Height * -1 'make .Top negative
SecondForm.Height = FirstForm.Height '//make the .Height equal
SecondForm.Width = FirstForm.Width '//make the .Width equal
SecondForm.Left = FirstForm.Left '//make the .Left equal
Do Until SecondForm.Top = 0
'//do the loop until the form is all the
' way to the bottom
SecondForm.Top = SecondForm.Top + 15
Pause 0.3
Loop
End Sub
Public Sub SlideLeft(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show
SecondForm.Top = FirstForm.Top
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Width '//put on right side of screen
Do Until SecondForm.Left = 0
SecondForm.Left = SecondForm.Left - 15
Pause 0.3
Loop
End Sub
Public Sub SlideUp(FirstForm As Form, SecondForm As Form)
'//the second form is the one that does
' the transition
SecondForm.Show
SecondForm.Top = FirstForm.Height '//put form to bottom of screen
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Left
Do Until SecondForm.Top = 0
SecondForm.Top = SecondForm.Top - 15
Pause 0.3
Loop
End Sub
--------------------------------------------------------------------------------
فورم دائري
*كود برمجي*
--------------------------------------------------------------------------------
Sub formcircle (frm As Form, Size As Integer)
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - e%
frm.Top = frm.Top + (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + (Size% - e%)
frm.Top = frm.Top + e%
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + e%
frm.Top = frm.Top - (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - (Size% - e%)
frm.Top = frm.Top - e%
Next e%
End Sub
--------------------------------------------------------------------------------
تنزيل ملف من الانترنت
*كود برمجي*
--------------------------------------------------------------------------------
'التصاريح
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
Public Function DownloadFile(URL As String, _
LocalFilename As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function
'الكود
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desktop\FileName.htm")
--------------------------------------------------------------------------------
أسماء المجلدات الرئيسية والفرعية في قائمة
*كود برمجي*
--------------------------------------------------------------------------------
'التصاريح
Sub Listdir(path)
Dim d(1000)
Dir1.path = path
For lop = 0 To Dir1.ListCount - 1
d(cnt) = Dir1.List(lop)
cnt = cnt + 1
Next lop
For lop = 0 To cnt - 1
List1.AddItem d(lop)
cur_depth = cur_depth + 1
listdir d(lop)
Next lop
cur_depth = curr_depth - 1
End Sub
'الكود
Listdir(اسم المجلد)
--------------------------------------------------------------------------------
كلام متحرك في TITLEBAR
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
If Me.Caption = "" Then
If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Left(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub
Private Sub Form_Load()
Timer1.Enabled = True
End Sub
--------------------------------------------------------------------------------
فتح وغلق سواقة الأقراص
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
Public Sub EjectCD()
Call mciSendString("set CDAudio Door Open Wait", 0&, 0&, 0&)
bopen = True
End Sub
Public Sub CloseCD()
Call mciSendString("set CDAudio Door Closed Wait", 0&, 0&, 0&)
bopen = False
End Sub
'لفتح السواقة EjectCD
'لغلق السواقة CloseCD
--------------------------------------------------------------------------------
مؤثر حلو على الفورم
*كود برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
اجعل برنامجك فوق الجميع always on top
*كود برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------
بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
*كود برمجي*
--------------------------------------------------------------------------------
'أضف مربعي نص وقائمة(لست بوكس)
Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Integer, _
ByVal wParam As Integer, lParam As Any) As Long
Private Sub Form_Load()
List1.Clear
List1.AddItem "abcd": List1.AddItem "acbd"
List1.AddItem "bcde": List1.AddItem "bdef"
List1.AddItem "cdef": List1.AddItem "cfde"
Text1.Text = ""
End Sub
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
End Sub
--------------------------------------------------------------------------------
أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص
*كود برمجي*
--------------------------------------------------------------------------------
Public Function GetWordCount(ByVal Text As String) As Long
Text = Trim(Replace(Text, "-" & vbNewLine, ""))
'Replace new lines with a single space
Text = Trim(Replace(Text, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While Text Like "* *"
Text = Replace(Text, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(Text, " "))
End Function
--------------------------------------------------------------------------------
تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
*كود برمجي*
--------------------------------------------------------------------------------
diff= DateDiff("d", "22/1/2001", "22/1/2002")
--------------------------------------------------------------------------------
تأجيل تنفيذ الكود لفترة معينة
*كود برمجي*
--------------------------------------------------------------------------------
Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub
Private Sub Command1_Click()
Delay 5
MsgBox "test"
End Sub
--------------------------------------------------------------------------------
كود للأتصال من خلال البرنامج باستعمال اداة mscomm
*كود برمجي*
--------------------------------------------------------------------------------
'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي
Option Explicit
Private Sub Command1_Click(Index As Integer)
Text1.Text = Text1.Text & Command1(Index).Caption
End Sub
Private Sub Command2_Click()
On Error GoTo er:
Dim DialString$, FromModem$, dummy
Dim Result As Long
If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub
If Text1.Text <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = Text2.Text
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.PortOpen = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء"
End If
MSComm1.InBufferCount = 0
'حلقة للحصول على نتائج الاتصال
Do
dummy = DoEvents()
'تم اقفال منفذ الاتصال
If MSComm1.PortOpen = False Then Exit Sub
If MSComm1.InBufferCount Then
FromModem$ = FromModem$ + MSComm1.Input
If InStr(FromModem$, "NO DIALTONE") Then
MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, ""
Exit Do
End If
If InStr(FromModem$, "BUSY") Then
MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, ""
Exit Do
End If
If InStr(FromModem$, "OK") Then
Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "")
Exit Do
End If
End If
Loop
MSComm1.PortOpen = False
Exit Sub
er:
If Err.Number = 8002 Then
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء"
Else
MsgBox Err.Number & " " & Err.Description, vbCritical, "خطاء"
End If
End Sub
Private Sub Command3_Click()
If MSComm1.PortOpen = False Then Exit Sub
MSComm1.PortOpen = False
End Sub
--------------------------------------------------------------------------------
تشغيل الصوت
*كود برمجي*
--------------------------------------------------------------------------------
'فقط *.wav إظهار الملفات من النوع
commonDialog1.Filter = "Wave Files|*.wav|"
'لإضهار مربع حوار فتح
CommonDialog1.ShowOpen
'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء
'دون فتح الملف
' FileName حيث أن اسم الملف يتواجد في الخاصية
If CommonDialog1.FileName = "" Then Exit Sub
'تحديد نوع الملف المطلوب تشغيله
MMControl1.DeviceType = "waveaudio"
'تحديد اسم ملف الصوت
MMControl1.FileName = CommonDialog1.FileName
'فتح ملف الصوت
MMControl1.Command = "open
--------------------------------------------------------------------------------
امر بحث عن الملفات
*كود برمجي*
--------------------------------------------------------------------------------
'ضع هذا الكود في ملف باس bas
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
(ByVal lpRootPath As String, _
ByVal lpInputName As String, _
ByVal lpOutputName As String) As Long
Public Const MAX_PATH = 260
Public Function FindFile(RootPath As String, _
FileName As String) As String
Dim lNullPos As Long
Dim lResult As Long
Dim sBuffer As String
On Error GoTo FileFind_Error
'Allocate buffer
sBuffer = Space(MAX_PATH * 2)
'Find the file
lResult = SearchTreeForFile(RootPath, FileName, sBuffer)
'Trim null, if exists
If lResult Then
lNullPos = InStr(sBuffer, vbNullChar)
If Not lNullPos Then
sBuffer = Left(sBuffer, lNullPos - 1)
End If
'Return filename
FindFile = sBuffer
Else
'Nothing found
FindFile = vbNullString
End If
Exit Function
FileFind_Error:
FindFile = vbNullString
End Function
'البحث عن ملف
'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره
MsgBox FindFile("c:\", "win.com")
--------------------------------------------------------------------------------
هل الملف موجود أم لا؟
*كود برمجي*
--------------------------------------------------------------------------------
If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
--------------------------------------------------------------------------------
عكس اتجاه جمله
*كود برمجي*
--------------------------------------------------------------------------------
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 Form_DblClick()
Dim strResult As String
'الكلمه المراد عكسها
strResult = reversestring("String")
MsgBox strResult
End Sub
--------------------------------------------------------------------------------
نعطيل النوافذ الدعائية في متصفحكDisble Popup Window
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
WebBrowser1.Navigate "http://www.aol.com"
End Sub
Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
'this sets the popup window to another b
' rowser control
'in which webbrowser2.visible = false
Set ppDisp = WebBrowser2.Object
End Sub
--------------------------------------------------------------------------------
تكملة تلقائية للكومبوبكس Auto complete Combobox
*كود برمجي*
--------------------------------------------------------------------------------
'قسم التصاريح
Public Const CB_FINDSTRING = &H14C
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'الكود
Sub AutoComplete(cbCombo As ComboBox, strKeyHit As String)
' To use this code, put the following co
' de in the combo box's KeyPress event
'
' AutoComplete , Key
' Ascii
'
' change to the nam
' e of the combobox
If KeyAscii = 13 Then
cbCombo.AddItem cbCombo.Text
KeyAscii = 0
Exit Sub
End If
Dim lngFind As Long, intPos As Integer, intLength As Integer
With cbCombo
If KeyAscii = 8 Then
If .SelStart = 0 Then Exit Sub
.SelStart = .SelStart - 1
.SelLength = 32000
.SelText = ""
Else
.SelText = chr(KeyAscii)
End If
KeyAscii = 0
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .Text)
If lngFind = -1 Then Exit Sub
intPos = .SelStart
intLength = Len(.List(lngFind)) - Len(.Text)
.SelText = .SelText & Right(.List(lngFind), intLength)
.SelStart = intPos
.SelLength = intLength
End With
End Sub
--------------------------------------------------------------------------------
حفظ ملف في قاعدة بياناتStore Binary files in a database
*كود برمجي*
--------------------------------------------------------------------------------
Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
If bUseStream Then
Set objStream = New ADODB.Stream
With objStream
.Type = adTypeBinary
.Open
.Write objField.Value
.SaveToFile strFullPath, adSaveCreateOverWrite
End With
DoEvents
Else
If Dir(strFullPath) <> "" Then
Kill strFullPath
End If
lngBytesLeft = objField.ActualSize
intFreeFile = FreeFile
Open strFullPath For Binary As #intFreeFile
Do Until lngBytesLeft <= 0
lngReadBytes = lngBytesLeft
If lngReadBytes > lngChunkSize Then
lngReadBytes = lngChunkSize
End If
byBuffer = objField.GetChunk(lngReadBytes)
Put #intFreeFile, , byBuffer
lngBytesLeft = lngBytesLeft - lngReadBytes
DoEvents
Loop
Close #intFreeFile
End If
If Err.Number <> 0 Or Err.LastDllError <> 0 Then
BLOBToFile = False
Else
BLOBToFile = True
End If
End Function
'***************************************
' ************************
' Abstract: Writes a binary file to a BL
' OB datafield. If the file
'is big I would recommend that you set b
' UseStream = False.
'
' Input: strFullPath: Full path to the s
' ource file
'objField: Field object that will contai
' n the BLOB data.
'bUseStream: (Optional) True = Use Strea
' m methode, False = Use GetChunk
'lngChunkSize: (Optional) Specifies the
' Chunk size to fetch with each GetChunk
'
' Output: True on success, False on fail
' ure
'***************************************
' ************************
Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytesLeft As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
Dim varChunk As Variant
If bUseStream Then
Set objStream = New ADODB.Stream
With objStream
.Type = adTypeBinary
.Open
.LoadFromFile strFullPath
objField.Value = .Read(adReadAll)
End With
Else
With objField
'<<--If the field does not support
' Long Binary data'-->>
'<<--then we cannot load the data
' into the field.-->>
If (.Attributes And adFldLong) <> 0 Then
intFreeFile = FreeFile
Open strFullPath For Binary Access Read As #intFreeFile
lngBytesLeft = LOF(intFreeFile)
Do Until lngBytesLeft <= 0
If lngBytesLeft > lngChunkSize Then
lngReadBytes = lngChunkSize
Else
lngReadBytes = lngBytesLeft
End If
ReDim byBuffer(lngReadBytes)
Get #intFreeFile, , byBuffer()
objField.AppendChunk byBuffer()
lngBytesLeft = lngBytesLeft - lngReadBytes
DoEvents
Loop
Close #intFreeFile
Else
Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data."
End If
End With
End If
If Err.Number <> 0 Or Err.LastDllError <> 0 Then
FileToBLOB = False
Else
FileToBLOB = True
End If
End Function
--------------------------------------------------------------------------------
بإمكانك تحريك الماوس برمجيا
*كود برمجي*
--------------------------------------------------------------------------------
'أضف Command1,Command2 ثم انسخ الكود التالي
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_MOVES = 2000
Dim pt As POINTAPI
Dim cur_x As Long
Dim cur_y As Long
Dim dest_x As Long
Dim dest_y As Long
Dim dx As Long
Dim dy As Long
Dim i As Integer
ScaleMode = vbPixels
GetCursorPos pt
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
'تحديد مكان الماوس الجديد
pt.X = Command2.Width / 2
pt.Y = Command2.Height / 2
ClientToScreen Command2.hwnd, pt
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
' Move the mouse.
dx = (dest_x - cur_x) / NUM_MOVES
dy = (dest_y - cur_y) / NUM_MOVES
For i = 1 To NUM_MOVES - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
DoEvents
Next i
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
--------------------------------------------------------------------------------
كود لعرض جملة في كل مرة تشغل فيها برنامجك (نصيحة اليوم)
قم بكتابة الحكم في ملف نصي TEST.TXT كل حكمة في سطر واحفظ الملف في مسار البرنامج.
ضع على نافذة المشروع أداة Label التي تريد عرض الحكم فيها وضع زر أوامر لعرض الحكمة التالية وانسخ الكود التالي :
*كود برمجي*
--------------------------------------------------------------------------------
Option Explicit
Dim Tips As New Collection
Const TIP_FILE = "TEST.TXT"
Dim CurrentTip As Long
Public Sub DisplayCurrentTip()
If Tips.Count > 0 Then
Label1.Caption = Tips.Item(CurrentTip)
End If
End Sub
Private Sub DoNextTip()
CurrentTip = Int((Tips.Count * Rnd) + 1)
form1.DisplayCurrentTip
End Sub
Function LoadTips(sFile As String) As Boolean
Dim NextTip As String
Dim InFile As Integer
InFile = FreeFile
If sFile = "" Then
LoadTips = False
Exit Function
End If
If Dir(sFile) = "" Then
LoadTips = False
Exit Function
End If
Open sFile For Input As InFile
While Not EOF(InFile)
Line Input #InFile, NextTip
Tips.Add NextTip
Wend
Close InFile
DoNextTip
LoadTips = True
End Function
Private Sub Command1_Click()
DoNextTip
End Sub
Private Sub Form_Load()
Dim ShowAtStartup As Long
ShowAtStartup = GetSetting(App.EXEName, "Options", "Show Tips at Startup", 1)
If ShowAtStartup = 0 Then
Unload Me
Exit Sub
End If
Randomize
If LoadTips(App.Path & "\" & TIP_FILE) = False Then
Label1.Caption = "That the " & TIP_FILE & " file was not found? " & vbCrLf & vbCrLf & _
"Create a text file named " & TIP_FILE & " using NotePad with 1 tip per line. " & _
"Then place it in the same directory as the application. "
End If
End Sub
--------------------------------------------------------------------------------
كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del
هذا يوضع في الجنرال التصريح
*كود برمجي*
--------------------------------------------------------------------------------
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 RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long
Private Const HKEY_LOCAL_MACHINE = &H80000002
Private Const KEY_WRITE = &H20006
Private Const REG_SZ = 1
Private Sub Command1_Click()
Form2.Show
End Sub
--------------------------------------------------------------------------------
---------------------------------
وهذا في الفورم
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
Call DisableCtrlAltDelete(True)
Dim Msg, Style, Title, Response
Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? "
Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading
Title = ";C??CE??"
Response = MsgBox(Msg, Style, Title)
Dim hregkey As Long
Dim SubKey As String
Dim stringbuffer As String
SubKey = "Software\Microsoft\Windows\CurrentVersion\Run"
retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _
KEY_WRITE, hregkey)
If retval <> 0 Then
Exit Sub
End If
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar
retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _
ByVal stringbuffer, Len(stringbuffer))
RegCloseKey hregkey
End Sub
--------------------------------------------------------------------------------
وهذا أذا عملت قائمة منسدلة ضع هذا الكود
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub E_Click()
MsgBox " ?C ?I? ?E?I ?? C?O? ?U?? ?E ", vbExclamation, "C??CE?? ?IE??"
Form2.Show
End Sub
--------------------------------------------------------------------------------
لتحميل جميع خطوط الكمبيوتر في الكومبو بوكس إكتب الكود
Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub
......................................................................
هذا الكود لعمل فورم رخامي
ضع هذا الكود في قسم التصريحات General
Private Sub GradientFill()
Dim i As Long
Dim c As Integer
Dim r As Double
r = ScaleHeight / 3.142
For i = 0 To ScaleHeight
c = Abs(220 * Sin(i / r))
Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30) 'Notice the bias To blue. You can be more subtle by reducing this number (try 10). Try other colours too.
Next
End Sub
وهذا الكود في حدث Resize للفورم
GradientFill
..........................................................................
هذه الدالة لتحميل صفحة من الإنترنت
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub Command1_Click()
lngRetVal = URLDownloadToFile(0, "http://www.الموقع.com", "c:\الموقع.htm", 0, 0)
End Sub
.......................................................................
هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
MoveFile "c:\Windows\Desktop\a.txt", "c:\a.txt"
End Sub
...........................................................................
هذه الدالة تقوم بتعطيل زر إغلاق Close الذي يوجد في كل نافذة
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Const MF_BYPOSITION = &H400&
Private Sub Form_Load()
Dim a As Long, b As Long
a = GetSystemMenu(Me.hwnd, False)
b = GetMenuItemCount(a)
RemoveMenu a, b - 1, MF_BYPOSITION
DrawMenuBar Me.hwnd
End Sub
..........................................................................
هذه الدالة لتغيير ألوان الواجهة للويندوز
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Const COLOR_ACTIVECAPTION = 2
Private Sub Form_Load()
a = GetSysColor(COLOR_ACTIVECAPTION)
SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 200, 140)
MsgBox "The old title bar color was" + Str$(a) + " And is now" + Str$(GetSysColor(COLOR_ACTIVECAPTION))
End Sub
........................................................................
هذه الدالة تعرض مربع حوار تهيئة القرص المرن
Const SHFD_CAPACITY_DEFAULT = 0
Const SHFD_FORMAT_QUICK = 0
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long
Private Sub Form_Load()
SHFormatDrive Me.hwnd, 0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK
End Sub
........................................................................
هذا الكود يقوم بإخبارك هب يوجد كرت صوت أم لا أي هل تستطيع تشغيل ملفات الأصوات في جهازك
ضع هذا الكود في الموديل Module
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
اضف زر Command وضع فيه الكود التالي
Dim i As Integer
i = waveOutGetNumDevs()
If i > 0 Then
MsgBox "بالإمكان تشغيل ملفات الأصوات في جهازك", _
vbInformation, "التأكد من وجود كرت الصوت"
Else
MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في جهازك", _
vbInformation, "التأكد من وجود كرت الصوت"
End If
........................................................................
هل تريد التعرف على خصائص الطابعة أي هل تريد إظهار نافذة خصائص الطابعة إتبع ما يلي :
إضغط على ctrl+t
إختر من النافذة التي سوف تظهر لك Microsoft Common Dialog وذلك بوضع أمامه صح ثم OK
أضفه في الفورم واكتب الكود التالي في حدث الضغط على زر
Dim BeginPage, EndPage, NumCopies, i
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
CommonDialog1.ShowPrinter
BeginPage = CommonDialog1.FromPage
EndPage = CommonDialog1.ToPage
NumCopies = CommonDialog1.Copies
For i = 1 To NumCopies
Next i
Exit Sub
ErrHandler:
Exit Sub
...........................................................................
هذا الكود يقوم بجمع الأرقام الموجود في Text1 و Text2 ويضع الناتج في Label1
Label1.Caption = Val(Text1.Text) + Val(Text2.Text)
وهذا الكود يقوم بطرح ال Text1 من ال Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) - Val(Text2.Text)
هذا الكود يقوم بضرب Text1 بـ Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) * Val(Text2.Text)
هذا الكود يقوم بقسمة Text1 على Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) / Val(Text2.Text)
........................................................................
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر :
Function GetCommandLine(Optional MaxArgs)
Dim C, CmdLine, CmdLnLen, InArg, I, NumArgs
If IsMissing(MaxArgs) Then
MaxArgs = 10
End If
ReDim ArgArray(MaxArgs)
NumArgs = 0:
InArg = False
CmdLine = Command()
CmdLnLen = Len(CmdLine)
For I = 1 To CmdLnLen
C = Mid(CmdLine, I, 1)
If (C <> " " And C <> vbTab) Then
If Not InArg Then
If NumArgs = MaxArgs Then
Exit For
End If
NumArgs = NumArgs + 1
InArg = True
End If
ArgArray(NumArgs) = ArgArray(NumArgs) & C
Else
InArg = False
End If
Next I
ReDim Preserve ArgArray(NumArgs)
GetCommandLine = ArgArray()
End Function
Private Sub Form_Activate()
Dim I
s = GetCommandLine
For I = 1 To UBound(s)
Print s(I)
Next I
End Sub
........................................................................
كيف تضع محتويات ملف في ليستا
Private Sub Command1_Click()
Dim StringHold As String
Open "C:\test.txt" For Input As #1
List1.Clear
While Not EOF(1)
Input #1, StringHold
List1.AddItem StringHold
Wend
Close #1
End Sub
.........................................................................
كيف تعرف اذا تم تغيير محتويات TextBox
Private bChanged As Boolean
Private Sub Text1_Change()
bChanged = True
End SubPrivate
Sub Form_Unload(Cancel As Boolean)
If bChanged Then
If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then
'Save Changes Here.
End If
End If
End Sub
...........................................................................
كيف تصنع قائمة فرعية من خلال زر امر
First, create a menu with the menu editor.
It should look like this:
Button Menu (Menu name: mnuBtn, Visible: False - Unchecked)
....SubMenu Item 1 (Menu name: mnuSub, Index: 0)
....SubMenu Item 2 (Menu name: mnuSub, Index: 1)
....SubMenu Item 3 (Menu name: mnuSub, Index: 2)
....SubMenu Item 4 (Menu name: mnuSub, Index: 3)
I hope you understand the above. Also create a CommandButton.
Then add this code:
Private Sub mnuSub_Click(Index As Integer)
Call MsgBox("Menu sub-item " & Index + 1 & " clicked!", _
vbExclamation)
End Sub
Private Sub Command1_Click()
Call PopupMenu(mnuBtn)
End Sub
P.S. For added effect, replace the line:
Call PopupMenu(mnuBtn)
With this one:
Call PopupMenu(Menu:=mnuBtn, X:=Command1.Left, Y:=Command1.Top + _
Command1.Height) ' Even more viola!
Or this one:
Call PopupMenu(mnuBtn, vbPopupMenuCenterAlign, Command1.Left + _
(Command1.Width / 2), Command1.Top + Command1.Height
...........................................................................
نسخ محتويات مربع نص الى مربع نص اخر
If you have VB6.0 you can use the Replace Function to
easily replace any Character(s) with something else, eg.
Text2 = Replace(Text1, vbCrLf, "" & vbCrLf)
Otherwise, you'll need to step though the Text yourself
checking for instances of vbCrLf, e.g.
code:
Dim sString As String
Dim sNewString As Strings
String = Text1
While Instr(sString, vbCrLf)
sNewString = sNewString & Left(sString, _
Instr(sString, vbCrLf) - 1) & "" & vbCrLf
sString = Mid(sString, Instr(sString, vbCrLf) + 2)
Wend
Text2 = sNewString
...........................................................................
) أكواد الحافظة....
الحافظة في الفيجوال بيسك تأخذ الأسم Clipboard ، حيث يتم ربط توابع معينة بهذا
الكائن لكي تتم أوامر الحافظة...سأكتب الأكواد على فرض أن لدينا صندوق نص اسمه
txtMyText...
*** كود القص:
Clipboard.clear
Clipboard.SetText txtMyText.SelText
txtMyText.SelText=""
إن المنهج Clear يقوم بتفرغة كل محتويات الحافظة... كما يقوم الأمر SetText بإضافة النص المحدد إلى الحافظة... و إذا أردنا معرفة ما تحملة العبارة التالية txtMyText.SelText فهي تحمل قيمة النص المحدد... أي أن SelText تشير إلى النص المحدد...
ثم في العبارة الأخيرة، نحذف النص المحدد لكي تتم عملية القص...
*** كود النسخ:
Clipboard.clear
Clipboard.SetText txtMyText.SelText
هذا الكود يماثل تماما الكود السابق، لكن الفرق أننا لا نقوم بحذف النص المحدد و الذي نود نسخه...
*** كود اللصق:
txtMyText.SelText=ClopBoard.GetText( )
إن العبارة ClipBoard.GetText() تحمل قيمة النص الموجود في الحافظة.... و نحن نأمر الجهاز في هذا الكود بوضع قيمة الحافظة مكان النص المحدد...
2) كود الأحداث المعلقة:
من المؤكد أنكم تتسائلون " ما هي الأحداث المعلقة؟ "، أنا سأشرح لكم...
إن بعض البرامج تحتوي على Loop أي حلقة ... و لهذه الحلقة أشكال كثيرة، أشهرها و
أكثرها شيوعا:
For I=0 to 100
.......
.....
.......
if I=100 then I=0
next I
إذا قمنا بتحليل عمل هذا البرنامج، نتوصل إلى انه سيقوم بتنفيذ الأوامر الموجودة داخل الحلقة إلى ما لا نهاية... و بذلك، فإن أي حدث تقوم بتنفيذه خلال عمل هذه الحلقة فإنه لن يستجيب.....
أعرف أنكم لم تفهموا، سأوسع الشرح...
لنفرض أنه لدينا برنامج يقوم برسم نقاط عشوائية على نموذج معين، و هذه النقاط غير منتهية.... و لدينا زري أوامر، الأول للبدء الحلقة، و الثاني لإنهاءها...
إذا ضغطنا زر البدء، فإن الحلقة ستبدأ إلى ما لا نهاية.... و سترسم نقاطا على النموذج إلى ما لا نهاية... فعند القيام بحدث الضغط على زر إنهاء الحلقة، فأنه لن يستجيب أبدا، و ذلك بسبب عمل الحلقة.... فما الحل إذن...
يوجد تابع خاص لهذه المشكلة و هو DoEvents... عند وضع هذا التابع ضمن الحلقة، فإنه ينفذ الحدث الذي قمت به، ثم يكمل تنفيذ الحلقة....
3) كود تنفيذ أي برنامج عن طريق الفيجوال بيسك:
إذا أردت أن تشغل إي برنامج في جهازك عن طريق الفيجوال بيسك، اكتب العبارة التالية....
Dim A
A = Shell ("programpath",n)
حيث A متغير... و اكتب مكان الــ programpath مسار البرنامج كاملا، و اكتب مكان n رقم من 0 إلى 6، حيث كل رقم له دلالته...
0 تظهر نافذة البرنامج مخفية.
1 تظهر نافذة البرنامج بحجمها الطبيعي و معها التركيز.
2 تظهر النافذة مصغرة و معها التركيز.
3 تظهر النافذة مكبرة و ومعها التركيز.
4 تظهر نافذة عادية و بدون تركيز.
6 تظهر نافذة مصغرة بدون تركيز.
و إن التابع Shell يرجع قيمة عددية تحفظ في المتغير A تشير إلى مقبض النافذة الذي يعترف عليه Windows
ملاحظة: الفائدة من وضع القيمة 0 للمتغير n ، هي لظهور النافذة مخفية، و بالتالي يتم تحميل النافذة في الذاكرة دون أن نراها. و نستغيد من هذه الحالة في تشغيل ملف تنفيذي لكي يؤدي وظائف معينة دون أن يشاهد المستخدم نافذة البرنامج (برامج الفيروسات و التجسس)
4) كود للقيام باتصال هاتفي:
يجب أولا تضمين أداة جديدة و هي MSComm، و ذلك بالخطوات التالية:
* اضغط بزر اليمين على مكان فارغ شريط الأدوات.
* اختر الخيار Components
* اختر الأداة MSComm من القائمة و اضغط على الزر موافق.
* ستظهر لك أداة جديدة لها شكل الهاتف على شريط الأدوات.
بعد تضمين هذه الأداة في النموذج، نسميها على سبيل المثال Comm1....
و إليك الكود:
Dim PhoneNumber as String
On Error Goto WrongPort
Comm1.CommPort = 1
Comm1.Settings = "300,n,8,1"
PhoneNumber = "164883"
Comm1.PortOpen = True
Comm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)Sub
WrongPort:
MsgBox "Title", 1048576 + 524288 + 16, "Prompt"
الشرح:
في السطر الأول: نعرف متغير حرفي و هو PhoneNumber
في السطر الثاني: نضع هذه العبارة بحيث في حال حدوث أي خطأ ( مثلا المودم غير
متصل، أو المنفذ غير صحيح ) ينتقل التنفيذ إلى السطر الثامن حيث
الإجراء . طبعا يمكن تسمة WrongPort كما نشاء.
في السطر الثالث: نحدد البورت الذي سنجري منه الإتصال. يفضل أن تقوم بتجر