مجموعة قيمه من اكواد الفيجوال بيسك (الجزء الثالث)

تنزيل ملف من الانترنت
*كود برمجي*


--------------------------------------------------------------------------------
كود:
'التصاريح
Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
"URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFile**** As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long


Public Function DownloadFile(URL As String, _
LocalFile**** As String) As Boolean
Dim lngRetVal As Long
lngRetVal = URLDownloadToFile(0, URL, LocalFile****, 0, 0)
If lngRetVal = 0 Then DownloadFile = True
End Function


'الكود
G = DownloadFile("UrlOfTheFileToDownload", "c:\******s\desktop\File****.htm")
--------------------------------------------------------------------------------

التقاط صورة للشاشة

كود:
Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc 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 Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With

'Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.hBmp = hBmp ' Handle to bitmap
.hPal = hPal ' Handle to palette (may be null)
End With

'Create the picture
R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

'Return the new picture
Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE

'Create a compatible device context
hDCMemory = CreateCompatibleDC(hDCSrc)
'Create a compatible bitmap
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
'Select the compatible bitmap into our compatible device context
hBmpPrev = SelectObject(hDCMemory, hBmp)

'Raster capabilities?
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
'Does our picture use a palette?
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
'What's the size of that palette?
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Set the palette version
LogPal.palVersion = &H300
'Number of palette entries
LogPal.palNumEntries = 256
'Retrieve the system palette entries
R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
'Create the palette
hPal = CreatePalette(LogPal)
'Select the palette
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
'Realize the palette
R = RealizePalette(hDCMemory)
End If

'Copy the source image to our compatible device context
R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

'Restore the old bitmap
hBmp = SelectObject(hDCMemory, hBmpPrev)

If HasPaletteScrn And (PaletteSizeScrn = 256) Then
'Select the palette
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If

'Delete our memory DC
R = DeleteDC(hDCMemory)

Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function
Private Sub Form_Load()
'Create a picture object from the screen
Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
End Sub
************************************************** ********************
فورم دائري
*كود برمجي*


--------------------------------------------------------------------------------
كود:
Sub formcircle (frm As Form, Size As Integer)


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - e%
frm.Top = frm.Top + (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + (Size% - e%)
frm.Top = frm.Top + e%
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left + e%
frm.Top = frm.Top - (Size% - e%)
Next e%


For e% = Size% - 1 To 0 Step -1
frm.Left = frm.Left - (Size% - e%)
frm.Top = frm.Top - e%
Next e%
End Sub
--------------------------------------------------------------------------------
طلب الاتصال بالإنترنت
كود:
Const FTP_TRANSFER_TYPE_UNKNOWN = &H0
Const FTP_TRANSFER_TYPE_ASCII = &H1
Const FTP_TRANSFER_TYPE_BINARY = &H2
Const INTERNET_DEFAULT_FTP_PORT = 21 ' default

'for FTP servers
Const INTERNET_SERVICE_FTP = 1
Const INTERNET_FLAG_PASSIVE = &H8000000 ' used

'for FTP connections
Const INTERNET_OPEN_TYPE_PRECONFIG = 0 '

'use registry configuration
Const INTERNET_OPEN_TYPE_DIRECT = 1 '

'direct to net
Const INTERNET_OPEN_TYPE_PROXY = 3 '

'via ****d proxy
Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java/******/INS
Const MAX_PATH = 260
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFile**** As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer
Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServer**** As String, ByVal nServerPort As Integer, ByVal sUser**** As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lContext As Long) As Long
Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxy**** As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long
Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean
Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFile**** As String) As Boolean
Private Declare Function FtpRe****File Lib "wininet.dll" Alias "FtpRe****FileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean
Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwContext As Long) As Boolean
Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwContext As Long) As Boolean
Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean
Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dw******* As Long) As Long
Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long
Const PassiveConnection As Boolean = True
Private Sub Form_Load()
Dim hConnection As Long, hOpen As Long, sOrgPath As String
'open an internet connection
hOpen = InternetOpen("API-Guide sample program", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
'connect to the FTP server
hConnection = InternetConnect(hOpen, "your ftp server", INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0)
'create a buffer to store the original directory
sOrgPath = String(MAX_PATH, 0)
'get the directory
FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath)
'create a new directory 'testing'
FtpCreateDirectory hConnection, "testing"
'set the current directory to 'root/testing'
FtpSetCurrentDirectory hConnection, "testing"
'upload the file 'test.htm'
FtpPutFile hConnection, "C:\test.htm", "test.htm", FTP_TRANSFER_TYPE_UNKNOWN, 0
're**** 'test.htm' to 'apiguide.htm'
FtpRe****File hConnection, "test.htm", "apiguide.htm"
'enumerate the file list from the current directory ('root/testing')
EnumFiles hConnection
'retrieve the file from the FTP server
FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0
'delete the file from the FTP server
FtpDeleteFile hConnection, "apiguide.htm"
'set the current directory back to the root
FtpSetCurrentDirectory hConnection, sOrgPath
'remove the direcrtory 'testing'
FtpRemoveDirectory hConnection, "testing"
'close the FTP connection
InternetCloseHandle hConnection
'close the internet connection
InternetCloseHandle hOpen
End Sub
Public Sub EnumFiles(hConnection As Long)
Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long
'set the graphics mode to persistent
Me.AutoRedraw = True
'create a buffer
pData.cFile**** = String(MAX_PATH, 0)
'find the first file
hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
'if there's no file, then exit sub
If hFind = 0 Then Exit Sub
'show the file****
Me.Print Left(pData.cFile****, InStr(1, pData.cFile****, String(1, 0), vbBinaryCompare) - 1)
Do
'create a buffer
pData.cFile**** = String(MAX_PATH, 0)
'find the next file
lRet = InternetFindNextFile(hFind, pData)
'if there's no next file, exit do
If lRet = 0 Then Exit Do
'show the file****
Me.Print Left(pData.cFile****, InStr(1, pData.cFile****, String(1, 0), vbBinaryCompare) - 1)
Loop
'close the search handle
InternetCloseHandle hFind
End Sub
Sub ShowError()
Dim lErr As Long, sErr As String, lenBuf As Long
'get the required buffer size
InternetGetLastResponseInfo lErr, sErr, lenBuf
'create a buffer
sErr = String(lenBuf, 0)
'retrieve the last respons info
InternetGetLastResponseInfo lErr, sErr, lenBuf
'show the last response info
MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical
End Sub
**************************************************

