[VBMaged]

اخواني الكرام اكواد كانت محفوظة عندي ولم إستفيد منها لأنني إعمل "VB.net" فحببت ان اضعها بين يديكم للأستفادة منها

نبدأ بأذن الله
-----------
معرفة اليوم الحالي

كود :

Private Sub Command1_Click()
Dim Dday As Integer
Dday = Weekday(Date)
If Dday = 1 Then Print "الأحد"
If Dday = 2 Then Print "الاثنين"
If Dday = 3 Then Print "الثلاثاء"
If Dday = 4 Then Print "الأربعاء"
If Dday = 5 Then Print "الخميس"
If Dday = 6 Then Print "الجمعة"
If Dday = 7 Then Print "السبت"
End Sub

معرفة الشهر الحالي

كود :

Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Print MonthName(Mmonth)
End Sub

عرض الوقت والتاريخ

كود :

Private Sub Form_Load()
Timer1.Interval = 1000
End Sub
Private Sub Timer1_Timer()
Label1 = Time & Date
End Sub

كود لاخفاء موشر الفارة

كود :

Private Declare Function ShowCursor Lib "user32" _  
(ByVal bShow As Long) As Long  
اخفاء المؤشر  
x = ShowCursor(False)  
إظهار المؤشر  
x = ShowCursor(True)

منع النسخ أو اللصق

كود :

Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
R = Clipboard.GetText
If Len(R) = 0 Then
Clipboard.Clear
End If
End Sub

نسخ ملف

كود :

Private Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub

فتح لوحة التحكم

كود :

Private Sub Command1_Click()
Shell "rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus
End Sub

لتشغيل شاشة التوقف

