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

بسم الله الرحمن الرحيم اليوم اقدم لكم بحث متقدم للبحث عن الاسم بالحرف او الكلمة او الجملة وعرض النتائج في كمبوبوكس والليست بوكس وايضا تم اضافة امكانية تحديد الاسم من الليست بوكس وعمل شيت بنفس الاسم المحدد داخل اللسيت كما يمكنك ايضا من الذهاب الى شيت الاسم المحدد داخل الليست بوكس الكود المستخدم داخل الملف كود البحث Private Sub ComboBox1_Change() Dim a() Dim b, c, d, e Dim Ws As Worksheet: Set Ws = Sheets("Sheet1") Dim l As MSForms.ComboBox: Set l = Me.ComboBox1 Dim i As Long: i = 0 e = Ws.Range("a40000").End(xlUp).Row a = Ws.Range("A2:a" & e).Value With Me.ComboBox1 .List = a .ListRows = 20 .MatchEntry = fmMatchEntryNone .TextAlign = fmTextAlignCenter End With Set b = CreateObject("Scripting.Dictionary") d = "*" & UCase(Me.ComboBox1) & "*" For Each c In a If UCase(c) Like d Then b(c) = "" Next c Me.ComboBox1.List = b.keys While i < l.ListCount If "" = Trim$(l.List(i, 0)) Then: l.RemoveItem (i): Else i = 1 + i Wend ListBox1.AddItem ListBox1.List = ComboBox1.List End Sub كود اضافة شيت بالاسم المختار من الليست بوكس Private Sub CommandButton1_Click() Dim Ws As Worksheet Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next Set Ws = Worksheets(CStr(ListBox1.Text)) On Error GoTo 0 If Ws Is Nothing Then Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = CStr(ListBox1.Text) Sheet1.Activate Set Ws = Nothing End If Application.EnableEvents = True Application.ScreenUpdating = True End Sub كود الذهاب الى شيت الاسم المختار Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Dim Ws As Worksheet On Error Resume Next Set Ws = Worksheets(CStr(ListBox1.Value)) Ws.Activate Set Ws = Nothing End Sub لتحمل البرنامج اضغط هنا تقبلو تحياتي ياسر العربي

و عليكم السلام و رحمة الله ... 1- اجعل مصدر النموذج هو الجدول f ( لا تحتاج الى الحقل m 1 ) 2- اجعل مصدر الحقل العلامة هو m و غير اسمه الى m 3- ضع الكود التالي عند النقر على مربع الاختيار الاول a1 If a1 = True Then Me.a2 = False Me.a3 = False Me.a4 = False Me.a5 = "أ" Else Me.a2 = False Me.a3 = False Me.a4 = False Me.a5 = "" Me.m = 0 End If If Me.a5 = Me.a6 Then Me.m = 2 Else Me.m = 0 End If 4- ضع نفس الكود عند النقر على بقية مربعات الاختيار مع تغيير ما يلزم من الكود 5- لكن عليك ان تأخذ بالحسبان ان المستخدم يستطيع ان يعرف الجواب الصحيح بتجربة كل مربعات الاختيار الى ان يجد الجواب الصحيح تستطيع ان تضع زر لتثبيت الاجابة بعد اختيار الجواب ثم بعد الضغط على الزر تضهر النتيجة ... كرار ...

و عليكم السلام و رحمة الله و بركاته ... للذهاب للسجل الأولمن نموذج رئيسي لنموذج فرعي Forms!asd!asd2.SetFocus Forms!asd!asd2.Form.Controls!nmm.SetFocus DoCmd.GoToRecord , , acFirst بحيث asd الرئيسي و asd2 الفرعي لإضافة سحل جديد من نموذج رئيسي لنموذج فرعي Forms!asd!asd2.SetFocus Forms!asd!asd2.Form.Controls!nmm.SetFocus DoCmd.GoToRecord , , acNewRec كرار ... فاتورة .rar

