لبناني وافتخر

1.اولا:اكواد عامه:0
--------------

1.كود لمعرفة الرقم التسلسلي للقرص الصلب:0(متميز)


كود:
'استخدام المكتبة Microsoft ******ing RuntimePrivate Sub Command1_Click()Dim obj_FSO As Object, obj_Drive As ObjectSet obj_FSO = CreateObject("******ing.FileSystemObject")Set obj_Drive = obj_FSO.GetDrive("c:\")MsgBox obj_Drive.SerialNumberSet obj_FSO = NothingSet obj_Drive = Nothing
End Sub



2.فتح cd -romواغلاقه
'ضع هذا الكود في الفورم


كود PHP:
[code][code]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[/CODE[/code]


]
في كوماند واحد


كود:
Private Sub Command1_Click()OpenCDDriveDoor (True)End Sub
وفي كوماند 2


كود:
Private Sub Command2_Click()OpenCDDriveDoor (False)End Sub


3.رسم دوائر ملونه باستخدام الماوس:0
ضع هذا الكود في الفورم

كود:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim i As Integeri = Rnd * 15If Button = 1 ThenMe.Circle (X, Y), 200, QBColor(i)End IfEnd Sub
وفي زر كوماند واحد


كود:
Private Sub Command1_Click()Form1.ClsEnd Sub


4.كود لعمل شورت كات للبرنامج:0(متميز)

كود:
Set wshshell = CreateObject("W******.shell")nStr = wshshell.specialfolders("Desktop")'(هذا بالنسبة للمكتب)set oshelllink = wshshell.createShortcut("nStr & "\MYPROGGR.lnk")oshelllink.Targetpath="c.....\prog .exe"oshelllink.hotkey = "ctrl+alt+c"oshelllink.iconlocation="c.....\pro.ic o"oshelllink.de******ion="........"oshelllink.s ave
اسبدل فقط desktop ب Startup لتجعل برنامجك في البداية او
Start Menu
او Programs



5.تشغيل حافظة الشاشة screen saverمتميز)

ضع الكود التالي في الفورم


كود:
Private Const WM_SYSCOMMAND = &H112&Private Const SC_SCREENSAVE = &HF140&Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
والتالي في كوماند 1


كود:
Private Sub Command1_Click()Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)End Sub


6.كود لفتح صورة معينه:0
ضع الكود التالي في الفورم

كود:
Picture1.Picture = LoadPicture("اكتب مسار الصوره .الامتداد")


7.طباعة نص:0ضع الكود التالي في الفورم
كود:
Private Sub Command1_Click()Printer.Print text1.textEnd Sub




ثانيا:اكواد الحمايه:0
----------------

1.منع تشغيل البرنامج اكثر من مرة:0(متميز)
ضع هذا الكود في الفورم


كود:
Private Sub Form_Load() If App.PrevInstance = True Then MsgBox "لا يمكن تشغيل البرنامج اكثر من مرة" Unload Me Exit Sub End If End Sub


2.فورم MDI + PictureBox

كود:
Private Sub MDIForm_Load() Picture1.Picture = LoadPicture("مكان الملف.الامتداد")End SubPrivate Sub MDIForm_Resize() Picture1.Move 0, 0, Me.*****, Me.HeightEnd Sub

3.حصر الماوس داخل نطاق معين:0

ضع الكود التالي في الفورم


كود:
Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)Private Type RECTLeft As IntegerTop As IntegerRight As IntegerBottom As IntegerEnd TypePrivate Type POINTX As LongY As LongEnd TypePrivate Sub Command1_Click()Dim Client As RECTDim Up As POINTClientToScreen Me.hwnd, UpGetClientRect Me.hwnd, ClientOffsetRect Client, Up.X, Up.YUp.X = Client.LeftUp.Y = Client.TopClipCursor ClientEnd SubPrivate Sub Command2_Click() ClipCursor ByVal 0&End Sub

