Admin Admin
عدد المساهمات : 76 تاريخ التسجيل : 18/09/2009
| موضوع: مكتبة اكواد الفيجوال بيسيك الجزء الاول الأربعاء أكتوبر 07, 2009 7:06 am | |
| اقدم لكم مكتبة اكواد للغة الفيجوال بيسيك من العقرب الاسود السوري المكتبة عبارة عن 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 ************************************************** ********* والحمد لله رب العالمين ارجو المشاركة واللى اللقاء يالجزء الثاني | |
|