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

وعليكم السلام تفضل اخي الكريم هل هذا هو المطلوب؟ بالتوفيق برنامج الحضور والغياب للطلاب بالباركود.accdb

السلام عليكم اعضاء واساتذة منتدانا الغالي هذه محاولة وتعديل لمشاركة احد الاخوة الكرام فيما يخص الصلاحيات لقاعدة البيانات اكواد تشفير الرقم السري هي نفسها المستخدمة سابقا بالاضافة مع الاستعانة ببعض الشروح ملاحظة : في القاعدة اربعة مستخدمين ثلاثة منهم بصلاحيات محدودة والادمن بصلاحيات كاملة اسم المستخدم كلمة السر admin 0 A 1 B 2 C 3 Root1000.rar

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

🙂

السبب هو عدد الحقول التي طلبتها ، اضف العلامة | في الدالة NZ ، بعددها في الكود بمعنى عندك 9 علامات : فلازم NZ يكون : جرب هذا A = Nz(DLookup("[ITEM_CODE] & '|' & [deskwn1] & '|' & [item_name] & '|' & [Expr1]& '|' & [Expr2] & '|' & [sub_id] & '|' & [FACTOR]& '|' & [UNT_ID]& '|' & [ITEM_CommissioN]& '|' & [CATEGORY]", "VW_ITEM_MASTAR", "[ITEM_BARCODE]='" & Me.ITEM_BARCODE & "'"), "|||||||||") جعفر

تفضل اكتب اي كلمة test34.xlsm

Try this file Offecna.xlsx

شاهد هذا الفيديو https://www.youtube.com/watch?v=0YNhxVu2a5s

اتفضل اخى حسين Me.EDET_QOTY = DLookup("[Qote_item]", "tabol102", "item_prais=" & [item_prais] & "and [ITEM_BARCODE]='" & Me.serh_Barcod & "'") DCount("ITEM_BARCODE", "tabol102", "ITEM_BARCODE = forms!forms_1!serh_Barcod and [item_prais]=forms!forms_1![item_prais]") test_1.accdb

جرب هذا الملف Ages.xlsx

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

تم

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

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

اولا : اخي احمد اشكرك وادعوا الله لك بالتوفيق ثانيا : استقطاع وقتك لمساعدة الاخرين تؤجر عليه لا حرمك الله الاجر وربي يجعلها في ميزان حسناتك ثالثا : هل ممكن في القاعدة السابقة نسطيع استبدال ( صواب - خطأ ) بكلمة نعم / لا وجزاك الله خيرا

انا قلت برضو كده بصراحه تسلم ايدك استاذي الفاضل jjafferr والشكر كل الشكر لاستاذي الفاضل أحمد الفلاحجى والله ماقصر وكوده ممتاذ بس انا من طبعي بحب الكود يكون صغير / خير الكلام ما قل وذل 😂 والف شكر للجميع وجعله الله في ميزان حسناتكم

تفضل 🙂 الدالة NZ تحل المشكلة 🙂 A = Nz(DLookup("[SELLS_PRICE]& '|' & [item_name]", "POS_MASTER", "[ITEM_BARCODE]='" & Me.ITEM_BARCODE & "'"), "|") x = Split(A, "|") Me.SELLS_PRICE_2 = x(0) Me.ITEM_NAME_2 = x(1) جعفر

السلام عليكم في تذييل التقرير اكتب في مربع نص غير منضم الكود التالي =Count(*) تحياتي Database2.rar

الحمدالله تم عمل الازم تمام التمام شكرا خالد

بالانتظار استاذي شكرا لك

جزاك الله خير المحسنين

حياك الله 🙂 انا قمت بعمل شرح اكثر في مثال الرابط ، فرجاء مراجعته ، واخبرني اذا اصبح واضح 🙂 جعفر

استاذي الفاضل jjafferr بخصوص هذا الكود انه ممتاذ جدا انا جربته فوق الممتاز وفر علي جهود كثيره زادك الله من علمه وجعله في ميزان حسناتك Dim x() As String A = DLookup("[pn] & '|' & [Size] & '|' & [Vendor] & '|' & [Description] & '|' & [Maxrl] & '|' & [Maxrlegyptair] & '|' & [actype] & '|' & [pos] & '|' & [biasradial] & '|' & [code]", "code", "[pn]=forms!frm_dataentry!Combopn") x = Split(A, "|") ' For i = LBound(x) To UBound(x) ' Debug.Print x(i) ' Next i Me.pn = x(0) Me.size = x(1) Me.vendor = x(2) Me.Description = x(3) Me.Maxrl = x(4) Me.Maxrlegyptair = x(5) Me.ACType = x(6) Me.Pos = x(7) Me.BiasRadial = x(8) Me.code = x(9)

