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

السلام عليكم ورحمة الله وبركاته إخوتي الكرام سأقوم بإرفاق الملف لتشغيل الوسائط راجياً أن ينال إعجابكم أخي الحبيب ياسر أرجو أن تخبرنا كيف نشغل الملفات السابقة أو اللاحقة. أخي الحبيب عبد العزيز:أرى أن الأخ الحبيب ياسر قد دلنا على ما يلي: تحديد السواقة ثم المسار ثم الملف حسب النوع و مشغل الوسائط الذي ربطها جميعاً ببعضها للوصول إلى الغاية المرجوّة والسلام عليكم. مشغل وسائط مصطبة ياسر العربي.rar

السلام عليكم أخي الكريم تفضل الحل بالمرفق خيثر.rar

السلام عليكم ورحمة الله أخي الكريم عبد العزيز، هذه المرة لم أقم بتلبية طلبك المتمثل في تضليل الخلايا من كل صف والتي مجموعها يساوي قيمة "مجموع البحث" بل قمت بتركيب كود (كلاسيكي ليس مثلما يقدمه الإخوة المتمكنين من الأكواد) يقوم بجلب عناوين الخلايا من كل صف لكل الحالات الممكنة التي يتوفر فيها المطلوب... (ربما يكون الكود بطيئا في العمل -هذا حال المبتدئين-)... أرجو أني فهمت المطلوب وقربت المفهوم... قم بوضع مجموع البحث في الخلية المعنية والضغط على الزر "TEST" (وانتظر بعض الوقت...)... أخوك بن علية مجموع البحث الجديد.rar

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

السلام عليكم أستاذى بن عليه أثناء تجربتى لمرفق حضرتك وجدت الآتى : اذا وضعت مكونات العدد 100 ( 15 و 5 و 50 و 30 ) مثلا فى ال 4 صفوف و حذفت الكلمات الصف أ و الصف ب ...... الخ التى بأول كل صف فان الكود لا يعطى شيئا هذا دفعنى للعمل على الكود و تعديله بالكيفية الآتيه : الاستغناء عن كل التسميات فى المرفق والتى تزيد من بطء الكود و التعويض عنها بنطاقات فى الكود نفسه وهذا من شأنه اعطاء الكود مرونة وسرعة . الى جانب تعديلات أخرى بسيطة فى موضع ظهور النتائج Sub TEST2() ' Find every combination H.ben & Mokhtar 5/1/2015 Dim i As Integer Dim Adrs1 As String, Adrs2 As String, Adrs3 As String, Adrs4 As String Dim C1 As Range, C2 As Range, C3 As Range, C4 As Range, MyCel As Range Dim Rng1 As Range, Rng2 As Range, Rng3 As Range, Rng4 As Range i = 16 Set MyCel = Sheets("Sheet1").Range("E12") Set Rng1 = Sheets("Sheet1").Range(Range("B3"), Cells(3, Cells(3, Columns.Count).End(xlToLeft).Column)) Set Rng2 = Sheets("Sheet1").Range(Range("B5"), Cells(5, Cells(5, Columns.Count).End(xlToLeft).Column)) Set Rng3 = Sheets("Sheet1").Range(Range("B7"), Cells(7, Cells(7, Columns.Count).End(xlToLeft).Column)) Set Rng4 = Sheets("Sheet1").Range(Range("B9"), Cells(9, Cells(9, Columns.Count).End(xlToLeft).Column)) On Error Resume Next With Application .ScreenUpdating = False: .DisplayAlerts = False: .Calculation = xlCalculationManual End With Sheets("Sheet1").Range(Cells(16, 2), Cells(Rows.Count, 6)).ClearContents For Each C1 In Rng1 Adrs1 = C1.Address For Each C2 In Rng2 Adrs2 = C2.Address For Each C3 In Rng3 Adrs3 = C3.Address For Each C4 In Rng4 Adrs4 = C4.Address If C1 + C2 + C3 + C4 = MyCel Then Cells(i, 2) = i - 15 Cells(i, 3) = Adrs1 Cells(i, 4) = Adrs2 Cells(i, 5) = Adrs3 Cells(i, 6) = Adrs4 i = i + 1 End If Next Next Next Next On Error GoTo 0 Set MyCel = Nothing Set Rng1 = Nothing Set Rng2 = Nothing Set Rng3 = Nothing Set Rng4 = Nothing With Application .ScreenUpdating = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic End With End Sub تحياتى لك من قلبى سيدى الفاضل الخلوق . و السلام عليكم Find every combination H.ben & Mokhtar.rar

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

وعليكم السلام ورحمة الله وبركاته تفضل Project1.rar

اليك هذا الملف عساه المطلوب test salim.rar

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

السلام عليكم ورحمة الله وبركاته الاصدار الرابع : فورم اضافة وبحث وتعديل مرن مع استعراض الصور (تحكم كامل بالصورة ) المرفق 2003 فورم ادخال و تعديل مرن مع الصور.rar http://www.officena.net/team/khboor/kh_image/p86.png هام جدا بتاريخ ( 14 / 6 / 2023 ) لكي يعمل الفورم جيدا بدون اخطاء لابد من عمل الاتي 1- UnRegister MSCOMCT2.OCX ازاله تسجيل الملف MSCOMCT2.OCX تشغيل الامر cmd كمسئول ثم كتابه الأمر التالي لو كان الويندوز ٦٤ بت regsvr32 /u C:\Windows\SysWOW64\MSCOMCT2.OCX او regsvr32 /u C:\Windows\System32\MSCOMCT2.OCX لو كان الويندوز ٣٢ ثم بفك الضغط عن الملف المرفق بأسم MSCOMCT2.OCX ونقوم بنسخه الي المسار التالي ويندوز٦٤ بت C:\Windows\SysWOW64 ويندوز ٣٢ بت C:\Windows\System32 2- Register MSCOMCT2.OCX ثم نقوم بعمل ريجستر للملف الذي نسخناه في الويندوز عن طريق هذا الأمر ويندوز ٦٤ regsvr32 C:\Windows\SysWOW64\MSCOMCT2.OCX ويندوز ٣٢ regsvr32 C:\Windows\Sys\MSCOMCT2.OCX MSCOMCT2.zip

