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

اخي عبد السلام تسلم اديك هذه المعادلة ستكون بالفعل افضل حل في حالة ثبات وعدم تفاوت السعر تحياتي

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

تفضل ما تريد (الصفحة 3) Code or ID advanced.rar

بسم الله الرحمان الرحيم السلام عليكم اولا ما هو النص التنبئي باختصار هو تنبئ البرنامج او الدالة او الكود بالكلمات التي تبحث عنها من خلال كتابة اول حروف الكلمة مثل مايحدث اثناء البحث عن طريق محرك البحث قوقل هذا الموضوع ليس جديد فهناك كود في المنتدى يعتمد على مربع نص وليست بوكس لاكني منذ فترة حاولت تطبيق الامر على الكمبوبوكس الى ان وفقني الله الى ذلك وها انا الان اشارككم الموضوع ما هي الفائدة من هذا الموضوع كثيرا ما يكون لدينا قاعدة بيانات كبيرة مثلا الاصناف في الفواتير و غالبا متكون عمليات الادخال خاصتا مكررة و كثيرة فهذه الطريقة ستساعدك كثيرا في ادخال الاصناف بسلاسة وسهولة بدل عناء اعادت كتابت الصنف مرارا وتكرارا لا اطيل عليكم في المرفق تجد مثال توضيحي احدهما مطبق على الشيت وهو مايهم اصحاب ادخالات الفواتير والثاني مطبق على الفورم صورة توضيحية بالنسبة للمثال المطبق على الشيت كما في الصورة من جهة اليمين عند الضغط على اي خلية ملونة بالاخضر تظهر كمبوبكس اكتب داخلها اي حرف لتجلب لك الكلمات التي تحمل تلك الحرف كما في الصورة يمكنك التنقل بين النتائج بواسطة سهم الاعلى والاسفل من الكبيور اضغط انتلر لادخال النتيجة في الخلية وانتقال الكمبو الى اسفل الخلية المفعلة بالنسبة للمثال المطبق على الفورم كما في الصورة من جهة اليسار نفس الامر كما في المثال الاول فقط الاختلاف في ان ادالبحث يكون من الفورم ارجو ان يكون الموضوع مفيد للجميع تحياتي للجميع تنويه تم استبدال المرفق بعد 23 تحميل texte prédictive 2007 2003.rar

السلام عليكم ورحمة الله وبركاته إخواني الكرام في الصرح العملاق أوفيسنا (الذي يعتبر بمثابة الأم التي تحتضن أبناء الوطن جميعهم) أقدم لكم موضوع بسيط جدا في كيفية تظليل عمود وصف الخلية النشطة بناءً على رغبة الأخ الحبيب أحمد غانم (حفظه الله ورعاه) إذا أردت تنفيذ الفكرة بنفسك قم بعمل الآتي : أولاً حدد خلايا ورقة العمل بأكملها ..مش صعبة يا أحمد ثانياً روح للتنسيق الشرطي ..واختار New Rule ثم Use a formula to determine which cells to format ثم اكتب المعادلة التالية : =COLUMN()=COLUMN(INDIRECT($P$1)) اضغط Format ثم التبويب Fill واختار اللون اللي على مزاجك (يا لذيذ يا رايق) كرر نفس الخطوات السابقة مرة أخرى واكتب المعادلة التالية أيضاً .. =ROW()=ROW(INDIRECT($P$1)) ثالثاً : كليك يمين على ورقة العمل ثم View Code واكتب الكود التالي : Private Sub Worksheet_SelectionChange(ByVal Target As Range) Application.ScreenUpdating = False Range("P1").Value = Target.Address Application.ScreenUpdating = True End Sub رابعاً ودي أهم خطوة : بس خلاص جرب الملف المرفق .. في الملف المرفق قمت بتلوين بعض النطاقات ، وعمل تنسيق شرطي للتأكد من أن الكود لا يؤثر بأي حال على التنسيق الشرطي الموجود ولا على الخلايا التي تم تلوينها من قبل ، ويسمح أيضاً بتلوين أي خلايا تريدها Highlight Activecell's Row And Column V2.rar

كيف تغرف ارقام الاعمدة من A الى ما تريد(حسب تحديد العدد) انظر الى المرفق column_number.rar

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

كل عام و انتم بخير بمناسبة قرب حلول الشهر الفضيل

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة المساعدة في عمل باسورد لشيت بداخل ملف الاكسيل تم ارفاق كود الحل من الفاضل / حمادة عمر اسم المستخدم : SAMA " حروف كبيرة " كلمة المرور : 12345 و لا تنسونا من صالح الدعاء تحياتى شاشة دخول ورقم سري لشيت معين.rar