4.جعل ال TextBox لا يقبل الا ارقام عشرية


هذا الكود يجعل ال TextBox لا يقبل الا أرقام عشرية و يتم و ضعه في الحدث KeyPress



if(Char.IsNumber(e.KeyChar) || e.KeyChar = = (char)8 || (e.KeyChar = = ' . ' & ((TextBox)sender).Text.IndexOf( ' . ' ) < 0))
{
e.Handled = false;
}
else e.Handled = true;



-----------------------------------------------------

اكواد :ahmed ksnv
.لمعرفة حجم مجلد معين:0


كود:
Private Const MAX_PATH = 260Private Type FILETIMEdwLowDateTime As LongdwHighDateTime As LongEnd TypePrivate Type WIN32_FIND_DATAdwFileAttributes As LongftCreationTime As FILETIMEftLastAccessTime As FILETIMEftLastWriteTime As FILETIMEnFileSizeHigh As LongnFileSizeLow As LongdwReserved0 As LongdwReserved1 As LongcFileName As String * MAX_PATHcAlternate As String * 14End TypePrivate Declare Function FindFirstFile Lib "kernel32" _Alias "FindFirstFileA" (ByVal lpFileName As String, _lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindNextFile Lib "kernel32" _Alias "FindNextFileA" (ByVal hFindFile As Long, _lpFindFileData As WIN32_FIND_DATA) As LongPrivate 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 DoubleDim hFind As LongDim fdata As WIN32_FIND_DATADim dblSize As DoubleDim sName As StringDim x As LongOn Error Resume Nextx = GetAttr(DirPath)If Err Then SizeOf = 0: Exit FunctionIf (x And vbDirectory) = vbDirectory ThendblSize = 0Err.ClearsName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)If Err.Number = 0 ThenhFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)If hFind = 0 Then Exit FunctionDoIf (fdata.dwFileAttributes And vbDirectory) = vbDirectory ThensName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)If sName <> "." And sName <> ".." ThendblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)End IfElsedblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLowEnd IfDoEventsLoop While FindNextFile(hFind, fdata) <> 0hFind = FindClose(hFind)End IfElseOn Error Resume NextdblSize = FileLen(DirPath)End IfSizeOf = dblSizeEnd FunctionPrivate Function EndSlash(ByVal PathIn As String) As StringIf Right$(PathIn, 1) = "\" ThenEndSlash = PathInElseEndSlash = PathIn & "\"End IfEnd FunctionPrivate Sub Form_Load()'Replace 'c:\windows' with the directory name that you want to get its size.MsgBox SizeOf("c:\windows")End Sub
2.تحديد نوع نظام الملفات لأي قسم من القرص

كود:
Private Declare Function GetVolumeInformation Lib _"kernel32.dll" Alias "GetVolumeInformationA" _(ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _ByVal lpFileSystemNameBuffer As String, _ByVal nFileSystemNameSize As Long) As LongPrivate Function FileSystem(ByVal Drive As String) As StringDim lAns As LongDim lRet As LongDim sVolumeName As String, sDriveType As StringDim sDrive As StringDim iPos As IntegersDrive = DriveIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End IfsVolumeName = String$(255, Chr$(0))sDriveType = String$(255, Chr$(0))lRet = GetVolumeInformation(sDrive, sVolumeName, _255, lAns, 0, 0, sDriveType, 255)iPos = InStr(sDriveType, Chr$(0))If iPos > 0 Then sDriveType = Left(sDriveType, iPos - 1)FileSystem = sDriveTypeEnd FunctionPrivate Sub Form_Load()MsgBox "The file system of drive c: is: " & FileSystem("c:")End Sub

3.النسخ الاحتياطي للبيانات