ما عليك الا اضافة 1 (او اي رقم تريده) الى المعادلة كي تصبح هكذا =IF(OR(A2="",B2=""),"",DATEDIF(DATE(B2,1,1),TODAY(),"y")+1)

كالعادة استاذ على دائما تحفنا باعمالك الجميلة

السلام عليكم اخوي احمد 🙂 أنا قد اجبت على سؤال الموضوع ، واخبرتك 🙂 فرجاء فتح موضوع جديد والاشارة الى هذا السؤال ، ورجاء تجاوب فيه على الاسئلة اللي طرحتها عليك (لأنك لم تجاوب عليها) ، حتى يعرف الاعضاء كيف يمكنهم مساعدتك 🙂 جعفر

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

مثل هذا الجهاز AT9000 ، ويعمل بنفس طريقة الجهاز CR100 بأته يأخذ كود MRZ ويفككه (وسيكون مشروعي التالي ان شاء الله 🙂 ) ، وبالاضافة يأخذ: صورة ملونة لصفحة الجواز ، صورة ابيض واسود لصفحة الجواز (لكشف التزوير) ، صورة من صورة صاحب الجواز الشخصية ، . . نعم يمكن التحكم في هذا ، بطريقتين: عن طريق ملف XML ، او بتفكيك السطر على اساس علامات "<" (لاحظ الوحدة النمطية في مشاركتي الأولى) ، او الاثنين معا 🙂 جعفر

السلام عليكم هل تقصد تحديث النموذج الفرعي Sub per Line الموجود غي النموذج الرئيسي Main per Line بواسطة الزر Calculate المهم وجدت هذا الكود في حدث عند نقر زر Calculate انت عامله لفتح استعلام ؟؟؟ DoCmd.OpenQuery "Main TABL, acViewNormal, acReadOnly" تحياتي انظر للمرفق DRI Plant # 01.rar

تفضل تم وضع المعادلة في العمود E وتتم الفلترة من خلال هذا العمود =IF(AND(ISBLANK(B2);ISBLANK(C2));"إخفاء الصف";"") Filtering.xlsx

وعليكم السلام 🙂 اسمح لي اشارك معاك اخوي خالد 🙂 انا شايف ان الرقم العشوائي مجرد تمويه ، او لم يتم استعماله بالطريقة الصحيحة في الكود !! الكود يطلب منك كلمة السر ويحتفظ بها في المتغير x ، المتغير z يعمل عملية حسابية على كلمة السر التي ادخلتها ، اذا كانت كلمة السر صحيحة ، فيخبرك انها صحيحة ويفتح لك النموذج "معلومات التقارير" ، واذا كانت فيخبرك انها خطأ ويغلق النموذج "معلومات التقارير" !! ولكن النموذج "معلومات التقارير" : يا انه مُغلق ، فيتم فتحه ، او مفتوح فيتم غلقه ، ولكن الكود يعمل الاثنين ، حسب صحّة كلمة السر !! جعفر

وهذا ما يفعله الكود الذي رفعته لك بالضبط (لكن بدون رقم سري ) اذا اردت يمكن وضع رقم سري بالكود

اولا الف شكر للاخ الكريم ووجدت طريقة اخرى قمت باستخدامها وهي الغاء الحماية عن كل الخلايا مثل الصورة المرفقة ثم عمل حماية على الخلايا او الاعمدة المراد حمايتها فقط ( locked ) من ثم عمل protect sheet لها مثل الصور المرفقة

تحية طيبة وعطرة... تفضل ما طلبته في الملف المرفق... بن علية حاجي Cash at Banks (TEST).xlsm

السلام عليكم ورحمة الله تم عمل المطلوب في الملف المرفق... أرجو أن تفي الغرض المطلوب.. بن علية حاجي ملاحظة: تم تصحيح خطأ في المعادلة الثانية للإحداثيات في الملف المرفق (خطأ في الإشارة).. معذرة لذلك... (النتائج المحصل عليها تمت في معلم متعامد ومتجانس) Circle & Center.xls

