hamata00
11-30-2006, 03:34 PM
السلام عليكم
عالم الكودات+تصميم برامج أختراق+تصميم مساعد أوفيس المتحرك+ winsock+خدع
للأتصال بالأنترنت باستخدام الdailup connection
*كود برمجي*
Option Explicit
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
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
[CODE]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
---------------------------------------------------------
ارجو الردود علي الموضوع بعد التجربة
عالم الكودات+تصميم برامج أختراق+تصميم مساعد أوفيس المتحرك+ winsock+خدع
للأتصال بالأنترنت باستخدام الdailup connection
*كود برمجي*
Option Explicit
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
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
[CODE]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
---------------------------------------------------------
ارجو الردود علي الموضوع بعد التجربة