طريق الايمان

TvQuran


الإهداءات


العودة   فريق قراصنة غزة || Gaza Hacker Team > .:: القسم التقني ::. > .:: قسم لغات البرمجة ::. > قسم برمجة لغة Php , Html

« آخـــر الــمــواضــيــع »
         :: (حصريا) افضل ميلر لاصحاب السبام برمجة 2014 (آخر رد :Stray)       :: بخصووص الروووت (آخر رد :logic bugzer)       :: سارع بالتسجيل فى اقوى دوره تدريبيه لتعلم اختراق المواقع والمنتديات - شرح صوت وصوره (آخر رد :فى بى ان)       :: انطلاق اقوى دوره تدريبيه احترافيه لتعلم اختراق المواقع والمنتديات - شرح صوت وصوره (آخر رد :فى بى ان)       :: بخصوص السنايل..!! (آخر رد :النينجا المخترق)       :: السلام عليكم (آخر رد :An0n)       :: كورس تدريبى احترافى لتعلم اختراق الاجهزه والبريد - شرح صوت وصوره ع مدار 30 يوم (آخر رد :فى بى ان)       :: افتتاح التسجيل فى اقوى دوره لتعلم اختراق المواقع والمنتديات - شرح صوت وصوره وتطبيق (آخر رد :فى بى ان)       :: ارجوا دخول محترفين اختراق المواقع شباب (آخر رد :غزة في قلبي)       :: كورس تدريبى احترافيى لتعلم اختراق المواقع والمنتديات - شرح بالصوت والصوره خطوه بخطوه (آخر رد :غزة في قلبي)       :: استفسار (آخر رد :نسر الانبار)       :: شل هدية للمبتدئين (آخر رد :oplmoplm)       :: مشكلة في اختراق الاجهزة (آخر رد :oplmoplm)       :: دوره تدريبيه احترافيه لتعلم لغات البرمجه مثل البيرل والبايثون لاول مره صوت وصوره (آخر رد :قوات امنية)       :: اقوى دوره تدريبيه لتعلم اختراق الاجهزه والبريد - شرح صوت وصوره - تطبيق عملى امامك (آخر رد :قوات امنية)       :: افتتاح دوره تدريبيه احترافيه لتعلم اختراق المواقع والمنتديات شرح صوت وصوره وتطبيق (آخر رد :القآتـل)       :: brute force FTP via METASPLOIT (آخر رد :logic bugzer)       :: WinZip System Utilities Suite (آخر رد :nasa007)       :: Solid Converter (آخر رد :nasa007)       :: Snooper (آخر رد :nasa007)      

إضافة رد
 
أدوات الموضوع انواع عرض الموضوع
قديم 05-09-2010, 09:47 PM   #1
Mr.DaGaA

 


الصورة الرمزية Mr.DaGaA


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
إرسال رسالة عبر مراسل MSN إلى Mr.DaGaA
Mr.DaGaA غير متواجد حالياً

 

Exclamation مكتبة اكواد الفيجول بيسك ...


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





هذي مجموعة أكواد





************************************************** ***

إنشاء ملف جديد

Private Sub Command1_Click()
open "c:\FileName.txt" for append as #1
Print #1,"Willkommen auf die Erde"
Close #1
End Sub

************************************************** ****

معرفة الفرق بين تاريخين باليوم

Private Sub Command1_Click()
On Error GoTo 1
Dim Form1Date As Date
Dim Form2Date As Date
Form1Date = Text1.Text
Form2Date = Text2.Text
Text3.Text = DateDiff("d", Text1.Text, Text2.Text) & " يوم"
Exit Sub
1 MsgBox ("من فضلك أدخل التاريخ بشكل صحيح")
End Sub
************************************************** *****

معرفة مسار مجلد الـ Temp

Public Function TheTempDir() As String
Dim lpBuffer As String
Dim TempPath As Long
lpBuffer = Space(255)
TempPath = GetTempPath(255, lpBuffer)
TheTempDir = ****(lpBuffer, TempPath)
End Function
Private Sub Command1_Click()
Text1.Text = TheTempDir
End Sub
ونكتب في موديل Modell
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

************************************************** **
عرض الزمن والتاريخ

Private Sub Form_Load()
Timer1.Interval = 1000
End Sub

Private Sub Timer1_Timer()
Label1 = Time & Date
End Sub

************************************************** *****
نسخ الملفات من وإلى أي مكان في الهارديسك

Private Sub Command1_Click()
FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat"
End Sub
************************************************** ****
فتح صفحة إنترنت
Private Sub Command1_Click()
Shell "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", vbNormalFocus
End Sub

Private Sub Command2_Click()
Dim X As Object
Set X = CreateObject("InternetExplorer.Application")
X.Navigate "www.noisrael.com"
X.Visible = True
End Sub
************************************************** ****
تشغيل ملف من نوع AVI دون الحاجة إلى أي أدوات

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

Private Sub Form_Click()
Dim Ret As Long, A$, x As Integer, y As Integer
x = 10
y = 10
A$ = "c:\Filename.avi"
Ret = mciSendString("stop movie", 0&, 128, 0)
Ret = mciSendString("close movie", 0&, 128, 0)
Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0)
Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0)
Ret = mciSendString("play movie", 0&, 128, 0)
End Sub

Private Sub Form_DblClick()
End
End Sub

Private Sub Form_Terminate()
Dim Ret As Long
Ret = mciSendString("close all", 0&, 128, 0)
End Sub
************************************************** *******

رش الألوان على الفورم

Private Sub Form_Load()
Me.AutoRedraw = True
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
X = Me.CurrentX
Y = Me.CurrentY
End Sub
Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Me.PSet (X + Rnd * 255, Y + Rnd * 255), RGB(Rnd * 255, Rnd * 255, Rnd * 255)
End Sub
************************************************** *****

طريقة جميلة لإغلاق الفورم

Sub SlideWindow(frmSlide As Form, iSpeed As Integer)
While frmSlide.**** + frmSlide.Width < Screen.Width
DoEvents
frmSlide.**** = frmSlide.**** + iSpeed
Wend
While frmSlide.Top - frmSlide.Height < Screen.Height
DoEvents
frmSlide.Top = frmSlide.Top + iSpeed
Wend
Unload frmSlide
End Sub
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub
************************************************** ****

التحكم في رفع وخفض الصوت

Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long

Sub SetVol(Volume As Long)
Dim Vol&
Vol = CLng("&H" & Hex(Volume + 65536))
waveOutSetVolume 0, Vol
End Sub

Private Sub Command1_Click()
SetVol Text1.Text
End Sub

Private Sub Form_Load()
Text1.Text = "ضع قيمة عددية تنحصر ما بين 0 و 65536"
End Sub
************************************************** ****

إنشاء مجلد جديد

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long

Private Sub Command1_Click()
Dim attr As SECURITY_ATTRIBUTES ' security attributes structure
Dim rval As Long
' Set security attributes
attr.nLength = Len(attr) 'size of the structure
attr.lpSecurityDescriptor = 0 'normal level of security
attr.bInheritHandle = 1 'default setting
' Create directory.
rval = CreateDirectory(Text1.Text, attr)
End Sub

Private Sub Form_Load()
Text1.Text = "c:\Abdu"
Command1.Caption = "New Directory"
End Sub
************************************************** *****

معرفة مسار مجلد الـ System

Public Function TheSystemDir() As String
Dim strBuffer As String
Dim L As Long
strBuffer = Space(255)
L = GetSystemDirectory(strBuffer, 255)
TheSystemDir = ****(strBuffer, L)
End Function

Private Sub Command1_Click()
Text1.Text = TheSystemDir
End Sub

ونكتب في موديل Modell

Declare Function GetSystemDirectory Lib "Kernel32.dll" Alias "GetSystemDirectoryA" (ByVal strBuffer As String, ByVal lngSize As Long) As Long

************************************************** *****

حصر الماوس داخل نطاق معين


Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)
Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)
Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)
Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)
Private Type RECT
**** As Integer
Top As Integer
Right As Integer
Bottom As Integer
End Type
Private Type POINT
X As Long
Y As Long
End Type


Private Sub Command1_Click() 'هذا الايعاز يجعل الماوس لا يخرج عن نطاق الفورم
Dim Client As RECT
Dim Up As POINT
ClientToScreen Me.hwnd, Up
GetClientRect Me.hwnd, Client
OffsetRect Client, Up.X, Up.Y
Up.X = Client.****
Up.Y = Client.Top
ClipCursor Client
End Sub


Private Sub Command2_Click() 'هذا الايعاز يحرر حركة الماوس
ClipCursor ByVal 0&
End Sub

' في هذا المثال سوف تنحصر حركة الماوس داخل الفورم
' كما يمكنك حصرها داخل أي أداة أخرى
' me.hwnd باستبدال الكلمة
'أو غيرها text1.hwnd , label1.hwnd باسم

************************************************** *****

إزالة اسم البرنامج من قائمة المهام الموجودة في ويندوز Ctrl + ALt + Delete

Private Sub Form_Load()
App.TaskVisible = False
End Sub
************************************************** *******

تغيير اسم القرص

Private Declare Function SetVolumeLabel Lib "kernel32.dll" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

Private Sub Command1_Click()
Dim rval As Long
rval = SetVolumeLabel("C:\", Text1.Text)
End Sub

Private Sub Form_Load()
Text1.Text = "Driver 1"
End Sub

************************************************** ****

نسخة مشتركة من البرنامج تشتغل لعدد معين، ثم تطلب منك شراء النسخة الأصلية

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 Me
End If
End Sub
************************************************** ****

طباعة نص

Private Sub Command1_Click()
Printer.Print text1.text
End Sub
************************************************** *****
منع نسخ أو لصق أي ملف ..في الـ Autorun لحماية برنامجك من النسخ.

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
************************************************** *****

لتشغيل ملف صوتي من نـramـوع

Private Sub Command1_Click()
RealAudio1.Source = "c:\Demo.ram"
RealAudio1.DoPlay
End Sub
************************************************** ******
إنشاء أداتي Command Button و Text Box بواسطة الكود
Private WithEvents btnObj As CommandButton
Private WithEvents txtObj As TextBox


Private Sub btnObj_Click()
On Error Resume Next
Set txtObj = Controls.Add("VB.textbox", "txtObj")
With txtObj
.Visible = True
.RightTo**** = True
.Alignment = 2
.Width = 2000
.Text = "السلام عليكم"
.Top = 2000
.**** = 1000
End With
End Sub

Private Sub Form_Load()
Set btnObj = Controls.Add("VB.CommandButton", "btnObj")
With btnObj
.Visible = True
.Width = 2000
.Caption = "Click"
.Top = 1000
.**** = 1000
End With
End Sub
************************************************** *****
معرفة مسار مجلدي الويندوز، والسيستيم، ومعرفة اسم المستخدم


Option Explicit
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias

"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As

Long) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Form_Load()
Dim W
Dim WindowsD As String
WindowsD = Space(144)
W = GetWindowsDirectory(WindowsD, 144)
Text1.Text = WindowsD

Dim S
Dim SystemD As String
SystemD = Space(144)
S = GetSystemDirectory(SystemD, 144)
Text2.Text = SystemD

Dim N
Dim UserN As String
UserN = Space(144)
N = GetUserName(UserN, 144)
Text3.Text = UserN

End Sub
************************************************** *********

فتح الـ CD-ROM وإغلاقه

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 OpenCDDriveDoor(ByVal State As Boolean)
If State = True Then
Call mciSendString("Set CDAudio Door Open", 0&, 0&, 0&)
Else
Call mciSendString("Set CDAudio Door Closed", 0&, 0&, 0&)
End If
End Sub