شكراً استاذ محسن و لي انا بهذا الشأن هذا الماكرو (عسى ان ينال الإعجاب) Option Explicit Sub S_H_Test_NEW() Dim D As Worksheet: Set D = Sheets("Data") Dim M As Worksheet: Set M = Sheets("المطلوب") Dim ARR(): ARR = Array("S", "G", "C", "H") Dim Obj As Object, i%, Chek%, t% Set Obj = CreateObject("Scripting.Dictionary") M.Range("K2").CurrentRegion.ClearContents i = 2 Do Until D.Range("F" & i) = vbNullString For t = 1 To 4 Chek = Chek + (UCase(M.Cells(2, t)) = _ UCase(D.Cells(i, ARR(t - 1)))) Next If Chek = -4 Then _ Obj.Add i, D.Cells(i, "F") i = i + 1: Chek = 0 Loop If Obj.Count Then _ M.Cells(2, "k").Resize(Obj.Count) = _ Application.Transpose(Obj.items) Set Obj = Nothing: Set D = Nothing: Set M = Nothing Erase ARR End Sub الملف من جديد MY_search_MD_SH.xlsm

مبدع دائما أستاذنا الكبير / سليم وإثراء للموضوع يمكن تجربة الكود التالى لاستدعء البيانات بأكثر من شرط Option Explicit Sub M_D_Test() Dim ws As Worksheet: Set ws = Sheets("Data") Dim sh As Worksheet: Set sh = Sheets("المطلوب") Dim Arr As Variant, Arr1 As Variant, Temp As Variant Dim lr As Long, I As Long, j As Long, P As Long lr = ws.Range("C" & Rows.Count).End(xlUp).Row '------------------------------------ Application.ScreenUpdating = False sh.Range("H2:H22").ClearContents Arr = ws.Range("A2:Z" & lr).Value '=================== Arr1 = Array(5) '==================== ReDim Temp(1 To UBound(Arr, 1) + 1, 0 To UBound(Arr1) + 1) For I = 1 To UBound(Arr) ' الـ 3 شروط ' ================================================================================================== If Arr(I, 19) = sh.[A2].Value And Arr(I, 7) = sh.[B2].Value And Arr(I, 3) = sh.[C2].Value Then '================================================================================================== P = P + 1 For j = 0 To UBound(Arr1) Temp(P, j) = Arr(I, Arr1(j)) Next j End If Next I If P > 0 Then sh.Range("H2").Resize(P, UBound(Temp, 2)).Value = Temp '------------------------------------ Application.ScreenUpdating = True End Sub MY_search_MD.xlsm

جرب هذا الملف MY_search.xlsx

السلام عليكم ورحمة الله تم حل المشكل بتعديل معادلة الخلية الأولى باستعمال دالة IFERROR في الملف المرفق... أرجو أن تفي الغرض المطلوب.. بن علية حاجي فصل أيام الغياب.xlsx

نعم اخي تفضل شاهد المرفقات Test_1.xls

جرب هذا الماكرو Option Explicit Sub Join_by_three() Dim my_rg As Range Dim lr%, i%, col%, m%, k% col = Cells(1, Columns.Count).End(1).Column lr = Range("a2", Range("A1")).End(4).Row m = lr + 2 Range("a" & m).Resize(10000, 3 * col).Clear For i = 1 To lr Step 3 For k = 0 To 2 Range("a" & i + k).Resize(, col).Copy _ Range("a" & m).Offset(, k * col) Next k m = m + 1 Next i End Sub MY_one_file.xlsm

تفضل لقد قمت بتصميم صفحة html و أرفقتها مع المثال ضعهما في نفس المجلد و جرب مع العلم أنني ما زلت لم أضع درس الأحداث بعد Desktop.rar

