في انتظارك يوم 15 :):) وبالتوفيق (f)
أكواد للمبتدئين
مغلقاستطلاعرائج
محدش رد ليه معقول مفيش حد اسكندرانى هنا
أخي العزيز/عبد الله فتحي
السلام عليكم ورحمة الله وبركاته وبعد:
أولا: اشكرك على هذا الموضوع الممتاز. وجزاك الله خيرا علىيه.
وثانيا: أنك قلت سوف تنقطع عنا إلى تاريخ 15/6/2003م . ولم تقول إن شاء الله. حيث كل شيء بمشئة الله عز وجل.
وثالثا: أتمنى لك التوفيق. في دراستك. والسلام عليكم.
أخوك/الساكت1
(f)الكود الحادي والسبعون(f)
معرفة نوع القرص (قرص مرن، صلب، سي دي روم ... الخ)
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
(f)الكود الثاني والسبعون(f)
لمعرفة معلومات عن القرص [مساحته، المستخدم، المتبقي ...الخ]
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 Text1.Text = drv 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
(f)الكود الثالث والسبعون(f)
لإبطال مفعول زر X في النافذة :
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Cancel = True End Sub
(f)الكود الرابع والسبعون(f)
للتحكم في حركة الماوس
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 left 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
(f)الكود الخامس والسبعون(f)
لتغميق وتفتيح الصورة بشكل رائع
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(f)الكود السادس والسبعون(f)
معرفة اللون الذي يمر عليه الماوس
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(f)الكود السابع والسبعون(f)
لمعرفة اسم الكمبيوتر
Private Const MAX_COMPUTERNAME_LENGTH As Long = 31 Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (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_COMPUTERNAME_LENGTH + 1 strString = String(dwLen, "X") 'Get the computer name GetComputerName strString, dwLen 'get only the actual data strString = Left(strString, dwLen) 'Show the computer name MsgBox strString End Sub
(f)الكود الثامن والسبعون(f)
للاتصال من خلال الكود
Private Sub Command1_Click() Dim PhoneNumber As String On Error GoTo WrongPort MSComm1.CommPort = 3 'قم بتغيير البورت من 1 إلى 8 حتى تصل إلى البورت الصحيح MSComm1.Settings = "300,n,8,1" PhoneNumber = "164883" 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
(f)الكود التاسع والسبعون(f)
لفتح الفورم بشكل رائع
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
(f)الكود الثمانون(f)
تحريك الكلام في عنوان الفورم ومربع النص
Private strText As String Private Sub Form_Load() Timer1.Interval = 75 strText = "Guten Tag! Wie ght's Ihnen? Ich hoffe Ihnen alles Gutes!" strText = Space(50) & strText End Sub Private Sub Timer1_Timer() strText = Mid(strText, 2) & Left(strText, 1) Text1.Text = strText Me.Caption = strText End Sub
(f)الكود الحادي والثمانون(f)
تغيير لون النص بشكل مستمر
Private Sub Timer1_Timer() Static Col1, Col2, Col3 As Integer Static c1, C2, C3 As Integer If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) _ And (Col3 = 0 Or Col3 = 250) Then c1 = Int(Rnd * 3) C2 = Int(Rnd * 3) C3 = Int(Rnd * 3) End If If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10 If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10 If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10 If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10 If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10 If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10 Label1.ForeColor = RGB(Col1, Col2, Col3) End Sub Private Sub Form_Load() Timer1.Interval = 100 End Sub
(f)الكود الثاني والثمانون(f)
تغيير لون الخلفية للنص
Private Sub Timer1_Timer() Static Col1, Col2, Col3 As Integer Static c1, C2, C3 As Integer If (Col1 = 0 Or Col1 = 250) And (Col2 = 0 Or Col2 = 250) _ And (Col3 = 0 Or Col3 = 250) Then c1 = Int(Rnd * 3) C2 = Int(Rnd * 3) C3 = Int(Rnd * 3) End If If c1 = 1 And Col1 <> 0 Then Col1 = Col1 - 10 If C2 = 1 And Col2 <> 0 Then Col2 = Col2 - 10 If C3 = 1 And Col3 <> 0 Then Col3 = Col3 - 10 If c1 = 2 And Col1 <> 250 Then Col1 = Col1 + 10 If C2 = 2 And Col2 <> 250 Then Col2 = Col2 + 10 If C3 = 2 And Col3 <> 250 Then Col3 = Col3 + 10 Label1.BackColor = RGB(Col1, Col2, Col3) End Sub
(f)الكود الثالث والثمانون(f)
كود جميل لجعل خلفية النص تومض
اجعل الإنترفال للتايمر 10
Private Sub Timer1_Timer() Static COL COL = COL + 10 If COL > 510 Then COL = 0 Label1.BackColor = RGB(Abs(COL - 255), 0, 0) Label2.BackColor = RGB(0, Abs(COL - 255), 0) Label3.BackColor = RGB(0, 0, Abs(COL - 255)) Label4.BackColor = RGB(Abs(COL - 0), 180, 180) Label5.BackColor = RGB(Abs(COL - 200), 30, 180) End Sub
(f)الكود الرابع والثمانون(f)
خلفية جميلة للفورم
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 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_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
(f)الكود الخامس والثمانون(f)
لإفراغ سلة المهملات
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 Sub Command1_Click() SHEmptyRecycleBin Me.hwnd, vbNullString, 0 SHUpdateRecycleBinIcon End Sub
(f)
السلام عليكم
الأخ الفاضل كاتب الموضوع...شكرا لك على هذه المشاركات الجميله جدا
انا مشترك جديد من مصر أم الدنيا
ROCKWELL21@HOTMAIL.COM أتمنى من الله عز وجل أن يوفقك
رجاء أخير وهام
من فضلك أربد أكواد الكوبى و الباست و الكت و الفوورود و الباك
أكون شاكرآ......................................................................
سؤال هل هذه الأكواد للفيجوال فقط؟
:)
الأخ العزيز MATRIXMAN(f) الأكواد المذكورة في هذا الموضوع هي للفيجول بيسيك فقط، وبالنسبة للأكواد التي تريدها، إن شاء الله في الطريق إليك.
هذا الموضوع مغلق.