كود :

ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Const WM_SYSCOMMAND = &H112&
Private Const SC_SCREENSAVE = &HF140&
Private Sub Command1_Click()
Dim Res As Long
Res = SendMessage(Me.hWnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub

تأجيل تنفيذ الكود لفترة معينة

كود :

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

تحرك صورة مع الماوس

كود :

في الفورم حدث form mousemove
picture1.move x - 200, y - 200

كود لالتقاط صورة للشاشة في الحافظة

كود :

Private Sub Command1_Click()
keybd_event vbKeySnapshot, 0, 0, 0
DoEvents
End Sub[/


كود إظهار اليوم الحالي
[CODE]Private Sub Command1_Click()  
Dim Dday As Integer  
Dday = Weekday(Date)  
If Dday = 1 Then Print "الأحد"  
If Dday = 2 Then Print "الاثنين"  
If Dday = 3 Then Print "الثلاثاء"  
If Dday = 4 Then Print "الأربعاء"  
If Dday = 5 Then Print "الخميس"  
If Dday = 6 Then Print "الجمعة"  
If Dday = 7 Then Print "السبت"  
End Sub

جرب كرر الضغط على Command
سيقوم بتكرار اليوم الحالي على طول الفورم
او

كود :

Text1 = Format(Date, "dddd")

او

كود :

label1= Format(Date, "dddd")

"في ليبل "


اذا إعجبكم ادعو لي بصلاح الحال
بالتوفيق للجميع

[VBMaged]

كود إعادة الريجيستري
طبعاَ بعد ان يتم ازالة الفيروس (Autorun) من جهازك فان مشاكل كثيرة تبقى منها ان الـ Regestry Editor لا يمكن الدخول عليه بعدها ويظهر رسالة (regestry editor has been disabled by your adminstrator)
هذا الكود لارجاعه
اولاً الكود يكتب في التيكست وليس في نافذة VB6. اي NotePad hgl الموجود مع نظام التشغيل "ويندوز" في جميع الأصدارت "تقريبا"

الكود

كود :

Option Explicit
'تعريف المتحولات ادناه
Dim AA, rr, rr2, MyBox, val, val2, ttl, toggle
Dim jobfunc, itemtype
On Error Resume Next
Set AA= WScript.CreateObject("WScript.Shell")
val = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
val2 = "HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
itemtype = "REG_DWORD"
jobfunc = "محرر السجل -الريجيستري- الآن: "
ttl = "Result"
'تنفيد الاجراء المكتوب في فاليو.
rr = AA.RegRead (val)
rr2 = AA.RegRead (val2)
toggle=1
If (rr=1 or rr2=1) Then toggle=0
If toggle = 1 Then
AA.RegWrite val, 1, itemtype
AA.RegWrite val2, 1, itemtype
Mybox = MsgBox(jobfunc & "غير مفعل.", 4096, ttl)
Else
AA.RegDelete val
AA.RegDelete val2
Mybox = MsgBox(jobfunc & "مفعل.", 4096, ttl)
End If

قبل الحفظ عليك ان تحفظ الملف بامتداد VBS. وليس بامتداد txt.
ستحفظه اي اسم تريد ولكن بامتداد VBS وسيصبح شكله كحرف S وسيعمل انشالله وسيقوم بقفل الرجيستري اذا كان مفتوحاً وفتحه اذا كان مقفلا وهكذا كلما اردت فتحه او اغلاقه يمكنك ذلك من خلال الضغط على الملف الناتج VBS

[VBMaged]

لمنع تشغيل أكثر من نسخة من برنامجك

إقتباس :Private Sub Form_Load()
If App.PrevInstance = True Then
MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج"
Unload Me
Exit Sub
End If
End Sub

لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب

إقتباس :Call DisableCtrlAltDelete(True)

لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب

إقتباس :Call DisableCtrlAltDelete(False)

عرض نموذج داخل نموذج آخر
أضف نموذجين Form2, Form1

إقتباس :Private Declare Function SetParent Lib "user32" _
(ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Sub Form_Load()
SetParent Form1.hwnd, Form2.hwnd
Form2.Show
End Sub

تحريك الماوس برمجيا باستخدام الكود التالي
أضف Command1,Command2 ثم انسخ الكود التالي

إقتباس :Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_MOVE = &H1 ' mouse move
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute move
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_MOVES = 2000
Dim pt As POINTAPI
Dim cur_x As Long
Dim cur_y As Long
Dim dest_x As Long
Dim dest_y As Long
Dim dx As Long
Dim dy As Long
Dim i As Integer
ScaleMode = vbPixels
GetCursorPos pt
cur_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
cur_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
'تحديد مكان الماوس الجديد
pt.X = Command2.Width / 2
pt.Y = Command2.Height / 2
ClientToScreen Command2.hwnd, pt
dest_x = pt.X * 65535 / ScaleX(Screen.Width, vbTwips, vbPixels)
dest_y = pt.Y * 65535 / ScaleY(Screen.Height, vbTwips, vbPixels)
' Move the mouse.
dx = (dest_x - cur_x) / NUM_MOVES
dy = (dest_y - cur_y) / NUM_MOVES
For i = 1 To NUM_MOVES - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_MOVE, cur_x, cur_y, 0, 0
DoEvents
Next i
End Sub

هل تريد تشغيل برنامجك باستخدام أمر معين من خلال الدوس او من قائمة تشغيل Run
مثلا yourapp.exe /msg
او yourapp.exe /normal
هذا الكود مفيد جدا وغير معروف لأغلب المستخدمين

إقتباس :Private Sub Form_Load()
Dim args As String
Get the command line arguments.
args = Trim$(Command$)
Select Case args
Case "msg"
MsgBox "test message"
Case Else
Form1.Caption = args
End Select
End Sub

كود للبحث عن كلمة في التكست بوكس

إقتباس :Private Sub Form_Load()
Text1.Text = "Two of the peak human experiences"
Text1.Text = Text1.Text & " are good food and classical music."
End Sub
Private Sub Form_Click()
Dim Search, Where ' Declare variables.
' Get search string from user.
Search = InputBox("Enter text to be found:")
Where = InStr(Text1.Text, Search) ' Find string in text.
If Where Then ' If found,
Text1.SetFocus
Text1.SelStart = Where - 1 ' set selection start and
Text1.SelLength = Len(Search) ' set selection length.
Else
MsgBox "String not found." Notify user.
End If
End Sub

هذا الكود لإنهاء البرنامج عند النقر على Esc في لوحة المفاتيح مهما كان موقع التركيز بين الأدوات.....
'Load انسخ هذا الكود لحدث تحميل النموذج

إقتباس :Private Sub Form_Load()
Form1.KeyPreview = True
End Sub

انسخ هذا الكود لحدث النموذج 'KeyPress

إقتباس :Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then
End
End If
End Sub

حفظ ما يتغير في التيكست بعد اغلاقه

إقتباس :Private Sub Form_Load()
Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")
End Sub
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)
End Sub

[@@أبورائد@@]

السلام عليكم ورحمة الله وبركاته

VBMaged كتب :اذا إعجبكم ادعو لي بصلاح الحال

أسأل الله أن يصلح حالي وحالك أخي [b]VBMaged[/b] وبارك الله فيك





السلام عليكم ورحمة الله وبركاته

[VBMaged]

شكرا معلمي الفاضل واخي الكريم ابو رائد
وان يصلح حالي وحالك