السلام عليكم إخواني سليم وعبد السلام جزيتم خيراً على الحلول المتميزة ولكن لاحظت اختلاف في النتائج فقمت بحساب العملية بشكل يدوي للتأكد من صحة المعادلات المقدمة عدد الأسهم = 39 سهم ( بطرح 24 نحصل على 15 سهم متبقي .. ولا خلاف في النتائج المقدمة من الطرفين) عدد القراريط = 47 قيراط (وبإضافة القيراط الذي حصلنا عليه من الأسهم يكون الإجمالي 48 قيراط) .. وفي هذه الحالة يتم تحويل 48 قيراط إلى عدد 2 فدان (مما يعني أن عدد القراريط سيكون صفر وليس 24 أو 23) عدد الأفدنة = 103 فدان + عدد 2 حصلنا عليه من النقطة السابقة مما يعني 105 فدان ، وليس 104 بناءً على ما سبق ... فضلت أن أقوم بتحويل كل عمود من الأرقام إلى أسهم (ومن خلال إجمالي الأسهم يمكن بناء المعادلات ببساطة) في أي خلية ضع المعادلة التالية والتي ستقوم بحساب وجمع إجمالي الأسهم لكل عمود ، حيث يتم ضرب الأسهم * 1 ، والقيراط * 24 ، والفدان * 576 ( 24 سهم * 24 قيراط) =SUM(($E$6:$E$9*1),($F$6:$F$9*24),($G$6:$G$9*576)) والمعادلة صفيف أي بعد الإدخال يتم الضغط على Ctrl + Shift + Enter ******************** ننتقل لآخر جزئية وهي المعادلات التي تقوم بحساب عدد الأسهم =INT(MOD($E$3,24)) باعتبار أن الخلية E3 هي الخلية التي وضعت فيها إجمالي الأسهم للثلاثة أعمدة ----------------------------- والمعادلة التالية للحصول على عدد القراريط =INT(MOD($E$3/24,24)) ----------------------------- والمعادلة التالية للحصول على عدد الأفدنة =INT($E$3/576) أرجو أن يكون الناتج صحيحاً إن شاء الله

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

السلام عليكم ورحمة الله وبركاته 3D - Chart الجدول يتم زيادته تلقائيا ويتم زيادة الرسم البيانى ايضا يمكن تغيير وظيفة الجدول ليعرض تقرير عن المصروفات او المبيعات او الموظفين ..الخ زكاة العلم نشره تحميل الملف chart111.rar

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

بسم الله الرحمن الرحيم ومازلنا نواصل بلا فواصل كما قال استاذنا الحبيب ياسر خليل (ابو البراء) ونكمل معكم سسلة تعليم اكسل vba للمبتدئين الجزء السادس https://youtu.be/Rhr4LciVKRY

الله يسعدك ويوفقك .... مييييييييييييه مييييييييييييييه

ما عاش اللى يجعلك تخبص ليش ما قلت هيك من الأول واش لون تستغنى عن كل ها الشىء ونكتفى باهدول السطور فقط DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste ولكن لابد من الوقوف على السجل المراد تكراره قبل دعس الزر طبعا انا بحاول التكلم بلهجتك (من شان هيك تلقانى ممتاز ) على فكرة اتفقنا على

وعليكم السلام ورحمة الله وبركاته أولا - فكرة تكرار السجل هى عملية نسخ ولصق للسجل الذى تريد تكراره ثانيا - هذا هو الكود وقد استخرجته لك من معالج انشاء الأزرار بالأكسس وهذا هو: On Error Resume Next DoCmd.RunCommand acCmdSelectRecord If (MacroError = 0) Then DoCmd.RunCommand acCmdCopy End If If (MacroError = 0) Then DoCmd.RunCommand acCmdRecordsGoToNew End If If (MacroError = 0) Then DoCmd.RunCommand acCmdSelectRecord End If If (MacroError = 0) Then DoCmd.RunCommand acCmdPaste End If If (MacroError <> 0) Then Beep MsgBox MacroError.Description, vbOKOnly, "" End If Command203_Click_Exit: Exit Sub Command203_Click_Err: MsgBox Error$ Resume Command203_Click_Exit وأخيرا - تمنياتى بالتوفيق ولا تنسانا من دعائك

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

السيد جمال السيد ما يقصر ... هو و كل الاعضاء في المنتدى ربي يحفظهم جميعا ...

تفضل Book1.rar

هذا الكود موجود خلف مربع منطقة الوصول If Len(t1 & "") = 0 Or _ Len(t2 & "") = 0 Then MsgBox "Please insert Start/End Point " Else t0 = t1 & " " & t2 End If وهو بسيط كما ترى ويقوم باختبار وجود بيانات بمنطقة الانطلاق ومنطقة الوصول فان وجد بيانات جمعها وأرسله للمسلك وان لم يجد أعطاك رسالة تنبيه بضرورة ملأ البيانات اعذرنى فأنا لا أجيد الشرح النظرى ولكن يمكنك عرض الكود ومحاولة التعديل عليه لتنظر ما هى التغيرات المناسبة لك

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