الحلقة السادسة: تابع لدرس التعامل مع الجداول في صفحة ويب في الدرس الماضي قمنا بالتعامل مع جدول له خاصية id و في هذا الجدول سوف نتعلم كيفية التعامل مع الجداول التي ليس لها خاصية id أو name سوف نعتمد في هذا الدرس على خاصية Tagname التطبيق سوف يكون على صفحة ويكيبيديا: https://mawdoo3.com/جميع_دول_العالم_وعواصمها 1- كود حساب عدد الجدول في الصفحة: MsgBox WebBrowser3.Document.getElementsByTagName("table").Length 2- كود حساب عدد الخلايا في الجدول: MsgBox WebBrowser3.Document.getElementsByTagName("table").Item(0).cells.Length 3- كود حساب عدد الصفوف في الجدول: MsgBox WebBrowser3.Document.getElementsByTagName("table").Item(0).rows.Length 4- كود استخراج بيانات خلية في الجدول: MsgBox WebBrowser3.Document.getElementsByTagName("table").Item(0).rows(1).cells(1).innerText 5- كود ارسال بيانات إلى خلية في الجدول: WebBrowser3.Document.getElementsByTagName("table").Item(0).rows(5).cells(0).innerText = "salah" ملاحظة: المقصود بـ item(0) i هو الجدول الأول الأزرار داخل الإطار الأحمر هي الخاصة بأكواد هذا الدرس قبل البدئ إضغط على زر فتح صفحة التجربة لفتح الصفحة أمامك webbroser.rar

الحلقة الخامسة: التعامل مع الجداول في صفحة ويب سوف نتطرق في هذه الحلقة إلى الأكواد التي تمكننا من التحكم في الجداول داخل صفحة ويب و سوف نستخدم مرفق أخي ابو البشر في هذا الدرس و هي عبارة عن صفحة ويب محفوظة خاصية id للجدول اسمها: ctl00_PlaceHolderMain_gvCourseSectionExamsGrades عند فتح المرفق يجب تحديد صفحة الويب المرفقة كمصدر للأداة و ذلك بإتباع الخطوات التالية: 1- كود استخراج عدد الخلايا في الجدول: MsgBox Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").cells.Length 2- كود استخراج عدد الصفوف في الجدول: MsgBox Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows.Length 3- كود استخراج بيانات العمود الأول في الجدول: في هذا الكود نقوم بعرض الأرقام الموجودة في العمود الأول For i = 2 To Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows.Length MsgBox Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows(i - 1).cells(0).innerText Next i 4- كود استخراج بيانات العمود الثاني في الجدول: في هذا الكود نقوم بعرض الأسماء الموجودة في العمود الثاني For i = 2 To Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows.Length MsgBox Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows(i - 1).cells(1).innerText Next i 5- كود ارسال بيانات إلى الجدول: في هذا الكود سوف نرسل بيانات للعمود الرابع الخاص بمادة البحوث و المشروعات For i = 2 To Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows.Length Me.WebBrowser3.Document.getElementById("ctl00_PlaceHolderMain_gvCourseSectionExamsGrades").rows(i - 1).cells(3).innerText = i - 1 Next i و هذا هو المرفق به جميع الدوال. webbroser.rar

جرب هذا الكود تم تغيير اسماء الشيتات الى اللغة الاجنبية لسهولة التعامل مع الكود من حيث النسخ واللصق Option Explicit Private Sub Worksheet_Activate() FIL_CDATA_VAL End Sub '++++++++++++++++++++++++++++++++++++++++++++++++ Sub FIL_CDATA_VAL() Dim i As Long: i = 8 Dim DIC As Object Set DIC = CreateObject("Scripting.Dictionary") Do Until Sheets("DATA").Range("C" & i) = vbNullString DIC(Sheets("DATA").Range("C" & i).Value) = "" i = i + 1 Loop With Sheets("RESULT").Range("k5").Validation .Delete .Add 3, Formula1:=Join(DIC.KEYS, ",") End With Set DIC = Nothing End Sub '++++++++++++++++++++++++++++++++++++++++ Sub GET_CERTIFICAT() Dim dat As Worksheet, RES As Worksheet Dim Num%, k%, R, i%, Found_Ro%, Ro%: Ro = 8 Dim FOUND_RG As Range Dim n: n = 3 Dim arr Set dat = Sheets("DATA"): Set RES = Sheets("RESULT") Union(RES.Range("c5"), RES.Range("c19"), RES.Range("c33")) = vbNullString Union(RES.Range("c8:k9"), RES.Range("c22:k23"), RES.Range("c36:k37")) = vbNullString Num = RES.Range("K5") arr = Array(2, 5, 7, 9, 11, 13, 15, 17, 19, 21) For k = 1 To n Set FOUND_RG = dat.Range("a8").CurrentRegion.Columns(3). _ Find(Num, LOOKAT:=1) If FOUND_RG Is Nothing Then Exit Sub R = FOUND_RG.Row RES.Cells(Ro - 3, 3) = dat.Cells(R, arr(0)) For i = 1 To UBound(arr) With RES.Cells(Ro, 3).Offset(, i - 1) .Value = dat.Cells(R, arr(i)) .Offset(1) = dat.Cells(R, arr(i) + 1) End With Next RES.Cells(Ro + 2, 3) = dat.Cells(R, 23) Num = Num + 1: Ro = Ro + 14 Next End Sub الملف مرفق RESULT.xlsm

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