كثيرا ما ننسي اضافة شيء و نتذكره بعد ارسال البريد مباشرة و نسرع بعمل استدعاء للبريد المرسل Recall بينما هناك حل جميل لم أعرفه من قبل و هو يؤدي الي تأخير ارسال البريد لعدد من الدقائق تحددها أنت و يتم تنفيذه من خلال قواعد الارسال الالية Rules and Alerts و حقيقة لم يسبق لى تطبيق القواعد على البريد المرسل و انما استخدمها بكثافة على البريد القادم و يتم ذلك من خلال البدء بانشاء قاعدة جديدة ثم Next و اختيار الخيار التالي كما فى الرسم و تحديد عدد الدقائق و لكن قد تكون فى حاجة الى ارسال رسائل فورية فى بعض الاحيان لذا يمكنك اجراء استثناءات كأن يكون البريد مرسل الى شخص او عدة اشخاص او يكون به كلمة معينة و عن نفسي افضل ان يكون الاستثناء ان يكون البريد مصنف كبريد هام، و ذلك كما هو موضح بالشاشة التالية تختار importance ثم تحدد القيمة ثم اختيار التالي و الاغلاق و هكذا تبقي الرسالة فى صندوق الارسال outbox لمدة دقيقتان قبل أن يتم ارسالها هذا ما لم تكن مصنفة كرسالة مهمة

السّلام عليكم و رحمة الله و بركاته باسم الله .. ما شاء الله .. تبارك الله بكل إعجاب أبارك هذه اللّمسة المميّزة و الممتازة واصل إبداعاتك يا غالي .. يا " أبا يوسف " .. و أكيد منكَ .. سنستفيد بإذن الله بارك الله فيك .. جزاك الله خيرًا و زادك من علمه و فضله فائق إحتراماتي و إعجاباتي

السلام عليكم ورحمة الله تم إضافة كود يقوم بإدارج "فاصل الصفحات" بعد كل محافظة مستعينا بالعمود C (عمود مساعد)... تم إدراج عدة تسميات لنطاقات معينة لتسهيل عملية الكود... بن علية صفحات الطباعة.rar

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

حياك الله اخي الكريم في البداية وعند فتح القاعدة توقعت المشكلة في نوع البيانات .. لأنك تبحث عن رقم وتسختدم علامات تنصيص وهي مخصصة لنوع بيانات النصوص ولكن بعد ذلك ظهرت لي مشكلة اخرى وهي .. رسالة تفيد بقلة المعلمات .. فقررت استخدام كود آخر .. ضع هذا الكود بدلا عن ذاك وجرب .. Dim tTotal As String tTotal = Nz(DCount("sarey", "ggh", "sarey between forms!form3!text2 and forms!form3!text0"), 0) MsgBox (tTotal) بالتوفيق

شكرا على التوضيح سأحاول في المرات القادمة تلافي هذا الإشكال

لا ليست مثل بعضها فالحروف تختلف بالطبع مثل حرف e بالإنجليزية أما في الفرنسية هو é ويختلف تنفيذ ذلك حسب إعدادات لغة الويندوز الذي تعمل عليه القاعدة بعد إذن أخي أبو رحيل.. تفضل أخي نبيل المرفق بتنسيق 2003 mouwazaf - C--edit.rar

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

اخى الحبيب اهلا بيك فى جامعه اوفيسنا بما انك مهتم بالسودكو زى بهديك ملف عندى من احد المواقع الاجنبيه جرب الملف ربما يعجبك بس اهم شئ تكون حريف تقبل تحياتى -------------------------------------------------------------------- SuDoku.zip

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

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

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

تفضل اخي الكريم في حدث بعد التحديث للحقل name تم وضع هذا الكود Me.d = Nz(DCount("name", "stu", "name=forms!ÌÏæá1!name"), 0) المرفق .. بالتوفيق oth.rar

السلام عليكم ورحمة الله أخي الكريم، تقوم بالعملية حسب المراحل التالية: 1- تحدد النطاق A1:D100 2- من التبويب "بيانات DATA" نختار الخاصية "التحقق من الصحة Data Validation" 3- نختار الميزة "مخصص Personalize" وندخل المعادلة التالية : =SUM($A1:$D1)<=$E$1 4- نوافق على التعديل... كل هذا تجده مطبقا في الملف المرفق... بن علية DD.rar

جرب هذا الملف التنسيق الشرطي salim.rar

وصلتني على البريد افتح الاوت لوك الخاص بك وحاول تجربة الاختصارات التالية: •Ctrl+R : الرد على بريد الكتروني •Alt+R : الرد على الكل في البريد الإلكتروني أو قم بالتبديل إلى طريقة عرض تقويم أسبوع العمل •Alt+W : إعادة توجيه البريد الإلكتروني أو قم بالتبديل إلى عرض التقويم الاسبوعي •Ctrl+M : F9 لإرسال/تلقي جميع المراسلات •Alt+S : أرسل بريد الكتروني •Ctrl+G للانتقال الى أي تاريخ في التقويم » الانتقال الي تاريخ « : فتح مربع يمكنك أيضا التبديل بين البريد والتقويم والاتصالات والعناصر الأخرى في "جزء التنقل" عن طريق Ctrl + 1, 2, 3, 4, 5 . جرب الأرقام كل على حدة

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

السلام عليكم ورحمة الله وبركاته أسأل الله الكريم رب العرش العظيم أن يجازيكم خيرا على ما قدمتم في سبيل تسهيل الصعاب على إخوة لكم لكم مني أعز التشكرات أخوكم خيثر .

جزاك الله خيرا أخي الفاضل الصقر ( حسام ) بعض ماعندكم أحبك الله الذي أحببتني فيه

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

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

السلام عليكم اشكرك اخي سعيد على فكرة الحل والتي تمت بالتنسيق الشرطي المعكوس

