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

السلام عليكم ورحمة الله تعالى وبركاته .. اليك الاجابة والافادة معا . مع تعديل برنامجك ليتناسب مع طلبك . Private Sub Add_Click() '''''اضافة البيانات الى الليست بوكس''''' Dim MH As Variant, n As Byte If txtName.Value = Empty Then MsgBox "Please Enter Name": txtName.SetFocus: Exit Sub If txtJob.Value = Empty Then MsgBox "Please Enter Job": txtJob.SetFocus: Exit Sub If txtSallary.Value = Empty Then MsgBox "Please Enter Sallary": txtSallary.SetFocus: Exit Sub MH = Array(txtName.Value, txtJob.Value, txtSallary.Value, txtDate.Value) lstStItems.ColumnCount = 3 If lstStItems.ListCount <= 0 Then lstStItems.Column = MH Else lstStItems.AddItem MH(0) For n = 1 To 3 lstStItems.List(lstStItems.ListCount - 1, n) = MH(n) Next n End If txtName.Value = "" txtJob.Value = "" txtSallary.Value = "" End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Fill_Click() '''''ترحيل البيانات من الليست بوكس الى التيكست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems txtName.Value = .List(.ListIndex, 0) txtJob.Value = .List(.ListIndex, 1) txtSallary.Value = .List(.ListIndex, 2) End With Else MsgBox " !المرجوا تحديد الصف ", vbCritical, "" End If End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Update_Click() '''''تعديل البيانات على الليست بوكس''''' If lstStItems.ListIndex <> -1 Then With lstStItems .List(.ListIndex, 0) = txtName.Value .List(.ListIndex, 1) = txtJob.Value .List(.ListIndex, 2) = txtSallary.Value End With Else MsgBox "!المرجوا تحديد الصف المراد تعديله ", vbCritical, "" End If End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Delete_Click() If lstStItems.ListIndex = -1 Then '''''حدف البيانات من الليست بوكس''''' MsgBox "!المرجوا تحديد الصف المراد حدفه !", vbCritical, "" Exit Sub End If If lstStItems.ListIndex >= 0 Then cevap = MsgBox("?هل انت متاكد من حدف البيانات", vbYesNo) If cevap = vbYes Then lstStItems.RemoveItem lstStItems.ListIndex End If End If End Sub Enter Data_MH.xlsm

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

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

الف مبروك و مرحبا بك أخي حسونة 💐

جرب المرفق فقط حددنا الكائن الذي سيتم تطبيق الامر عليه Function SetActiveControlColour() Dim ctl As Control For Each ctl In Me.Controls If ctl.ControlType = 104 Then ctl.BackColor = RGB(150, 180, 215) End If Next ctl Me.ActiveControl.BackColor = vbYellow End Function 104 يعني زر امر الملف مرفق تغير لون الزر(2).accdb

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

بسم الله الرحمن الرحيم السلام عليكم ورحمة الله وبركاته نفس الملف باستخدام نصوص تجربة2.xls

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

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

تفضل اخي الكريم خلية البحث (G3) 'البحث في عمود A,B Sub ChangeColor() Set MR = Range("A1:B10000") For Each cell In MR If cell.Value = Range("g3") Then cell.Interior.ColorIndex = 6 End If Next End Sub ''''''''''''''''''''''''''''''''''''''''' ' E,البحث عن القيمة في متسلسلة عمود 'وتغيير لون الكتابة Sub FindLoop() Dim strFirstAddress As String Dim rngFindValue As Range Dim rngSearch As Range Dim rngFind As Range Set rngFind = ActiveSheet.Range("E1:E100000") Set rngSearch = rngFind.Cells(rngFind.Cells.Count) Set rngFindValue = rngFind.Find(Range("g3"), rngSearch, xlValues) If Not rngFindValue Is Nothing Then strFirstAddress = rngFindValue.Address rngFindValue.Font.Color = vbRed Do Set rngFindValue = rngFind.FindNext(rngFindValue) rngFindValue.Font.Color = vbRed Loop Until rngFindValue.Address = strFirstAddress End If End Sub 298667823_.xlsm

