said
11-01-2013, بتوقيت غرينيتش 01:15 PM
http://www.dzbatna.com/images/icons/iconrote.gif ط§ظƒظˆط§ط¯ ظپط¬ظˆظ„ ط¨ظٹط³ظٹظƒ (http://www.dzbatna.com/t822791/)
السلام عليكم ورحمة الله وبركاته ..
اكواد فجول بيسيك مهمة .. منقولة طبعآ ..
بصراحه اناا الى الإن لم إجرب إي وحدة
--------------------------------------------------------------------------------
اقتباس
Option Explicit
Private Sub Command1_Click()
Dim X
Dim DialUpConnectName As String
'قم بتحديد اسم الاتصال الذي تود الاتصال به
DialUpConnectName = "Sts"
X = ____l("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1)
DoEvents
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة
'"123(enter)"
SendKeys "{enter__", True
DoEvents
End Sub
كود code خاص لمعرفة كلمة السر لملفات Access 97
*كود code برمجي*
--------------------------------------------------------------------------------
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.Defaul____ = "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
--------------------------------------------------------------------------------
معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
*كود code برمجي*
--------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
MsgBox Format(GetTickCount, "0")
End Sub
--------------------------------------------------------------------------------
كود code لمعرفة كلمات السر على هيئة نجوم ________*
*كود code برمجي*
--------------------------------------------------------------------------------
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
'المكتوب بها كلمة المرور(____box)نقوم هنا بمعرفة مقبض آداة التحرير
h = WindowFromPoint(x, y)
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub
--------------------------------------------------------------------------------
كود code لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة
*كود code برمجي*
--------------------------------------------------------------------------------
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
*كود code برمجي*
--------------------------------------------------------------------------------
'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.___ - 15)-(Ctl.Left + _
Ctl.Width, Ctl.___ - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.___)-(Ctl.Left - 15, _
Ctl.___ + Ctl.Height), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.Width, Ctl.___)- _
(Ctl.Left + Ctl.Width, Ctl.___ + Ctl.Height), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.___ + Ctl.Height)- _
(Ctl.Left + Ctl.Width, Ctl.___ + 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 ____box
Private Sub Form_Load()
Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is name of label
PaintControl3D Me, ____1 '____1 is name of ____box
End Sub
ملاحظة في البداية لبد من انشاء تكست وليبل
--------------------------------------------------------------------------------
كود code الاظهار النص بشكل عمودي
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code تستطيع من خلاله حذف اي ملف
*كود code برمجي*
--------------------------------------------------------------------------------
قم بوضع هذا الكود code في قسم جنرال
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")
--------------------------------------------------------------------------------
كود code لاستدعاء ملف من نوع mid
*كود code برمجي*
--------------------------------------------------------------------------------
قم بوضع اداة
mmcontrol1
m و
اجعل نامي
Private Sub Form_Load()
m.DeviceType = "sequencer"
m.FileName = ("e:\Holiday3.mid")
m.Command = "open"
m.Command = "play"
END SUB
--------------------------------------------------------------------------------
كود code لتحميل فلاش من نوع SWF
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
s.Movie = ("E:\Projects\Howl.swf")
End Sub
--------------------------------------------------------------------------------
كود code لوضع مقطع الفيديو في بكتشر
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
--------------------------------------------------------------------------------
الزر الأيمن للماوس
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
لكتابة بس ارقام في تكست بوكس
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub COMMAND1_CLICK()
DIM SS AS STRING
SS="123456789"
IF INSTR(SS,CHR(KEYASCII)=0 THEN
KEYASCII=0
END IF
End Sub
--------------------------------------------------------------------------------
عمل مسح ملفات للقرص المرن
*كود code برمجي*
--------------------------------------------------------------------------------
kill"A:\*.*"
--------------------------------------------------------------------------------
عرض صندوق حوار Open With
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim x As Long
x = ____l("rundll32.exe ____l32.dll,OpenAs_RunDLL C:\vbzoom.log")
End Sub
--------------------------------------------------------------------------------
حساب عدد سطور ملف نصى
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
فحص المنافذ
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = ____1.____
Winsock1.Listen
____2.____ = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
____2.____ = "المنفذ مفتوح"
Else
____2.____ = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا كود code لتشفير وفك تشفير نص
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
For i = 1 To Len(____1.____)
st1 = Mid(____1.____, i, 1)
as1 = Asc(st1)
ch1 = Chr(255 - as1)
st = st + ch1
Next
____1.____ = st
End Sub
--------------------------------------------------------------------------------
هذا الكود code لإضافة عروض الفلاش لبرنامجك
*كود code برمجي*
--------------------------------------------------------------------------------
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 يوماً فقط
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا الكود code يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code لنسخ خلفية سطح المكتب إلى نموذجك
*كود code برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesk___ Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكود codeالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesk___ Form1.hdc
End Sub
--------------------------------------------------------------------------------
تحويل اي حرف إلى حرف ASCII
*كود code برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(____1.____)
MsgBox temp
--------------------------------------------------------------------------------
تحيه حسب الوقت
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
نوعية القرص (قرص مرن،سي دي،.....)
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
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)
--------------------------------------------------------------------------------
مؤثر على الفورم
*كود code برمجي*
--------------------------------------------------------------------------------
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.___ = FirstForm.___ '//make the .___ 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.___ = FirstForm.Height * -1 'make .___ 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.___ = 0
'//do the loop until the form is all the
' way to the bottom
SecondForm.___ = SecondForm.___ + 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.___ = FirstForm.___
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.___ = FirstForm.Height '//put form to bottom of screen
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Left
Do Until SecondForm.___ = 0
SecondForm.___ = SecondForm.___ - 15
Pause 0.3
Loop
End Sub
--------------------------------------------------------------------------------
فورم دائري
*كود code برمجي*
--------------------------------------------------------------------------------
Sub formcircle (frm As Form, Size As Integer)
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - e%
frm.___ = frm.___ + (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + (Size% - e%)
frm.___ = frm.___ + e%
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + e%
frm.___ = frm.___ - (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - (Size% - e%)
frm.___ = frm.___ - e%
Next e%
End Sub
--------------------------------------------------------------------------------
تنزيل ملف من الانترنت
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desk___\FileName.htm")
--------------------------------------------------------------------------------
أسماء المجلدات الرئيسية والفرعية في قائمة
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
Listdir(اسم المجلد)
--------------------------------------------------------------------------------
كلام متحرك في TITLEBAR
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(____1.____, Len(____1.____) - 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(____1.____, Len(____1.____) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub
Private Sub Form_Load()
Timer1.Enabled = True
End Sub
--------------------------------------------------------------------------------
فتح وغلق سواقة الأقراص
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
مؤثر حلو على الفورم
*كود code برمجي*
--------------------------------------------------------------------------------
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 ___
*كود code برمجي*
--------------------------------------------------------------------------------
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____MOST = -1
Private Const HWND_NO___MOST = -2
Public Sub SetOn___(ByVal hwnd As Long, ByVal bSetOn___ As Boolean)
Dim lR As Long
If bSetOn___ Then
lR = SetWindowPos(hwnd, HWND____MOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NO___MOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub
Private Sub Form_Load()
SetOn___ Form1.hwnd, True
End Sub
--------------------------------------------------------------------------------
هذا الكود code لمنع تشغيل أكثر من نسخة من برنامجك
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------
بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
*كود code برمجي*
--------------------------------------------------------------------------------
'أضف مربعي نص وقائمة(لست بوكس)
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"
____1.____ = ""
End Sub
Private Sub ____1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal ____1.____)
End Sub
--------------------------------------------------------------------------------
أيضا يمكنك باستخدام الكود code التالي معرفة عدد الكلمات في مربع النص
*كود code برمجي*
--------------------------------------------------------------------------------
Public Function GetWordCount(ByVal ____ As String) As Long
____ = Trim(Replace(____, "-" & vbNewLine, ""))
'Replace new lines with a single space
____ = Trim(Replace(____, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While ____ Like "* *"
____ = Replace(____, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(____, " "))
End Function
--------------------------------------------------------------------------------
تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
*كود code برمجي*
--------------------------------------------------------------------------------
diff= DateDiff("d", "22/1/2001", "22/1/2002")
--------------------------------------------------------------------------------
تأجيل تنفيذ الكود code لفترة معينة
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code للأتصال من خلال البرنامج باستعمال اداة mscomm
*كود code برمجي*
--------------------------------------------------------------------------------
'اضف 12 command و 2 ____ و اداة mscomm و ضع الكود code التالي
Option Explicit
Private Sub Command1_Click(Index As Integer)
____1.____ = ____1.____ & Command1(Index).Caption
End Sub
Private Sub Command2_Click()
On Error GoTo er:
Dim DialString$, FromModem$, dummy
Dim Result As Long
If MSComm1.Por___en = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub
If ____1.____ <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = ____2.____
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.Por___en = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء"
End If
MSComm1.InBufferCount = 0
'حلقة للحصول على نتائج الاتصال
Do
dummy = DoEvents()
'تم اقفال منفذ الاتصال
If MSComm1.Por___en = 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.Por___en = False
Exit Sub
er:
If Err.Number = 8002 Then
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء"
Else
MsgBox Err.Number & " " & Err.De______ion, vbCritical, "خطاء"
End If
End Sub
Private Sub Command3_Click()
If MSComm1.Por___en = False Then Exit Sub
MSComm1.Por___en = False
End Sub
--------------------------------------------------------------------------------
تشغيل الصوت
*كود code برمجي*
--------------------------------------------------------------------------------
'فقط *.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
--------------------------------------------------------------------------------
امر بحث عن الملفات
*كود code برمجي*
--------------------------------------------------------------------------------
'ضع هذا الكود code في ملف باس 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
'البحث عن ملف
'هذا الكود code ضعه في الحدث الضغط على زر كوماند او غيره
MsgBox FindFile("c:\", "win.com")
--------------------------------------------------------------------------------
هل الملف موجود أم لا؟
*كود code برمجي*
--------------------------------------------------------------------------------
If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
--------------------------------------------------------------------------------
عكس اتجاه جمله
*كود code برمجي*
--------------------------------------------------------------------------------
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
==============================
منقوول للإمانة
ألعاب الأندرويد مجانا و حصريا (http://www.apotox.info/forum)
https://fbcdn-sphotos-d-a.akamaihd.net/hphotos-ak-ash4/482113_236967293114455_1193518507_n.png (http://www.dzbatna.com)
©المشاركات المنشورة تعبر عن وجهة نظر صاحبها فقط، ولا تُعبّر بأي شكل من الأشكال عن وجهة نظر إدارة المنتدى (http://www.dzbatna.com)©
السلام عليكم ورحمة الله وبركاته ..
اكواد فجول بيسيك مهمة .. منقولة طبعآ ..
بصراحه اناا الى الإن لم إجرب إي وحدة
--------------------------------------------------------------------------------
اقتباس
Option Explicit
Private Sub Command1_Click()
Dim X
Dim DialUpConnectName As String
'قم بتحديد اسم الاتصال الذي تود الاتصال به
DialUpConnectName = "Sts"
X = ____l("rundll32.exe rnaui.dll,RnaDial " & DialUpConnectName, 1)
DoEvents
'في حال اردت ارسال كلمة السر ايضا قم باضافتها في النص التالي قبل القوس الاول مباشرة
'"123(enter)"
SendKeys "{enter__", True
DoEvents
End Sub
كود code خاص لمعرفة كلمة السر لملفات Access 97
*كود code برمجي*
--------------------------------------------------------------------------------
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.Defaul____ = "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
--------------------------------------------------------------------------------
معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
*كود code برمجي*
--------------------------------------------------------------------------------
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
MsgBox Format(GetTickCount, "0")
End Sub
--------------------------------------------------------------------------------
كود code لمعرفة كلمات السر على هيئة نجوم ________*
*كود code برمجي*
--------------------------------------------------------------------------------
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
'المكتوب بها كلمة المرور(____box)نقوم هنا بمعرفة مقبض آداة التحرير
h = WindowFromPoint(x, y)
'Char 0 الى (PasswordChar)فى هذه الخطوة نقوم بتعديل خاصية ال
Dim NewChar As Integer
NewChar = CLng(0)
retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub
--------------------------------------------------------------------------------
كود code لاضافة بيانات حقل معين في قاعدة البيانات الى عنصر list
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك) ثم يتوقف نهائيا عن العمل ، وهو يشبه طريقة عمل الـ(register) في البرامج المشهورة
*كود code برمجي*
--------------------------------------------------------------------------------
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
*كود code برمجي*
--------------------------------------------------------------------------------
'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.___ - 15)-(Ctl.Left + _
Ctl.Width, Ctl.___ - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.___)-(Ctl.Left - 15, _
Ctl.___ + Ctl.Height), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.Width, Ctl.___)- _
(Ctl.Left + Ctl.Width, Ctl.___ + Ctl.Height), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.___ + Ctl.Height)- _
(Ctl.Left + Ctl.Width, Ctl.___ + 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 ____box
Private Sub Form_Load()
Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is name of label
PaintControl3D Me, ____1 '____1 is name of ____box
End Sub
ملاحظة في البداية لبد من انشاء تكست وليبل
--------------------------------------------------------------------------------
كود code الاظهار النص بشكل عمودي
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code تستطيع من خلاله حذف اي ملف
*كود code برمجي*
--------------------------------------------------------------------------------
قم بوضع هذا الكود code في قسم جنرال
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")
--------------------------------------------------------------------------------
كود code لاستدعاء ملف من نوع mid
*كود code برمجي*
--------------------------------------------------------------------------------
قم بوضع اداة
mmcontrol1
m و
اجعل نامي
Private Sub Form_Load()
m.DeviceType = "sequencer"
m.FileName = ("e:\Holiday3.mid")
m.Command = "open"
m.Command = "play"
END SUB
--------------------------------------------------------------------------------
كود code لتحميل فلاش من نوع SWF
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
s.Movie = ("E:\Projects\Howl.swf")
End Sub
--------------------------------------------------------------------------------
كود code لوضع مقطع الفيديو في بكتشر
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
--------------------------------------------------------------------------------
الزر الأيمن للماوس
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
لكتابة بس ارقام في تكست بوكس
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub COMMAND1_CLICK()
DIM SS AS STRING
SS="123456789"
IF INSTR(SS,CHR(KEYASCII)=0 THEN
KEYASCII=0
END IF
End Sub
--------------------------------------------------------------------------------
عمل مسح ملفات للقرص المرن
*كود code برمجي*
--------------------------------------------------------------------------------
kill"A:\*.*"
--------------------------------------------------------------------------------
عرض صندوق حوار Open With
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim x As Long
x = ____l("rundll32.exe ____l32.dll,OpenAs_RunDLL C:\vbzoom.log")
End Sub
--------------------------------------------------------------------------------
حساب عدد سطور ملف نصى
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
فحص المنافذ
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = ____1.____
Winsock1.Listen
____2.____ = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
____2.____ = "المنفذ مفتوح"
Else
____2.____ = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا كود code لتشفير وفك تشفير نص
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
For i = 1 To Len(____1.____)
st1 = Mid(____1.____, i, 1)
as1 = Asc(st1)
ch1 = Chr(255 - as1)
st = st + ch1
Next
____1.____ = st
End Sub
--------------------------------------------------------------------------------
هذا الكود code لإضافة عروض الفلاش لبرنامجك
*كود code برمجي*
--------------------------------------------------------------------------------
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 يوماً فقط
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
هذا الكود code يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code لنسخ خلفية سطح المكتب إلى نموذجك
*كود code برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesk___ Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكود codeالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesk___ Form1.hdc
End Sub
--------------------------------------------------------------------------------
تحويل اي حرف إلى حرف ASCII
*كود code برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(____1.____)
MsgBox temp
--------------------------------------------------------------------------------
تحيه حسب الوقت
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
نوعية القرص (قرص مرن،سي دي،.....)
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
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)
--------------------------------------------------------------------------------
مؤثر على الفورم
*كود code برمجي*
--------------------------------------------------------------------------------
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.___ = FirstForm.___ '//make the .___ 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.___ = FirstForm.Height * -1 'make .___ 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.___ = 0
'//do the loop until the form is all the
' way to the bottom
SecondForm.___ = SecondForm.___ + 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.___ = FirstForm.___
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.___ = FirstForm.Height '//put form to bottom of screen
SecondForm.Height = FirstForm.Height
SecondForm.Width = FirstForm.Width
SecondForm.Left = FirstForm.Left
Do Until SecondForm.___ = 0
SecondForm.___ = SecondForm.___ - 15
Pause 0.3
Loop
End Sub
--------------------------------------------------------------------------------
فورم دائري
*كود code برمجي*
--------------------------------------------------------------------------------
Sub formcircle (frm As Form, Size As Integer)
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - e%
frm.___ = frm.___ + (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + (Size% - e%)
frm.___ = frm.___ + e%
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + e%
frm.___ = frm.___ - (Size% - e%)
Next e%
For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - (Size% - e%)
frm.___ = frm.___ - e%
Next e%
End Sub
--------------------------------------------------------------------------------
تنزيل ملف من الانترنت
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
G = DownloadFile("UrlOfTheFileToDownload", "c:\windows\desk___\FileName.htm")
--------------------------------------------------------------------------------
أسماء المجلدات الرئيسية والفرعية في قائمة
*كود code برمجي*
--------------------------------------------------------------------------------
'التصاريح
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
'الكود code
Listdir(اسم المجلد)
--------------------------------------------------------------------------------
كلام متحرك في TITLEBAR
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(____1.____, Len(____1.____) - 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(____1.____, Len(____1.____) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub
Private Sub Form_Load()
Timer1.Enabled = True
End Sub
--------------------------------------------------------------------------------
فتح وغلق سواقة الأقراص
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
مؤثر حلو على الفورم
*كود code برمجي*
--------------------------------------------------------------------------------
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 ___
*كود code برمجي*
--------------------------------------------------------------------------------
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____MOST = -1
Private Const HWND_NO___MOST = -2
Public Sub SetOn___(ByVal hwnd As Long, ByVal bSetOn___ As Boolean)
Dim lR As Long
If bSetOn___ Then
lR = SetWindowPos(hwnd, HWND____MOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NO___MOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End If
End Sub
Private Sub Form_Load()
SetOn___ Form1.hwnd, True
End Sub
--------------------------------------------------------------------------------
هذا الكود code لمنع تشغيل أكثر من نسخة من برنامجك
*كود code برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub
--------------------------------------------------------------------------------
بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
*كود code برمجي*
--------------------------------------------------------------------------------
'أضف مربعي نص وقائمة(لست بوكس)
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"
____1.____ = ""
End Sub
Private Sub ____1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal ____1.____)
End Sub
--------------------------------------------------------------------------------
أيضا يمكنك باستخدام الكود code التالي معرفة عدد الكلمات في مربع النص
*كود code برمجي*
--------------------------------------------------------------------------------
Public Function GetWordCount(ByVal ____ As String) As Long
____ = Trim(Replace(____, "-" & vbNewLine, ""))
'Replace new lines with a single space
____ = Trim(Replace(____, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While ____ Like "* *"
____ = Replace(____, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(____, " "))
End Function
--------------------------------------------------------------------------------
تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
*كود code برمجي*
--------------------------------------------------------------------------------
diff= DateDiff("d", "22/1/2001", "22/1/2002")
--------------------------------------------------------------------------------
تأجيل تنفيذ الكود code لفترة معينة
*كود code برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود code للأتصال من خلال البرنامج باستعمال اداة mscomm
*كود code برمجي*
--------------------------------------------------------------------------------
'اضف 12 command و 2 ____ و اداة mscomm و ضع الكود code التالي
Option Explicit
Private Sub Command1_Click(Index As Integer)
____1.____ = ____1.____ & Command1(Index).Caption
End Sub
Private Sub Command2_Click()
On Error GoTo er:
Dim DialString$, FromModem$, dummy
Dim Result As Long
If MSComm1.Por___en = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub
If ____1.____ <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = ____2.____
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.Por___en = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vbCritical, "خطاء"
End If
MSComm1.InBufferCount = 0
'حلقة للحصول على نتائج الاتصال
Do
dummy = DoEvents()
'تم اقفال منفذ الاتصال
If MSComm1.Por___en = 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.Por___en = False
Exit Sub
er:
If Err.Number = 8002 Then
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vbCritical, "خطاء"
Else
MsgBox Err.Number & " " & Err.De______ion, vbCritical, "خطاء"
End If
End Sub
Private Sub Command3_Click()
If MSComm1.Por___en = False Then Exit Sub
MSComm1.Por___en = False
End Sub
--------------------------------------------------------------------------------
تشغيل الصوت
*كود code برمجي*
--------------------------------------------------------------------------------
'فقط *.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
--------------------------------------------------------------------------------
امر بحث عن الملفات
*كود code برمجي*
--------------------------------------------------------------------------------
'ضع هذا الكود code في ملف باس 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
'البحث عن ملف
'هذا الكود code ضعه في الحدث الضغط على زر كوماند او غيره
MsgBox FindFile("c:\", "win.com")
--------------------------------------------------------------------------------
هل الملف موجود أم لا؟
*كود code برمجي*
--------------------------------------------------------------------------------
If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If
--------------------------------------------------------------------------------
عكس اتجاه جمله
*كود code برمجي*
--------------------------------------------------------------------------------
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
==============================
منقوول للإمانة
ألعاب الأندرويد مجانا و حصريا (http://www.apotox.info/forum)
https://fbcdn-sphotos-d-a.akamaihd.net/hphotos-ak-ash4/482113_236967293114455_1193518507_n.png (http://www.dzbatna.com)
©المشاركات المنشورة تعبر عن وجهة نظر صاحبها فقط، ولا تُعبّر بأي شكل من الأشكال عن وجهة نظر إدارة المنتدى (http://www.dzbatna.com)©
