أهم الأكواد في الفيجول بيسك 2003

#1 (**permalink**) 14-12-2006, 10:52 AM

أهم الأكواد في الفيجول بيسك 2003

كود توليد الأرقام العشوائية

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Label4.Visible = False
PictureBox1.Visible = False
Label1.Text = CStr(Int(Rnd() * 10))
Label2.Text = CStr(Int(Rnd() * 10))
Label3.Text = CStr(Int(Rnd() * 10))
If (Label1.Text = "7") Or (Label2.Text = "7") Or (Label3.Text = "7") Then
PictureBox1.Visible = True
Label4.Visible = True

End If

End Sub

كود توليد الألوان بطريقة عشوائية

Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
ProgressBar1.Value += 1
Dim a As String
Dim i As Integer
a = CStr(Int(Rnd() * 100))
Label1.BackColor = Color.FromArgb(100, 150, (a))

i = Val(a)
Me.BackColor = Color.FromArgb(i, 100, 0)
If ProgressBar1.Value = ProgressBar1.Maximum Then
End
End If
End Sub

كود توليد الألوان بحلقات التكرار

Private Sub Label2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Label2.Click
Dim x As Integer
Dim k As Integer
For x = 0 To 250
Label1.BackColor = Color.FromArgb(100, 150, x)
Me.BackColor = Color.FromArgb(250, 50, x)
MyBase.Refresh()
For k = 1 To 1000000

Next k
Next x
End Sub

كود عمل نص متحرك على الشاشة

Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
If Label1.Left > Form1.ActiveForm.Width Then Label1.Left = -50
Label1.Left = Label1.Left + 5

End Sub

فتح مستندات html :-

Dim explorer as SHDocvw.internet explorer
Explorer= new SHDocvw.internet explorer
Explorer.visible = true
Explorer.navigate (" مسار الموقع ")

تغيير شفافية الشاشة

Private Sub VScrollBar1_Scroll(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ScrollEventArgs) Handles VScrollBar1.Scroll
Label2.Text = Val(VScrollBar1.Value) / 100
Me.Opacity = Label2.Text
End Sub

إعادة تشغيل النظام

Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4

Private Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved _
As Long) As Long

Private Sub Form_Load()
t& = ExitWindowsEx(EWX_FORCE Or EWX_REBOOT, 0)
End Subs

#2 (**permalink**) 14-12-2006, 11:01 AM

إفراغ سلة المحذوفات

Const SHERB_NOCONFIRMATION = &H1
Const SHERB_NOPROGRESSUI = &H2
Const SHERB_NOSOUND = &H4
Private Type ULARGE_INTEGER
LowPart As Long
HighPart As Long
End Type
Private Type SHQUERYRBINFO
cbSize As Long
i64Size As ULARGE_INTEGER
i64NumItems As ULARGE_INTEGER
End Type
Private Declare Function SHEmptyRecycleBin Lib "shell32.dll" Alias "SHEmptyRecycleBinA" (ByVal hwnd As Long, ByVal pszRootPath As String, ByVal dwFlags As Long) As Long
Private Declare Function SHUpdateRecycleBinIcon Lib "shell32.dll" () As Long
Private Declare Function SHQueryRecycleBin Lib "shell32.dll" Alias "SHQueryRecycleBinA" (ByVal pszRootPath As String, pSHQueryRBInfo As SHQUERYRBINFO) As Long
Private Sub Form_Load()
'KPD-Team 2000
'URL: [فقط الأعضاء المسجلين يمكنهم رؤية الروابط. ]
'E-Mail: [فقط الأعضاء المسجلين يمكنهم رؤية الروابط. ]
Dim RBinInfo As SHQUERYRBINFO, Msg As VbMsgBoxResult
RBinInfo.cbSize = Len(RBinInfo)
SHQueryRecycleBin vbNullString, RBinInfo
If (RBinInfo.i64Size.LowPart And &H80000000) = &H80000000 Or RBinInfo.i64Size.HighPart > 0 Then
Msg = MsgBox("Your Recycle Bin consumes over 2 gigabytes right now!" + vbCrLf + "Do you want to empty it?", vbYesNo + vbQuestion)
Else
Msg = MsgBox("Your Recycle Bin consumes" + Str$(RBinInfo.i64Size.LowPart) + " bytes right now." + vbCrLf + "Do you want to empty it?", vbYesNo + vbQuestion)
End If
If Msg = vbYes Then
SHEmptyRecycleBin Me.hwnd, vbNullString, 0
SHUpdateRecycleBinIcon
End If
End Sub

tempمسار مجلد ال

' في موديول

Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

' في الفورم

Public Function TheTempDir() As String
Dim lpBuffer As String
Dim TempPath As Long
lpBuffer = Space(255)
TempPath = GetTempPath(255, lpBuffer)
TheTempDir = Left(lpBuffer, TempPath)
End Function
Private Sub Command1_Click()
Text1.Text = TheTempDir
End Sub

انشاء مسار