السادة الافاضل كل عام و انتمك بخير بمناسبة شهر رمضان المعظم اعاده الله علينا و على امة سيدنا محمد بالخير و اليمن و البركاته برجاء تصحيح معادلة الشهادات لتظهر شهادات الراسبين فقط عند فلترة شيت الدور الثانى رابط المستند هو http://up.top4top.net/downloadf-1553esc1-rar.html و بارك الله فيكم

الاخ ناصر سعيد لقدروفقن الله وعرفت المشكله وهي مسح منطقة الاخراج قبل الفلتره فيكون الكود كالتالي تم اضافة كومبوبكس لأختيار التقدير وتم تعديل التقيرات في الصفحة الرئيسية لتشمل كل التقديرات لتوضيح عمل الكود Sub kh_Filter() ' Dim LR As Long With Sheet2 .Range(.Cells(9, 1), .Cells(Rows.Count, Columns.Count)).ClearContents End With With Sheet1 LR = .Cells(.Rows.Count, "AF").End(xlUp).Row .Range("AD6:BH" & LR).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("A1:A2"), CopyToRange:=Sheet2.Range("C9"), Unique:=True End With Range("a3").Select LR = Cells(Rows.Count, "AF").End(xlUp).Row ActiveSheet.PageSetup.PrintArea = Range("b2:AB" & LR).Address ' End Sub انظر المرفقات كود فلتره 9.rar مع حبي وتقديري

كل عام وانتم بخير اعاننا الله وإياكم على صيامه وقيامه

بعد اذنكم .. لما لا تجرب هذه المعادلة =INT((E2+10)/20)

تم التعديل على ملف أخي ياسر العربي Book1.rar

تفضل ما تريد (الصفحة 3) تم التعديل على الملف Code or ID advanced 1.rar

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

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

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

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

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة سند قبض تم ارفاق كود الحل من الفاضل/ طلعت محمد حسن و لا تنسونا من صالح الدعاء تحياتى سند قبض1_طلعت حسن).rar

شكرا جزيلا اخى الكريم تمام هذا هو المطلوب تحياتى لك

السلام عليكم ورحمة الله طرح من قبل فكرة برامج حسابات مفتوح الكود ومشاركة المبرمجين والمحاسبين لتطوير هذا البرامج بشرط أن يكون مفتوح الكود ليتم تطويره من أي مبرمج لكن لم أجد تثنية ولا أدري هل في الفكرة فيه شيء المهم رجعت للفكرة مرة اخرى بعد سؤال الاخ sonysam وطلبه تعديل برامج البيان للمحاسبة وقد ابدى الاخوة خيرا وانا قمت ببعض التطوير قبل سؤال الاخ وسارسله واطلب من الاخوة التعليق والتطوير والمشاركة مع العلم اني تعلمت في هذا المنتدى ومازلت طالبا فيه لم ادرس في كلية ولا جامعة ولا معهد حتى بل منتدى اوفيسنا والفريق العربي فقط واود شكرهم وقد استخدمت ما تعلمته وبعض الاكواد التي اتحفونا بها ومرفق برنامج البيان الاصدار 1.1 كما سميته وليكن اي تطوير بزيادة 0.1 لهذه النسخة Albayan_new.rar

هل هذا ما تقصده ان لم يكن يرجى الايضاح وشكرا Book1.rar

جزاك الله خير استاذ سليم .. ملف مفيد ويوفر الكثير من الوقت

تم النقل الي قسم الاكسيس تنقيح المواضيع القديمة

تفضل ... wael2.rar

اذا كان عدد الحقول قليل فتستطيع ان تقول الحقل 1 ="" الحقل 2 ="" و هكذا او الحقول كثيرة فتستطيع حذف السجل بالكامل هذا طبعا ان لم يكن له حقل ترقيم تلقائي ...

عذرا اخي الفكره كلها في حرف P اخذفه من السطر الرابع ستحل المشكلة ان شاء الله وسيكون الكود علي الشكل التالي والشكر موصول للاخ عمر الحسيني Private Sub CommandButton1_Click() Dim Sh As Shape For Each Sh In ActiveSheet.Shapes If Sh.Type = msoAutoShape Or Sh.Type = msoTextBox Then Sh.Delete Next Sh End Sub

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

السلام عليكم اخي انظر التعديل حيث تم وضع كود في حدث قبل تحديث للقائمة Product name New Microsoft Access Database.rar

جرب استبدل الكلمة Currency بهذه Double

اجعل القيمة الافتراضية = صفر واختر التنسيق Short Time او اجعل القيمة الافتراضية خالية واستخدم الدالة NZ عند اجراء العمليات مثال : nz([text1])+nz([text2])