كود:
Private Sub CMDmak_Click() 'MkDir "D:\BACKUP" 'MkDir "D:\BACKUP\SITRAWI" End Sub 'لنسخ الملفPrivate Sub CMDBAK_Click() SOURCE = "D:\hus\Aig.bmp" dESTN = "D:\BACKUP\SITRAWI\AIG.BMp" FileCopy SOURCE, dESTN End Sub 4.دالة MoveFile لنقل ملف كود:
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As LongPrivate Sub Command1_Click()MoveFile "c:\my ********s\a.txt", "c:\a.txt"End Sub

5.دوال التعامل مع الملفات


كود:
الدالة FileLen : تعود هذه الدالة بقيمه تمثل حجم الملف بالبايت وتأخذ الصورة التالية code: ss = FileLen("c:\TafTaf.txt")MsgBox ss & " Byte"الدالة FileDateTime : وتعطي لك هذه الدالة معلومات عن وقت وتاريخ إنشاء الملف وتأخذ الصورة التالية :code: ss = FileDateTime("c:\TafTaf.txt")MsgBox ssالدالة LOF : وهذه الدالة قريبة الشبه بالدالة FileLen ولكن الاختلاف بينهم أن هذه الدالة تعود بقيمه تمثل حجم الملفات المفتوحة بتمرير رقم للملف المفتوح وتأخذ الصورة التالية :code: Open "C:\TafTaf.txt" For Binary As #1MsgBox LOF(1) & " Byte"Close 1الدالة LOC : تعيد هذه الدالة موقع مؤشر القراءة والكتابة في الملف المفتوح وتأخذ الصورة التالية :code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Loc (1)Line Input #1, ssMsgBox ssClose #1الدالة EOF : تعود هذه الدالة بقيمة منطقية تبين ما إذا قد تم الوصول لنهاية الملف أم لا (False - True ) وتأخذ الصورة التالية : code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Do While Not EOF(1(Line Input #1, ssText1.Text = Text1.Text & vbNewLine & ssLoopClose #1الدالة GetAttr : : تمكنك هذه الدالة من معرفة خصائص الملف File Attributes وتأخذ الصورة التالية : code: If GetAttr("c:\TafTaf.txt") = vbNormal ThenMsgBox "الملف غير مخفي"ElseMsgBox "الملف مخفي"End Ifالدالة SetAttr : وهذه الدالة تمكنك من تغير خصائص الملفات شرط أساسي أن يكون الملف غير مفتوح وتأخذ الصورة التالية : code: SetAttr ("c:\TafTaf.txt"), vbHiddenالدالة FreeFile : تعود هذه الدالة برقم غير محجوز ( رقم حر غير مستخدم ) لفتح الملف وتأخذ الصورة التالية : code: MyFree = FreeFileOpen "c:\TafTaf.txt" For Input As #MyFreeMsgBox MyFreeClose #MyFreeالدالة Seek : تعمل هذه الدالة علي تغير موقع مؤشر القراءة والكتابة في الملف وتأخذ الصورة التالية :code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Seek #1, 20Line Input #1, ssMsgBox ssClose #1الدالة SavePicture : تعمل هذه الدالة علي حفظ الصورة إلى ملف خارجي بأي امتداد تريده ومن أي أداة يمكنها احتواء صورة بداخلها وتأخذ الشكل التالي :code: SavePicture Picture1.Picture, "C:\TafTaf.bmp"الدالة LoadPicture : تعمل هذه الدالة علي ( تحميل ) الصورة من مكان تحدده أنت أو من الممكن ( تحميل ) الصورة تابعة لكائن وتأخذ الصورة التالية :code: Picture1.Picture = LoadPicture("c:\TafTaf.bmp")

5.التأكد من وجود ملف



كود:
Private Sub Command1_Click()On Error GoTo Error:Open "ضع مسار الملف هنا" For Input As #1CloseMsgBox ("الملف موجود")Exit SubError:MsgBox ("الملف غير موجود")End Subكود آخرIf Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then Msgbox "الملف غير موجود" Else Msgbox "الملف موجود" End If

6.تغيير خصائص ملف