Private Declare Function SHCreateDirectoryEx Lib "shell32" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal psa As Any) As Long
Private Sub Form_Load()
'KPD-Team 2000
'URL: [فقط الأعضاء المسجلين يمكنهم رؤية الروابط. ]
'E-Mail: [فقط الأعضاء المسجلين يمكنهم رؤية الروابط. ]
'create the directory 'c:\test\dir\hello\something\apiguide\'
SHCreateDirectoryEx Me.hwnd, "c:\test\dir\hello\something\apiguide\", ByVal 0&
End Sub

لمعرفة حجم مجلد معين

Private 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 FindFirstFile Lib "kernel32" _
Alias "FindFirstFileA" (ByVal lpFileName As String, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindNextFile Lib "kernel32" _
Alias "FindNextFileA" (ByVal hFindFile As Long, _
lpFindFileData As WIN32_FIND_DATA) As Long

Private Declare Function FindClose Lib "kernel32" _
(ByVal hFindFile As Long) As Long

'Insert the following code to your form:

Private Function SizeOf(ByVal DirPath As String) As Double
Dim hFind As Long
Dim fdata As WIN32_FIND_DATA
Dim dblSize As Double
Dim sName As String
Dim x As Long
On Error Resume Next
x = GetAttr(DirPath)
If Err Then SizeOf = 0: Exit Function
If (x And vbDirectory) = vbDirectory Then
dblSize = 0
Err.Clear
sName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)
If Err.Number = 0 Then
hFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)
If hFind = 0 Then Exit Function
Do
If (fdata.dwFileAttributes And vbDirectory) = vbDirectory Then
sName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)
If sName <> "." And sName <> ".." Then
dblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)
End If
Else
dblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLow
End If
DoEvents
Loop While FindNextFile(hFind, fdata) <> 0
hFind = FindClose(hFind)
End If
Else
On Error Resume Next
dblSize = FileLen(DirPath)
End If
SizeOf = dblSize
End Function

Private Function EndSlash(ByVal PathIn As String) As String
If Right$(PathIn, 1) = "\" Then
EndSlash = PathIn
Else
EndSlash = PathIn & "\"
End If
End Function

Private Sub Form_Load()
'Replace 'c:\windows' with the directory name that you want to get its size.
MsgBox SizeOf("c:\windows")
End Sub

تغيير خلفية الشاشة

private Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam _
As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_UPDATEINIFILE = &H1
Const SPIF_SENDWININICHANGE = &H2

'===================================

ولتغيير خلفية سطح المكتب قم باستخدام الكود التالي باعتبار ان
المتغير File_Name يحمل اسم ومسار الصورة المراد وضعها كخلفية لسطح المكتب :

'====================================

Dim File_Name As String
Dim X As Long
File_Name = "c:\windows\setup.bmp"
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, File_Name, _
SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE)
+++++

===================================='

أما اذا اردت ان تجعل سطح المكتب بدون خلفية .. استخدم الكود التالي:

'===============================

Dim X As Long
X = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0&, "(None)", _
SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE

#3 (**permalink**) 14-12-2006, 02:54 PM

الله يزيدك معرفة رئااام

شاكرلك من كل قلبي

دام عطاؤك المتميز

#4 (**permalink**) 16-12-2006, 03:05 AM

الغالى

رمش الشووق

أول شمعة أنارت صفحتي
وأول حرف تجري فوق سطوري
كل الشكر لــــك

رمش الشوووق

دوما حضورك مميز اين ماكنت

عسانا مانفقدك يالغالي

تقبل منى فائق إحترامي وتقديري

مع باقة ورد

#5 (**permalink**) 16-12-2006, 12:28 PM

رئام مشكوره على هالمجهود الجبار والمتميز

تقبلي وجودي

نادر الوجود

#6 (**permalink**) 19-12-2006, 04:55 AM

المشاركة الأصلية كتبت بواسطة نادر الوجود


	رئام مشكوره على هالمجهود الجبار والمتميز تقبلي وجودي نادر الوجود

اخى الكريم

نادر الوجود

التميز بطلتك وحضورك

يعطيك ربي الف عافيه

#7 (**permalink**) 19-12-2006, 05:02 AM

رئام

رائعه

تقبلي مروري ومزيداً من التميز

#8 (**permalink**) 19-12-2006, 12:39 PM

المشاركة الأصلية كتبت بواسطة الاستشاري®


	رئام رائعه تقبلي مروري ومزيداً من التميز

اخى الكريم

الاستشاري

يعطيك ربي الف عافيه
على التواجد الرائع

الله لايحرمنا منك ولا من طلتك

أدوات الموضوع
مشاهدة صفحة طباعة الموضوع أرسل هذا الموضوع إلى صديق
طرق مشاهدة الموضوع
العرض العادي الانتقال إلى العرض المتطور الانتقال إلى العرض الشجري

أهم الأكواد في الفيجول بيسك 2003

برامج وتكنولوجيا