السلام عليكم اخي العزيز اشكراهتمامك بمشكلتي لقد حلت المشكلة بارك الله فيك وحفظك الله يااخي مع الشكرالجزيل

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

انا ايضا لم افهم القصد .. اذا كان القصد كما كما نوه الاستاذ ياسر فيمكن ان تضع المعادلة الاتية مباشرة =IF(TRIM(A1)=B1;"";"Different")

جرب الملف المرفق إذا لم يكن المطلوب يرجى إرفاق النتائج المتوقعة TestThis.rar

و عليكم السلام و رحمة الله و بركاته ... اخي انت عملت موضوع في منتدى الاكسس ... يرجى النقل لمنتدى الاكسل ...

هذه المرة لم استطع تحميل المرفق أرجو من الاخوة الأعضاء اخبارنا هل استطاع تحميل المرفق أم لا ولكن وعل كل حال لدى اقتراحين حاول التجربة ووافنى بالنتيجة 1- بعد مراجعه نص السؤال الأول مرة أخرى اتضح لى أن حضرتك قد جعلت الدالة Date()= فى خاصية القيمة الافتراضية لمربع النص هل هذا صحيح؟ اذا كان صحيحا فاقتراحى أن تجعل الدالة فى Control Source لــ textbox لا فى ال Defult value 2- أما اقتراحى الثانى أن تجعل هذا الكود فى زر الحفظ على اعتبار ان التكست بوكس اسمه t1 T1 = Date وأكرر آسفى أنى لم أستطع تحميل المرفق الخاص بحضرتك

السلام عليكم واسعد الله صباحكم ويوم مبارك بإذن اللع تعالى استاذ ياسر العربي تعجز الكلمات بارك الله بك زجزاك كل خير وسر خاطرك وجعلها في ميزان حسناتك

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

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

حل آخر بشكل مباشر بدون الاستعانة بخلية مساعدة لجمع الأسهم .. المعادلة الأولى لحساب عدد الأسهم =MOD(SUM($E$6:$E$9),24) المعادلة الثانية حساب عدد القراريط =MOD(SUM($F$6:$F$9,INT(MOD(SUM($E$6:$E$9)/24,24))),24) المعادلة الثالثة لحساب الأفدنة =SUM($G$6:$G$9,INT(SUM($F$6:$F$9,INT(MOD(SUM($E$6:$E$9)/24,24)))/24),INT(SUM($E$6:$E$9)/576))

اخى ياسر جزاك الله خيرا

نعم النتيجة يتم اختيارها من القائمة المنسدلة في العمود F تفضل النتيجة1.rar

سلمت يداك ابو عبد الله الحلواني وادامك الله مشكور تم

لكم نفتقد ايامنا المتميزة التي جمعتنا بكم بالمنتدى جزيت خيرا اخي الكريم ابو البراء تقبل فائق احترامي

لنفرض أن لدينا مودييل اسمه Module1 فلا يصلح أن تكون ال Function اسمها أيضا Module1 هل هذا واضح؟ وعلى كل أرفق مثالا للتعديل عليه اذا أحببت

جزاك الله خيراً أخي الحبيب عبد العزيز ...على ما قدمت وبينت ...بارك الله بكم وجعل مثوانا ومثواكم جنة عرضها السموات والأرض أعدت للمتقين ....آمين..آمين ...والصلاة والسلام على سيد المرسلين والحمد لله رب العالمين.

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

السلام عليكم ورحمة من لجنه وبركات بارك الله بك وبجهودك

السلام عليكم ورحمة الله وبركاته بارك الله بجهودكم أخي الكريم عماد ...رائع ...جزاكم الله خيراً... أخوكم أبو يوسف

جزاك الله خيراً و بارك الله فيك

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