كود:
Private Sub COMMAND1_CLICK()SetAttr "C:\data.txt", vbHiddenSetAttr "C:\data.txt", vbReadOnlySetAttr "C:\data.txt", vbArchiveEnd Sub


7.ارسال ملف الى سلة المحذوفات



كود:
Private Type SHFILEOPSTRUCThwnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As LonghNameMappings As LonglpszProgressTitle As LongEnd TypePrivate Declare Function SHFileOperation Lib _"shell32.dll" Alias "SHFileOperationA" (lpFileOp _As SHFILEOPSTRUCT) As LongPrivate Const FO_DELETE = &H3Private Const FOF_ALLOWUNDO = &H40Private Sub Command1_Click()Dim SHop As SHFILEOPSTRUCTDim strFile As StringstrFile = "C:\autoexec.bat"With SHop.wFunc = FO_DELETE.pFrom = strFile.fFlags = FOF_ALLOWUNDOEnd WithSHFileOperation SHopEnd Sub

اود ان اقدم لكم اكبر مجموعه من الاكواد ستكون متجدده يوميا (ارجو التثبيت)
ارجو من المشرف انا ضفت 3 اكواد للتجربه لو ثبت الموضوع ساكمل الاكواد
الكود المهم ساكتب عليه متميز
1.اولا:اكواد عامه:0
--------------

1.كود لمعرفة الرقم التسلسلي للقرص الصلب:0(متميز)


كود:
'استخدام المكتبة Microsoft ******ing RuntimePrivate Sub Command1_Click()Dim obj_FSO As Object, obj_Drive As ObjectSet obj_FSO = CreateObject("******ing.FileSystemObject")Set obj_Drive = obj_FSO.GetDrive("c:\")MsgBox obj_Drive.SerialNumberSet obj_FSO = NothingSet obj_Drive = Nothing
End Sub



2.فتح cd -romواغلاقه
'ضع هذا الكود في الفورم


كود PHP:
[code][code]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[/CODE[/code]


]
في كوماند واحد


كود:
Private Sub Command1_Click()OpenCDDriveDoor (True)End Sub
وفي كوماند 2


كود:
Private Sub Command2_Click()OpenCDDriveDoor (False)End Sub


3.رسم دوائر ملونه باستخدام الماوس:0
ضع هذا الكود في الفورم

كود:
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)Dim i As Integeri = Rnd * 15If Button = 1 ThenMe.Circle (X, Y), 200, QBColor(i)End IfEnd Sub
وفي زر كوماند واحد


كود:
Private Sub Command1_Click()Form1.ClsEnd Sub


4.كود لعمل شورت كات للبرنامج:0(متميز)

كود:
Set wshshell = CreateObject("W******.shell")nStr = wshshell.specialfolders("Desktop")'(هذا بالنسبة للمكتب)set oshelllink = wshshell.createShortcut("nStr & "\MYPROGGR.lnk")oshelllink.Targetpath="c.....\prog .exe"oshelllink.hotkey = "ctrl+alt+c"oshelllink.iconlocation="c.....\pro.ic o"oshelllink.de******ion="........"oshelllink.s ave
اسبدل فقط desktop ب Startup لتجعل برنامجك في البداية او
Start Menu
او Programs



5.تشغيل حافظة الشاشة screen saverمتميز)

ضع الكود التالي في الفورم


كود:
Private Const WM_SYSCOMMAND = &H112&Private Const SC_SCREENSAVE = &HF140&Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
والتالي في كوماند 1


كود:
Private Sub Command1_Click()Call SendMessage(Me.hwnd, WM_SYSCOMMAND, SC_SCREENSAVE, 0)End Sub


6.كود لفتح صورة معينه:0
ضع الكود التالي في الفورم

كود:
Picture1.Picture = LoadPicture("اكتب مسار الصوره .الامتداد")


7.طباعة نص:0ضع الكود التالي في الفورم
كود:
Private Sub Command1_Click()Printer.Print text1.textEnd Sub