تفضل اخى الكريم أستفسار حول عمل تقرير مقارن(1).rar اخى الكريم يمكنك مراجعة معايير الاستعلام الوقت والتاريخ من هذا الرابط من ميكروسوفت https://support.office.com/ar-sa/article/%D8%A3%D9%85%D8%AB%D9%84%D8%A9-%D9%84%D9%85%D8%B9%D8%A7%D9%8A%D9%8A%D8%B1-%D8%A7%D9%84%D8%A7%D8%B3%D8%AA%D8%B9%D9%84%D8%A7%D9%85-3197228c-8684-4552-ac03-aba746fb29d8#bm4

أخي الكريم انظر لتلك المعادلة =SUMPRODUCT(--($D$2:$D$50="متزوج"),--($C$2:$C$50>75000)) يمكن ببساطة وضع علامة زائد في آخر المعادلة وتكرار نفس المعادلة مرة أخرى وتغيير كلمة "متزوج" إلى "متزوجة" ليحقق لك الهدف إن شاء الله بهذا الشكل =SUMPRODUCT(--($D$2:$D$50="متزوج"),--($C$2:$C$50>75000))+SUMPRODUCT(--($D$2:$D$50="متزوجة"),--($C$2:$C$50>75000)) أرجو أن يفي بالغرض

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

السلام عليكم اخي الكريم هذا كود التفقيط ضعه في وحدة نمطية واستدعيه ضمن مربع النص Function NoToTxt(TheNo As Double, MyCur As String, MySubCur As String) As String Dim MyArry1(0 To 9) As String Dim MyArry2(0 To 9) As String Dim MyArry3(0 To 9) As String Dim MyNo As String Dim GetNo As String Dim RdNo As String Dim My100 As String Dim My10 As String Dim My1 As String Dim My11 As String Dim My12 As String Dim GetTxt As String Dim Mybillion As String Dim MyMillion As String Dim MyThou As String Dim MyHun As String Dim MyFraction As String Dim MyAnd As String Dim i As Integer Dim ReMark As String If TheNo > 999999999999.99 Then Exit Function If TheNo = 0 Then NoToTxt = "صفر" Exit Function End If MyAnd = " و" MyArry1(0) = "" MyArry1(1) = "مائة" MyArry1(2) = "مائتان" MyArry1(3) = "ثلاثمائة" MyArry1(4) = "أربعمائة" MyArry1(5) = "خمسمائة" MyArry1(6) = "ستمائة" MyArry1(7) = "سبعمائة" MyArry1(8) = "ثمانمائة" MyArry1(9) = "تسعمائة" MyArry2(0) = "" MyArry2(1) = " عشر" MyArry2(2) = "عشرون" MyArry2(3) = "ثلاثون" MyArry2(4) = "أربعون" MyArry2(5) = "خمسون" MyArry2(6) = "ستون" MyArry2(7) = "سبعون" MyArry2(8) = "ثمانون" MyArry2(9) = "تسعون" MyArry3(0) = "" MyArry3(1) = "واحد" MyArry3(2) = "اثنان" MyArry3(3) = "ثلاثة" MyArry3(4) = "أربعة" MyArry3(5) = "خمسة" MyArry3(6) = "ستة" MyArry3(7) = "سبعة" MyArry3(8) = "ثمانية" MyArry3(9) = "تسعة" '====================== GetNo = Format(TheNo, "000000000000.00") i = 0 Do While i < 15 If i < 12 Then MyNo = Mid$(GetNo, i + 1, 3) Else MyNo = "0" + Mid$(GetNo, i + 2, 2) End If If (Mid$(MyNo, 1, 3)) > 0 Then RdNo = Mid$(MyNo, 1, 1) My100 = MyArry1(RdNo) RdNo = Mid$(MyNo, 3, 1) My1 = MyArry3(RdNo) RdNo = Mid$(MyNo, 2, 1) My10 = MyArry2(RdNo) If Mid$(MyNo, 2, 2) = 11 Then My11 = "إحدى عشر" If Mid$(MyNo, 2, 2) = 12 Then My12 = "إثنى عشر" If Mid$(MyNo, 2, 2) = 10 Then My10 = "عشرة" If ((Mid$(MyNo, 1, 1)) > 0) And ((Mid$(MyNo, 2, 2)) > 0) Then My100 = My100 + MyAnd If ((Mid$(MyNo, 3, 1)) > 0) And ((Mid$(MyNo, 2, 1)) > 1) Then My1 = My1 + MyAnd GetTxt = My100 + My1 + My10 If ((Mid$(MyNo, 3, 1)) = 1) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My11 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My11 End If If ((Mid$(MyNo, 3, 1)) = 2) And ((Mid$(MyNo, 2, 1)) = 1) Then GetTxt = My100 + My12 If ((Mid$(MyNo, 1, 1)) = 0) Then GetTxt = My12 End If If (i = 0) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then Mybillion = GetTxt + " مليار" Else Mybillion = GetTxt + " مليارات" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " مليار" If ((Mid$(MyNo, 1, 3)) = 2) Then Mybillion = " ملياران" End If End If If (i = 3) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyMillion = GetTxt + " مليون" Else MyMillion = GetTxt + " ملايين" If ((Mid$(MyNo, 1, 3)) = 1) Then MyMillion = " مليون" If ((Mid$(MyNo, 1, 3)) = 2) Then MyMillion = " مليونان" End If End If If (i = 6) And (GetTxt <> "") Then If ((Mid$(MyNo, 1, 3)) > 10) Then MyThou = GetTxt + " ألف" Else MyThou = GetTxt + " آلاف" If ((Mid$(MyNo, 3, 1)) = 1) Then MyThou = " ألف" If ((Mid$(MyNo, 3, 1)) = 2) Then MyThou = " ألفان" End If End If If (i = 9) And (GetTxt <> "") Then MyHun = GetTxt If (i = 12) And (GetTxt <> "") Then MyFraction = GetTxt End If i = i + 3 Loop If (Mybillion <> "") Then If (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then Mybillion = Mybillion + MyAnd End If If (MyMillion <> "") Then If (MyThou <> "") Or (MyHun <> "") Then MyMillion = MyMillion + MyAnd End If If (MyThou <> "") Then If (MyHun <> "") Then MyThou = MyThou + MyAnd End If If MyFraction <> "" Then If (Mybillion <> "") Or (MyMillion <> "") Or (MyThou <> "") Or (MyHun <> "") Then NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur + MyAnd + MyFraction + " " + MySubCur Else NoToTxt = ReMark + MyFraction + " " + MySubCur End If Else NoToTxt = ReMark + Mybillion + MyMillion + MyThou + MyHun + " " + MyCur End If End Function

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