تابع

التأكد من وجود ملف
كود:
Private Sub Command1_Click()
On Error GoTo Error:
Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1
Close
MsgBox ("الملف موجود")
Exit Sub
Error:
MsgBox ("الملف غير موجود")
End Sub
************************************************** ***
معرفة حجم الملف بالبايت
كود:
Private Sub Command1_Click()
Print FileLen("c:\Autoexec.bat")
End Sub
************************************************** ***
معرفة الوقت الذي مضى على تشغيل الويندوز بالدقيقة
كود:
Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub
************************************************** ***

لتشغيل ملف من نوع mdi
كود:
Private Sub Form_Load()
MMControl1.Visible = False
MMControl1.DeviceType = "sequencer"
MMControl1.File**** = ("c:\File****.mid")
MMControl1.Command = "open"
MMControl1.Command = "play"
End Sub
************************************************** ***

تشغيل ملف فيديو في Picture.
كود:
Private Sub Form_Load()
MMControl1.File**** = ("c:\File****.dat")
MMControl1.Command = "open"
MMControl1.hWndDisplay = Picture1.hWnd
End Sub
************************************************** ***
حذف أي ملف
كود:
Private Sub Command1_Click()
Kill ("C:\File****.fnm")
End Sub
************************************************** ***

إنشاء ملف جديد
كود:
Private Sub Command1_Click()
open "c:\File****.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 = Left(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:\File****.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 ****** 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_MouseMove(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 Slide******(frmSlide As Form, iSpeed As Integer)
While frmSlide.Left + frmSlide.Width < Screen.Width
DoEvents
frmSlide.Left = frmSlide.Left + 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 Slide******(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
lpSecurityDe******or As Long
bInheritHandle As Boolean
End Type
Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPath**** 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.lpSecurityDe******or = 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 = Left(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
Left 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.Left
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 lpRootPath**** As String, ByVal lpVolume**** 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
.RightToLeft = True
.Alignment = 2
.Width = 2000
.Text = "السلام عليكم"
.Top = 2000
.Left = 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
.Left = 1000
End With
End Sub
************************************************** *****
معرفة مسار مجلدي الويندوز، والسيستيم، ومعرفة اسم المستخدم

كود:
Option Explicit
Private Declare Function Get******sDirectory Lib "kernel32" Alias

"Get******sDirectoryA" (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 GetUser**** Lib "advapi32.dll" Alias "GetUser****A" (ByVal lpBuffer As String, nSize As Long) As Long

Private Sub Form_Load()
Dim W
Dim ******sD As String
******sD = Space(144)
W = Get******sDirectory(******sD, 144)
Text1.Text = ******sD

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 = GetUser****(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 **** :", "تحياتي")
End If

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

صهر الشاشة
كود:
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
************************************************** *********
عمل نموذج شفاف
كود:
Private Declare Function SetLayered******Attributes Lib "user32.dll" (ByVal hwnd As Long, ByValcrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Private Declare Function Set******Long Lib "user32" Alias "Set******LongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function Get******Long Lib "user32" Alias "Get******LongA" (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()
Set******Long hwnd, GWL_EXSTYLE, Get******Long(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayered******Attributes 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()
**** "c:\Autoexec.bat" As "D:\Autoexec.bat"
End Sub
************************************************** *******

جعل الفورم في المقدمة
كود:
Private Declare Function Set******Pos 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_NOMOVE = 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 = Set******Pos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
Else
lR = Set******Pos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE 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 GetActive****** Lib "user32" () As Long
Private Declare Function Get******DC 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 Get******DC(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 ******s 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 = "******s 32s "
Case 1
PId = "******s 95/98"
Case 2
PId = "******s NT "
End Select
Print "OS: " + PId
Print "Win version:" + str$(OSInfo.dwMajorVersion) + "." + LTrim(str(OSInfo.dwMinorVersion))
Print "Build: " + str(OSInfo.dwBuildNumber)
End Sub