ثانيا:اكواد الحمايه:0
----------------

1.منع تشغيل البرنامج اكثر من مرة:0(متميز)
ضع هذا الكود في الفورم


كود:
Private Sub Form_Load() If App.PrevInstance = True Then MsgBox "لا يمكن تشغيل البرنامج اكثر من مرة" Unload Me Exit Sub End If End Sub


2.فورم MDI + PictureBox

كود:
Private Sub MDIForm_Load() Picture1.Picture = LoadPicture("مكان الملف.الامتداد")End SubPrivate Sub MDIForm_Resize() Picture1.Move 0, 0, Me.*****, Me.HeightEnd Sub

3.حصر الماوس داخل نطاق معين:0

ضع الكود التالي في الفورم


كود:
Private Declare Sub ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINT)Private Declare Sub ClipCursor Lib "user32" (lpRect As Any)Private Declare Sub OffsetRect Lib "user32" (lpRect As RECT, ByVal X As Long, ByVal Y As Long)Private Declare Sub GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT)Private Type RECTLeft As IntegerTop As IntegerRight As IntegerBottom As IntegerEnd TypePrivate Type POINTX As LongY As LongEnd TypePrivate Sub Command1_Click()Dim Client As RECTDim Up As POINTClientToScreen Me.hwnd, UpGetClientRect Me.hwnd, ClientOffsetRect Client, Up.X, Up.YUp.X = Client.LeftUp.Y = Client.TopClipCursor ClientEnd SubPrivate Sub Command2_Click() ClipCursor ByVal 0&End Sub

4.جعل ال TextBox لا يقبل الا ارقام عشرية


هذا الكود يجعل ال TextBox لا يقبل الا أرقام عشرية و يتم و ضعه في الحدث KeyPress



if(Char.IsNumber(e.KeyChar) || e.KeyChar = = (char)8 || (e.KeyChar = = ' . ' & ((TextBox)sender).Text.IndexOf( ' . ' ) < 0))
{
e.Handled = false;
}
else e.Handled = true;



-----------------------------------------------------

اكواد :ahmed ksnv
.لمعرفة حجم مجلد معين:0


كود:
Private Const MAX_PATH = 260Private Type FILETIMEdwLowDateTime As LongdwHighDateTime As LongEnd TypePrivate Type WIN32_FIND_DATAdwFileAttributes As LongftCreationTime As FILETIMEftLastAccessTime As FILETIMEftLastWriteTime As FILETIMEnFileSizeHigh As LongnFileSizeLow As LongdwReserved0 As LongdwReserved1 As LongcFileName As String * MAX_PATHcAlternate As String * 14End TypePrivate Declare Function FindFirstFile Lib "kernel32" _Alias "FindFirstFileA" (ByVal lpFileName As String, _lpFindFileData As WIN32_FIND_DATA) As LongPrivate Declare Function FindNextFile Lib "kernel32" _Alias "FindNextFileA" (ByVal hFindFile As Long, _lpFindFileData As WIN32_FIND_DATA) As LongPrivate 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 DoubleDim hFind As LongDim fdata As WIN32_FIND_DATADim dblSize As DoubleDim sName As StringDim x As LongOn Error Resume Nextx = GetAttr(DirPath)If Err Then SizeOf = 0: Exit FunctionIf (x And vbDirectory) = vbDirectory ThendblSize = 0Err.ClearsName = Dir$(EndSlash(DirPath) & "*.*", vbSystem Or vbHidden Or vbDirectory)If Err.Number = 0 ThenhFind = FindFirstFile(EndSlash(DirPath) & "*.*", fdata)If hFind = 0 Then Exit FunctionDoIf (fdata.dwFileAttributes And vbDirectory) = vbDirectory ThensName = Left$(fdata.cFileName, InStr(fdata.cFileName, vbNullChar) - 1)If sName <> "." And sName <> ".." ThendblSize = dblSize + SizeOf(EndSlash(DirPath) & sName)End IfElsedblSize = dblSize + fdata.nFileSizeHigh * 65536 + fdata.nFileSizeLowEnd IfDoEventsLoop While FindNextFile(hFind, fdata) <> 0hFind = FindClose(hFind)End IfElseOn Error Resume NextdblSize = FileLen(DirPath)End IfSizeOf = dblSizeEnd FunctionPrivate Function EndSlash(ByVal PathIn As String) As StringIf Right$(PathIn, 1) = "\" ThenEndSlash = PathInElseEndSlash = PathIn & "\"End IfEnd FunctionPrivate Sub Form_Load()'Replace 'c:\windows' with the directory name that you want to get its size.MsgBox SizeOf("c:\windows")End Sub
2.تحديد نوع نظام الملفات لأي قسم من القرص