وعليكم السلام.. طبيعي أن تظهر لك رسالة خطأ لأن حقل المعرف أصبح فارغا بعد الحذف، في حين أن شرط الكود هو فتح النموذج حسب حقل المعرف ما رأيك أخي أن تستخدم هذا الكود في زر (حذف)؟ ملحوظة هامة.. يفضل تسمية الحقول والكائنات بالإنجليزية وليست بالعربية وبدون مسافات If MsgBox("هل أنت متأكد من حذف العميل" & " : " & [Nom] & " ", vbOKCancel + vbCritical, "تنبيه") = vbOK Then DoCmd.SetWarnings False DoCmd.RunCommand acCmdDeleteRecord DoCmd.OpenForm "نموذج1" DoCmd.Close acForm, "نموذج2", acSaveYes Else: Exit Sub: End If

استخدم أداة الFormat Painter بعد تحديد التنسيق على أول خانتين التنسيق الشرطى2.rar

بارك الله فيك أخي الغالي مختار أخي الكريم أبو حماده جرب الكود بهذا الشكل Private Sub TextBox1_Change() If Me.TextBox1.Text = "سبحان الله" Then Command1.Enabled = True Else Command1.Enabled = False End If End Sub تقبل تحياتي

السلام عليكم ورحمة الله وبركاته أستاذنا الحبيب محمد طاهر .. لفتةٌ طيبةٌ وجّهتم عنايتكم من خلالها لإخوة كرام طالما اجتهدوا وبذلوا قصارى جهودهم لإيصال المعلومة الصحيحة والنصح الجميل مترافقين بحلم وأناة ولين جانبٍ إنهما أخوينا الكريمين ياسر خليل أبو البراء وأبو خليل المحترمين اللهم اجعلهما أخلاء متقين آمين.شكراً لكل من ساهم برفع سويةِ منتدانا وألّف إليه قلوباً تهفو إلى علمٍ ناصعٍ ومحبةٍ فياضةٍ والسلام عليكم.

بسم الله بارك الله بكم جميعاً ومن هنا أتوجه بكلمة شكر للمنتدى ادارة ومراقبين واعضاء صرح من العلم مع تقديري واحترامي رضا الله

السي أبو رحيل ... جرب هذا التعديل المخصص mouwazaf.rar

السلام عليكم ورحمة الله المعادلة تجعلها بالشكل التالي: =SUM($A1:$D1)>=$E$1 ثم تسحبها على النطاق الذي تريد... بن علية

اخي الغالي ما اشرت اليه ما هو الا اقواس يتم وضعها في اغلب الاحيان لضم كلمة المرور داخلها مثلا الباسوورد كدا Password:="01097192367" دا الطبيعي في كتابة كلمة المرور في اغلب الاحيان يتم كتابتها بين قوسين والاضمن لعدم وجود اخطاء طيب لما نعرفها كمتغير لو كتبناها كدا زي ما عرفناها Dim strPassword As String strPassword = "01097192367" Password:="strPassword" كدا خطأ لانه هيتعامل كانه نص عادي يبقي لازم يخرج بره الاقواس زي كدا Password:="" & strPassword & "" وصلت حافظنا على تواجد الاقواس مع ادراج قيمة المتغير بينهم وللعلم تعمل احيانا هكذا ولكن لست اضمنها في معظم الحالات Password:=strPassword اما اذا كنت تريد تطبيق ما تريده يبقي هكذا Dim NAME As String NAME = Text5.Text YXL.Workbooks.Open App.Path & "/aseel.xlsx", UpdateLinks:=0, Password:="" & NAME & "" او هكذا YXL.Workbooks.Open App.Path & "/aseel.xlsx", UpdateLinks:=0, Password:=NAME ياريت المعلومة تكون وصلت او هكذا اذا كان هذا ما تقصد Dim NAME As String NAME = Text5.Text YXL.Workbooks.Open App.Path & "/" & NAME, UpdateLinks:=0, Password:="" & Text6.text & "" او هكذا YXL.Workbooks.Open App.Path & "/" & NAME , UpdateLinks:=0, Password:=Text6.text

Sub MokhtarSquare2() Application.ScreenUpdating = False With Cells .RowHeight = 6.694 .ColumnWidth = 1 End With Application.ScreenUpdating = True End Sub جعل عرض كل الأعمدة = 2.17 و ارتفاع كل الصفوف = 18 هذه الأرقام تجعل كل خلايا الشيت تبدو مربعة الشكل بنسبة كبيرة جدا وهو ما تريده و تقريبا تقدر تقول كل 1 نقطة فى عرض العمود = 5.694 فى ارتفاع الصف جرب الكود السابق ستجد أن كل خلايا الشيت مربعة الشكل زود الزوم ستجد أيضا الخلايا مربعة الشكل و الله أعلى وأعلم

بالشكل ده Private Sub TextBox1_Change() If Me.TextBox1.Text = "سبحان الله" Then Command1.Enabled = True End Sub

ررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررررائع بارك الله فيك وفي وقتك وعلمك

تم التعدبل حسب الرعبة ترتيب لكل صف salim 3.rar

اخى الكريم جرب المرفق تم تطبيق المطلوب حسب ما فهمت من طلبك هو طبعا هل مش احترافى قوى لكنه يؤدى الغرض تقبل تحياتى جديد الدوائر الحمراء.zip

وتقدر تعمل الكود التالي (انا طابعه هنا مباشرة دون تجربته ، فقد يكون فيه خطأ ما ) بدل الاستعلام: set rst=me.recordsetclone rst.movelast:rst.movefirst RC=rst.recordcount for i=1 to RC rst.edit rst!commprint=0 rst.update rst.movenext next i rst.close: set rst=nothing جعفر

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

وهذه طريقة اخرى مع مثال من استاذنا أبوخليل http://www.officena.net/ib/index.php?showtopic=60383 جعفر