Private Sub Command1_Click()
OpenCDDriveDoor (True)
End Sub

Private Sub Command2_Click()
OpenCDDriveDoor (False)
End Sub
************************************************** ********

التقاط صورة للفورم في الحافظ

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Private Const VK_SNAPSHOT = &H2C

Private Sub Command1_Click()
keybd_event VK_SNAPSHOT, 1, 1, 1
End Sub
************************************************** ********
تنفيذ أوامر عند الضغط على زري F9 أو F10

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 120 Then
Email = InputBox("Enter Your Name :", "تحياتي")
End If

If KeyCode = 121 Then
Email = InputBox("Enter Your E-mail :", "تحياتي")
End If
End Sub
****************

Dim typDevM As typDevMODE
Dim lngResult As Long
Dim intAns As Integer

lngResult = EnumDisplaySettings(0, 0, typDevM)

With typDevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
.dmPelsWidth = 640 'اختر العرض (640,800,1024, etc)
.dmPelsHeight = 480 'اختر الطول (480,600,768, etc)
End With

lngResult = ChangeDisplaySettings(typDevM, CDS_TEST)
Select Case lngResult
Case DISP_CHANGE_RESTART
intAns = MsgBox("You must restart your computer to apply these changes." & _
vbCrLf & vbCrLf & "Do you want to restart now?", _
vbYesNo + vbSystemModal, "Screen Resolution")
If intAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0)
Case DISP_CHANGE_SUCCESSFUL
Call ChangeDisplaySettings(typDevM, CDS_UPDATEREGISTRY)
MsgBox "Screen resolution changed", vbInformation, "Resolution Changed"
Case Else
MsgBox "Mode not supported", vbSystemModal, "Error"
End Select

End Sub

ونكتب في موديل Modell

Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1

Type typDevMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" (lptypDevMode As Any, ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags As Long, ByVal dwReserved As Long) As Long
************************************************** **********

صهر الشاشة

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyEscape Then Unload Me
End Sub

Private Sub Form_Load()
Dim lngDC As Long
Dim intWidth As Integer, intHeight As Integer
Dim intX As Integer, intY As Integer

lngDC = GetDC(0)

intWidth = Screen.Width / Screen.TwipsPerPixelX
intHeight = Screen.Height / Screen.TwipsPerPixelY

form1.Width = intWidth * 15
form1.Height = intHeight * 15

Call BitBlt(hDC, 0, 0, intWidth, intHeight, lngDC, 0, 0, vbSrcCopy)
form1.Visible = vbTrue

Do
intX = (intWidth - 128) * Rnd
intY = (intHeight - 128) * Rnd

Call BitBlt(lngDC, intX, intY + 1, 128, 128, lngDC, intX, intY, vbSrcCopy)

DoEvents
Loop
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set form1 = Nothing
End
End Sub
************************************************** *********





يتــبع ...
[عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]

 

الموضوع الأصلي : [عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]     -||-     المصدر : [عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]     -||-     الكاتب : [عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]

التوقيع :
  رد مع اقتباس
قديم 05-09-2010, 09:49 PM   #2
Mr.DaGaA

 


الصورة الرمزية Mr.DaGaA


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
إرسال رسالة عبر مراسل MSN إلى Mr.DaGaA
Mr.DaGaA غير متواجد حالياً

 

افتراضي




عمل نموذج شفاف

Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Const LWA_ALPHA = 2
Const GWL_EXSTYLE = (-20)
Const WS_EX_LAYERED = &H80000

Private Sub Form_Load()
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, 0, 128, LWA_ALPHA
End Sub

************************************************** *********
تشغيل شاشة افتتاحية لفترة معينة، ثم تختفي ويشتغل البرنامج

' سوف نحتاج إلى نموذجين، ضع هذا الكود في النموذج الأول
Private Sub Form_Load()
Dim Start, Finsh
Form2.Show
Start = Timer
Finsh = Start + 3
Do Until Finsh <= Timer
DoEvents
Loop
Unload Form2
Form1.Show
End Sub

************************************************** *********

إيقاف الماوس ولوحة المفاتيح عن العمل لمدة معينة

Private Declare Function BlockInput Lib "user32" (ByVal fBlock As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Activate()
DoEvents
BlockInput True
Sleep 1000
BlockInput False
End Sub

************************************************** *******
نقل ملف من مكان إلى مكان

Private Sub Command1_Click()
Name "c:\Autoexec.bat" As "D:\Autoexec.bat"
End Sub

************************************************** *******

جعل الفورم في المقدمة

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_NO**** = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NO**** Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NO**** Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
SetOnTop Form1.hwnd, True
End Sub

************************************************** ********
تحريك نص بطريقة مسلية
Private Sub Form_Load()
Me.Label1.Top = 0
End Sub

Private Sub Timer1_Timer()
a = Me.Height
b = 200
If Me.Label1.Top < a Then 'Me.Height Then
Me.Label1.Top = Me.Label1.Top + b
Exit Sub
End If
For m = 1 To (Int(a / b) + 1)
Me.Label1.Top = Me.Label1.Top - 200
For x = 1 To 1000000
Next
Next
End Sub

************************************************** ********
كرات صغيرة تتبع الماوس

Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function Ellipse Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Sub Form_Load()
Timer1.Interval = 100
Timer1.Enabled = True
Timer2.Interval = 100
Timer2.Enabled = True
Form1.Hide
End Sub
Sub Timer1_Timer()
Dim Position As POINTAPI
GetCursorPos Position

Ellipse GetWindowDC(0), Position.x - 7, Position.y - 7, Position.x + 5, Position.y + 5
End Sub

************************************************** *********
معرفة الإصدارة الحالية من الويندوز

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Sub Form_Load()
Dim OSInfo As OSVERSIONINFO, PId As String
'Set the graphical mode to persistent
Me.AutoRedraw = True
'Set the structure size
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
'Get the Windows version
Ret& = GetVersionEx(OSInfo)
'Chack for errors
If Ret& = 0 Then MsgBox "Error Getting Version Information": Exit Sub
'Print the information to the form
Select Case OSInfo.dwPlatformId
Case 0
PId = "Windows 32s "
Case 1
PId = "Windows 95/98"
Case 2
PId = "Windows NT "
End Select
Print "OS: " + PId
Print "Win version:" + str$(OSInfo.dwMajorVersion) + "." + LTrim(str(OSInfo.dwMinorVersion))
Print "Build: " + str(OSInfo.dwBuildNumber)
End Sub

************************************************** **********

تأثير على الـنص


Option Explicit
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As Long, ByVal nCharExtra As Long) As Long

Private Type RECT
**** As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Declare Function OffsetRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long

Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const COLOR_BTNFACE = 15

Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4 ' Character-stream, PLP
Private Const DT_DISPFILE = 6 ' Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_**** = &H0
Private Const DT_METAFILE = 5 ' Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0 ' Vector plotter
Private Const DT_RASCAMERA = 3 ' Raster camera
Private Const DT_RASDISPLAY = 1 ' Raster display
Private Const DT_RASPRINTER = 2 ' Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

Public Sub TextEffect(obj As Object, ByVal sText As String, ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop As Boolean = False, Optional ByVal lStartSpacing As Long = 128, Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor As OLE_COLOR = vbWindowText)

Dim lhDC As Long
Dim i As Long
Dim x As Long
Dim lLen As Long
Dim hBrush As Long
Static tR As RECT
Dim iDir As Long
Dim bNotFirstTime As Boolean
Dim lTime As Long
Dim lIter As Long
Dim bSlowDown As Boolean
Dim lCOlor As Long
Dim bDoIt As Boolean

lhDC = obj.hdc
iDir = -1
i = lStartSpacing
tR.**** = lX: tR.Top = lY: tR.Right = lX: tR.Bottom = lY
OleTranslateColor oColor, 0, lCOlor

hBrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
lLen = Len(sText)

SetTextColor lhDC, lCOlor
bDoIt = True

Do While bDoIt
lTime = timeGetTime
If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
bSlowDown = True
iDir = 1
lIter = (i + 4)
End If
If (i > 128) Then iDir = -1
If Not (bLoop) And iDir = 1 Then
If (i = lEndSpacing) Then
' Stop
bDoIt = False
Else
lIter = lIter - 1
If (lIter <= 0) Then
i = i + iDir
lIter = (i + 4)
End If
End If
Else
i = i + iDir
End If