كود:
Private Declare Function GetVolumeInformation Lib _"kernel32.dll" Alias "GetVolumeInformationA" _(ByVal lpRootPathName As String, ByVal lpVolumeNameBuffer As String, _ByVal nVolumeNameSize As Integer, lpVolumeSerialNumber As Long, _lpMaximumComponentLength As Long, lpFileSystemFlags As Long, _ByVal lpFileSystemNameBuffer As String, _ByVal nFileSystemNameSize As Long) As LongPrivate Function FileSystem(ByVal Drive As String) As StringDim lAns As LongDim lRet As LongDim sVolumeName As String, sDriveType As StringDim sDrive As StringDim iPos As IntegersDrive = DriveIf Len(sDrive) = 1 ThensDrive = sDrive & ":\"ElseIf Len(sDrive) = 2 And Right(sDrive, 1) = ":" ThensDrive = sDrive & "\"End IfsVolumeName = String$(255, Chr$(0))sDriveType = String$(255, Chr$(0))lRet = GetVolumeInformation(sDrive, sVolumeName, _255, lAns, 0, 0, sDriveType, 255)iPos = InStr(sDriveType, Chr$(0))If iPos > 0 Then sDriveType = Left(sDriveType, iPos - 1)FileSystem = sDriveTypeEnd FunctionPrivate Sub Form_Load()MsgBox "The file system of drive c: is: " & FileSystem("c:")End Sub

3.النسخ الاحتياطي للبيانات


كود:
Private Sub CMDmak_Click() 'MkDir "D:\BACKUP" 'MkDir "D:\BACKUP\SITRAWI" End Sub 'لنسخ الملفPrivate Sub CMDBAK_Click() SOURCE = "D:\hus\Aig.bmp" dESTN = "D:\BACKUP\SITRAWI\AIG.BMp" FileCopy SOURCE, dESTN End Sub 4.دالة MoveFile لنقل ملف كود:
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As LongPrivate Sub Command1_Click()MoveFile "c:\my ********s\a.txt", "c:\a.txt"End Sub

5.دوال التعامل مع الملفات


