مكتبة أكواد Visual Basic

عدد الرسائل : 17 تاريخ التسجيل : 22/01/2008

اضافه نص متحرك
الادوات 2 TIMER AND LEBEL
' ضع هذا الكود في الفورم
Dim Llabel As Integer

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

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

Private Sub Timer2_Timer()
Llabel = Llabel - 10
Label1.Left = Llabel
If Llabel < 0 Then
Timer1.Interval = 100
Timer2.Interval = 0
End If
End Sub

********

لاضافه ملف صوتي من نوع MDI
Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.FileName = ("c:\FileName.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub
*****
حذف اي ملف
Private Sub Command1_Click()
Kill ("C:\FileName.fnm")
End Sub
****
اضافة ملف جديد
Private Sub Command1_Click()
open "c:\FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1
End Sub
*****
معرفة الوقت والتاريخ
الادوات timer +lebel
Private Sub Form_Load()
Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
Label1 = Time & Date
End Sub
****
فتح صفحة انترنت
الادوات كوماند command
' ضع هذا الكود في الفورم
Private Sub Command2_Click()
Dim X As Object
Set X = CreateObject("InternetExplorer.Application")
X.Navigate "www.theforsan.yoo7.com"
X.Visible = True
End Sub

عدد الرسائل : 17 تاريخ التسجيل : 22/01/2008

كود لجعل
نموذجك كامل الشاشة

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 Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1
Const HWND_TOP = 0
Const SWP_SHOWWINDOW = &H40 الشفرة
Dim cx As Long
Dim cy As Long
Dim RetVal As Long
' Determine if screen is already maximized.
If Me.WindowState = vbMaximized Then
' Set window to normal size
Me.WindowState = vbNormal
End If ' Get full screen width.
cx = GetSystemMetrics(SM_CXSCREEN) ' Get full screen height.
cy = GetSystemMetrics(SM_CYSCREEN)
' Call API to set new size of window.
RetVal = SetWindowPos(Me.hwnd, HWND_TOP, 0, 0, cx, cy, SWP_SHOWWINDOW)

عدد الرسائل : 17 تاريخ التسجيل : 22/01/2008

كود لاغلاق الفورم بشكل بطيء لاعلى من ضمن الديكورات الاضافية على شكل الفورم....
الادوات:- كوماندز وبقية الموثرات على الفورم من خلال الخصائص كم تشاء
للمبتدئين

Private Sub Command1_Click()
msg = MsgBox("هل ترغب بالخروج", vbOKCancel, "خروج")
If msg = vbOK Then
For I = 1 To 9000
For J = 1 To 4000
Next
Form1.Height = Form1.Height - 1
Next I
Unload Me
End If
End Sub

Private Sub Form_Load()
Form1.WindowState = 0
Form1.Width = 12000
Form1.Height = 9000
End Sub
'الصق الكود هذا بنافذة الكود والادوات المطلوبة كوماند للخروج ....

عدد الرسائل : 17 تاريخ التسجيل : 22/01/2008

للأتصال بالأنترنت باستخدام الdailup connection

*كود برمجي*

--------------------------------------------------------------------------------

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
كود خاص لمعرفة كلمة السر لملفات 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.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

--------------------------------------------------------------------------------

معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
*كود برمجي*

--------------------------------------------------------------------------------

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Command1_Click()
MsgBox Format(GetTickCount, "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 ********************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
ملاحظة في البداية لبد من انشاء تكست وليبل

--------------------------------------------------------------------------------

كود الاظهار النص بشكل عمودي
*كود برمجي*

--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------

عرض صندوق حوار Open With
*كود برمجي*

--------------------------------------------------------------------------------

Private Sub Command1_Click()
Dim x As Long
x = ********************l("rundll32.exe ********************l32.dll,OpenAs_RunDLL C:\vbzoom.log")
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 Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long

'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub

تحيه حسب الوقت
*كود برمجي*

--------------------------------------------------------------------------------

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

» برنامج visual basic 6
» اكبر مكتبة للصوتيات للشيخ مشاري العفاسي
» أكبر مكتبة برامج حماية برامج 2008 أدخل و حمل ما تريد