FillRect lhDC, tR, hBrush
x = 32 - (i * lLen)
SetTextCharacterExtra lhDC, i
DrawText lhDC, sText, lLen, tR, DT_CALCRECT
tR.Right = tR.Right + 4
If (tR.Right > obj.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = obj.ScaleWidth \ Screen.TwipsPerPixelX
DrawText lhDC, sText, lLen, tR, DT_****
obj.*******

Do
DoEvents
If obj.Visible = False Then Exit Sub
Loop While (timeGetTime - lTime) < 20

Loop
DeleteObject hBrush

End Sub

Private Sub Command1_Click()
Me.ScaleMode = vbTwips
Me.AutoRedraw = True
Call TextEffect(Me, "H e l l o!", 10, 10, False, 75)
End Sub
---------------------------------------------------------------------------------
شوية أكواد منقولين بس حكايه

لازم حستخدم واحد منهم وأنت بعمل برنامج

تظليل النص

يمكن بهذا الكود تظليل النص لنسخة او حذفه اول شىء يجب ان تضع فى الفورم
Text1
Command1
Text1.SetFocus
Text1.SelStart = 0
Text1.SelLength = Len(Text1)



Alt+Ctrl+Delete لإخفاء برنامجك من قائمة

لكي لا يستطيع المستخدم إغلاق برنامجك من هذه الازرار وفي هذا العمل لا تحتاج الى ازار
ضع هذا الكود فى التصريح
General

Private Const RSP_SIMPLE_SERVICE = 1
Private Const RSP_UNREGISTER_SERVICE = 0
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" _
(ByVal dwProcessID As Long, ByVal dwType As Long) As Long
Sub HideApp(Hide As Boolean)
Dim ProcessID As Long
ProcessID = GetCurrentProcessId()
If Hide Then
retval = RegisterServiceProcess(ProcessID, RSP_SIMPLE_SERVICE)
Else
retval = RegisterServiceProcess(ProcessID, RSP_UNREGISTER_SERVICE)
End If
End Sub

والكود التالي للفورم وطبعا لحدث التحميل اللى هو
Load
HideApp (True)


عمل كلمة مرور للبرنامج

لعمل كلمة سر للبرنامج وتحتاج لهذا العمل
Form1
form2
نضع هذا الكود للفورم رقم واحد وطبعا لا تنسى كلمه المرور واللى هي خمسة اصفار وبإمكانك طبعا تغيرها وعند كتابة كلمة المرور صحيحه راح يظهر لك الفورم رقم اثنين وبأمكانك انك تغبر طرقه عرض الفورم مثلا تريد ان تعرض رساله للمستخدم او اي شىء
نضع هذا الكود للفورم واحد فى حذث التحميل اللى هو
Load
Dim s As Integer
Dim passw As String
Do Until (s = 5 Or passw = "00000")
passw = InputBox("من فضلك اكتب كلمة المرور", "كلمة المرور")
s = s + 1
Loop
If s = 5 Then

MsgBox "كلمة المرور خاطئه حاول مره اخرى", vbOKOnly, "خطاء فى كلمة المرو"
End


form2.Show


End If



TextBox حساب عدد حروف

لمعرفه عدد الحروف فى صندوق النص اللى هو
Text box
نحتاج لهذا العمل زر وصندوق نص
Command1
Text1
نضع هذا الكود للزر
MsgBox ("number of charector =" + Str(Len(Text1.Text)))


(RND) برنامج لتوليد أرقام عشوائية و ذلك بإستخدام الدالة

في هذا العمل نحتاج الى زر وقائمه
Command1
List1
نضع الكود التالي في الزر
NR = Int(Rnd * 1000)
List1.AddItem NR


كــود لإعادة تشغيل الجهاز

في هذا العمل نحتاج لزر فقط
Command1
نضع هذا الكود للتصريح الجنرال
General
Private Declare Function SetupPromptReboot Lib "setupapi.dll" (ByRef FileQueue As Long, ByVal Owner As Long, ByVal ScanOnly As Long) As Long
ونضع هذا الكود للزر
SetupPromptReboot ByVal 0&, Me.hWnd, 0



للأتصال بالأنترنت باستخدام ال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.****Next
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.****, Ctl.Top - 15)-(Ctl.**** + _
Ctl.Width, Ctl.Top - 15), &H808080, BF
' darkgrey, **** - vertical
frm.Line (Ctl.**** - 15, Ctl.Top)-(Ctl.**** - 15, _
Ctl.Top + Ctl.Height), &H808080, BF
' white, right - vertical
frm.Line (Ctl.**** + Ctl.Width, Ctl.Top)- _
(Ctl.**** + Ctl.Width, Ctl.Top + Ctl.Height), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.****, Ctl.Top + Ctl.Height)- _
(Ctl.**** + 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, **** - 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
ملاحظة في البداية لبد من انشاء تكست وليبل


******************

'التصاريح
Sub Listdir(path)
Dim d(1000)
Dir1.path = path


For lop = 0 To Dir1.ListCount - 1
d(cnt) = Dir1.List(lop)
cnt = cnt + 1
Next lop


For lop = 0 To cnt - 1
List1.AddItem d(lop)
cur_depth = cur_depth + 1
listdir d(lop)
Next lop
cur_depth = curr_depth - 1
End Sub

'الكود
Listdir(اسم المجلد)


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


كلام متحرك في TITLEBAR
*كود برمجي*


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


Private Sub Timer1_Timer()
On Error Resume Next
If Val(Timer1.Tag) < Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = Right(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1


If Me.Caption = "" Then
If Val(Timer1.Tag) > Val(Timer1.Tag) - 1 Then Timer1.Tag = 0
Me.Caption = ****(Text1.Text, Len(Text1.Text) - Val(Timer1.Tag))
Timer1.Tag = Val(Timer1.Tag) + 1
End If
End Sub


Private Sub Form_Load()
Timer1.Enabled = True
End Sub


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


فتح وغلق سواقة الأقراص
*كود برمجي*


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


Private Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" _
(ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long



Public Sub EjectCD()
Call mciSendString("set CDAudio Door Open Wait", 0&, 0&, 0&)
bopen = True
End Sub


Public Sub CloseCD()
Call mciSendString("set CDAudio Door Closed Wait", 0&, 0&, 0&)
bopen = False
End Sub

'لفتح السواقة EjectCD
'لغلق السواقة CloseCD


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


مؤثر حلو على الفورم
*كود برمجي*


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


Function Dist(x1, y1, x2, y2) As Single
Dim A As Single, B As Single
A = (x2 - y1) * (x2 - x1)
B = (y2 - y1) * (y2 - y1)
Dist = Sqr(A + B)
End Function
Sub ****It(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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It 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)
****It x1, x2, t
****It y1, y2, t
****It x2, x3, t
****It y2, y3, t
****It x3, x4, t
****It y3, y4, t
****It x4, x1, t
****It y4, y1, t
Loop
End Sub


--------------------------------------------------------------------------------
اجعل برنامجك فوق الجميع always on top
*كود برمجي*


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


Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, ByVal X As Long, _
ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, _
ByVal wFlags As Long) As Long
Private Const SWP_NO**** = 2
Private Const SWP_NOSIZE = 1
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean)
Dim lR As Long
If bSetOnTop Then
lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NO**** Or SWP_NOSIZE)
Else
lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NO**** Or SWP_NOSIZE)
End If
End Sub

Private Sub Form_Load()
SetOnTop Form1.hwnd, True
End Sub



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


هذا الكود لمنع تشغيل أكثر من نسخة من برنامجك
*كود برمجي*


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


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


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


بمجرد الكتابة في مربع النص يتم تحديد العنصر المطابق في صندوق القائمة Autocomplete
*كود برمجي*


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


'أضف مربعي نص وقائمة(لست بوكس)

Const LB_FINDSTRING = &H18F
Private Declare Function SendMessage Lib "User32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal wMsg As Integer, _
ByVal wParam As Integer, lParam As Any) As Long
Private Sub Form_Load()
List1.Clear
List1.AddItem "abcd": List1.AddItem "acbd"
List1.AddItem "bcde": List1.AddItem "bdef"
List1.AddItem "cdef": List1.AddItem "cfde"
Text1.Text = ""
End Sub
Private Sub Text1_Change()
List1.ListIndex = SendMessage(List1.hWnd, LB_FINDSTRING, -1, ByVal Text1.Text)
End Sub


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


أيضا يمكنك باستخدام الكود التالي معرفة عدد الكلمات في مربع النص
*كود برمجي*


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


Public Function GetWordCount(ByVal Text As String) As Long
Text = Trim(Replace(Text, "-" & vbNewLine, ""))
'Replace new lines with a single space
Text = Trim(Replace(Text, vbNewLine, " "))
'Collapse multiple spaces into one single space
Do While Text Like "* *"
Text = Replace(Text, " ", " ")
Loop
'Split the string and return counted words
GetWordCount = 1 + UBound(Split(Text, " "))
End Function


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


تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
*كود برمجي*


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


diff= DateDiff("d", "22/1/2001", "22/1/2002")


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


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


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


Public Sub Delay(HowLong As Date)
TempTime = DateAdd("s", HowLong, Now)
While TempTime > Now
DoEvents
Wend
End Sub

Private Sub Command1_Click()
Delay 5
MsgBox "test"
End Sub


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


كود للأتصال من خلال البرنامج باستعمال اداة mscomm
*كود برمجي*


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


'اضف 12 command و 2 text و اداة mscomm و ضع الكود التالي
Option Explicit

Private Sub Command1_Click(Index As Integer)

Text1.Text = Text1.Text & Command1(Index).Caption

End Sub


Private Sub Command2_Click()

On Error GoTo er:

Dim DialString$, FromModem$, dummy
Dim Result As Long

If MSComm1.PortOpen = True Then: MsgBox "منفذ الاتصال قيد الاستخدام حاليا", vbInformation, "": Exit Sub

If Text1.Text <> "" Then
With MSComm1
'تحديد منفذ الاتصال الخاص بالمودم
.CommPort = Text2.Text
'اعدادات خاصة بالمودم وسرعته
.Settings = "9600,N,8,1"
'فتح المنفذ للحصول على الخط
.PortOpen = True
'بعض الثوابت لتعريف الاتصال
.Output = "ATDT" & MSComm1.Tag & Chr$(13)
End With
Else
MsgBox "لايوجد رقم للأتصال به ؟", vb***tical, "خطاء"
End If

MSComm1.InBufferCount = 0

'حلقة للحصول على نتائج الاتصال
Do
dummy = DoEvents()
'تم اقفال منفذ الاتصال
If MSComm1.PortOpen = False Then Exit Sub

If MSComm1.InBufferCount Then
FromModem$ = FromModem$ + MSComm1.Input

If InStr(FromModem$, "NO DIALTONE") Then
MsgBox "لايوجد صوت طنين تاكد من الخط غير مشغول او باتصاله بالمودم بشكل صحيح", vbInformation, ""
Exit Do
End If

If InStr(FromModem$, "BUSY") Then
MsgBox "الخط مشغول اعد الاتصال مرة اخرى", vbInformation, ""
Exit Do
End If

If InStr(FromModem$, "OK") Then
Result = MsgBox("ارفع السماعة واضغط موافق للمكالمة ان اردت انهاء المكالمة اضغط موافق بدون رفع السماعة", vbInformation, "")
Exit Do
End If
End If
Loop
MSComm1.PortOpen = False

Exit Sub
er:
If Err.Number = 8002 Then
MsgBox "لا يوجد مودم في المنفذ المحدد فضلا تأكد من المنفذ الصحيح أو تأكد من وصل المودم بجهازك بشكل جيد", vb***tical, "خطاء"
Else
MsgBox Err.Number & " " & Err.Des***ption, vb***tical, "خطاء"
End If

End Sub


Private Sub Command3_Click()

If MSComm1.PortOpen = False Then Exit Sub
MSComm1.PortOpen = False

End Sub


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


تشغيل الصوت
*كود برمجي*


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


'فقط *.wav إظهار الملفات من النوع
commonDialog1.Filter = "Wave Files|*.wav|"
'لإضهار مربع حوار فتح
CommonDialog1.ShowOpen
'لو لم يختار أي ملف فإنه يتم الخروج من هذا الإجراء
'دون فتح الملف
' FileName حيث أن اسم الملف يتواجد في الخاصية
If CommonDialog1.FileName = "" Then Exit Sub

'تحديد نوع الملف المطلوب تشغيله
MMControl1.DeviceType = "waveaudio"
'تحديد اسم ملف الصوت
MMControl1.FileName = CommonDialog1.FileName
'فتح ملف الصوت
MMControl1.Command = "open


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


امر بحث عن الملفات
*كود برمجي*


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


'ضع هذا الكود في ملف باس bas
Declare Function SearchTreeForFile Lib "IMAGEHLP.DLL" _
(ByVal lpRootPath As String, _
ByVal lpInputName As String, _
ByVal lpOutputName As String) As Long

Public Const MAX_PATH = 260
Public Function FindFile(RootPath As String, _
FileName As String) As String

Dim lNullPos As Long
Dim lResult As Long
Dim sBuffer As String

On Error GoTo FileFind_Error

'Allocate buffer
sBuffer = Space(MAX_PATH * 2)

'Find the file
lResult = SearchTreeForFile(RootPath, FileName, sBuffer)

'Trim null, if exists
If lResult Then
lNullPos = InStr(sBuffer, vbNullChar)
If Not lNullPos Then
sBuffer = ****(sBuffer, lNullPos - 1)
End If
'Return filename
FindFile = sBuffer
Else
'Nothing found
FindFile = vbNullString
End If

Exit Function

FileFind_Error:
FindFile = vbNullString

End Function