كود:
الدالة FileLen : تعود هذه الدالة بقيمه تمثل حجم الملف بالبايت وتأخذ الصورة التالية code: ss = FileLen("c:\TafTaf.txt")MsgBox ss & " Byte"الدالة FileDateTime : وتعطي لك هذه الدالة معلومات عن وقت وتاريخ إنشاء الملف وتأخذ الصورة التالية :code: ss = FileDateTime("c:\TafTaf.txt")MsgBox ssالدالة LOF : وهذه الدالة قريبة الشبه بالدالة FileLen ولكن الاختلاف بينهم أن هذه الدالة تعود بقيمه تمثل حجم الملفات المفتوحة بتمرير رقم للملف المفتوح وتأخذ الصورة التالية :code: Open "C:\TafTaf.txt" For Binary As #1MsgBox LOF(1) & " Byte"Close 1الدالة LOC : تعيد هذه الدالة موقع مؤشر القراءة والكتابة في الملف المفتوح وتأخذ الصورة التالية :code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Loc (1)Line Input #1, ssMsgBox ssClose #1الدالة EOF : تعود هذه الدالة بقيمة منطقية تبين ما إذا قد تم الوصول لنهاية الملف أم لا (False - True ) وتأخذ الصورة التالية : code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Do While Not EOF(1(Line Input #1, ssText1.Text = Text1.Text & vbNewLine & ssLoopClose #1الدالة GetAttr : : تمكنك هذه الدالة من معرفة خصائص الملف File Attributes وتأخذ الصورة التالية : code: If GetAttr("c:\TafTaf.txt") = vbNormal ThenMsgBox "الملف غير مخفي"ElseMsgBox "الملف مخفي"End Ifالدالة SetAttr : وهذه الدالة تمكنك من تغير خصائص الملفات شرط أساسي أن يكون الملف غير مفتوح وتأخذ الصورة التالية : code: SetAttr ("c:\TafTaf.txt"), vbHiddenالدالة FreeFile : تعود هذه الدالة برقم غير محجوز ( رقم حر غير مستخدم ) لفتح الملف وتأخذ الصورة التالية : code: MyFree = FreeFileOpen "c:\TafTaf.txt" For Input As #MyFreeMsgBox MyFreeClose #MyFreeالدالة Seek : تعمل هذه الدالة علي تغير موقع مؤشر القراءة والكتابة في الملف وتأخذ الصورة التالية :code: Dim ssOpen "c:\TafTaf.txt" For Input As #1Seek #1, 20Line Input #1, ssMsgBox ssClose #1الدالة SavePicture : تعمل هذه الدالة علي حفظ الصورة إلى ملف خارجي بأي امتداد تريده ومن أي أداة يمكنها احتواء صورة بداخلها وتأخذ الشكل التالي :code: SavePicture Picture1.Picture, "C:\TafTaf.bmp"الدالة LoadPicture : تعمل هذه الدالة علي ( تحميل ) الصورة من مكان تحدده أنت أو من الممكن ( تحميل ) الصورة تابعة لكائن وتأخذ الصورة التالية :code: Picture1.Picture = LoadPicture("c:\TafTaf.bmp")

5.التأكد من وجود ملف



كود:
Private Sub Command1_Click()On Error GoTo Error:Open "ضع مسار الملف هنا" For Input As #1CloseMsgBox ("الملف موجود")Exit SubError:MsgBox ("الملف غير موجود")End Subكود آخرIf Dir("c:\test.txt", vbNormal or vbReadOnly or vbHidden or vbSystem or vbArchive) = "" then Msgbox "الملف غير موجود" Else Msgbox "الملف موجود" End If

6.تغيير خصائص ملف



كود:
Private Sub COMMAND1_CLICK()SetAttr "C:\data.txt", vbHiddenSetAttr "C:\data.txt", vbReadOnlySetAttr "C:\data.txt", vbArchiveEnd Sub


7.ارسال ملف الى سلة المحذوفات



كود:
Private Type SHFILEOPSTRUCThwnd As LongwFunc As LongpFrom As StringpTo As StringfFlags As IntegerfAnyOperationsAborted As LonghNameMappings As LonglpszProgressTitle As LongEnd TypePrivate Declare Function SHFileOperation Lib _"shell32.dll" Alias "SHFileOperationA" (lpFileOp _As SHFILEOPSTRUCT) As LongPrivate Const FO_DELETE = &H3Private Const FOF_ALLOWUNDO = &H40Private Sub Command1_Click()Dim SHop As SHFILEOPSTRUCTDim strFile As StringstrFile = "C:\autoexec.bat"With SHop.wFunc = FO_DELETE.pFrom = strFile.fFlags = FOF_ALLOWUNDOEnd WithSHFileOperation SHopEnd Sub

سهم القلوب

مشكووووووووووووووووووووووررر انا منزماااااااااان ابغي هذي الاكواد