السلام عليكم ورحمة الله تعالى وبركاته تفضل اخي يمكنك اختيار معيار الفلترة في خانة (D1) او ادخاله يدويا لفلترة جميع الاوراق على نفس المعيار Sub Filter_Me() Dim ans As String Dim T As ListObject MH = Sheets("Drawing").Range("D1") For i = 1 To Sheets.Count For Each T In Sheets(i).ListObjects T.Range.AutoFilter Field:=1, Criteria1:=MH Next Next End Sub ''''الغاء الفلترة من جميع الاوراق Sub Remove_Filters_From_Workbook() Dim MH As Worksheet Dim lstObj As ListObject For Each MH In Worksheets For Each lstObj In MH.ListObjects lstObj.AutoFilter.ShowAllData Next lstObj Next MH End Sub New Microsoft Excel Worksheet_MH.xlsm

طيب شوف كده ............ Book Info.accdb

مع ان الكلام موجه لاخي وصديقي المهندس قاسم نعم ممكن تعديل بسيط على عمل اخي قاسم ولو املك الوقت لقدمت حل بفكره اخرى تغير لون الزر(2)(1).accdb

أستاذنا الغالي @مبرمج متقاعد .. أعتذر منك من الاخطاء اللغوية الذي لم انتبه لها ألا الآن عني وعن المسلمين من كل مكروه

احسنت اخي قاسم ويمكن التصريح باسم العنصر مباشرة او كما يفعل بعض جيل الطيبين بوضع قيمة العنصر بدون كتابة اسمه acAttachment 126 Attachment control acBoundObjectFrame 108 BoundObjectFrame control acCheckBox 106 CheckBox control acComboBox 111 ComboBox control acCommandButton 104 CommandButton control acCustomControl 119 ActiveX control acEmptyCell 127 EmptyCell control acImage 103 Image control acLabel 100 Label control acLine 102 Line control acListBox 110 ListBox control acNavigationButton 130 NavigationButton control acNavigationControl 129 NavigationControl control acObjectFrame 114 Unbound ObjectFrame control acOptionButton 105 OptionButton control acOptionGroup 107 OptionGroup control acPage 124 Page control acPageBreak 118 PageBreak control acRectangle 101 Rectangle control acSubForm 112 SubForm control acTabCtl 123 Tab control acTextBox 109 TextBox control acToggleButton 122 ToggleButton control acWebBrowser 128 WebBrowserControl control تحياتي

احسنت اخي استاذ خالد .. لم اكن اعلم ان هناك كنترول غير الازار كنترول الازرار حسب مايكروسوفت

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

تفضل اخي https://streamable.com/dqdtjq

طبعا وفبل كل شيئ هناك طرق اكثر احترافية في المنتدى للقيام بحماية قاعدة البيانات ولكن انظر لهذة الطريقة البسيطة ربما تفي بالقرض .... Book Info.accdb

جرب المرفق ...... Book Info.accdb

وعليكم السلام -وبما انك لم تقم برفع ملف واكتفيت بالصورة على الرغم أننا نبهنا كثير جداً على ضرورة رفع الملف داخل المشاركات , فسيتم أيضاً الرد عليك بصورة لتثبيت الصف الأعلى أثناء عملية الطباعة

خبير يااستاذنا @Moosak جزاك الله كل خير شكرا ياريس واسف علي التأخير

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

الف مبروك استاذنا الكريم

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

وعليك السلام ورحمة الله وبركاته أخي صابر 🙂 جرب الآن ... dlookup problem.rar

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

وعليكم السلام ورحمة الله وبركاته أخي عبدالله 🙂 لو صورت الجزئية التي يقف عليها المؤشر بالأصفر عند الضغط على ال Debug وعلى العموم يمكنك ببساطة تغيير الكود .. هناك الكثير من الأكواد التي تؤدي نفس العمل .. 🙂 هذا الكود الذي أستخدمه أنا ويعمل معي جيد ، الكود يأخذ نسخة لقاعدة البيانات كلها إذا كانت غير مقسمة . وإذا كانت مقسمة فإنه ينسخ ملف الجداول فقط . وفي كلا الحالتين الكود ينشئ النسخة في مجلد اسمه Backup بجانب البرنامج : Public Sub Backupme() On Error GoTo MyErr Dim OldFile, NewFile, CopyMyDB, wheretoBackup, BackupFolder, DBName As String If IsNull(DLookup("Database", "MSysObjects", "Type=6")) Then OldFile = CurrentProject.FullName wheretoBackup = CurrentProject.Path Else OldFile = DLookup("Database", "MSysObjects", "Type=6") wheretoBackup = Left(OldFile, InStrRev(OldFile, "\")) End If BackupFolder = wheretoBackup & "\Backup" On Error Resume Next If Len(Dir(BackupFolder)) = 0 Then MkDir BackupFolder Else End If On Error GoTo MyErr DBName = Left(CurrentProject.Name, InStrRev(CurrentProject.Name, ".") - 1) NewFile = wheretoBackup & "\Backup\" & DBName & "-Backup-" & Format(Date, "dd-mm-yyyy") & "-" & Format(Now(), "Hh-Nn-ss-AMPM.") & Right(OldFile, 5) CopyMyDB = "cmd.exe /C copy " & """" & OldFile & """" & " " & """" & NewFile & """" Shell CopyMyDB, 0 MsgBox "Backup……..Done" & vbNewLine & vbNewLine & "Saved in :" & vbNewLine & NewFile, , " " MyErr: If Err.Number <> 0 Then MsgBox Err.Number & " - " & Err.Description End If End Sub '=======================================(كود آخر) Public Function CreateBackup() As Boolean Dim Source As String Dim Target As String Dim a As Integer Dim objFSO As Object Dim Path As String Path = CurrentProject.Path 'get location of current folder Source = CurrentDb.Name Target = Path & "\BackupDB " Target = Target & Format(Now(), "mm-dd") & ".accdb" ' create the backup a = 0 Set objFSO = CreateObject("Scripting.FileSystemObject") a = objFSO.CopyFile(Source, Target, True) Set objFSO = Nothing End Function وهذا الكود للمهندس محمد عصام :

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

تفضلي اختي الفاضلة Invoices-j.xlsm

تفضل اخي جرب Imprimer-3.xlsm

نعم اجابتك صحيحة