'البحث عن ملف
'هذا الكود ضعه في الحدث الضغط على زر كوماند او غيره
MsgBox FindFile("c:\", "win.com")



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


هل الملف موجود أم لا؟
*كود برمجي*


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


If Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود"
End If


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


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


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


Public Function reversestring(revstr As String) As String
Dim doreverse As Long
reversestring = ""
For doreverse = Len(revstr) To 1 Step -1
reversestring = reversestring & Mid$(revstr, doreverse, 1)
Next
End Function

Private Sub Form_DblClick()
Dim strResult As String
'الكلمه المراد عكسها
strResult = reversestring("String")
MsgBox strResult
End Sub


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


نعطيل النوافذ الدعائية في متصفحكDisble Popup Window
*كود برمجي*


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


Private Sub Form_Load()
WebBrowser1.Navigate "http://www.aol.com"
End Sub


Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
'this sets the popup window to another b
' rowser control
'in which webbrowser2.visible = false
Set ppDisp = WebBrowser2.Object
End Sub


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


تكملة تلقائية للكومبوبكس Auto complete Combobox
*كود برمجي*


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


'قسم التصاريح
Public Const CB_FINDSTRING = &H14C
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

'الكود
Sub AutoComplete(cbCombo As ComboBox, strKeyHit As String)
' To use this code, put the following co
' de in the combo box's KeyPress event
'
' AutoComplete , Key
' Ascii
'
' change to the nam
' e of the combobox


If KeyAscii = 13 Then
cbCombo.AddItem cbCombo.Text
KeyAscii = 0
Exit Sub
End If
Dim lngFind As Long, intPos As Integer, intLength As Integer


With cbCombo


If KeyAscii = 8 Then
If .SelStart = 0 Then Exit Sub
.SelStart = .SelStart - 1
.SelLength = 32000
.SelText = ""
Else
.SelText = chr(KeyAscii)
End If
KeyAscii = 0
lngFind = SendMessage(.hWnd, CB_FINDSTRING, 0, ByVal .Text)
If lngFind = -1 Then Exit Sub
intPos = .SelStart
intLength = Len(.List(lngFind)) - Len(.Text)
.SelText = .SelText & Right(.List(lngFind), intLength)
.SelStart = intPos
.SelLength = intLength
End With
End Sub





يتبـع ...

التوقيع :
  رد مع اقتباس
قديم 05-09-2010, 09:50 PM   #3
Mr.DaGaA

 


الصورة الرمزية Mr.DaGaA


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
إرسال رسالة عبر مراسل MSN إلى Mr.DaGaA
Mr.DaGaA غير متواجد حالياً

 

افتراضي


حفظ ملف في قاعدة بياناتStore Binary files in a database
*كود برمجي*


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


Public Function BLOBToFile(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytes**** As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte


If bUseStream Then
Set objStream = New ADODB.Stream


With objStream
.Type = adTypeBinary
.Open
.Write objField.Value
.SaveToFile strFullPath, adSaveCreateOverWrite
End With


DoEvents
Else


If Dir(strFullPath) <> "" Then
Kill strFullPath
End If
lngBytes**** = objField.ActualSize
intFreeFile = FreeFile
Open strFullPath For Binary As #intFreeFile


Do Until lngBytes**** <= 0
lngReadBytes = lngBytes****


If lngReadBytes > lngChunkSize Then
lngReadBytes = lngChunkSize
End If
byBuffer = objField.GetChunk(lngReadBytes)
Put #intFreeFile, , byBuffer
lngBytes**** = lngBytes**** - lngReadBytes


DoEvents
Loop
Close #intFreeFile
End If


If Err.Number <> 0 Or Err.LastDllError <> 0 Then
BLOBToFile = False
Else
BLOBToFile = True
End If
End Function
'***************************************
' ************************
' Abstract: Writes a binary file to a BL
' OB datafield. If the file
'is big I would recommend that you set b
' UseStream = False.
'
' Input: strFullPath: Full path to the s
' ource file
'objField: Field object that will contai
' n the BLOB data.
'bUseStream: (Optional) True = Use Strea
' m methode, False = Use GetChunk
'lngChunkSize: (Optional) Specifies the
' Chunk size to fetch with each GetChunk
'
' Output: True on success, False on fail
' ure
'***************************************
' ************************


Public Function FileToBLOB(ByVal strFullPath As String, ByRef objField As ADODB.Field, Optional ByVal bUseStream As Boolean = True, Optional ByVal lngChunkSize As Long = 8192) As Boolean
On Error Resume Next
Dim objStream As ADODB.Stream
Dim intFreeFile As Integer
Dim lngBytes**** As Long
Dim lngReadBytes As Long
Dim byBuffer() As Byte
Dim varChunk As Variant


If bUseStream Then
Set objStream = New ADODB.Stream


With objStream
.Type = adTypeBinary
.Open
.LoadFromFile strFullPath
objField.Value = .Read(adReadAll)
End With
Else


With objField
'<<--If the field does not support
' Long Binary data'-->>
'<<--then we cannot load the data
' into the field.-->>


If (.Attributes And adFldLong) <> 0 Then
intFreeFile = FreeFile
Open strFullPath For Binary Access Read As #intFreeFile
lngBytes**** = LOF(intFreeFile)


Do Until lngBytes**** <= 0


If lngBytes**** > lngChunkSize Then
lngReadBytes = lngChunkSize
Else
lngReadBytes = lngBytes****
End If
ReDim byBuffer(lngReadBytes)
Get #intFreeFile, , byBuffer()
objField.AppendChunk byBuffer()
lngBytes**** = lngBytes**** - lngReadBytes


DoEvents
Loop
Close #intFreeFile
Else
Err.Raise -10000, "FileToBLOB", "The Database Field does Not support Long Binary Data."
End If
End With
End If



If Err.Number <> 0 Or Err.LastDllError <> 0 Then
FileToBLOB = False
Else
FileToBLOB = True
End If
End Function


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


بإمكانك تحريك الماوس برمجيا
*كود برمجي*


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


'أضف Command1,Command2 ثم انسخ الكود التالي
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Sub mouse_event Lib "user32" _
(ByVal dwFlags As Long, ByVal dx As Long, _
ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Private Const MOUSEEVENTF_**** = &H1 ' mouse ****
Private Const MOUSEEVENTF_ABSOLUTE = &H8000 ' absolute ****
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Sub Command1_Click()
Const NUM_****S = 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)
' **** the mouse.
dx = (dest_x - cur_x) / NUM_****S
dy = (dest_y - cur_y) / NUM_****S
For i = 1 To NUM_****S - 1
cur_x = cur_x + dx
cur_y = cur_y + dy
mouse_event MOUSEEVENTF_ABSOLUTE + MOUSEEVENTF_****, cur_x, cur_y, 0, 0
DoEvents
Next i
End Sub


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


رسم احداثيات سيني وصادي تبعا لحركة الماوس
*كود برمجي*


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


Private Sub Form_Mouse****(Button As Integer, Shift As Integer, _
X As Single, Y As Single)
Me.Cls
Line (X, 0)-(X, Me.ScaleHeight), vbRed
Line (0, Y)-(Me.ScaleWidth, Y), vbGreen
End Sub


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


كود لعرض جملة في كل مرة تشغل فيها برنامجك (نصيحة اليوم)
قم بكتابة الحكم في ملف نصي TEST.TXT كل حكمة في سطر واحفظ الملف في مسار البرنامج.
ضع على نافذة المشروع أداة Label التي تريد عرض الحكم فيها وضع زر أوامر لعرض الحكمة التالية وانسخ الكود التالي :


*كود برمجي*


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



Option Explicit
Dim Tips As New Collection
Const TIP_FILE = "TEST.TXT"
Dim CurrentTip As Long

Public Sub DisplayCurrentTip()
If Tips.Count > 0 Then
Label1.Caption = Tips.Item(CurrentTip)
End If
End Sub

Private Sub DoNextTip()
CurrentTip = Int((Tips.Count * Rnd) + 1)
form1.DisplayCurrentTip
End Sub

Function LoadTips(sFile As String) As Boolean
Dim NextTip As String
Dim InFile As Integer
InFile = FreeFile
If sFile = "" Then
LoadTips = False
Exit Function
End If
If Dir(sFile) = "" Then
LoadTips = False
Exit Function
End If
Open sFile For Input As InFile
While Not EOF(InFile)
Line Input #InFile, NextTip
Tips.Add NextTip
Wend
Close InFile
DoNextTip
LoadTips = True
End Function

Private Sub Command1_Click()
DoNextTip
End Sub

Private Sub Form_Load()
Dim ShowAtStartup As Long
ShowAtStartup = GetSetting(App.EXEName, "Options", "Show Tips at Startup", 1)
If ShowAtStartup = 0 Then
Unload Me
Exit Sub
End If
Randomize
If LoadTips(App.Path & "\" & TIP_FILE) = False Then
Label1.Caption = "That the " & TIP_FILE & " file was not found? " & vbCrLf & vbCrLf & _
"Create a text file named " & TIP_FILE & " using NotePad with 1 tip per line. " & _
"Then place it in the same directory as the application. "
End If
End Sub


--------------------------------------------------------------------------------
كود لا يمكن حذف الملف أبدا الا بالفورمات لانه يتوغل في الجيستري ويعطل alt+ctrl+del

هذا يوضع في الجنرال التصريح


*كود برمجي*


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



Private Declare Function RegOpenKeyEx Lib "advapi32.dll" _
Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As _
String, ByVal ulOptions As Long, ByVal samDesired As Long, _
phkResult As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long

Private Declare Function RegSetValueEx Lib "advapi32.dll" _
Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal Reserved As Long, ByVal dwType As Long, _
lpData As Any, ByVal cbData As Long) As Long

Private Const HKEY_LOCAL_MACHINE = &H80000002

Private Const KEY_WRITE = &H20006
Private Const REG_SZ = 1

Private Sub Command1_Click()
Form2.Show
End Sub



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


---------------------------------
وهذا في الفورم

*كود برمجي*


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



Private Sub Form_Load()
Call DisableCtrlAltDelete(True)


Dim Msg, Style, Title, Response
Msg = "?C ???C C?C??? C??C??E ?C? ??? ?C EI ?? C?????CE" & Chr(13) & Chr(10) + "C??CE?? ... ?E??? ?C?? C??IE?C? ?C?EI??? ?C?????CE C???EC?? "
Style = vbOKOnly + vbExclamation + vbMsgBoxRight + vbMsgBoxRtlReading
Title = ";C??CE??"

Response = MsgBox(Msg, Style, Title)

Dim hregkey As Long
Dim SubKey As String
Dim stringbuffer As String

SubKey = "Software\Microsoft\Windows\CurrentVersion\Run "

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, SubKey, 0, _
KEY_WRITE, hregkey)
If retval <> 0 Then
Exit Sub
End If
stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar
retval = RegSetValueEx(hregkey, "C??CE??", 0, REG_SZ, _
ByVal stringbuffer, Len(stringbuffer))

RegCloseKey hregkey

End Sub



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


وهذا أذا عملت قائمة منسدلة ضع هذا الكود

*كود برمجي*


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



Private Sub E_Click()
MsgBox " ?C ?I? ?E?I ?? C?O? ?U?? ?E ", vbExclamation, "C??CE?? ?IE??"
Form2.Show

End Sub



--------------------------------------------------------------------------------
لتحميل جميع خطوط الكمبيوتر في الكومبو بوكس إكتب الكود
Private Sub Form_Load()
Dim i As Integer
For i = 0 To Screen.FontCount - 1
Combo1.AddItem Screen.Fonts(i)
Next i
Combo1.Text = Combo1.List(0)
End Sub

*************

.................................................. ....................
هذا الكود لعمل فورم رخامي
ضع هذا الكود في قسم التصريحات General
Private Sub GradientFill()
Dim i As Long
Dim c As Integer
Dim r As Double
r = ScaleHeight / 3.142
For i = 0 To ScaleHeight
c = Abs(220 * Sin(i / r))
Me.Line (0, i)-(ScaleWidth, i), RGB(c, c, c + 30) 'Notice the bias To blue. You can be more subtle by reducing this number (try 10). Try other colours too.
Next
End Sub
وهذا الكود في حدث Resize للفورم
GradientFill

.................................................. ........................
هذه الدالة لتحميل صفحة من الإنترنت
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub Command1_Click()
lngRetVal = URLDownloadToFile(0, "http://www.الموقع.com", "c:\الموقع.htm", 0, 0)
End Sub

.................................................. .....................
هذه الدالة تقوم بنقل ملف من مسار إلى مسار آخر
Private Declare Function ****File Lib "kernel32" Alias "****FileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Command1_Click()
****File "c:\Windows\Desktop\a.txt", "c:\a.txt"
End Sub

.................................................. .........................
هذه الدالة تقوم بتعطيل زر إغلاق Close الذي يوجد في كل نافذة
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function Re****Menu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Const MF_BYPOSITION = &H400&
Private Sub Form_Load()
Dim a As Long, b As Long
a = GetSystemMenu(Me.hwnd, False)
b = GetMenuItemCount(a)
Re****Menu a, b - 1, MF_BYPOSITION
DrawMenuBar Me.hwnd
End Sub

.................................................. ........................
هذه الدالة لتغيير ألوان الواجهة للويندوز
Private Declare Function SetSysColors Lib "user32" (ByVal nChanges As Long, lpSysColor As Long, lpColorValues As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Const COLOR_ACTIVECAPTION = 2
Private Sub Form_Load()
a = GetSysColor(COLOR_ACTIVECAPTION)
SetSysColors 1, COLOR_ACTIVECAPTION, RGB(255, 200, 140)
MsgBox "The old title bar color was" + Str$(a) + " And is now" + Str$(GetSysColor(COLOR_ACTIVECAPTION))
End Sub

.................................................. ......................
هذه الدالة تعرض مربع حوار تهيئة القرص المرن
Const SHFD_CAPACITY_DEFAULT = 0
Const SHFD_FORMAT_QUICK = 0
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwndOwner As Long, ByVal iDrive As Long, ByVal iCapacity As Long, ByVal iFormatType As Long) As Long
Private Sub Form_Load()
SHFormatDrive Me.hwnd, 0, SHFD_CAPACITY_DEFAULT, SHFD_FORMAT_QUICK
End Sub

.................................................. ......................
هذا الكود يقوم بإخبارك هب يوجد كرت صوت أم لا أي هل تستطيع تشغيل ملفات الأصوات في جهازك
ضع هذا الكود في الموديل Module
Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
اضف زر Command وضع فيه الكود التالي
Dim i As Integer
i = waveOutGetNumDevs()
If i > 0 Then
MsgBox "بالإمكان تشغيل ملفات الأصوات في جهازك", _
vbInformation, "التأكد من وجود كرت الصوت"
Else
MsgBox "ليس بالإمكان تشغيل ملفات الأصوات في جهازك", _
vbInformation, "التأكد من وجود كرت الصوت"
End If
.................................................. ......................
هل تريد التعرف على خصائص الطابعة أي هل تريد إظهار نافذة خصائص الطابعة إتبع ما يلي :
إضغط على ctrl+t
إختر من النافذة التي سوف تظهر لك Microsoft Common Dialog وذلك بوضع أمامه صح ثم OK
أضفه في الفورم واكتب الكود التالي في حدث الضغط على زر
Dim BeginPage, EndPage, NumCopies, i
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
CommonDialog1.ShowPrinter
BeginPage = CommonDialog1.FromPage
EndPage = CommonDialog1.ToPage
NumCopies = CommonDialog1.Copies
For i = 1 To NumCopies
Next i
Exit Sub
ErrHandler:
Exit Sub

.................................................. .........................
هذا الكود يقوم بجمع الأرقام الموجود في Text1 و Text2 ويضع الناتج في Label1
Label1.Caption = Val(Text1.Text) + Val(Text2.Text)

وهذا الكود يقوم بطرح ال Text1 من ال Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) - Val(Text2.Text)

