نجوم المشاركات

Dim WMI As Object Dim wmiCollection As Object Dim wmiMember As Object Set WMI = GetObject("winmgmts:\\") Set wmiCollection = WMI.InstancesOf("Win32_PhysicalMedia") For Each wmiMember In wmiCollection MsgBox Trim(wmiMember.SerialNumber) Exit For Next Set wmiMember = Nothing Set wmiCollection = Nothing Set WMI = Nothing جرب ان تغيره

لي طلب هل ممكن ان ترسم لي التقريرات المطلوبة و تعطيني اسماء الجداول والحقول اللي لازم اخذ فيها المعلومات اي اسماء الحقول والجداول اللي لازم اعمل عليه تحياتي

نعم تقدر تستخدم واي شي تريد تكدر تعمل به لانه ذاك البيانات تخزن في الجدول هل تريد لكل مواد او مادة العربية فقط ؟

إخواني الأعزاء السلام عليكم ورحمة الله وبركاته برنامجي الصغير والسريع للحماية برقم القرص الصلب أهديه إلى إخواني المبرجين المبتدئين في عالم الأكسس ملحوظة : نموذج التسجيل لا يظهر إلا مرة واحدة عند بداية التسجيل ثم يختفي كل ما عليك هو استيراد نموذج التسجيل ونموذج الترحيب والجدول إلى برنامجك ( لا تنسى تعديل اسم النموذج الرئيسي داخل الكود والذي هو في المثال "QQ" وتستبدله باسم النموذج الرئيسي في برنامجك المعادلة : ( رقم التسجيل = رقم النسخة + 55 * 2 ) وبإمكانك التعديل داخل الكود كما تشاء أمل أن يحوز على القبول والرضا فلا تنسوني من صالح دعائكم . تقبلوا تحياتي ،،، حماية برقم القرص يظهر مرة واحدة.rar

ترقيم تلقائي يتجدد مع بداية كل سنة على النحو التالي 1300001 1300002 1300003 1400001 1400002 وهكذا ................. باعتبار الرقم 13 ، 14 هو السنة والترقيم لاشك سيكون تبعا للسنة الحالية Private Sub Form_BeforeInsert(Cancel As Integer) On Error Resume Next Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer prtyr = Right(DatePart("yyyy", Date), 2) prtTxt = Left(DMax("ID", "tbl1"), 2) xLast = DMax("ID", "tbl1", prtTxt = prtyr) If IsNull(xLast) Then xNext = 1 Else xNext = Val(Mid(xLast, 3, 5)) + 1 End If Me!ID = prtyr & Format(xNext, "00000") End Sub ترقيم تلقائي جديد كل سنة.rar

اخوة الافاضل جزاكم الله خيرا على جهدكم العظيم ورغبتكم في الافادة بعون الله بدات في تصميم برنامج لحسابات المقاولات ومش عارف هل سبقني احد في هذا ام لا المهم اني بدات ومحدد خطوات للعمل وتصور كامل واحب اتشارك معكم لو يحب احد يشارك في هذا العمل ليكون مشروع متكامل بدلا من ان اسال فقط عن الامور التي تقف امامي واستفيد وحدي جزاكم الله خيرا مرفق ملف به اول خطوة ومستعد للتواصل مع من يريد المساهمة مقاولات.rar

تفضل اخي الكريم اليك الملف التالي به المطلوب ان شاء الله نقبل خالص تحياتي فورم ادخال بيانات و ترحيل.rar

الكود غيير كالاتي Private Sub Form_Current() If DSum("[رياضيات]", "اسماء") = 0 Then [رياضيات].ColumnHidden = True Else [رياضيات].ColumnHidden = False End If End Sub

عجيب جدا ,, كل ما اضفت كلما تغير !! ولكني جربت كودا تفضل به اخونا شيفان هنا ويبدوا انه يأخذ رقم الهارد الحقيقي وليس القسم واضفته الى مرفقنا جرب ووافني بالنتيجة

تفضل اخي الكريم Private Sub CommandButton1_Click() With Sheet1.Range("a1") .Value = Me.TextBox1.Value .NumberFormat = "0.00" TextBox1.Text = Format(TextBox1, "0.00") End With End Sub واليك ملف كمثال كود لترحيل قي من التكست بوكس الى الخلية مع التنسيق المطلوب.rar

up

Private Sub Form_Current() If DSum("[رياضيات]", "اسماء") = 0 Then [رياضيات].ColumnWidth = 0 End If End Sub تحياتي

عفوا الان غير الكود كالاتي Dim MeMaxRec As Integer DoCmd.OpenForm "FORMS2", acNormal MeMaxRec = DMax("[costmor_no]", "tabol_costmor") Forms!FORMS2!costmor_no = MeMaxRec Forms!FORMS2!costmor_name = DLookup("[costmor_name]", "tabol_costmor", "[costmor_no]=" & MeMaxRec) Forms!FORMS2!addres_costm = DLookup("[addres_costm]", "tabol_costmor", "[costmor_no]=" & MeMaxRec) Forms!FORMS2!tel_costmor = DLookup("[tel_costmor]", "tabol_costmor", "[costmor_no]=" & MeMaxRec) DoCmd.Close acForm, "FORMS1", acSaveYes اتفضل مع القاعدة test.rar

تمام بانتظارك

اتفضل شوف الصورة مع استخدام جملة الشرطية اتفضل مع ملفك بعد عمل عليها تلوين السجلات.rar تحياتي

على الرغم ما افتهمت ما قصدك بالضبط هل تريد مسار البقاعدة بيانات الحالية مع اسم التقرير ام تريد شيء اخر تقدر تستخدم هذا الكود كمصدر لمربع نصي اللي باسم text في نموذج =[Application].[CurrentProject].[FullName] & "\X" هذا الجزء من الكود سيعطيك مسار القاعدة الحالية =[Application].[CurrentProject].[FullName] و حرف x هو اسم تقريرك في هذه القاعدة احنا اضفنا \ لكي يفرق بين اسم القاعدة و اسم التقرير تحياتي

ابدأ بالعمل و ان شاء الله كلنا راح نساعدك بقدر مستطاعنا لكن من الاول لازم عندك خطة لكي تعمل عليه ابدأ بعمل جداول و ابحث في المنتدى في اي شي تريد واذا ما رأيت احنا راح نساعدك خطوة بخطوة تحياتي

اتفضل استخدم هذا الكود خلف زر Me.costmor_no = DMax("[costmor_no]", "tabol_costmor") Me.costmor_name = DLookup("[costmor_name]", "tabol_costmor", "[costmor_no]=" & Me.costmor_no) Me.addres_costm = DLookup("[addres_costm]", "tabol_costmor", "[costmor_no]=" & Me.costmor_no) Me.tel_costmor = DLookup("[tel_costmor]", "tabol_costmor", "[costmor_no]=" & Me.costmor_no)

سؤال : وهل من المحتمل ان يكون كله سوى او اثنين معا اي يعني مبلغ من الرياض الى مكة + مبلغ من مكة الى المدينة او تختار واحد منه فقط

تمام الله يباركلك بسم الله ماشاء الله عليك تمام هزود المدة افضل من انى اضيف حقل جديد فى الرئيسى والف الف الف شكر لاهتمامك وردك العطر افدتنى كتير جدا ربنا يجعلة فى ميزان حسناتك امييين رجاء المساعدة الضرورية فى عمل اى شئ لعدم تكرار الاسم اثناء الادخال وعند مطابقة الاسم لاسم موجود فى الجدول تظهر رسالة تفيد بأن الاسم موجود تحت رقم مسلسل كذا بدون ازرار معاينة بمعنى انى عند الادخال مباشرة وعند التطابق تظهر الرسالة تفيد بان الاسم مسجل تحت رقم كذا مع تجاهل الهمزةوالتشكيل بكل انواعة انا كنت رفعت الموضوع دة فى سؤال منفصل بس بعد تحديث سيرفر الموقع الموضوع مش بيفتح خالص ممكن الرد علية هنا واحب اضيف ان فية احد الاعضاء الكرام خلص الجزيئة بتاعت عدم التكرار بس فاضل انة يتجاهل التشكيل والهمزة علشان الاسم ميتكررش وهى دى الجزئية اللى انا واقف عليها بس

وهذا نفس قصدى قمت بتعديل المشاركة Refresh

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

مبدئيا زد مدة الانتظار فى الاستعلام الأول الذى يحذف الفرعى مكان ٣٠ اجعلها ٣٢ بهذا يتم حذف الفرعى و الرئيسى بعد ٣٢ يوما أما ربط الحذف فى الرئيسى لأى زمن فهذا يستدعى وجود حقل تاريخ فى الجدول الرئيس يسجل فيه تاريخ حذف الفرعى يعنى قبل أن تحذف الفرعى تسجل تاريخ الحذف فى حقل فى الرئيسى لعله مفهوم إن شاء الله

تمام الله ينةر عليك بس مش ممكن الحذف للرئيسى يتاخر يومين 48 ساعة بعد حذف الفرعى

نعم استعلام حذف أى رقم عميل فى جدول DATA غير موجود فى جدول ORDER قاعدة بيانات1_2.rar

تفضل أخي التعديل على الملف و الشرح كالتالي: 1- عند الفتح مباشرة تظهر ملفات القرص e و عند الضغط المزدوج على المجلد تظهر ملفاته داخل مربع القائمة الثانية. 2- إذا كان الملف صورة فعند الضغط عليها تظهر في رقم 3 (صورة) استخراج اسماء الملفات الفرعية لمجلد.rar هل هذا ما تبحث عنه أستاذ عبد الفتاح

استاذنا @jjafferr دمتم بخير اينما كنت

اعمل كومبوبوكس وبواسطة موديول لجلب اسماء الطابعات خلي بيجيب اسماء الطابعات اللي على جهازك وقبل طباعة اختر من كومبوبوكس الطابعة اللي تريد ان تطبع

لانني احبك في الله استاذ حماده ...ارجو اشتراكك ايضا في http://laernoffice.com/vb/f7

السلام عليكم ورحمة الله وبركاته اخي ابو الاء القي نظرتا الى جدول ونموذج FRMTaqdir اسف لاني ما اكدرت اعمل لك استعلام جدولي كما تريد لكن بواسطة اكواد و الجدول والنموذج عطيتك ما تريد في اي حين تريد بس فتح نموذج واضغط على زر كشف التقديرات وشوف النتيجة اليك قاعدة بياناتك Copy of 027 (1).rar

السلام عليكم روحمة الله وبركاتة لو كنت حاب اعرض التقرير بالعرض لورقة A4 يعني القياسات 29 عرض 20 ارتفاع جربت اعملها وما ضبطت معي ممكن لو احد يعرف الطريقة يرفع مثال واكون له شاكر

اخي احمد ضع خلف زر فتح التقرير الكود التالي DoCmd.OpenReport "اسم التقرير", acViewPreview With Application.Reports("اسم التقرير").Printer .Orientation = acPRORLandscape End With

السلام عليكم اشكرك جزيلا أستاذ خالد على متابعة موضوعي وجزالك الله عنا كل خير

السلام عليكم مطلبوب ايقونه او ماكرو في برنامج اكسل يقوم بحفظ والخروج من الأكسل مرفق ملف اكسل عينه من المطلوب ولكم جزيل الشكر والعرفان WinRAR ZIP archive جديد ‫‬.zip

الوحدات النمطية : Public IsUserID As String ' اعلان عن متغير عام يأخذ قيمة المعرف داخل النماذج أو التقارير Public Function RelinkIspic() 'اعلان عن اسم الوحدة النمطية Dim i, x, r As String 'اعلان عن متغيرات نصية r = IsUserID 'المتغير هذا يساوي قيمة المعرف i = mID(CurrentDb.TableDefs("tblNames").Connect, 11) ' المتغير هذا يساوي المكان البعيد الذي تتواجد به قاعدة بيانات الجداول x = Left(i, InStrRev(i, "\")) & r & ".jpg" 'اسم الملف ونوعه في المكان البعيد RelinkIspic = x 'لا تحتاج شرح End Function'اغلاق '============================================================== Public Function RelinkIsshar() Dim i, x, r As String r = "shar" ' اسم الملف i = mID(CurrentDb.TableDefs("tblNames").Connect, 11) x = Left(i, InStrRev(i, "\")) & r & ".jpg" RelinkIsshar = x End Function كما نلاحظ الوحدتين النمطيتين طبق الاصل الاولى ترجع الملف بمعلومية متغير والثانية بمعلومية اسم الملف ويتم الاستدلال على المسار بواسطة الجدول المرتبط به البعيد وكل ما علينا عمله هو نداء الدالة RelinkIspic في الاول والدالة RelinkIsshar في الثاني والمثال المرفق سيوضح الطريقة بشكل عملي حيث يشتمل على : 1- الوحدة النمطية والكودات الخاصة بربط الجداول آليا عند تغيير مكان مجلد قاعدة الجداول 2- الوحدة النمطية الخاصة برفع الملفات واستبدالها ، وستلاحظون كيف وظفنا ()RelinkIspic داخلها 3- وحداتنا النمطية الخاصة بهذا الموضوع وعملها في عرض الملفات وتوجيه النسخة الاحتياطية بعد فك الضغط عن المرفقات وتشغيل الواجهات سيطالبك البرنامج بربط الجداول وهذا كل ما عليك فعله فقط . يمكنكم بعد التطبيق بنجاح نقل المجلد فقط وتغيير مكانه للتجربة ملحوظة : بسبب نظام وندوز قد يحتاج بعض اصدارات اكسس لتفقد المكتبات وتعديلها لا تنسون اخيكم من دعوة صالحة في ظهر الغيب . أسأل ربي الكريم ان يجزيني بكرمه وفضله . قراءة مسار الشبكة آليا وربط الجداول والنسخ الاحتياطي.rar

السلام عليكم ورحمه‌ الله وبركاته اخي الكريم كم مره‌ فتحت موضوعك وقرأت ونزلت المرفق لكن ما اعرف بالضبط ماتريد ممكن ترسم وتشرح ماتريد لعل وعسى اكدر اساعدك تحياتي

مجهود ممتاز ونتمنى الاعضاء يطلعوا عليه

ابدأ من هنا

osamaww اخي ممكن ترسل ايميلك نتواصل معاك اذا احتجنا اي سؤال

هذه المجموعة من الاكواد من تجميع ابو حمود -------------------------------------------------- — للبحث عن ملف : Set fs = Application.FileSearch With fs .LookIn = "C:\My Documents" .FileName = "DO.*" If .Execute > 0 Then MsgBox "There were " & .FoundFiles.Count & _ " file(s) found." For I = 1 To .FoundFiles.Count MsgBox .FoundFiles(I) Next I Else MsgBox "There were no files found." End If End With ولإعادة البحث : With Application.FileSearch If .Execute() > 0 Then MsgBox "There were " & .FoundFiles.Count & _ " file(s) found." For i = 1 To .FoundFiles.Count MsgBox .FoundFiles(i) Next i Else MsgBox "There were no files found." End If End With ولإعادة البحث مع تحديد معيار أكثر تفصيلاً : With Application.FileSearch .NewSearch .LookIn = "C:\My Documents" .SearchSubFolders = True .FileName = "Run" .MatchTextExactly = True .FileType = msoFileTypeAllFiles End With انظر التفصيلات في هذا المثال : With Application.FileSearch .NewSearch .LookIn = "C:\My Documents" .SearchSubFolders = True .FileName = "run" .TextOrProperty = "San*" .MatchAllWordForms = True .FileType = msoFileTypeAllFiles If .Execute() > 0 Then MsgBox "There were " & .FoundFiles.Count & _ " file(s) found." For I = 1 To .FoundFiles.Count MsgBox .FoundFiles(i) Next I Else MsgBox "There were no files found." End If End With — لنسخ ملف إلى دليل آخر باستخدام الطريقة CopyFile Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.CopyFile "C:\My Documents\شهادة.Gif", "c:\My Documents\My Pictures\", True True للكتابة فوق نسخة موجودة وFalse للنسخ بدون كتابة ، ويعطي رسالة خطأ إذا وجد نسخة . — لنسخ ملف باستخدام FileCopy Dim SourceFile, DestinationFile SourceFile = "اسم الملف مع القرص والدليل" DestinationFile = "اسم المحرك والمجلد" FileCopy SourceFile, DestinationFile — نسخ محتويات مجلد Folder إلى مجلد آخر باستخدام الطريقة CopyFolder Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.CopyFolder "C:\My Documents\مجلد جديد" "c:\My Documents\برامج", True — لإنشاء مجلد جديد باستخدام الطريقة CreateFolder Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.CreateFolder "C:\My Documents\مجلد جديد" ● لإنشاء مجلد folder استخدم : MkDir "اسم المجلد الجديد" لاحظ إذا لم يكتب اسم محرك الأقراص قبل المجلد فسوف ينشأ المجلد على محرك الأقراص الحالي . — لحذف ملف باستخدام الطريقة DeleteFile Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFile "C:\My Documents\نسخ من شهادة.gif", True True لحذف ملف للقراء فقط وFalse لعدم حذفه . — لحذف مجلد باستخدام الطريقة DeleteFolder Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.DeleteFolder "C:\My Documents\مجلد جديد", True True لحذف مجلد للقراء فقط وFalse لعدم حذفه ، لاحظ أنه يحذف المجلد وكل الملفات التي بداخله . — لحذف مجلد : Rmdir "اسم المجلد" لابد أن يكون هذا المجلد خالي من الملفات ليتم حذفه وإلا استخدم Kill لحذف الملفات أولا : Kill ("اسم القرص والدليل والملف مع اللاحقة") ولحدف كافة محتويات المجلد استخدم بعد القرص ثم المجلد : *.* ولحذف نوع ملفات استخدم النجمة واللاحقة مثال : *.TXT — لمعرفة أقراص المحركات الموجودة باستخدام الطريقة DriveExists Dim fs Set fs = CreateObject("Scripting.FileSystemObject") fs.DriveExists("c") يعيد السطر الأخير True إذا وجد المحرك وFalse إذا لم يجده ، لاحظ أن المحركات القابلة للإزالة يعيد السطر الأخير لها True ولو لم تكن موجودة . — لمعرفة الملفات الموجودة باستخدام الطريقة FileExists Dim fs Set fs = CreateObject("Scripting.FileSystemObject") MsgBox fs.FileExists("c:\my documents\شهادة.gif") يعيد السطر الأخير True إذا وجد الملف وFalse إذا لم يجده ، لاحظ أنه يجي عليك كتابة المجلد واسم الملف واللاحقة . — لمعرفة المجلدات الموجودة باستخدام الطريقة FolderExists Dim fs Set fs = CreateObject("Scripting.FileSystemObject") MsgBox fs.FolderExists ("c:\my documents") يعيد السطر الأخير True إذا وجد المجلد وFalse إذا لم يجده ، لاحظ أنه يجي عليك كتابة المحرك واسم المجلد . لمعرفة محركات الأقراص الموجودة في الحاسب : Sub ShowDriveList Dim fs, d, dc, s, n Set fs = CreateObject("Scripting.FileSystemObject") Set dc = fs.Drives For Each d in dc s = s & d.DriveLetter & " - " If d.DriveType = 3 Then n = d.ShareName Else n = d.VolumeName ' هذا السطر يظهر اسم محرك الأقراص قد يسبب مشاكل ويفضل تعطيله End If s = s & n & vbCrLf Next MsgBox s End Sub ● لإظهار المحركات في قائمة منسدلة ؛ ضع في حدث عند التركيز : Dim fs, d, dc Dim الكل As Variant Dim محركات_الأقراص As String Set fs = CreateObject("Scripting.FileSystemObject") Set dc = fs.Drives For Each d In dc محركات_الأقراص = d If IsEmpty(الكل) Then الكل = محركات_الأقراص & "\" Else الكل = الكل & ";" & محركات_الأقراص & "\" End If Next Me![اسم القائمة المنسدلة].RowSource = الكل ملاحظة هامة جداً : يجب جعل نوع مصدر الصف للقائمة هي قائمة القيم . — لإظهار الملفات في دليل Sub ShowFileList(folderspec) Dim fs, f, f1, fc, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set fc = f.Files For Each f1 in fc s = s & f1.name s = s & vbCrLf Next MsgBox s End Sub ويستدعى من إجراء مع وسيطة اسم المجلد أو القرص ، مثال : Call ShowFileList("C:\My Documents") - لمعرفة حجم ونوع ملف Dim fs, f, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFile("c:\My Documents\db1.mdb") s = " اسم الملف هو :" & UCase(f.Name) & " وحجمه : " & "(" & (f.Size) & ")" & " ونوعه : " & f.Type MsgBox s, vbMsgBoxRight + vbMsgBoxRtlReading, "معلومات ملف" - لإظهار قائمة بأسماء ملفات الخطوط وليس أسماء الخطوط Dim fs, f, f1, fc, s Dim الملفات As String Dim الكل As Variant Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder("C:\WINDOWS\FONTS") Set fc = f.Files For Each f1 In fc If f1.Type = "ملف خط تروتايب" Then الملفات = f1.Name If IsEmpty(الكل) Then الكل = الملفات Else الكل = الكل & ";" & الملفات End If End If Next List1.RowSource = UCase(الكل) - لمعرفة حجم ونوع مجلد Dim fs, f, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder("c:\My Documents") s = " اسم المجلد هو :" & UCase(f.Name) & " وحجمه : " & "(" & (f.Size) & ")" & " ونوعه : " & f.Type MsgBox s, vbMsgBoxRight + vbMsgBoxRtlReading, "معلومات مجلد" - لإعادة اسم ملف من دليل : Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") MsgBox fs.GetFileName("c:\My Documents\db1.mdb") يعيد السطر الأخير اسم الملف الموجود بعد اسم المجلد . ولإعادة المجلد كاملاً استخدم : MsgBox fs.GetFile("c:\My Documents\db1.mdb") - لإعادة المجلد بعد المحرك من دليل : Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") MsgBox fs.GetParentFolderName("c:\KPCMS\My Documents") - لنقل ملف استخدم الطريقة MoveFile Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") fs.MoveFile "c:\My Documents\سوند فورج.htm", "c:\My Documents\My Htmal\" - نقل مجلد باستخدام MoveFolder Dim fs, f Set fs = CreateObject("Scripting.FileSystemObject") fs.MoveFolder "c:\المجلد المطلوب نقله", "c:\المجلد الذي سينقل إليه المجد السابق\" - لإظهار قائمة بالمجلدات قم باستدعاء التالي: Sub ShowFolderList(folderspec) Dim fs, f, f1, s, sf Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder(folderspec) Set sf = f.SubFolders For Each f1 In sf s = s & f1.Name s = s & vbCrLf Next MsgBox s End Sub ولجعلها تظهر في قائمة منسدلة : Dim fs, f, f1, s, sf Dim الكل As Variant Dim كل_المجلدات As String Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFolder([قرص]) Set sf = f.SubFolders For Each f1 In sf كل_المجلدات = f1.Name If IsEmpty(الكل) Then الكل = كل_المجلدات Else الكل = الكل & ";" & كل_المجلدات End If Next Me![اسم القائمة المنسدلة].RowSource = الكل مع وضع وسيطه إما محرك أقراص أو مجلد ، مثال : Call ShowFolderList("c:\") — لإظهار كافة المجلدات في قرص أو دليل وطباعتها في الدبج : MyPath = "c:\" MyName = Dir(MyPath, vbDirectory) Do While MyName <> "" If MyName <> "." And MyName <> ".." Then If (GetAttr(MyPath & MyName) And vbDirectory) = vbDirectory Then Debug.Print MyName End If End If MyName = Dir Loop ولإظهارها في قائمة منسدلة : Dim الكل As Variant Dim كل_المجلدات As String MyPath = قرص كل_المجلدات = Dir([MyPath], vbDirectory) Do While كل_المجلدات <> "" If كل_المجلدات <> "." And كل_المجلدات <> ".." Then If (GetAttr(MyPath & كل_المجلدات) And vbDirectory) = vbDirectory Then If IsEmpty(الكل) Then الكل = كل_المجلدات Else الكل = الكل & ";" & كل_المجلدات End If End If End If كل_المجلدات = Dir Loop Me![اسم القائمة المنسدلة].RowSource = الكل — لإظهار أول ملف بخاصية معينة Dim MyFile MyFile = Dir("*.TXT", vbHidden) - لإظهار معلومات عن ملف استدعي الإجراء التالي : Sub ShowFileAccessInfo(filespec) Dim fs, f, s Set fs = CreateObject("Scripting.FileSystemObject") Set f = fs.GetFile(filespec) s = UCase(filespec) & vbCrLf s = s & "تاريخ الإنشاء: " & f.DateCreated & vbCrLf s = s & "التشغيل الأخير: " & f.DateLastAccessed & vbCrLf s = s & "التعديل الأخير: " & f.DateLastModified MsgBox s, 0, "معلومات ملف" End Sub مع وضع وسيطه إما محرك أقراص أو مجلد ، مثال : Call ShowFileAccessInfo("c:\My Documents\do.mdb") — لتغيير اسم ملف أو مجلد للملف : Dim OldName, NewName OldName = "C:\MY Documents\1.bmp": NewName = "C:\MY Documents\خلفية.bmp" Name OldName As NewName للمجلد Dim OldName, NewName OldName = "C:\MY Documents\مجلد جديد": NewName = "C:\MY Documents\احذفه لو سمحت" Name OldName As NewName - لمعرفة نوع المجلد هل هو جذر مجلدات root folder أو مجلد داخل جذر أو مجلد آخر ومستواه Sub DisplayLevelDepth(pathspec) Dim fs Set fs = CreateObject("Scripting.FileSystemObject") Dim f, n Set f = fs.GetFolder(pathspec) If f.IsRootFolder Then MsgBox "The specified folder is the root folder." Else Do Until f.IsRootFolder Set f = f.ParentFolder n = n + 1 Loop MsgBox "The specified folder is nested " & n & " levels deep." End If End Sub ويحتاج إلى تمرير وسيطة اسم المجلد أو القرص . — لمعرفة حجم القرص الصلب والمتاح منه Sub ShowSpaceInfo(drvpath) Dim fs, d, s Set fs = CreateObject("Scripting.FileSystemObject") Set d = fs.GetDrive(fs.GetDriveName(fs.GetAbsolutePathName(drvpath))) s = "Drive " & d.DriveLetter & ":" s = s & vbCrLf s = s & "السعة: " & FormatNumber(d.TotalSize / 1024, 0) & " Kbytes" s = s & vbCrLf s = s & "المساحة الحرة: " & FormatNumber(d.AvailableSpace / 1024, 0) & " Kbytes" s = s & vbCrLf s = s & "المساحة المستخدمة: " & FormatNumber((d.TotalSize - d.AvailableSpace) / 1024, 0) & " Kbytes" MsgBox s End Sub يمكنك استبدال سطر المساحة الحرة بالسطر التالي وهو يؤدي إلى نفس النتيجة : s = s & "المساحة الحرة: " & FormatNumber(d.FreeSpace / 1024, 0) رسالة بمسار سطح المكتب Option Compare Database Private Enum SpecialFolderIDs sfidDESKTOP = &H0 ' سطح المكتب sfidPROGRAMS = &H2 ' البرامج sfidPERSONAL = &H5 ' شخصي sfidFAVORITES = &H6 ' المفضلة sfidSTARTUP = &H7 ' بدء التشغيل sfidRECENT = &H8 ' قائمة الملفات المفتوحة حديثا sfidSENDTO = &H9 ' إرسال إلى sfidSTARTMENU = &HB ' قائمة بدء التشغيل sfidDESKTOPDIRECTORY = &H10 ' مجلد سطع المكتب sfidNETHOOD = &H13 sfidFONTS = &H14 ' الخطوط sfidTEMPLATES = &H15 ' مؤقت sfidCOMMON_STARTMENU = &H16 sfidCOMMON_PROGRAMS = &H17 sfidCOMMON_STARTUP = &H18 sfidCOMMON_DESKTOPDIRECTORY = &H19 sfidAPPDATA = &H1A sfidPRINTHOOD = &H1B sfidProgramFiles = &H10000 sfidCommonFiles = &H10001 End Enum Private Declare Function SHGetSpecialFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As SpecialFolderIDs, ByRef pIdl As Long) As Long Private Declare Function SHGetPathFromIDListA Lib "shell32" (ByVal pIdl As Long, ByVal pszPath As String) As Long Private Const NOERROR = 0 ثم في حدث زر الأمر أو غيره ضع التالي : Dim sPath As String Dim IDL As Long Dim strPath As String Dim lngPos As Long ' Fill the item id list with the pointer of each folder item, rtns 0 on success If SHGetSpecialFolderLocation(0, sfidDESKTOP, IDL) = NOERROR Then sPath = String$(255, 0) SHGetPathFromIDListA IDL, sPath lngPos = InStr(sPath, Chr(0)) If lngPos > 0 Then strPath = Left$(sPath, lngPos - 1) MsgBox strPath End If End If