تفضل أخى =IFERROR(MID($A2,LEN($A2)-(COLUMNS($B2:B2)-1),1),0)+0 ويمكن إستخدام هذا الكود أيضا Sub SplitNumbers() 'gamal abd elsameh 28/8/2014 'http://www.officena.net Dim WRng As Range Dim Cell As Range Dim Lgth As Byte Dim i As Byte 'Exit if worksheet not active If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub 'Set range to work with With ActiveSheet Set WRng = Intersect(.Columns("A"), .UsedRange) End With 'Loop through cells and 'split the characters... For Each Cell In WRng Lgth = Len(Cell.Value) If Lgth > 0 Then For i = 1 To Lgth Cell.Offset(0, i).Value = Mid(Cell.Value, i, 1) Next i End If Next Cell End Sub تقبل تحياتى فصل أرقام بطريقة عكسية.rar

السلام عليكم الكود التالي يعمل على 2003-2007 Option Explicit '////////////////////////////////////////////////////// ' اسم مجلد الملفات Const FilName As String = "ملفاتي" ' عنوان خلية الجمع في الملفات Const Adr As String = "A1" '////////////////////////////////////////////////////// Sub kh_SumAllBook() Dim MyObj, MyObjFol, Obj Dim xlw As Excel.Workbook Dim MySheet As Worksheet Dim iPath As String, iName As String Dim Last As Long, i As Long Dim ch As String * 1 ch = Application.PathSeparator '============================ On Error GoTo Err_kh_Files '============================ iPath = ActiveWorkbook.Path & ch & FilName & ch Set MyObj = CreateObject("Scripting.FileSystemObject") Set MyObjFol = MyObj.GetFolder(iPath) '============================ Set MySheet = ThisWorkbook.Worksheets("TOTAL") '============================ With MySheet Last = .Cells(Rows.Count, "A").End(xlUp).Row .Range("A2").Resize(Last, 3).ClearContents End With '============================ kh_Application False '============================ On Error Resume Next For Each Obj In MyObjFol.Files iName = Obj.Path If Not Dir(Obj.Path) = "" Then If TestType(CStr(Obj.Name)) Then Set xlw = Workbooks.Open(iName) With MySheet i = i + 1 .Cells(i + 1, "A").Value = CStr(Obj.Name) .Cells(i + 1, "B").Value = CStr(xlw.Worksheets(1).Name) .Cells(i + 1, "C").Value = Val(xlw.Worksheets(1).Range(Adr)) End With xlw.Close False End If End If Next On Error GoTo 0 '============================ If i Then MySheet.Range("E2").Value = Evaluate("Sum(" & Range("C2").Resize(i).Address & ")") '============================ Err_kh_Files: kh_Application True If Err Then MsgBox "Err.Number:" & vbCr & Err.Number: Err.Clear '============================ Set MySheet = Nothing: Set MyObj = Nothing: Set MyObjFol = Nothing End Sub Sub kh_Application(mbol As Boolean) With Application .Calculation = IIf(mbol, -4105, -4135) .ScreenUpdating = mbol .EnableEvents = mbol End With End Sub Function TestType(MyTName As String) As Boolean Dim MyTyp As String MyTyp = Mid$(MyTName, InStrRev(MyTName, ".")) TestType = MyTyp Like ".xls*" End Function المرفق 2003-2007 kh_sum.rar

هذه المجموعة من الاكواد من تجميع ابو حمود -------------------------------------------------- — للبحث عن ملف : 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