هذا الكود يقوم بضرب Text1 بـ Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) * Val(Text2.Text)

هذا الكود يقوم بقسمة Text1 على Text2 ويضع الناتج في ال Label1
Label1.Caption = Val(Text1.Text) / Val(Text2.Text)

.................................................. ......................
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر :

Function GetCommandLine(Optional MaxArgs)
Dim C, CmdLine, CmdLnLen, InArg, I, NumArgs
If IsMissing(MaxArgs) Then
MaxArgs = 10
End If
ReDim ArgArray(MaxArgs)
NumArgs = 0:
InArg = False
CmdLine = Command()
CmdLnLen = Len(CmdLine)
For I = 1 To CmdLnLen
C = Mid(CmdLine, I, 1)
If (C <> " " And C <> vbTab) Then
If Not InArg Then
If NumArgs = MaxArgs Then
Exit For
End If
NumArgs = NumArgs + 1
InArg = True
End If
ArgArray(NumArgs) = ArgArray(NumArgs) & C
Else
InArg = False
End If
Next I
ReDim Preserve ArgArray(NumArgs)
GetCommandLine = ArgArray()
End Function


Private Sub Form_Activate()
Dim I
s = GetCommandLine
For I = 1 To UBound(s)
Print s(I)
Next I
End Sub

.................................................. ......................
كيف تضع محتويات ملف في ليستا

Private Sub Command1_Click()
Dim StringHold As String

Open "C:\test.txt" For Input As #1

List1.Clear
While Not EOF(1)
Input #1, StringHold
List1.AddItem StringHold
Wend
Close #1
End Sub

.................................................. .......................
كيف تعرف اذا تم تغيير محتويات TextBox

Private bChanged As Boolean

Private Sub Text1_Change()
bChanged = True
End SubPrivate

Sub Form_Unload(Cancel As Boolean)
If bChanged Then
If Msgbox("Save Changes?", vbYesNo, "Save") = vbYes Then
'Save Changes Here.
End If
End If
End Sub

.................................................. .........................
كيف تصنع قائمة فرعية من خلال زر امر

First, create a menu with the menu editor.
It should look like this:

Button Menu (Menu name: mnuBtn, Visible: False - Unchecked)
....SubMenu Item 1 (Menu name: mnuSub, Index: 0)
....SubMenu Item 2 (Menu name: mnuSub, Index: 1)
....SubMenu Item 3 (Menu name: mnuSub, Index: 2)
....SubMenu Item 4 (Menu name: mnuSub, Index: 3)

I hope you understand the above. Also create a CommandButton.

Then add this code:

Private Sub mnuSub_Click(Index As Integer)
Call MsgBox("Menu sub-item " & Index + 1 & " clicked!", _
vbExclamation)
End Sub

Private Sub Command1_Click()
Call PopupMenu(mnuBtn)
End Sub

P.S. For added effect, replace the line:

Call PopupMenu(mnuBtn)

With this one:

Call PopupMenu(Menu:=mnuBtn, X:=Command1.****, Y:=Command1.Top + _
Command1.Height) ' Even more viola!

Or this one:

Call PopupMenu(mnuBtn, vbPopupMenuCenterAlign, Command1.**** + _
(Command1.Width / 2), Command1.Top + Command1.Height

.................................................. .........................
نسخ محتويات مربع نص الى مربع نص اخر

If you have VB6.0 you can use the Replace Function to
easily replace any Character(s) with something else, eg.

Text2 = Replace(Text1, vbCrLf, "" & vbCrLf)

Otherwise, you'll need to step though the Text yourself
checking for instances of vbCrLf, e.g.


code:

Dim sString As String
Dim sNewString As Strings

String = Text1
While Instr(sString, vbCrLf)
sNewString = sNewString & ****(sString, _
Instr(sString, vbCrLf) - 1) & "" & vbCrLf
sString = Mid(sString, Instr(sString, vbCrLf) + 2)
Wend
Text2 = sNewString
.................................................. .........................

) أكواد الحافظة....
الحافظة في الفيجوال بيسك تأخذ الأسم Clipboard ، حيث يتم ربط توابع معينة بهذا
الكائن لكي تتم أوامر الحافظة...سأكتب الأكواد على فرض أن لدينا صندوق نص اسمه
txtMyText...

*** كود القص:
Clipboard.clear
Clipboard.SetText txtMyText.SelText
txtMyText.SelText=""

إن المنهج Clear يقوم بتفرغة كل محتويات الحافظة... كما يقوم الأمر SetText بإضافة النص المحدد إلى الحافظة... و إذا أردنا معرفة ما تحملة العبارة التالية txtMyText.SelText فهي تحمل قيمة النص المحدد... أي أن SelText تشير إلى النص المحدد...
ثم في العبارة الأخيرة، نحذف النص المحدد لكي تتم عملية القص...

*** كود النسخ:
Clipboard.clear
Clipboard.SetText txtMyText.SelText

هذا الكود يماثل تماما الكود السابق، لكن الفرق أننا لا نقوم بحذف النص المحدد و الذي نود نسخه...

*** كود اللصق:
txtMyText.SelText=ClopBoard.GetText( )

إن العبارة ClipBoard.GetText() تحمل قيمة النص الموجود في الحافظة.... و نحن نأمر الجهاز في هذا الكود بوضع قيمة الحافظة مكان النص المحدد...

2) كود الأحداث المعلقة:
من المؤكد أنكم تتسائلون " ما هي الأحداث المعلقة؟ "، أنا سأشرح لكم...
إن بعض البرامج تحتوي على Loop أي حلقة ... و لهذه الحلقة أشكال كثيرة، أشهرها و
أكثرها شيوعا:
For I=0 to 100
.......
.....
.......
if I=100 then I=0
next I

إذا قمنا بتحليل عمل هذا البرنامج، نتوصل إلى انه سيقوم بتنفيذ الأوامر الموجودة داخل الحلقة إلى ما لا نهاية... و بذلك، فإن أي حدث تقوم بتنفيذه خلال عمل هذه الحلقة فإنه لن يستجيب.....
أعرف أنكم لم تفهموا، سأوسع الشرح...
لنفرض أنه لدينا برنامج يقوم برسم نقاط عشوائية على نموذج معين، و هذه النقاط غير منتهية.... و لدينا زري أوامر، الأول للبدء الحلقة، و الثاني لإنهاءها...
إذا ضغطنا زر البدء، فإن الحلقة ستبدأ إلى ما لا نهاية.... و سترسم نقاطا على النموذج إلى ما لا نهاية... فعند القيام بحدث الضغط على زر إنهاء الحلقة، فأنه لن يستجيب أبدا، و ذلك بسبب عمل الحلقة.... فما الحل إذن...
يوجد تابع خاص لهذه المشكلة و هو DoEvents... عند وضع هذا التابع ضمن الحلقة، فإنه ينفذ الحدث الذي قمت به، ثم يكمل تنفيذ الحلقة....

3) كود تنفيذ أي برنامج عن طريق الفيجوال بيسك:
إذا أردت أن تشغل إي برنامج في جهازك عن طريق الفيجوال بيسك، اكتب العبارة التالية....
Dim A
A = Shell ("programpath",n)

حيث A متغير... و اكتب مكان الــ programpath مسار البرنامج كاملا، و اكتب مكان n رقم من 0 إلى 6، حيث كل رقم له دلالته...

0 تظهر نافذة البرنامج مخفية.
1 تظهر نافذة البرنامج بحجمها الطبيعي و معها التركيز.
2 تظهر النافذة مصغرة و معها التركيز.
3 تظهر النافذة مكبرة و ومعها التركيز.
4 تظهر نافذة عادية و بدون تركيز.
6 تظهر نافذة مصغرة بدون تركيز.

و إن التابع Shell يرجع قيمة عددية تحفظ في المتغير A تشير إلى مقبض النافذة الذي يعترف عليه Windows

ملاحظة: الفائدة من وضع القيمة 0 للمتغير n ، هي لظهور النافذة مخفية، و بالتالي يتم تحميل النافذة في الذاكرة دون أن نراها. و نستغيد من هذه الحالة في تشغيل ملف تنفيذي لكي يؤدي وظائف معينة دون أن يشاهد المستخدم نافذة البرنامج (برامج الفيروسات و التجسس)