وعليكم السلام أخي علي لقد قمت بالرد على هذا الموضوع في منتدى الفريق العربي للبرمجة ، وهنا اضع لك نفس الرد 1. في برنامج الواجهات ، وليس برنامج الجداول ، احفظ هذا الكود في وحدة نمطية ، سميها basJStreetAccessRelinker : '----------------------------------------------- 'VERSION 2 BETA '- Supports both 32-bit and 64-bit versions of Access 2010. '- Supports encrypted (password-protected) back-end Access databases. The password is stored in the front-end database unencrypted, so care should be taken to protect the front-end application. '----------------------------------------------- 'This database contains the module and macros necessary to implement an automatic linked Access table validity checker. 'It also allows the user to change the current backend databases (whether currently valid or not). 'You can try this feature using the ChangeTableLinks macro. 'This utility supports multiple back-end Access databases. It does not need a separate "list of tables" in a table, 'INI file or anywhere else. In order to have it check and relink new tables, just link them. 'This version of the utility supports only Access linked tables. It does not support ODBC tables such as SQL Server, 'SharePoint linked table, or any other kind of linked tables. Linked tables other than Access tables are ignored. 'To implement, import all modules and macros into an Access database. If there is already an AutoExec macro, 'copy the one line from this one into the existing one. 'Note: Since Access doesn't always refresh the TableDefs collection when a new table is first linked, 'you may need to close and reopen the database when you first link new tables so that the utility will detect them. 'On startup, all linked tables will be checked automatically. 'For slow networks, or for databases with many (say over 100) linked tables, you can use the "Quick" mode. 'This checks only 1 table in each backend database, and assumes the rest are okay. 'You can use this mode by calling jstCheckTableLinks_Quick. 'To change backend databases, even if the current one is valid, have a form button invoke the code: 'jstCheckTableLinks_Prompt 'This can be useful for switching the backend database between Production, Test and Training, for example. 'For any selected mode (Full, Prompt or Quick) a fourth, optional parameter called CheckAppFolder forces table links 'to a database that resides in the same folder as the application. For example, if a table in ProjectApplication.mdb is 'linked to \\Server\Share\Folder\ProjectData.mdb and there is a database of the same name in the same folder 'as the application, then the table link will be changed to reference the ProjectData.mdb file in the application folder. 'This behavior overrides all prompting for a new location; tables linked to a database in the same folder as the 'application will never be prompted. This mode is helpful for local "work databases" or single user applications. 'If you are using the Display Form default in Access you will need to change that default to (None) so that the 'AutoExec macro will execute to link the files before your first form is displayed. 'To get the form you want to display after the files are linked you need to add a line of code to Open Form 'at the end of the AutoExec. 'This code requires the DAO library to be selected in your References List (e.g. “Microsoft DAO 3.6 Object Library”) 'For more information from the function (such as whether the links are okay and whether the user changed them) call 'Sub jstCheckTableLinks directly and check the value of its output parameters. See the comments in the Sub for more 'details. 'This utility has been used successfully in Access 95, 97, 2000, XP/2002, 2003, 2007 and 2010. It works with MDB and 'ACCDB back-end databases. To link to ACCDB/ACCDE back-end databases, this code must be running in an ACCDB/ACCDE 'front-end application. 'This utility contains some techniques that are backward compatible with older versions of Access, such as InStrRight. 'You may use and distribute this code in your own applications, provided that you leave all comments and notices intact. 'J Street Technology offers this code "as is" and does not assume any liability for bugs or problems with any of the code. 'In addition, we do not provide free technical support for this code. 'Developed by J Street Technology, Inc. 'Www.JStreetTech.com '© 1997 - 2011 '-------------------------------------------------------------------- ' ' Copyright 1996-2013 J Street Technology, Inc. ' www.JStreetTech.com ' ' This code may be used and distributed as part of your application ' provided that all comments remain intact. ' ' J Street Technology offers this code "as is" and does not assume ' any liability for bugs or problems with any of the code. In ' addition, we do not provide free technical support for this code. ' ' Code for Password-masked InputBox was originally written by ' Daniel Klann in March 2003 and has been adapted & updaed for 64-bit ' compatiblity '-------------------------------------------------------------------- Option Compare Database Option Explicit 'Revised Type Declare for compatability with NT 'Re-revised for 64-bit compatibility #If VBA7 Then Type tagOPENFILENAME lStructSize As Long hwndOwner As LongPtr hInstance As LongPtr lpstrFilter As String lpstrCustomFilter As Long nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As LongPtr lpfnHook As LongPtr lpTemplateName As Long End Type Private Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Boolean 'APIs for Password-masked Inputbox Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _ ByVal hHook As LongPtr, _ ByVal ncode As Long, _ ByVal wParam As LongPtr, _ lparam As Any _ ) As LongPtr Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _ ByVal lpModuleName As String _ ) As LongPtr Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As LongPtr, _ ByVal hmod As LongPtr, _ ByVal dwThreadId As Long _ ) As LongPtr Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As LongPtr _ ) As Long Private Declare PtrSafe Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _ ByVal hDlg As LongPtr, _ ByVal nIDDlgItem As Long, _ ByVal wMsg As Long, _ ByVal wParam As LongPtr, _ ByVal lparam As LongPtr _ ) As LongPtr Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" ( _ ByVal hWnd As LongPtr, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long _ ) As Long Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long Private hHook As LongPtr #Else Type tagOPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As Long nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As Long End Type Private Declare Function GetOpenFileName Lib "comdlg32.dll" _ Alias "GetOpenFileNameA" (OPENFILENAME As tagOPENFILENAME) As Long 'APIs for Password-masked Inputbox Private Declare Function CallNextHookEx Lib "user32" ( _ ByVal hHook As Long, _ ByVal ncode As Long, _ ByVal wParam As Long, _ lparam As Any _ ) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" ( _ ByVal lpModuleName As String _ ) As Long Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _ ByVal idHook As Long, _ ByVal lpfn As Long, _ ByVal hmod As Long, _ ByVal dwThreadId As Long _ ) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" ( _ ByVal hHook As Long _ ) As Long Private Declare Function SendDlgItemMessage Lib "user32" Alias "SendDlgItemMessageA" ( _ ByVal hDlg As Long, _ ByVal nIDDlgItem As Long, _ ByVal wMsg As Long, _ ByVal wParam As Long, _ ByVal lparam As Long _ ) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" ( _ ByVal hWnd As Long, _ ByVal lpClassName As String, _ ByVal nMaxCount As Long _ ) As Long Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long Private hHook As Long #End If 'Constants used by Password-masked Inputbox Private Const EM_SETPASSWORDCHAR As Long = &HCC Private Const WH_CBT As Long = 5 Private Const HCBT_ACTIVATE As Long = 5 Private Const HC_ACTION As Long = 0 Private Sub HandleError(strLoc As String, strError As String, intError As Integer) MsgBox strLoc & ": " & strError & " (" & intError & ")", 16, "CheckTableLinks" End Sub Private Function TableLinkOkay(strTableName As String) As Boolean 'Function accepts a table name and tests first to determine if linked 'table, then tests link by performing refresh link. 'Error causes TableLinkOkay = False, else TableLinkOkay = True Dim CurDB As DAO.Database Dim tdf As TableDef Dim strFieldName As String On Error GoTo TableLinkOkayError Set CurDB = DBEngine.Workspaces(0).Databases(0) Set tdf = CurDB.TableDefs(strTableName) TableLinkOkay = True If tdf.Connect <> "" Then '#BGC updated to be more thorough in checking the link by opening a recordset 'ACS 10/31/2013 Added brackets to support spaces in table and field names strFieldName = CurDB.OpenRecordset("SELECT TOP 1 [" & tdf.Fields(0).Name & "] FROM [" & tdf.Name & "];", dbOpenSnapshot, dbReadOnly).Fields(0).Name 'Do not test if nonlinked table End If TableLinkOkay = True TableLinkOkayExit: Exit Function TableLinkOkayError: TableLinkOkay = False GoTo TableLinkOkayExit End Function '---------------------------------------------------------------- Private Function Relink(tdf As TableDef) As Boolean 'Function accepts a tabledef and tests first to determine if linked 'table, then links table by performing refresh link. 'Error causes Relink = False, else Relink = True On Error GoTo RelinkError Relink = True If tdf.Connect <> "" Then tdf.RefreshLink 'Do not test if local or system table End If Relink = True RelinkExit: Exit Function RelinkError: Relink = False GoTo RelinkExit End Function '--------------------------------------------------------------------------- Private Sub RelinkTables(strCurConnectProp As String, intResultcode As Integer) 'This subroutine accepts a table connect property and displays a dialog to allow 'modification of table links. Routine verifies link for each modification. 'intResultcode = 0 if cancel ocx or no link change, 1 if new links OK, and '2 if link check fails. Dim CurDB As DAO.Database Dim NewDB As Database Dim tdf As TableDef Dim strFilter As String Dim strDefExt As String Dim strTitle As String Dim OPENFILENAME As tagOPENFILENAME Dim strFileName As String Dim strFileTitle As String Dim APIResults As Long Dim intSlashLoc As Integer Dim intConnectCharCt As Integer Dim strDBName As String Dim strPath As String Dim strNewConnectProp As String Dim intNumTables As Integer Dim intTableIndex As Integer Dim strTableName As String Dim strSaveCurConnectProp As String Dim strMsg As String Dim varReturnVal Dim strAccExt As String Dim strPassword As String Const OFN_PATHMUSTEXIST = &H1000 Const OFN_FILEMUSTEXIST = &H800 Const OFN_HIDEREADONLY = &H4 On Error GoTo RelinkTablesError 'Returned by GetOpenFileName 'Revised to handle to the Win32 structure 'strFileName = Space$(256) 'strFileTitle = Space$(256) strFileName = String(256, 0) strFileTitle = String(256, 0) Set CurDB = DBEngine.Workspaces(0).Databases(0) strSaveCurConnectProp = strCurConnectProp 'Parse table connect property to get data base name intSlashLoc = 1 intConnectCharCt = Len(strCurConnectProp) Do Until InStr(intSlashLoc, strCurConnectProp, "\") = 0 intSlashLoc = InStr(intSlashLoc, strCurConnectProp, "\") + 1 Loop strDBName = Right$(strCurConnectProp, intConnectCharCt - intSlashLoc + 1) strPath = Right$(strCurConnectProp, intConnectCharCt - 10) strPath = Left$(strPath, intSlashLoc - 12) 'Set up display of dialog 'October 2009 - now handles Access 2007 formats ACCDB and ACCDE strAccExt = "*.accdb; *.mdb; *.mda; *.accda; *.mde; *.accde" strFilter = "Microsoft Office Access (" & strAccExt & ")" & Chr$(0) & strAccExt & Chr$(0) & _ "All Files (*.*)" & Chr$(0) & "*.*" & _ Chr$(0) & Chr$(0) strTitle = "Find new location of " & strDBName strDefExt = "mdb" 'Revisions to handle to the Win32 structure 'See changes to type declare 'Changed from Len to LenB for 64-bit compatibility '----------------------------------------------------------- With OPENFILENAME .lStructSize = LenB(OPENFILENAME) .hwndOwner = Application.hWndAccessApp .lpstrFilter = strFilter .nFilterIndex = 1 .lpstrFile = strDBName & String(256 - Len(strDBName), 0) .nMaxFile = Len(strFileName) - 1 .lpstrFileTitle = strFileTitle .nMaxFileTitle = Len(strFileTitle) - 1 .lpstrTitle = strTitle .Flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY .lpstrDefExt = strDefExt .hInstance = 0 .lpstrCustomFilter = 0 .nMaxCustFilter = 0 .lpstrInitialDir = strPath .nFileOffset = 0 .nFileExtension = 0 .lCustData = 0 .lpfnHook = 0 .lpTemplateName = 0 End With '----------------------------------------------------------- APIResults = GetOpenFileName(OPENFILENAME) intResultcode = APIResults If APIResults = 1 Then '1 if user selected file strNewConnectProp = ";DATABASE=" & OPENFILENAME.lpstrFile If Trim(strNewConnectProp) <> Trim(strSaveCurConnectProp) Then 'Open New Database and create New Connect Property DoCmd.Hourglass True '#BGC Moved to a separate routine and handle the password 'Set NewDB = OpenDatabase(OPENFILENAME.lpstrFile, False, True) strPassword = ExtractPassword(strSaveCurConnectProp) Set NewDB = GetDatabase(OPENFILENAME.lpstrFile, strPassword) If Not NewDB Is Nothing Then 'Set tables connect property to new connect & test If Len(strPassword) Then strNewConnectProp = "MS Access;PWD=" & strPassword & strNewConnectProp End If intNumTables = CurDB.TableDefs.Count varReturnVal = SysCmd(acSysCmdInitMeter, "Linking Access Database", intNumTables) For intTableIndex = 0 To intNumTables - 1 DoEvents varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex) Set tdf = CurDB.TableDefs(intTableIndex) If tdf.Connect = strCurConnectProp Then tdf.Connect = strNewConnectProp strTableName = tdf.Name If Not Relink(tdf) Then 'Link failed, restore previous connect property and generate msgs tdf.Connect = strCurConnectProp intResultcode = 2 'Link failed '#BGC changed the Right to Mid$ and searching on the DATABASE key to handle different starting length strSaveCurConnectProp = Mid$(strSaveCurConnectProp, InStr(1, strSaveCurConnectProp, ";DATABASE=") + 10) strMsg = "Access Table: " & strTableName & " link failed using selected database." & vbCrLf & vbCrLf & "Table is still linked to previous database path: " & strSaveCurConnectProp & "." strTitle = "Failed Access Table Link" MsgBox strMsg, 16, strTitle End If End If Next intTableIndex varReturnVal = SysCmd(acSysCmdRemoveMeter) Else 'Unable to connect to the database, return link failed intResultcode = 2 strMsg = "Relinking selected database failed." & vbCrLf & vbCrLf & "Table(s) are still linked to previous database path: " & Mid$(strSaveCurConnectProp, InStr(1, strSaveCurConnectProp, ";DATABASE=") + 10) & "." strTitle = "Failed Access Table Link" MsgBox strMsg, 16, strTitle End If Else intResultcode = 0 'No change in Link End If End If RelinkTablesExit: Exit Sub RelinkTablesError: HandleError "RelinkTables", Error, Err Resume RelinkTablesExit Resume End Sub '------------------------------------------------------------------ Public Sub jstCheckTableLinks(CheckMode As String, LinksChanged As Boolean, LinksOK As Boolean, Optional CheckAppFolder As Boolean) ' 'INPUT: 'CheckMode = "prompt", Subroutine queries operator for location of ' each database required by linked tables. Msgbox for each failed link ' and summary Msgbox on final link status (success or failure) if any ' links were changed. If no links changed, then no summary status. ' 'CheckMode = "full", Subroutine identifies invalid table links ' and queries operator for location of database(s) required to satisfy ' failed links. Msgbox for each failed link and summary Msgbox ' if link failures. No Msgbox appears if all links are valid. ' 'CheckMode = "quick", same as "full" except that only the first table for ' each linked database is checked. If the link is not valid, the user is ' is prompted for the location of the database and all tables in that ' database are relinked. ' 'CheckAppFolder = True, override linked table connections if the same database name ' exists in the application folder. If False or not specified, no override occurs. ' 'OUTPUT: 'LinksChanged = true if at least one table link was changed. ' false if no links where changed. 'LinksOK = true if all links are OK upon subroutine exit. ' false if least one table link was not successful. '-------------------------------------------------------------------- Dim CurDB As Database Dim tdf As TableDef Dim TableConnectPropBadArray() As String, intDBBadCount As Integer Dim TableConnectPropChkArray() As String, intDBChkCount As Integer Dim UniquePathArray() As Variant, intDBCount As Integer, intDBIndex As Integer, intDBOverrideIndex As Integer Dim bOverride As Boolean Dim bPathFound As Boolean Dim strUniqueDBPath As String Dim strFileSearch As String Dim intTableIndex As Integer Dim intNumTables As Integer Dim strTableName As String Dim strFieldName As String Dim intBadIndex As Integer Dim intChkIndex As Integer Dim fFound As Integer Dim fAllFound As Integer Dim fLinkGood As Integer Dim strCurConnectProp As String Dim intResultcode As Integer Dim strMsg As String Dim strTitle As String Dim intNoLinksChanged As Integer Dim varReturnVal As Variant Dim strPassword As String On Error GoTo CheckTableLinksError DoCmd.Hourglass True varReturnVal = SysCmd(acSysCmdSetStatus, "Checking linked databases.") Set CurDB = DBEngine.Workspaces(0).Databases(0) 'Get number of tables. intNumTables = CurDB.TableDefs.Count ReDim TableConnectPropBadArray(intNumTables) 'Set largest size ReDim TableConnectPropChkArray(intNumTables) 'Set largest size ReDim UniquePathArray(intNumTables, 1) 'If app configured to first check in applicaiton folder for linked databases If CheckAppFolder = True Then For intTableIndex = 0 To intNumTables - 1 Set tdf = CurDB.TableDefs(intTableIndex) 'If there is a connect string If tdf.Connect & "" <> "" Then '#BGC Commented -- the loop is not needed when doing CheckAppFolder since we're overriding ' bPathFound = False ' 'Loop through the array to check for pre-existence of database to preserve uniqueness of db paths ' For intDBIndex = 0 To (intNumTables - 1) ' If tdf.Connect = UniquePathArray(intTableIndex, 0) Then ' bPathFound = True ' Exit For ' End If ' Next ' 'If the path was not found in the array, add it to the unique array of paths. ' If bPathFound = False Then UniquePathArray(intDBCount, 1) = 0 UniquePathArray(intDBCount, 0) = tdf.Connect intDBCount = intDBCount + 1 ' End If End If Next 'Loop through all databases in array; set Override 'flag'(second column of array) For intDBIndex = 0 To intDBCount strUniqueDBPath = UniquePathArray(intDBIndex, 0) UniquePathArray(intDBIndex, 1) = ExistsInAppFolder(strUniqueDBPath) Next End If 'Set up Array of Databases (all if forcelink is true, failed links if ' forcelink is false) (local and system tables will pass test). varReturnVal = SysCmd(acSysCmdInitMeter, "Checking linked databases.", intNumTables) LinksOK = True 'Assume success For intTableIndex = 0 To intNumTables - 1 DoEvents varReturnVal = SysCmd(acSysCmdUpdateMeter, intTableIndex) Set tdf = CurDB.TableDefs(intTableIndex) fFound = False If tdf.Connect Like "*;DATABASE=*" Then 'BGC -- changed from NOT "ODBC" to = ";DATABASE=" explicitly to get Access tables only strCurConnectProp = tdf.Connect If CheckAppFolder = True Then bOverride = False For intDBOverrideIndex = 0 To intDBCount If tdf.Connect & "" <> "" And tdf.Connect = UniquePathArray(intDBOverrideIndex, 0) And UniquePathArray(intDBOverrideIndex, 1) = True Then bOverride = True strFileSearch = UniquePathArray(intDBOverrideIndex, 0) strPassword = ExtractPassword(tdf.Connect) If Len(strPassword) Then strPassword = "MS Access;PWD=" & strPassword End If tdf.Connect = strPassword & ";DATABASE=" & PathOnly(CurDB.Name) & FileOnly(strFileSearch) Exit For End If Next End If If bOverride = True Then If Not Relink(tdf) Then 'Link failed, restore previous connect property and generate msgs tdf.Connect = strCurConnectProp 'intResultcode = 2 'Link failed strMsg = "Application Folder Table: " & tdf.Name & " link failed." & vbCrLf & vbCrLf & "The current path for this linked table is: " & Mid$(strCurConnectProp, InStr(1, strCurConnectProp, ";DATABASE=") + 10) & "." strTitle = "Failed Table Link" MsgBox strMsg, 16, strTitle End If Else ' regular table, not overridden Select Case CheckMode Case "prompt" ' put each connect string into the Bad array to force prompting later For intBadIndex = 0 To intDBBadCount If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then fFound = True Exit For End If Next intBadIndex If Not fFound Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 End If Case "full" ' check each link, and put each bad connect string into ' the Bad array to prompt later For intBadIndex = 0 To intDBBadCount If tdf.Connect = TableConnectPropBadArray(intBadIndex) Then fFound = True Exit For End If Next intBadIndex If Not fFound Then If Not TableLinkOkay(tdf.Name) Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 LinksOK = False End If End If Case "quick" ' for each link, see if it has already been checked. ' if it hasn't, add it to the checked array, ' and check it. If the link is bad, add it to the bad array to prompt later. For intChkIndex = 0 To intDBChkCount If tdf.Connect = TableConnectPropChkArray(intChkIndex) Then fFound = True Exit For End If Next intChkIndex If Not fFound Then TableConnectPropChkArray(intDBChkCount) = tdf.Connect intDBChkCount = intDBChkCount + 1 If Not TableLinkOkay(tdf.Name) Then TableConnectPropBadArray(intDBBadCount) = tdf.Connect intDBBadCount = intDBBadCount + 1 LinksOK = False End If End If Case Else MsgBox "CheckMode parameter """ & CheckMode & """ is not valid. It must be ""prompt"", ""full"" or ""quick"".", vbCritical + vbOKOnly LinksChanged = False GoTo CheckTableLinksExit End Select End If ' overridden table End If ' an Access linked table Next intTableIndex varReturnVal = SysCmd(acSysCmdRemoveMeter) 'Prompt user to locate each database in TableConnectPropBadArray. varReturnVal = SysCmd(acSysCmdSetStatus, "Linking databases.") fAllFound = True 'Assume success in relinking all tables. intNoLinksChanged = 0 'Avoid successful message if no links were changed. For intBadIndex = 0 To intDBBadCount - 1 DoEvents strCurConnectProp = TableConnectPropBadArray(intBadIndex) RelinkTables strCurConnectProp, intResultcode intNoLinksChanged = intNoLinksChanged + intResultcode If CheckMode = "prompt" Then If intResultcode = 2 Then fAllFound = False 'Failed relink. Else If Not intResultcode = 1 Then fAllFound = False End If Next intBadIndex 'Display summary messages based upon forcelink value strTitle = "Database Links" If fAllFound = False Then strMsg = "One or more Access database tables may not be correctly linked." MsgBox strMsg, 16, strTitle LinksOK = False Else If CheckMode = "prompt" And intNoLinksChanged <> 0 Then strMsg = "All Access databases were linked successfully." MsgBox strMsg, 0, strTitle End If If CheckMode <> "prompt" Then LinksOK = True End If 'Setup links changed flag. If intNoLinksChanged = 0 Then LinksChanged = False Else LinksChanged = True End If CheckTableLinksExit: DoCmd.Hourglass False varReturnVal = SysCmd(acSysCmdClearStatus) Exit Sub CheckTableLinksError: HandleError "CheckTableLinks", Error, Err Resume CheckTableLinksExit End Sub Public Function jstCheckTableLinks_Prompt() 'prompt for new database locations of linked tables jstCheckTableLinks CheckMode:="prompt", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Public Function jstCheckTableLinks_Full() 'check linked tables jstCheckTableLinks CheckMode:="full", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Public Function jstCheckTableLinks_Quick() 'check linked tables, only the first per database jstCheckTableLinks CheckMode:="quick", LinksChanged:=False, LinksOK:=False, CheckAppFolder:=False End Function Private Function ExistsInAppFolder(strPath As String) As Boolean On Error GoTo Err_ExistsInAppFolder Dim db As Database Dim i As Integer Dim lngPos As Long Dim strDBName As String Dim strAppPath As String Dim strCurrPath As String ExistsInAppFolder = False Set db = CurrentDb strDBName = FileOnly(strPath) strCurrPath = PathOnly(db.Name) If FileExists(strCurrPath & strDBName) Then ExistsInAppFolder = True End If Exit_ExistsInAppFolder: On Error Resume Next db.Close Set db = Nothing Exit Function Err_ExistsInAppFolder: ExistsInAppFolder = False Resume Exit_ExistsInAppFolder Resume End Function Private Function FileExists(Path As Variant) As Boolean On Error GoTo Err_FileExists Dim varRet As Variant If IsNull(Path) Then FileExists = False Exit Function End If varRet = Dir(Path) If Not IsNull(varRet) And varRet <> "" Then FileExists = True Else FileExists = False End If Exit_FileExists: Exit Function Err_FileExists: FileExists = False Resume Exit_FileExists End Function Private Function FileOnly(WholePath As Variant) As Variant On Error GoTo Err_FileOnly Dim FileOnlyPos If IsNull(WholePath) Then FileOnly = Null Exit Function End If FileOnlyPos = InStrRight(WholePath, "\") + 1 FileOnly = Mid(WholePath, FileOnlyPos) Exit_FileOnly: Exit Function Err_FileOnly: MsgBox Err.Number & ", " & Err.Description Resume Exit_FileOnly End Function Private Function PathOnly(WholePath As Variant) As Variant On Error GoTo Err_PathOnly Dim FileOnlyPos If IsNull(WholePath) Then PathOnly = Null Exit Function End If FileOnlyPos = InStrRight(WholePath, "\") + 1 PathOnly = Left(WholePath, FileOnlyPos - 1) Exit_PathOnly: Exit Function Err_PathOnly: MsgBox Err.Number & ", " & Err.Description Resume Exit_PathOnly End Function Private Function InStrRight(SearchString As Variant, soughtString As Variant) As Variant On Error GoTo Err_InStrRight Dim SoughtLen As Integer Dim Found As Integer Dim Pos As Integer If IsNull(SearchString) Or IsNull(soughtString) Then InStrRight = Null Exit Function End If If SearchString = "" Or soughtString = "" Then InStrRight = 0 Exit Function End If SoughtLen = Len(soughtString) Found = False Pos = Len(SearchString) - SoughtLen + 1 Do While Pos > 0 And Not Found If Mid(SearchString, Pos, SoughtLen) = soughtString Then Found = True Else Pos = Pos - 1 End If Loop InStrRight = Pos Exit_InStrRight: Exit Function Err_InStrRight: MsgBox Err.Number & ", " & Err.Description Resume Exit_InStrRight End Function Private Function GetDatabase( _ strDatabasePath As String, _ strPassword As String _ ) As DAO.Database Dim db As DAO.Database Dim lngTries As Long Do On Error GoTo NoPasswordErrHandler Set db = DBEngine.OpenDatabase(strDatabasePath, False, True, "MS Access;PWD=" & strPassword) On Error GoTo ErrHandler If db Is Nothing Then If Len(strPassword) Then MsgBox "Invalid password.", vbCritical, "Try again." End If strPassword = InputBoxDK("The database requires a password to open. Please provide a password.", "Password-protected database.") lngTries = lngTries + 1 If Len(strPassword) = 0 Then Exit Do End If End If Loop While db Is Nothing And lngTries < 3 Set GetDatabase = db ExitProc: On Error Resume Next Exit Function NoPasswordErrHandler: If Err.Number = 3031 Then Set db = Nothing Resume Next End If ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function Private Function ExtractPassword(strConnectionString As String) As String Dim lngleft As Long Dim lngRight As Long Const pwd As String = "PWD=" On Error GoTo ErrHandler lngleft = InStr(1, strConnectionString, pwd) If lngleft Then lngleft = lngleft + Len(pwd) lngRight = InStr(lngleft, strConnectionString, ";") If lngRight = 0 Then 'No ending semicolon was found; return the whole substring lngRight = Len(strConnectionString) End If ExtractPassword = Mid$(strConnectionString, lngleft, lngRight - lngleft) Else ExtractPassword = vbNullString End If ExitProc: On Error Resume Next Exit Function ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function #If VBA7 Then Private Function InputBoxPasswordMaskProc( _ ByVal lngCode As Long, _ ByVal wParam As LongPtr, _ ByVal lparam As LongPtr _ ) As LongPtr #Else Private Function InputBoxPasswordMaskProc( _ ByVal lngCode As Long, _ ByVal wParam As Long, _ ByVal lparam As Long _ ) As Long #End If 'DO NOT PUT IN VBA ERROR HANDLING 'This is a Windows procedure called by Message loop. On Error Resume Next 'Originally written by Daniel Klann 'Updated for 64-bit compatibility Dim RetVal Dim strClassName As String Dim lngBuffer As Long If lngCode < HC_ACTION Then InputBoxPasswordMaskProc = CallNextHookEx(hHook, lngCode, wParam, lparam) Exit Function End If strClassName = String$(256, " ") lngBuffer = 255 If lngCode = HCBT_ACTIVATE Then 'A window has been activated RetVal = GetClassName(wParam, strClassName, lngBuffer) If Left$(strClassName, RetVal) = "#32770" Then 'Class name of the Inputbox 'This changes the edit control so that it display the password character *. 'You can change the Asc("*") as you please. SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0 End If End If 'This line will ensure that any other hooks that may be in place are 'called correctly. CallNextHookEx hHook, lngCode, wParam, lparam End Function Private Function InputBoxDK( _ Prompt, _ Optional Title, _ Optional Default, _ Optional XPos, _ Optional YPos, _ Optional HelpFile, _ Optional Context _ ) As String 'Originally written by Daniel Klann 'Updated for 64-bit compatibility 'Replicate the functionality of Inputbox function 'while providing password masking. #If VBA7 Then Dim lngModHwnd As LongPtr #Else Dim lngModHwnd As Long #End If Dim lngThreadID As Long On Error GoTo ErrHandler lngThreadID = GetCurrentThreadId lngModHwnd = GetModuleHandle(vbNullString) hHook = SetWindowsHookEx(WH_CBT, AddressOf InputBoxPasswordMaskProc, lngModHwnd, lngThreadID) InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) UnhookWindowsHookEx hHook ExitProc: On Error Resume Next Exit Function ErrHandler: Select Case Err.Number Case Else VBA.MsgBox "Error " & Err.Number & " (" & Err.Description & ")" End Select Resume ExitProc Resume 'for Debugging End Function 'Hope someone can use it! 2. اعمل Macro ، واحفظه باسم autoexec (هذا معناه بانه سيكون اول شئ يشتغل في قاعدة البيانات لما تفتح) ، في السطر الاول اختر: Runcode ثم ضع السطر التالي كاسم للكود: jstCheckTableLinks_Full() وبعدها تقدر ان تضع سطر آخر ليفتح اي نموذج. الكود سيفحص الجداول ، واذا لم يجد الرابط ، فسيفتح نافذة يسمح للمستخدم ان يختار برنامج الجداول ومساره ، وبسهولة جعفر

أحبابي وإخواني الأعزاء لقد افتقدتكم جميعاً ويعلم الله لم يمنعني عنكم إلا الظروف الشديدة والحمد لله على كل حال . هذه هدية متواضعة لكم أحبابي . هام جداً : أرجو قبل التعامل مع الملف ضرورة الاطلاع على ورقة شرح الملف والتي أسميتها " HELP" ويمكن الانتقال إليها وسائر الأوراق من مفتاح " الانتقال إلى " والموجود بكل الأوراق ، وأرجو أن تكون الفكرة فيها ولو بعض الفائدة . وتقبلوا حبي وتقديري أبو عبدالله _________________________________.rar