أخي الكريم طرازان هل اطلعت على هذا الموضوع http://www.officena.net/ib/index.php?showtopic=57813&hl=

ههههه .. ظريف .. واعذرني على هذه الغفلة والاجابة يسيرة وهي ان تضع كلمة المرور الخاصة بقاعدة الجداول داخل الكود الكود موجود في محرر نموذج البداية كالتالي : If CheckLinks("ضع كلمة المرور هنا") = False Then Call Quit End If

وهذه طريقة اخرى مع مثال من استاذنا أبوخليل 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() وبعدها تقدر ان تضع سطر آخر ليفتح اي نموذج. الكود سيفحص الجداول ، واذا لم يجد الرابط ، فسيفتح نافذة يسمح للمستخدم ان يختار برنامج الجداول ومساره ، وبسهولة جعفر

تسلم أخي الحبيب محمد أبو عباس الأكواد منقولة منقولة ..ما كلنا بننقل أو معظمنا .. نشوف المفيد اللي نقدر نفيد بيه غيرنا ونضعه بالمكتبة ..يبقا مرجع للجميع إن شاء الله بعد ما يكتمل العمل قليلاً ستحس بالفرق تقبل تحياتي (وياريت تبقا تزورنا كل يوم بكود ..لو صعب يبقا كودين كل يوم ..لو شايف إن دا هيكون أمر مستحيل يبقا تجيب معاك 3 أكواد كل يوم)

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Excel.Range) Static OldCell As Range If Not OldCell Is Nothing Then OldCell.Interior.ColorIndex = xlColorIndexNone End If Target.Interior.ColorIndex = 6 Set OldCell = Target End Sub السلام عليكم اخي الحبيب ابو البراء زادكم الله من فضله علما وشرفا هذه مشاركة بسيطة عشان ماتبقاش جنب الجهاز بخاف على نظرك انت عزيز علينا وهو كود تلوين الخلية النشطة تقبلوافائق احترامي وتقديري

إخواني الكرام وهذا إصدار آخر مختلف قليلاً عن الإصدار رقم 2 حيث أنه أصلا طلب الأخ أحمد غانم أن يكون بهذا الشكل ... :fff: Highlight Activecell's Row And Column V3.rar

أخى فى الله الأستاذ الكريم// خالد العنانى يمكن ذلك فقط اجعل الكود هكذا Sub Printing() ActiveSheet.Unprotect Password:="12345" Rows([Row] & ":300").EntireRow.Hidden = True ActiveWindow.SelectedSheets.PrintPreview 'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False Rows("8:300").EntireRow.Hidden = False ActiveSheet.Protect Password:="12345" End Sub واليكم الملف بعد اضافة الكود وتقبلوا منى وافر الاحترام والتقدير قيود بكشف حساب 11.rar

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

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

هذه المشاركة لأحد الزملاء بالمنتدى رفعته كما هو دون تغيير "طباعة الحقول الممتلئة فقط" طباعة الحقول الممتلئة فقط.rar

أخى الفاضل / فراس أشكركم على الملاجظة .. وتم عمل اللازم اخفاء وطباعة المطلوب 2اخفاء واظهار أية قيمة.rar