4) كود للقيام باتصال هاتفي:
يجب أولا تضمين أداة جديدة و هي MSComm، و ذلك بالخطوات التالية:
* اضغط بزر اليمين على مكان فارغ شريط الأدوات.
* اختر الخيار Components
* اختر الأداة MSComm من القائمة و اضغط على الزر موافق.
* ستظهر لك أداة جديدة لها شكل الهاتف على شريط الأدوات.

بعد تضمين هذه الأداة في النموذج، نسميها على سبيل المثال Comm1....
و إليك الكود:
Dim PhoneNumber as String
On Error Goto WrongPort
Comm1.CommPort = 1
Comm1.Settings = "300,n,8,1"
PhoneNumber = "164883"
Comm1.PortOpen = True
Comm1.OutPut = "ATDT" + PhoneNumber + Chr$(13)Sub
WrongPort:
MsgBox "Title", 1048576 + 524288 + 16, "Prompt"

الشرح:
في السطر الأول: نعرف متغير حرفي و هو PhoneNumber
في السطر الثاني: نضع هذه العبارة بحيث في حال حدوث أي خطأ ( مثلا المودم غير
متصل، أو المنفذ غير صحيح ) ينتقل التنفيذ إلى السطر الثامن حيث
الإجراء . طبعا يمكن تسمة WrongPort كما نشاء.
في السطر الثالث: نحدد البورت الذي سنجري منه الإتصال. يفضل أن تقوم بتجربة البرنامج
عدة مرات بتغيير البورت (1، 2، 3، 4، 5، 6، 7 ) حتى تصل للبورت
الصحيح.
في السطر الرابع: نحدد إعدادات الإتصال. ضعها كما هي موجودة في هذا الكود، لأن
شرحها معقد نوعا ما.
في السطر الخامس: نكتب رقم الهاتف المراد طلبه.
في السطر السادس: يفتح البورت الذي حددته.
في السطر السابع: تنتقل البيانات عبر خط الهاتف مع بعض الشيفرات.
في السطر الثامن: ينتهي تنفيذ الأوامر.
في السطر التاسع: يوجد الإجراء الذي ينتقل أليه التنفيذ عند حدوث خطأ.
في السطر العاشر: تظهر رسالة الخطأ التي عنوانها Title و نصها هو Prompt.
يمكن تغيير هذه القيم كما تشاء.

و الأن تم الإتصال، و ماعليك سوى التكلم عن طريق الهيدفون أو الهاتف.
لقطع الإتصال: ضع الكود التالي:
Comm1.PortOpen = False
حيث يقوم هذا السطر بإغلاق المنفذ.

5) كود لإيقاف تشغيل ويندوز:
ننشئ نافذة جديدة من النوع Module و نكتب فيها السطر التالي:
Public Declare Function ExitWindowsEx Lib "user32" (ByVal uFlags as Long, By Val dwReserved As Long) As Long

و لكن انتبه، اكتبه في سطر واحد، و ليس في سطرين...
و الأن في النموذج، ضمن أزرارا لإيقاف التشغيل، و أعادت التشغيل، و إنهاء كافة العمليات البرمجية، و أنهاء كافة العمليات البرمجية التي لا تستجيب.
و اكتب الكود التالي لكل زر:
Dim LonStatus
LonStatus = ExitWindowsEx (Flag, n)

اكتب إحدى الأرقام التالية للمتغير n:
0 لإنهاء كافة العمليات البرمجية.
1 لإيقاف التشغيل.
2 لإعادة التشغيل.
4 ينهي كافة العمليات البرمجية التي لا تستجيب.

.................................................. .........................

كود لابطال عملية ctrl+alt+del
ضع هذا الكود في قسم التعريفات

