مكتبة اكواد فيجول بيسك | Visual Basic Codes " موضوع متجدد باستمرار"

يسمح لجميع الأعضاء بطرح كودات في هذا الموضوع ... ويفضل ان يرفق بشرح للكود


ملاحظه مهمة : لا يسمح بالردود التي لا تحتوي على اكواد فيجوال بيسك وسيكون الموضوع عبارة عن مكتبة لطرح الاكواد فقط لا غير وسوف يحذف اي رد بدون اكواد للفيجوال بيسك وشرحها .. بالتوفيق للجميع \ 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

كود افراغ حقول التكسـت

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

كــٍوٍدٍ لوضع الموقع في المفـضـله

في المديـل
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