مكتبة اكواد الفيجوال بيسيك الجزء الاول

Admin عدد المساهمات : 76 تاريخ التسجيل : 18/09/2009

اقدم لكم مكتبة اكواد للغة الفيجوال بيسيك من العقرب الاسود السوري
المكتبة عبارة عن 3 اجزاء وهاد الجزء الاول
$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
إنشاء ملف جديد

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
************************************************** *********
والحمد لله رب العالمين
ارجو المشاركة
واللى اللقاء يالجزء الثاني Shocked

» مكتبة اكواد الفيجوال بيسيك الجزء الثاني
» مكتبة اكواد الفيجوال بيسيك الجزء الثالث
» احدث اكواد الجوال بين يديك
» اصنع فيروسك الاحترافي خلال خمس ثواني وبدون برامج فقط اكواد