Private Declare Function SystemParametersInfo Lib _
"user32" Alias "SystemParametersInfoA" (ByVal uAction _
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub

لإبطال عمل المفاتيح ضع السطر التالي في المكان المناسب
Call DisableCtrlAltDelete(True)

لإعادة عمل المفاتيح ضع السطر التالي في المكان المناسب
Call DisableCtrlAltDelete(False)

.................................................. ........................

كود هـل الملف موجود أم لا ؟
قد يحتاج برنامجك في بعض الأحيان أن يعرف عن أحد الملفات كونه موجوداً على القرص أم لا ، يمكن عمل ذلك باستخدام الأسطر التالية :
If Dir(myfilename, vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then
Msgbox "الملف غير موجود"
Else
Msgbox "الملف موجود" --
ش
End If
.................................................. ........................

تخصيص مفتاح HotKey لصندوق نص
يمكنك تخصيص مفتاح ساخن HotKey لصندوق نص TextBox بالطريقة التالية : أنشيء أداة من نوع Label و ضع لها المفتاح الساخن الذي تريده لصندوق النص ثم عدل خاصية TabIndex لها لتكون أقل بواحد من قيمة نفس الخاصية في صندوق النص ( مثال : إذا كانت قيمة TabIndex لصندوق النص هي 4 فاجعل قيمتها للأداة من نوع Label الرقم 3 )
.................................................. .....................

كيف تجعل النص يظهر بشكل عمودي في الأداة Label
يمكن عمل ذلك باستخدام الرمز vbCrLf ، حيث يوضع بعد كل حرف في محتوى الأداة Label كما يلي :
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
.................................................. .....................

كيفية إغلاق ويندوز من داخل البرنامج أو إعادة تشغيلها
قد تحتاج في بعض البرامج أن تقوم بإعادة تشغيل ويندوز بعد قيام المستخدم بتعديل بعض الخيارات أو لدواع أمنية أو غير ذلك

لعمل ذلك ألصق الأسطر التالية في قسم التعريفات من برنامجك
Declare Function ExitWindowsEx Lib "user32" Alias _
"ExitWindowsEx" (ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long
وفي المكان المناسب ، ضع السطر التالي و الذي يقوم بإغلاق ويندوز
t& = ExitWindowsEx(EWX_REBOOT, 0)

.................................................. ......................
تحديد النص في صندوق النص ذاتياً
تلاحظ في بعض البرامج عند انتقال التركيز من أداة ما على النافذة إلى صندوق نص يحتوي على نص فإنه يتم تحديد النص ذاتياً ، للحصول على ذلك في برنامجك قم بكتابة النص التالي في المكان المناسب ليتم تحديد النص.
Text1.SelStart = 0
Text1.SelLength = Len(Text1)

.................................................. .......................
إخفاء مؤشر الفأرة في تطبيق فيجوال بيسك
تستطيع إخفاء مؤشر الفأرة في موضع معين من برنامجك باستخدام الدالة ShowCursor و التي يتم تعريفها في قسم التعريفات أعلى البرنامج لأنها من دوال واجهة برمجة التطبيقات API على النحو التالي :

Private Declare Function ShowCursor Lib "user32" _
(ByVal bShow As Long) As Long

ومن ثم تستطيع اخفاء المؤشر بتنفيذ الدالة بالشكل التالي
x = ShowCursor(False)

تستطيع إعادة إظهار المؤشر بتنفيذ الدالة بالشكل التالي
x = ShowCursor(True)
.................................................. ........................



هل يحتوي مشغل الأقراص المدمجة على قرص أم لا ؟؟
تستطيع من خلال إضافة السطور التالية إلى برنامجك تحديد ما إذا كان مشغل الأقراص المدمجة يحتوي على قرص أم لا.
Dim FSO As FileSystemObject
Dim aDrive As Drive
Set FSO = New FileSystemObject
For Each aDrive In FSO.Drives
If aDrive.DriveType = CDRom And aDrive.IsReady = False Then
MsgBox "لا يوجد قرص في المشغل"
Exit For
ElseIf aDrive.DriveType = CDRom Then
MsgBox aDrive.VolumeName
Exit For
End If
Next
Set FSO = Nothing

.................................................. ......................
تحديد ما إذا كان تاريخان في نفس الشهر أم لا
تستطيع أن تحدد في برنامجك ما إذا كان تاريخان مدخلان يقعان في نفس الشهر أم لا باستخدام الدالة DateDiff

المثال التالي يوضح كيفية ذلك
Date1 = "01/02/1999"

Date2 = "15/02/1999"

If DateDiff("m", Date1, Date2) Then
MsgBox "التاريخان في شهرين مختلفين"
Else
MsgBox "التاريخان في نفس الشهر"
End If

.................................................. .........................
تحديد دقة عرض الشاشة في جهاز المستخدم
Dim x,y As Integer
x = Screen.Width / 15
y = Screen.Height / 15
If x = 640 And y = 480 Then MsgBox ("640 * 480")
If x = 800 And y = 600 Then MsgBox ("800 * 600")
If x = 1024 And y = 768 Then MsgBox ("1024 * 768")

.................................................. ........................
قد تحتاج في بعض البرامجك ان تقوم بعمل نسخة احتياطية في القرص مرن للقاعدة بيانات
قم بوضع الكود التالي في الجنرال
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

ومن ثم قم بوضع الكود التالي في مكان المناسب
Dim g
g = CopyFile("c:\db1.mdb", "a:\db1.mdb", True)
.................................................. ......................

***********************

كيفية تحريك النافذة عن طريق مؤشر الفأرة
ضع الكود التالي في قس الجنرال
Dim vX, vY
Dim vM As Boolean
اكتب الكود التالي في زر اوامر في حدث موس دون
vX = X
vY = Y
vM = True
ثم اضف الكود التالي في موس موفي
Dim frmX, frmY
frmX = Form1.**** + (X - vX)
frmY = Form1.Top + (Y - vY)
If vM = True Then
Form1.**** frmX, frmY
End If
واخير اضف الكود التالي في زر اوامر عند حدث موس اب
vM = False
.................................................. ......................
للتشفير وفك التشفير
ضع هذا الكود في لود فورم
SubClass (Me.HWnd
وضع هذا الكود في ان لود فورم
UnSubClass (Me.HWnd)
.................................................. ........................
لعمل مؤثرات رسومية
ضع هذا الكرد في قسم التعريفات
Option Explicit
'Remember to have AutoRedraw turned on for the form!
Private mb_Filled As Boolean 'for when the form is re-sized

Public Sub GradientForm_0(po_Form As Object, pl_Start As Long, pl_End As Long, pi_Orientation As Integer)

Dim li_StartRed As Integer
Dim li_StartGreen As Integer
Dim li_StartBlue As Integer
Dim li_EndRed As Integer
Dim li_EndGreen As Integer
Dim li_EndBlue As Integer
Dim ld_DifR As Double
Dim ld_DifG As Double
Dim ld_DifB As Double
Dim li_Counter As Integer
Dim li_DrawWidth As Integer

GetRGBComponents pl_Start, li_StartRed, li_StartGreen, li_StartBlue
GetRGBComponents pl_End, li_EndRed, li_EndGreen, li_EndBlue

ld_DifR = (li_EndRed - li_StartRed) / 255
ld_DifG = (li_EndGreen - li_StartGreen) / 255
ld_DifB = (li_EndBlue - li_StartBlue) / 255

'Draw the gradient onto the form
Select Case pi_Orientation
Case 1 'horizontal gradient
po_Form.Scale (0, 0)-(1, 256)
For li_Counter = 0 To 255
po_Form.Line (0, li_Counter)-(1, li_Counter + 1), _
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _
CInt(li_StartGreen + (ld_DifG * li_Counter)), _
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF
Next li_Counter
Case 2 'vertical gradient
po_Form.Scale (0, 0)-(256, 1)
For li_Counter = 0 To 255
po_Form.Line (li_Counter, 0)-(li_Counter + 1, 1), _
RGB(CInt(li_StartRed + (ld_DifR * li_Counter)), _
CInt(li_StartGreen + (ld_DifG * li_Counter)), _
CInt(li_StartBlue + (ld_DifB * li_Counter))), BF
Next li_Counter
Case 3 'radial gradient
po_Form.Scale (0, 0)-(256, 256)
li_DrawWidth = po_Form.DrawWidth
po_Form.DrawWidth = 3
For li_Counter = 0 To 255
po_Form.Circle (123, 123), li_Counter, _
RGB(CInt(li_StartRed + (ld_DifR * (li_Counter))), _
CInt(li_StartGreen + (ld_DifG * (li_Counter))), _
CInt(li_StartBlue + (ld_DifB * (li_Counter))))
Next li_Counter
po_Form.DrawWidth = li_DrawWidth
End Select
po_Form.Scale

End Sub
Public Sub GetRGBComponents(ByVal pl_Colour As Long, pi_Red As Integer, pi_Green As Integer, pi_Blue As Integer)

Dim ls_Colour As String
Dim ls_Hex As String

ls_Hex = CStr(Hex(pl_Colour))

If Len(ls_Hex) > 6 Then
ls_Hex = Right(ls_Hex, 6)
End If

'Get Blue
If Len(ls_Hex) > 4 Then
ls_Colour = ****(ls_Hex, Len(ls_Hex) - 4)
pi_Blue = Val("&h" & ls_Colour)
ls_Hex = Right(ls_Hex, 4)
End If

'Get Green
If Len(ls_Hex) > 2 Then
ls_Colour = ****(ls_Hex, Len(ls_Hex) - 2)
pi_Green = Val("&h" & ls_Colour)
ls_Hex = Right(ls_Hex, 2)
End If

'Get Red
pi_Red = Val("&h" & ls_Hex)

End Sub
ومن ثم ضع هذا الكود في زر اوامر
GradientForm_0 Me, Text1, Text2, Combo1.Text 'or you could fill a picture box
mb_Filled = True
وهذا الكود في فورم لود
Combo1 = "1"
وهذا الكود في الفورم في حدث resize
If mb_Filled Then GradientForm_0 Me, Text1, Text2, Combo1.Text

ملاحظة قم بتدقيق بالادوات المستخدمة
.................................................. ......................
الايقاف عمل شاشة التوقف
ضع هذا الكود في قسم الجنرال
Option Explicit
Private Const WM_SYSCOMMAND = &H112
Private Const SC_SCREENSAVE = &HF140&
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
ومن ثم ضع هذا الكود في زر اوامر
LaunchScreenSaver Me.hwnd
ومن ثم ضع هذا الكود في اي مكان يعني في مكان فاضي
Sub LaunchScreenSaver(pl_OwnerFormHwnd As Long)
Call SendMessage(pl_OwnerFormHwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0&)
End Sub
.................................................. ......................

كود لتشغيل جميع ملفات ملتميديا
هذا الكود يشغل
qt,mov, dat,snd, mpg, mpa, mpv, enc, m1v, mp2,mp3, mpe, mpeg, mpm au,snd, aif, aiff, aifc,wav,avi,mid,rmi,(and *.vob this format for dvd video)...etc

ويمكن الوصول الى الكود فقط
أضغط هنا
.................................................. ........................
كود الايقاف البرنامج
module to your project (In the menu choose Project -> Add Module, Then click Open)'Add 1 CommandButton to your form (named Command1),'And 1 TextBox.'When you will press the button the program will pause for 3 seconds.'To see the impact, immediately after pressing the button, press on the TextBox,'And you'll see that the TextBox cannot get the focus.'Insert this code to the module :Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)'Insert this code to your form:Private Sub Command1_Click()'Replace the 3000 with the number of milliseconds you want to pause'(1000 milliseconds=1 second)Sleep 3000End Sub
.................................................. .......................
كود لجعل نافذة فوق نافذة
ضع هذا الكود في وحدة نمطية
Public 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
ومن ثم ضع هذا الكود في الفورم
Dim vWindowPos As Long
vWindowPos = SetWindowPos(Form1.hwnd, -1, 0, 0, 0, 0, 1 Or 2)
.................................................. ......................
كود لنبض الفورم
ضع هذا الكود في قسم التصريحات
Option Explicit

Private Declare Function *****Window Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long
Private mb_*****ing As Boolean

ومن ثم ضع هذا الكود في زر اوامر
mb_*****ing = Not mb_*****ing
Timer1.Enabled = mb_*****ing

If mb_*****ing = False Then
Call *****Window(Me.hwnd, 0)
End If

ومن ثم ضع هذا الكود في الوقت
Call *****Window(Me.hwnd, 1)
.................................................. ...................
كود لتحكم بزر ابدا
procedure EnableStartButton;
begin
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn d', nil), 0, 'Button', nil), true);
end;

procedure DisableStartButton;
begin
EnableWindow(FindWindowEx(FindWindow('Shell_TrayWn d', nil), 0, 'Button', nil), false);
end;



.................................................. .......................
جميع اكواد في قاعدة بيانات وتحديثها

اقدم لكم طريقة الإضافة والحذف وتحديث في VB باستخدام كل من الأداتين data control/ Adodc والطريقة كما يلي:
- قم بتشغيل فيجوال بيسك واختيار Standar EXE .
2 - أضف أحدا الأداتين data control أو Adodc وقم بربطها بقاعدة بيانات موجودة .
3- أضف أربع أدوات من نوع CommandButton وقم بتنسيقها كما يلي :
A : Name cmdAction , Caption &AddNwe index 0
B : Name cmdAction , Caption &Cancel index 1
C : Name cmdAction , Caption &Delete index 2
D : Name cmdAction , Caption &******* index 3
لاحظ إن جميع الأزرار تأخذ اسماً واحداً وذلك لتسهيل عملية كتابة النص(Code) ويعطى كلاً منها رقم Index يبدأ من صفر .
بعد الانتهاء من إضافة أزرار الأمر
قم بكتابة النص التالي في قسم التعريفات العامة :
Option Explicit
Private Enum FormMode
fmAdd = True
fmEdit = False
End Enum
وبعد ذلك قم بكتابة الكود التالي :
Public Sub ADOAdd()
On Error GoTo LocalErr
'
With Data1.Recordset
If cmdAction(0).Caption = "&AddNew" Then
.AddNew

cmdAction(0).Caption = "&Save"
setFormModeTo fmAdd
Else
.Update
cmdAction(0).Caption = "&AddNew"
setFormModeTo fmEdit
End If
End With
Exit Sub
LocalErr:
MsgBox Err.Des***ption, vb***tical, "Error: " & CStr(Err.Number)
End Sub
وبعد ذلك قم بكتابة الكود التالي :
Public Sub ADOCancel()
If MsgBox("Undo changes?", vbYesNo + vbQuestion, "Cancel Edits") = vbYes Then
Data1.*******
cmdAction(0).Caption = "&AddNew"
setFormModeTo fmEdit
End If
'
End Sub
وبعد ذلك قم بكتابة الكود التالي :
Public Sub ADOCancel()
'
If MsgBox("Undo changes?", vbYesNo + vbQuestion, "Cancel Edits") = vbYes Then
Data1.*******
cmdAction(0).Caption = "&AddNew"
setFormModeTo fmEdit
End If
'
End Sub


وبعد ذلك قم بكتابة الكود التالي :
Public Sub ADO*******()
'
Data1.*******
setFormModeTo fmEdit
'
End Sub



وبعد ذلك قم بالنقر على اى زر من أزرار الامر نقراً مزدوجاً وأكتب الكود التالي
Private Sub cmdAction_Click(Index As Integer)
'
With Data1
Select Case Index
Case 0: ADOAdd
Case 1: ADOCancel
Case 2: ADODelete
Case 3: ADO*******
End Select
End With
'
End Sub
انتهينا
.................................................. .......................


طريقة التعامل مع ملفات التهيئة


لتعامل مع ملفات التهيئة هناك مجموعة من الدوال ولفهم طريقة إستخدامها سنشرح وظيفة وتركيب ملفات التهيئة . ومن ملفات التهيئة المشهورة الملفان win.ini و system.ini الخاصان بويندوز ، وعادة ما يكون لكل برنامج ملف تهيئة خاصة به وامتداد ملفات التهيئة هو ini , ويتم بملفات التهيئة حفظ أعداداتك الخاصة بك التي قمت بها عند تشغيل برنامج معين فـقـد تلاحـظ عـنـد دخولك لبرنامج ما انة قد وضع آخر اربعة ملفات قمت بتشغيلها في قائمة ملف ( مثل الورد مثلا ) وكذلك يحفظ كل ما قمت بة من تغيرات لتجدها لم تتغير عند تشغيلة في المرة القادمة فما يقوم بة البرنامج هو حفظ الأعدادات التي قمت بها في ملف تهيئة خاص ، لتتم قرائة في المرة القادمة لتشغيلك البرنامج ووضع اعداداتك التي قمت بها .

الشكل العام لملفات التهيئة :

[Desktop]
Wallpaper = (بلا)
TileWallpaper = 1
.
.
[windows]
run= C:\Scan.exe
load=
BaseCodePage = 1256

لاحظ أن ملف التهيئة يتكون من عدد من الآقسام وأسفل كل قسم عدد من المفاتيح وأمام كل مفتاح قيمتة ، مثلا القسم Desktop يحتوي على مفتاحين ، المفتاح TilrWallpaper قيمتة 1 ، وهذا حال كل ملفات التهيئة .


الإجراء WritePrivateProfileString و يعلن عنة كالتالي :

Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long


وظيفتة :

يستخدم للكتابة لملف التهيئة .

المتغيرات :

lpApplicationName وهو من النوع String وهو يمثل اسم القسم المراد الكتابة بة .
lpKeyName وهو من النوع Any وهو يمثل اسم المفتاح .
lpString وهو من النوع Any وهو يمثل القيمة التي تريد كتابتها.
lpFileName وهو من النوع String وهم يمثل اسم ومسار ملف التهيئة .

القيمة المعادة :

الإجراء يعود بقيمة من النوع Long لاتساوي الصفر في حالة نجاحة ، أما إن فشل الإجراء في اداء المطلوب فسيعود بقيمة تساوي الصفر .

ملاحظات :

عندما تستخدم هذا الإجراء للكتابة إلى ملف تهيئة ، فهناك عدة أحتمالات كأن يكون الملف الذي حددتة غير موجود. في هذة الحالة سيقوم الإجراء بعمل ملف جديد يضع فية ما حددتة لة من قسم ومفتاح وقيمة .
وأما إن كان الملف موجود ، فإنة يفتحة ويبحث عن القسم الذي حددتة ، فإذا لم يجدة فأنة ينشئة ويضع تحتة المفتاح والقيمة التي حددتهما لة . أما إذا وجد القسم فإنة يبحث عن المفتاح الذي حددتة ، فإذا لم يجدة فإنة ينشئة ويضع أمامة القيمة المحددة . أما إذا وجد المفتاح ، فإنة يستبدل القيمة الموجودة أمامة بالقيمة التي حددتها له .

الإجراء GetPrivateProfileString و يعلن عنه كالتالي :

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long

وظيفتة :

يستخدم للقراءة من ملف التهيئة

المتغيرات :

lpApplicationName وهو من النوع String وهو يمثل اسم القسم المراد الكتابة بة .
lpKeyName وهو من النوع Any وهو يمثل اسم المفتاح .
lpDefault وهو من النوع String وهو يمثل القيمة الافتراضية التي يعود بها الإجراء إن لم يجد المفتاح المحدد .
lpReturnedString وهم من النوع String وهو عبارة عن متغير حرفي يتم تخزين قيمة المفتاح المحدد بها أن وجدة الإجراء .
nSize وهو من النوع Long وهو يمثل حجم المتغير الحرفي .
lpFileName وهو من النوع String وهم يمثل اسم ومسار ملف التهيئة .

القيمة المعادة :

الإجراء يعود بقيمة من النوع Long لاتساوي الصفر في حالة نجاحة تمثل عدد حروف المتغير الذي قراءة ، أما إن فشل الإجراء في اداء المطلوب فسيعود بقيمة تساوي الصفر .

ملاحظة

هذاين الإجراء ين هما الأكثر استخداما مع ملفات التهيئة ، حيث ان الإجراءين WriteProfileString و GetProfileString فهما حاله خاصة من الإجراءين السابقين . فهما يؤديان نفس مهام الإجراءين السابقين ويتطلبان نفس المتغيرات ، ما عدا المتغير الأخير ( اسم ومسار ملف التهيئة ) حين أن هذين الإجراءين سيفترض أنة win.ini ، لذلك فهذا الإجراء يستخدم لتعامل مع الملف wini.ini فقط .
.................................................. ........................
بعض مميزات مخفية في بيئة دلفي
تشرح هذه الفقرة الصغيرة كيفية إنشاء مدخلات في قاعدة بيانات التسجيل Registry لنظام Windows لتغيير سلوك لوحة العناصر في دلفي 5 بالطريقة التي تناسبك.

تذكّر أنه توجد العديد من الميزات المخفية في منتجات لغات البرمجة عادةً، ويكون المبرمج فرحاً باكتشافها، أما أسباب إخفائها فقد يكون لأنها وضعت في المنتج بعد طباعة دليل الاستخدام، أو أُغفل عنها، أو لعدم تأكد الشركة من جودتها بفحصها بشكل صحيح، أو من وجودها في النسخ اللاحقة للمنتج، ولهذا يتحمل المستخدم المسئولية كاملةً في استخدامها وما ينتج عنها، وليس على الشركة أو علينا أيّ مسئولية.

تنبيه: قبل تعديل قاعدة بيانات التسجيل بأي شكل من الأشكال قم بعمل نسخة احتياطية منها.. إنتقل إلى فهرس النظام (غالباً C:\Windows) وانسخ منه الملفين user.dat وsystem.dat إلى مكان آمن.

ملف قاعدة بيانات التسجيل Registry هو المفتاح:

1- استخدم برنامج RegEdit لإجراء التعديلات على قاعدة بيانات التسجيل بعد - وفقط بعد - أخذ نسخة احتياطية من ملفاته. اطبع الكلمة RegEdit في شاشة حوار التشغيل Run من قائمة ابدأ Start، ثم اضغط Enter.

2- انتقل إلى المفتاح HKEY_CURRENT_USER\Software\Borland\Delphi\5.0.
- أضف مفتاح فرعي جديد باسم Extras.

4- أضف إلى مفتاح Extras متغير حرفي جديد New String/Value باسم AutoPaletteSelect واجعل قيمته 1 لتمكين "الاختيار التلقائي في صفحة العناصر باستخدام الفأرة"، وغيّرها إلى صفر إذا رغبت في تعطيل هذه الميزة.

5- أضف متغير حرفي آخر New String/Value باسم AutoPaletteScroll واجعل قيمته 1 لتمكين "الالتفاف التلقائي للصفحات في لوحة العناصر" والتي تسهل عليك اختيار العناصر غير الظاهرة لكثرتها (الله يزيد ويبارك) والتي تحتاج للعديد من النقرات بالفأرة، وطبعاً غيّرها إلى صفر إذا رغبت في تعطيل هذه الميزة.







تحياتي ,,, Mr.DaGaA


التوقيع :
  رد مع اقتباس
قديم 05-09-2010, 10:58 PM   #4
the dead man

 


الصورة الرمزية the dead man


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
the dead man غير متواجد حالياً
آخـر مواضيعي

المستوى: 17 [♥ Bأ©-Yأھu ♥]
الحياة 0 / 409

النشاط 115 / 5237
المؤشر 39%

 

افتراضي


مشكور الله يعطيك العافية

التوقيع :
  رد مع اقتباس
قديم 05-10-2010, 07:25 PM   #5
Imagination Boy

 


الصورة الرمزية Imagination Boy

افتراضي


مكتبة رائعه .. تسلم ايدك

التوقيع :
  رد مع اقتباس
قديم 05-13-2010, 04:20 AM   #6
Mr.DaGaA

 


الصورة الرمزية Mr.DaGaA


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
إرسال رسالة عبر مراسل MSN إلى Mr.DaGaA
Mr.DaGaA غير متواجد حالياً

 

افتراضي


اقتباس:
المشاركة الأصلية كتبت بواسطة the dead man [عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]
مشكور الله يعطيك العافية
الـعفو ياعسل تشكر ع المرور

التوقيع :



[عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا] ~> add me
  رد مع اقتباس
قديم 05-13-2010, 04:21 AM   #7
Mr.DaGaA

 


الصورة الرمزية Mr.DaGaA


آعجبنيً: 0
تلقي آعجاب 0 مرة في 0 مشاركة
إرسال رسالة عبر مراسل MSN إلى Mr.DaGaA
Mr.DaGaA غير متواجد حالياً

 

افتراضي


اقتباس:
المشاركة الأصلية كتبت بواسطة Imagination Boy [عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا]
مكتبة رائعه .. تسلم ايدك

يسلمك ربي ويخليك تشكر ع المرور

التوقيع :



[عزيزي الزائر يتوجب عليك التسجيل للمشاهدة الرابطللتسجيل اضغط هنا] ~> add me
  رد مع اقتباس
إضافة رد

العلامات المرجعية

الكلمات الدلالية (Tags)
مكتبة, الفيجول, اكواد, بيسك


يتصفح الموضوع حالياً : 1 (0 قرصان و 1 ضيف)
 
أدوات الموضوع
انواع عرض الموضوع

ضوابط المشاركة
لا تستطيع إضافة مواضيع جديدة
لا تستطيع الرد على المواضيع
لا يمكنك اضافة مرفقات
لا يمكنك تعديل مشاركاتك

BB code متاحة
كود [IMG] متاحة
كود HTML معطلة

الانتقال السريع


جميع الأوقات بتوقيت GMT +2. الساعة الآن 08:18 PM.


Powered by vBulletin® Gaza Hacker Team
Copyright ©2000 - 2014, By Gaza-Hacker.net.

تعريب وتطوير » فريق قراصنة غزة



أقسام المنتدى

الأقسام الإسلامية @ .:: القسم الإسلامي العام ::. @ .:: قسم القرآن الكريم وتجويده ::. @ .:: قسم الاناشيد والشريط الاسلامي ::. @ .:: سيرة و قصص الأنبياء و الصحابة ::. @ الأقسام العامة @ .:: قسم الساحة العامة ::. @ .:: قسم فـلـسـطــيــن ::. @ .:: قسم للتوعية الأمنية ::. @ .:: عالم البرامج الكاملة والنادرة ::. @ .:: قسم أخبار التقنية المعلوماتية والتكنولوجية ::. @ .:: قسم عالم المحادثة ::. @ .:: قسم الأمن و الحماية | Security ::. @ ::. قسم حماية الاجهزة والايميلات .:: @ ::. قسم حمايه المواقع والسيرفرات.:: @ ::. قسم إختراق المواقع والأجهزة والبريد الإلكتروني | Hacker .:: @ ::. قسم إختراق المواقع والمنتديات .:: @ ::.قسم إختراق الأجهزه والبريد الاكتروني .:: @ .:: قسم الثغرات ::. @ .:: الركن الترفيهي ::. @ .:: قسم الصور ::. @ .:: ركن الأدارية ::. @ .:: قسم الشكاوي ولأقتراحات ::. @ خاص بشروحات الفيديو @ الأدوات , hack tools @ .:: قسم مساعدة الاعضاء ::. @ :: المواضيع المحذوفة :: @ قسم الانجازات @ .:: جديد قراصنة غزة ::. @ :: قسم استراحة الأعضاء :: @ :: YouTube :: @ .:: القسم التقني ::. @ :: عالمـ الكومبيوتر :: @ :: قسم الجوالات والاتصالات :: @ :: قسم التصميم والغرافيك :: @ خاص للادارة والمشرفين @ :: قسم خاص بالمبتدئين :: @ :: خاص بثغرات المتصفح :: @ :: خاص بشروحات الفيديو :: @ .:: الدورات المقدمة من المشرفين ::. @ :: مشآكل الكومبيوتر وحلولها :: @ .:: للنقاش الجاد ::. @ الملتقى الأدبي .. @ :: طلبات الإشراف :: @ :: كتب الحماية والاختراق security&hacking :: @ البحوث العلمية @ تعليم اللغات الأجنبية @ .:: كتب الكترونية منوعة ::. @ .:: القسم الدعوي ::. @ قسم الكتب الاسلامية @ قسم المواضيع المميزة @ :: قسم خاص بالتشفير :: @ قسم اخبار العالم وقضايا الأمة الإسلامية @ Local root @ دورة إحترآف إلـ Spam Email @ فلسطين , palestine @ .:: مدن وقرى فلسطين ::. @ .:: تاريخ فلسطين ::. @ .:: شهداء فلسطين ::. @ .:: مدينة القدس ::. @ .:: مدينة غزة ::. @ .:: لعروض التصاميم ::. @ .:: لدروس التصاميم ::. @ :: قسم اصدارات وانجازات الفريق :: @ .:: قسم قضية فلسطين ::. @ .:: قسم عروض الاستايلات :.. @ قسم اخبار وقضايا اليهود @ .:: قسم الهاكات وتطوير المنتديات ::. @ ::. قسم المسابقات والنشاطات .:: @ لوحة تحكم سي بانل , cPanel Management @ حماية قواعد البيانات mysql , sql @ لوحة تحكم , Plesk Management @ ادارة سيرفرات Linux @ .:: SQL-injection , حقن قواعد بيانات ::. @ :: قسم خاص بالمبتدئين :: @ .:: قسم الكتب الالكترونية E-BOOK ::. @ .:: قسم تفسير القران الكريم ::. @ قسم الدفاع عن النبي محمد والصحابة وآل البيت @ .:: قسم لغات البرمجة ::. @ قسم برمجة لغة Php , Html @ قسم برمجة لغة mysql , sql @ .:: القسم الرمضانى ::. @ جديد الشيخ نبيل العوضى @ حجب الخدمة , ddos attack @ قسم الاختراق المتقدم @ .:: حماية الاجهزة وطرق كشف التلغيم ::. @ .:: قسم حماية الايميلات :. @ قسم اختراق سيرفرات windows @ .:: دورة قراصنة غزة للتصميم ::. @ .::: أسرى فلسطين ::. @ مدرسة قراصنة غزة لحقن قواعد البيانات @ ::. قسم مشروع الباك تراك backtrack , الميتاسبلويت MetaSploit .:: @ قسم الحقن المتقدم @ قسم دورات الحقن المتقدم @ GH-InjeCtor-Team @ .:: قسم الصلاة ثم الصلاة ::. @ وَحَرِّضِ الْمُؤْمِنِينَ @ قسم انظمة لينكس Linux, Unix @ قسم الالعاب الالكترونية @