وإياك أخي أبا عمر .. سعدت بمرورك تابع الاجراءات : نحن بحاجة الى كود يجعل النظام يقلع من برنامجنا عند اعادة التشغيل ’ بشرط الا يعمل الا مرة واحدة ويوجد طريقة برمجية يستخدمها البعض وهي نسخ اختصار للبرنامج ولصقه في مجلد بدء التشغيل ثم حذفه عند نهاية التنصيب ولكن يوجد طريقة أسهل من ذلك وهي موجودة ومهيأة في النظام وبالتحديد في التسجيل (الريجستري) فيمكن اعطاء امر وتسجيله ليقوم النظام بتنفيذه مرة واحدة عند بداية التشغيل وهذا هو المكان الذي سنضع فيه الأمر "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce ليصبح بعد اعداده والكتابة فيه هكذا : objWShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce\tsj", "D:\tsjeel.mdb", "REG_SZ" باعتبار برنامجنا سيتم تنصيبه على D باسم tsjeel يتبع ...

شكرا ابا آدم على المتابعة والمساندة وهو تسجيل بعض النتائج المهمة في الحدث . ويهمنا هنا درجة الامان ، فلا بد من شاهد او دليل على درجة الامان الابتدائية فحين يغلق النظام تذهب جميع البيانات العالقة في الذاكرة ، وهذه لا بد من اخذ حسابها من اجل ضبط العملية لذا سيكون من ضمن الكائنات المساعدة حقل في جدول نودع فيه درجة الامان قبل اغلاق النظام لذا سننشء جدولا باسم tblTemp به حقل رقمي باسم tmp دعونا الآن نعرض الاجراءات الاخرى التي سنستخدمها في العملية غير ما تم ذكره اعلاه 1- وحدة نمطية عامة وهي المسؤولة عن تسجيل المكتبات : Option Compare Database Option Explicit Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long Private Declare Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadID As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long) 'Purpose : This function registers and Unregisters OLE components 'Inputs : sFilePath The path to the DLL/OCX or ActiveX EXE ' bRegister If True Registers the control, else unregisters control 'Outputs : Returns True if successful 'Author : Andrewb 'Date : 04/09/2000 'Notes : This is the API equivalent of RegSvr32.exe. 'Example : ' If RegisterComponent("C:\MyPath\MyFile.dll") = True Then ' Msgbox "Component Successfully Registered" ' Else ' Msgbox "Failed to Registered Component" ' End If 'Revisions : 1/Jan/2002. Updated to include code for registering ActiveX Exes. Function RegisterComponent(ByVal sFilePath As String, Optional bRegister As Boolean = True) As Boolean Dim lLibAddress As Long, lProcAddress As Long, lThreadID As Long, lSuccess As Long, lExitCode As Long, lThread As Long Dim sRegister As String Const clMaxTimeWait As Long = 20000 'Wait 20 secs for register to complete On Error GoTo ErrFailed If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then 'File exists If UCase$(Right$(sFilePath, 3)) = "EXE" Then 'Register/Unregister ActiveX EXE If bRegister Then 'Register EXE Shell sFilePath & " /REGSERVER", vbHide Else 'Unregister ActiveX EXE Shell sFilePath & " /UNREGSERVER", vbHide End If RegisterComponent = True Else 'Register/Unregister DLL If bRegister Then sRegister = "DllRegisterServer" Else sRegister = "DllUnRegisterServer" End If 'Load library into current process lLibAddress = LoadLibraryA(sFilePath) If lLibAddress Then 'Get address of the DLL function lProcAddress = GetProcAddress(lLibAddress, sRegister) If lProcAddress Then lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread) If lThread Then 'Created thread and wait for it to terminate lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0) If Not lSuccess Then 'Failed to register, close thread Call GetExitCodeThread(lThread, lExitCode) Call ExitThread(lExitCode) RegisterComponent = False Else 'Successfully registered component RegisterComponent = True Call CloseHandle(lThread) End If End If Call FreeLibrary(lLibAddress) Else 'Object doesn't expose OLE interface Call FreeLibrary(lLibAddress) End If End If End If End If Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False On Error GoTo 0 End Function 2- وحدة نمطية لقراءة نوع النظام 32بت أو 64بت Public Function IsWin32OrWin64() As String Dim proc_query As String Dim proc_results As Object Dim info As Object proc_query = "SELECT * FROM Win32_Processor" Set proc_results = GetObject("Winmgmts:").ExecQuery(proc_query) For Each info In proc_results IsWin32OrWin64 = info.AddressWidth & "-bit" Next info End Function 3- وحدة نمطية للتأكد من وجود الملف قبل النسخ واللصق : Public Function DoesFileExist(vPathAndFile As String) As Boolean If Len(Dir$(vPathAndFile)) > 0 Then DoesFileExist = True Else DoesFileExist = False End Function 4- وحدة نمطية تقوم بنسخ الملفات من برنامجنا الى المكان الذي نحدده Function CopyFile(vPathSource As String, vPathDestination As String) As Boolean FileCopy vPathSource, vPathDestination CopyFile = True End Function 5- عملية النسخ والتسجيل وتم وضعها في وحدة نمطية عامة : Public Function tsjeelMktbat() Dim sjel As Variant sjel = IsWin32OrWin64() If sjel = "32-bit" Then If Not DoesFileExist("C:\Windows\System32\Barcodex.ocx") Then 'للتأكد من عدم وجود الملف CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\System32\Barcodex.ocx" 'نسخ الملف في المكان المحدد RegisterComponent ("C:\Windows\System32\Barcodex.ocx") 'تسجيل الملف Else RegisterComponent ("C:\Windows\System32\Barcodex.ocx") ' وان كان الملف موجود سجله End If 'يمكن اضافة اكثر من ملف اعلاه ElseIf sjel = "64-bit" Then If Not DoesFileExist("C:\Windows\SysWOW64\Barcodex.ocx") Then CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\SysWOW64\Barcodex.ocx" RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") Else RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") End If End If End Function يتبع ...

جزاك الله كل خير استاذنا الغالي و بارك الله فيك الكود للاستاذة القديرة زهرة العبدلله Dim SourceFile, DestinationFile SourceFile = Application.CurrentProject.Path & "\Rockey4ND.dll" DestinationFile = "c:\windows\system32\Rockey4ND.dll" FileCopy SourceFile, DestinationFile MsgBox ("تم النسخ بنجاح") لماذا لا نقوم بانهاء التنصيب ثم نخفض الأمان ثم نقوم باعادة التشغيل

أولا : المعوقات درجة أمان windows حيث لا يمكننا إضافة أو تسجيل ملفات حين تكون درجة امان حساب المستخدم مرتفعة وحتى لو قمنا بتركيبها يدويا فلن يتسنى لنا ذلك الا بعد تخفيض الأمان الى الحد الأدنى ثم اعادة تشغيل النظام وهنا يتبادر سؤال : ماذا لو كان الامان على الحد الأدنى ؟ كيف نعلم ذلك ؟ وهل سيختلف الاجراء ؟ إذا : يجب اولا التأكد من درجة الامان فإن كان منخفضا حينها تتم خطوات التنصيب والا سيقوم البرنامج بتخفيض الامان ثم يعيد تشغيل النظام وهنا يتبادر تساؤل ايضا : هل سيبقى الامان منخفضا ؟ وهل يجب علينا اخبار المستخدم بالوضع الحالي ؟ أم انه يلزمنا اعادة الامان الى وضعه السابق ؟ كل هذه الامور تجعلنا _ وبالاصح تجعلني_ أفضل ان يقوم المستخدم بالعملية بنفسه حيث انها لا تأخذ من المستخدم سوى نقرتين فقط واحدة على زر ابدأ والثانية على صورة المستخدم ليجد أمامه اعدادات التحكم في حسابه . والآن الى الخطوات : 7 windows قراءة حساب المستخدم ودرجة الأمان : Dim objWShell, objReead Set objWShell = CreateObject("WScript.Shell") objReead = objWShell.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA") اذا كانت درجة الامان مرتفعه نقوم بتخفيضها وإلا نخرج من الحدث : If objReead = "1" Then objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Else Exit Sub End If ويمكن عكس الوضع : اذا كانت درجة الامان مرتفعه نقوم بتخفيضها وإلا نرفعها If objReead = "1" Then objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Else objWShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 1, "REG_DWORD" End If يأتي الآن دور تثبيت التغيير ويتحقق بإعادة تشغيل النظام ويمكن تخيير المستخدم بين التنفيذ من عدمه : If MsgBox("سيتم إعادة تشغيل النظام" & vbCrLf & _ " هل تريد المتابعة؟", _ vbQuestion + vbYesNo, _ "اعادة تشغيل النظام") = vbNo Then Exit Sub Set objWShell = Nothing Else objWShell.Run "shutdown /r /t 10 /f /d P:4:2" Set objWShell = Nothing End If انتهينا يتبع ...

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