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

السلام عليكم ورحمة الله تعالى وبركاته الشرح الاتى لا يخص الأكسس بصفة خاصة ولكن لحماية حذف القاعدة او اى ملف داخل مجلد او المجلد الذى يحتوى قاعدة البيانات بالخطأ اولا نقوم بعمل مجلد جديد ونعطيه الاسم الذى نريد على سبيل المثال نضع مجلد جديد داخل القطاع D ونعطى المجلد اسم BackDB نقوم بتحديد المسار ونقوم بنسخه فيكون D:\Test\BackDB ولو كان اسم المجلد من مقطعين مثل Back DB سوف يكون المسار نسخ المسار الى ملف نصى ونقوم بتعديله ليكون D:\Test\Back_DB بعد ذلك نقوم بفتح موجه الاومر DOS ونقوم بكتابة او لصق الامر الاتى cacls D:\Test\BackDB /P everyone:n ولو اسم المجلد من مقطعين يكون cacls D:\Test\Back_DB /P everyone:n ثم نضغط على المقتاح Enter من لوحة المقاتيح ثم نضغط على المفتاح Y من لوحة المفاتيح كما هو موضح فى الصورة بعد ذلك نغلق موجه الاوامر DOS ونذهب الى المجلد ونقوم بالضغط عليه كليك يمين ونختار Properties تظهر لنا النافذة الاتية نحدد التبويب Security ثم نضغط بعد ذلك على Advanced كما هو موضع بالصورة ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالتحديد اولا كما هو فى الخطوة رقم 1 بالصورة ثم بعد ذلك كما هو بالخطوة رقم 2 نقوم بالضغط على Edit ثم بعد ذلك تظهر لنا النافذة الاتية نقوم بالضعط على Show Advanced Permissions ثم بعد ذلك تظهر لنا النافذة الاتية 1- فى الـ Type نختار Allow 2- فى اختيارات الـ Permissions نقوم بإزالة التأشير من على الاتى Delete Delete Subfolders and files لتصبح الاعدادت كما بالشكل الاتى ثم نضغط OK الان انسخ قاعدة البيانات داخل المجلد او اى ملفات تخاف من فقدانها جرب حذف الملفات لن يتم حذفها حاول حذف القاعدة كذلك لن يتم حذفها كذلك اقتح القاعدة واضف اليها بيانات او عدل او احذف منها اى بيانات سوف تعمل القاعدة بشكل طبيعى جدا لو اردت حذف المجلد او اى شئ بداخلة فقط استخدم الامر الاتى فى موجه اوامر الـ DOS cacls D:\Test\BackDB /P everyone:f وبعد حذف ما تريد يمكنك اعادة الخطوات ان اردت ارجاع الحماية مرة اخرى انتهى الشرح دمتم فى امان الله...

Private Sub CommandButton1_Click() Dim ws As Worksheet, lastRow As Long, rRow As Long, last As Integer, LS1 As Integer, LAS2 As Integer If Evaluate("ISREF('" & ComboBox6.Value & "'!A1)") Then Set ws = ThisWorkbook.Worksheets(ComboBox6.Value) Else MsgBox "Target Worksheet Not Found", vbExclamation: Exit Sub End If With ws .Activate rRow = .Cells(1, 1).CurrentRegion.Rows.Count + 1 last = .Range("A10000").End(xlUp).Row + 1 For i = 0 To ListBox1.ListCount - 1 .Cells(last, "F").Value = Me.ListBox1.List(i, 0) .Cells(last, "G").Value = Me.ListBox1.List(i, 1) .Cells(last, "H").Value = Me.ListBox1.List(i, 2) .Cells(last, "I").Value = Me.ListBox1.List(i, 3) last = last + 1 Next i LS1 = .Range("A10000").End(xlUp).Row + 1 ls2 = .Range("F10000").End(xlUp).Row For S = LS1 To ls2 .Cells(LS1, "A").Value = Me.TextBox1.Value .Cells(LS1, "b").Value = Me.ComboBox5.Value .Cells(LS1, "C").Value = Me.TextBox2.Value .Cells(LS1, "D").Value = Me.ComboBox4.Value Sheet2.Cells(LS1, "E").Value = Me.ComboBox5.Value LS1 = LS1 + 1 Next S End With MsgBox "Data Added Successfully", 64 End Sub

السلام عليكم ورحمة الله وبركاته.. من المعروف ان الواتس اب يسمح لك بارسال 5 رسائل فقط في كل مرة يعني لو كان لدينا 15 شخص نريد ان نرسل له رسالة علينا ان نقوم باعادة توجيه الرسالة 3 مرات كل مرة 5 اشخاص.. قمت بعمل اداة صغيرة في الـ NET. لتقوم بهذه المهمة. صورة مشروع الاكسس: قم بتحديد الاشخاص الذين تريد ارسال الرسالة لهم مع وضع نص الرسالة مع امكانية تحديد الكل يمكنك شروط البرنامج بحسب ماتراه مناسباً. النتيجة: ملاحظة يجب ان يكون برنامج الواتس اب موجود في جهاز الكومبيوتر واهم ملاحظة هي يجب كتاب رقم الواتس اب الذي تريد ان ترسل له الرسالة كما يظهر في البرنامج، مثال: لتحميل الواتس اب من الرابط الاتي: https://www.whatsapp.com/download لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. Whatsapp-Message-Sender.rar

عليكم السلام، نعم يمكن ذلك بواسطة الـ Commandline Sub Extract() Dim RarIt As String Dim Source As String Dim Desti As String Dim WinRarPath As String WinRarPath = "C:\Program Files\WinRar\" Source = "C:\Users\SEMO\Desktop\DBS\GoogleDriveUploader.rar" Desti = "C:\Users\SEMO\Desktop\DBS\" RarIt = Shell(Chr(34) & WinRarPath & "WinRar.exe" & Chr(34) & " e " & Chr(34) & Source & Chr(34) & " " & Chr(34) & Desti & Chr(34), vbNormalFocus) End Sub Sub Compress() Dim RarIt As String Dim Source As String Dim Desti As String Dim WinRarPath As String WinRarPath = "C:\Program Files\WinRar\" Desti = "C:\Users\SEMO\Desktop\DBS\" Source = "C:\Users\SEMO\Desktop\DBS\NameFolderRar.rar" RarIt = Shell(Chr(34) & WinRarPath & "WinRar.exe" & Chr(34) & " a " & Chr(34) & Source & Chr(34) & " " & Chr(34) & Desti & Chr(34), vbNormalFocus) End Sub

Press Alt + F11 Tools References Unchecko options start with MISSING word Use google translator if you still find difficulties

طيب مبدئيا كده ركز فى الكود انت بدأت الكود بـ If IsNull(Me.cbAproved) Then وبعد كده عاوزة يجلب البيانات من App1 = Me.cbEmpNo.Column(1) ركز كده مع اللون الاحمر طب ايه اللى جاب القلعة جمب البحر Dim str As String If IsNull(Me.cbAproved) Then Me.App1 = "" Me.App2 = "" Me.App3 = "" Me.App4 = "" str = "Select * from QryforREP_ALL_EMP" Me.RecordSource = str Exit Sub Else App1 = Me.cbEmpNo.Column(1) App2 = Me.cbEmpNo.Column(2) App3 = Me.cbEmpNo.Column(3) App4 = Me.cbEmpNo.Column(4) str = "Select * from QryforREP_ALL_EMP where [Emp_No]=" & Me.cbAproved.Column(0) Me.RecordSource = str End If الكود الصحيح يكون كالاتى ... وياريت نركز شوية واحنا شغالين ماشى Dim str1 As String If IsNull(Me.cbAproved) Then Me.App1 = "" Me.App2 = "" Me.App3 = "" Me.App4 = "" str1 = "Select * from QQQQ" Me.RecordSource = str1 Exit Sub Else App1 = Me.cbAproved.Column(1) App2 = Me.cbAproved.Column(2) App3 = Me.cbAproved.Column(3) App4 = Me.cbAproved.Column(4) str1 = "Select * from QQQQ where [Emp_No]=" & Me.cbAproved.Column(0) Me.RecordSource = str1 End If وهذا ملفك بعد التعديل test1001 -Update.accdb

السلام عليكم ورحمة الله وبركاته... قمت ببرمجة هذه الاداة تلبية لطلب اخونا @ابوخليل في هذا الموضوع هنا: الاداة مبرمجة 100% بلغة NET. وهي تستعمل مكتبات Google.Apis.Drive وهي تحتاج منصة الفريم ورك 4.5 ملاحظة: انا طبقت الشرح على نسخة احتياطية حيث وضعت الـ Path عبارة عن CurrentProject.FullName يمكنك استبداله بأي مسار صورة او فيديو او ملف او اي شي الشرح بصوتي الجميل😂: https://youtu.be/Uzj68nCaEbo الرابط الذي استعملته في التسجيل: https://console.developers.google.com/apis/credentials/oauthclient/ لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. GoogleDriveUploader.rar

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

To implement With your workbook active press Alt+F11 to bring up the vba window In the Visual Basic window use the menu to Insert|Module Copy and Paste the code below into the main right hand pane that opens at step 2 Close the Visual Basic window Press Alt+F8 to bring up the Macro dialog Select the macro & click Run Your workbook will need to be saved as a macro-enabled workbook (*.xlsm)

ساقوم بعمله وبإذن الله تظبط معي شكرا لك وجزاك الله خير

Suppose the word HEALTHY will be in column Q try the following code Sub Test() Const sOut As String = "Output" Dim a(1 To 10000, 1 To 1), ws As Worksheet, sh As Worksheet, m As Long, r As Long, k As Long Application.ScreenUpdating = False Application.DisplayAlerts = False On Error Resume Next: Sheets(sOut).Delete: On Error GoTo 0 Application.DisplayAlerts = True For Each ws In ThisWorkbook.Worksheets m = ws.Cells(Rows.Count, "V").End(xlUp).Row For r = 21 To m If ws.Cells(r, "Q").Value = "HEALTHY" Then k = k + 1 a(k, 1) = ws.Cells(r, "R").Value End If Next r Next ws If k > 0 Then Sheets.Add , Sheets(Sheets.Count) ActiveSheet.Name = sOut With Sheets(sOut) .Range("A1").Value = "Results" .Range("A2").Resize(UBound(a, 1), UBound(a, 2)).Value = a End With Else MsgBox "No Data", vbExclamation: Exit Sub End If Application.ScreenUpdating = True End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Const SW_SHOWMAXIMIZED As Long = 3 Private Const SW_SHOWNORMAL As Long = 1 Sub PlayMusic(strFile As String) If ShellExecute(0&, "Play", strFile, 0&, 0&, SW_SHOWNORMAL) < 33 Then MsgBox "Something Went Wrong", vbInformation End If End Sub Sub Test_PlayMusic() Call PlayMusic(ThisWorkbook.Path & "\YOURFILE.mp3") End Sub

قم بتشغيل البرنامج المسمى SWM والتقط لي صورة للخطأ الذي يظهر

الحمد لله بالتوفيق وفي تعديل ممكن ارفقه غداُ بارسال الصور والملفات .

قمت بتجربته و هو يعمل بشكل صحيح جزاك الله خيرآ أستاذي المحترم

جرب المرفق الذى وضعته بالمشاركة التى قبلك .

بسم الله ما شاء الله وربنا يكرمك على المجهود بس من الممكن انك تبعت رسائل من غير برنامج ملحق او باتش او اى مساعدة خارجية ولا يحتاج مكتبات ويعمل على النسختين 32 , 64 WhatsappMessageSender.accdb قمت بالتعديل على البرنامج الخاص بك لتوضيح الفكره ومن الممكن تجربتها ملحوظة هامة : عند الارسال لأول مره اول مرع على الاطلاق اضغط على زر Alt + Tap ستجد رسالة بها Allow و Not Allow وباعلاها علامه صح امسح الصح من على التشيك بوكس واضغط Allow ولن تظهر ثانيه وسيتم الارسال ورا بعض بدون ادني مشكلة . وبرجاء اخذها سكرين شوت ووضعها بالمشاركات لتعم الفائدة للجميع . ملحوظة اخري : سواء بالطريقة التى تفضلت بوضعها او التى انا قمت بوضعها اذا كان رقم الموبايل جديد او ارضي بياخد باند ولتفادى المشكلة يجب رفع زمن الانتظار بين الرسائل الى 16 ثانية بحد ادني والحد الاقصي لارسال رسائل من اى رقم قديم ان لا تتعدي 45 رسالة بالدقيقة . ملحوظة اخري : غير مشترط وضع اسم الشخص ولكن يجب ان يبدأ رقم الموبايل بكود الدولة .

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

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

استخدم الأمر: Kill Kill(PathName)

حفظك الله وغفر لك ولوالديك وزادك الله من فضله اللهم امين يارب

أولا أشكرك أخي العزيز .. جهود طيبة إن شاء الله .. لكن عندي ثلاث ملاحظات .. الأولى : برنامج الواتسأب يقف عند كتابة الرسالة ولا يقوم بعملية الإرسال : ثانيا : مربع البحث لايعمل ثالثا : أنا أعمل على نواة 64 بت فاضررت لإضافة PtrSafe على هذه الجمل : Private Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal _ hHandle As Long, ByVal dwMilliseconds As Long) As Long Private Declare PtrSafe Function CreateProcessA Lib "kernel32" (ByVal _ lpApplicationName As Long, ByVal lpCommandLine As String, ByVal _ lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _ ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _ ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, _ lpStartupInfo As STARTUPINFO, lpProcessInformation As _ PROCESS_INFORMATION) As Long Private Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal _ hObject As Long) As Long

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

بارك الله فيك اخي الكريم وغفر لك ولوالديك وزادك من فضله اللهم امين يارب

فعلا لم انتبه الى الفرق بين الاثنين عاشت ايدك @ابو جودي

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

السلام عليكم تهنئة من القلب استاذ عمرو والى الامام

ربنا يبارك فيك يا استاذنا ويرزقك التوفيق والسداد

اشكرك على رحابت صدرك بارك الله فيك

lionheart🤩 ماشاء الله عليك استاذ والله انت مبدع و جعله الله في ميزان حسناتك ربنا يحميك

اخي didi2333 تغضل فطلبك هنا http://www.officena.net/ib/index.php?showtopic=57798

Missing reference is the cause From VBE editor and Tools menu select References and uncheck any option that starts with MISSING

شكرا يا مهندس ويعطيك الف عافيه وكثر الله خيرك غلبتك معي .

كل الشكر والتقدير لاهتمامك

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

فعلا ما اخذت بالى من هذا الخطأ 😞 الف الف شكر وجعله فى ميزان حسناتك

طيب المثال من عندى والشرح من عندك ♥ Menu.mdb

السلام عليكم تفضل يا اخى اذا اردت التعديل على المعادلة الموجودة بالملف اظعط على Ctrl+Shift+Enter بعد التعديل عليها Time Attendance Details Report 15022022_125100.xls

تفضل أخي الكريم. 0.0_3rEd.0_3rEd!attachment!0_مواد دراسية (1).xlsx

تفضل التعديل Database51.accdb

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

Great solution but the heavy use of conditional formatting will make the file slow and heavy and at the same time will make the file size larger

لعلك صديقي العزيز لم تجرب المعادلة فقلت أنها بصراحة فكرة أن تعمل جدول اعتماداً على كتابة بيانات محددة أو رؤوس أعمدة للجدول جيدة. وهي بالأكواد أفضل، وكما أخبرنا الأخ المحترم lion heart أن الحدود غير دقيقة بالتنسيق الشرطي كلامه صحيح في حال اعتمدنا على التنسيق المسبق من قبلكم وإلغاء التنسيق من الصفوف الفارغة ولكن ماذا لو عكسنا المعادلة بحيث تكون الورقة خالية من التنسيقات ثم نقوم بتنسيقها(تنسيقات شرطية) حسب الجداول مع تمييز رؤوس الجداول بألوان وتنسيقات محددة تميزها عن البيانات المعطاة في الجداول، وحدود واضحة، أما مدى إنشاء الجداول ليس كما ذكرت - لمرة واحدة - بل مرات عديدة حتى نهاية الصفوف في الورقة كاملة ضمن عدد معلوم للأعمدة. تقبلوا تحياتي العطرة والسلام عليكم test.xlsx

Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim x, r As Long, cnt As Long Application.ScreenUpdating = False With ActiveSheet For r = sRow To eRow cnt = cnt + 1 x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0) If Not IsError(x) Then .Cells(x, 14).Resize(, 11).Cut If r <> x Then .Cells(r, 14).Insert Shift:=xlDown Else .Cells(r, 2).Resize(, 11).Cut .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Insert Shift:=xlDown If cnt = eRow Then Exit For r = r - 1 End If Next r End With Application.ScreenUpdating = True End Sub

This is a better version If the record doesn't exist in the two tables the record will be colored with yellow and if there are two records with the same id vbCyan will be the color for different information if exists Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim x, y, r As Long, c As Long Application.ScreenUpdating = False With ActiveSheet .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo .Rows(sRow & ":" & eRow).Interior.Color = xlNone For r = sRow To eRow x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0) If Not IsError(x) Then For c = 2 To 12 If .Cells(r, c).Value <> .Cells(x, c + 12).Value Then If .Cells(r, c).Interior.Color <> vbYellow Then .Cells(r, c).Interior.Color = vbCyan If .Cells(x, c + 12).Interior.Color <> vbYellow Then .Cells(x, c + 12).Interior.Color = vbCyan End If Next c Else .Cells(r, 2).Resize(, 11).Interior.Color = vbYellow End If y = Application.Match(.Cells(r, 14).Value, .Columns(2), 0) If Not IsError(y) Then For c = 2 To 12 If .Cells(y, c).Value <> .Cells(r, c + 12).Value Then If .Cells(y, c).Interior.Color <> vbYellow Then .Cells(y, c).Interior.Color = vbCyan If .Cells(r, c + 12).Interior.Color <> vbYellow Then .Cells(r, c + 12).Interior.Color = vbCyan End If Next c Else .Cells(r, 14).Resize(, 11).Interior.Color = vbYellow End If Next r End With Application.ScreenUpdating = True End Sub

Not so clear but try this code Sub Test() Const sRow As Integer = 4, eRow As Integer = 18 Dim r As Long, c As Long Application.ScreenUpdating = False With ActiveSheet .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo .Rows(sRow & ":" & eRow).Interior.Color = xlNone For r = sRow To eRow For c = 2 To 12 If .Cells(r, c).Value <> .Cells(r, c + 12).Value Then .Cells(r, c).Interior.Color = vbCyan .Cells(r, c + 12).Interior.Color = vbCyan End If Next c Next r End With Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته موضوع مكرر https://www.officena.net/ib/topic/112828-لا-اريد-تغير-اسم-الملف-الرئيسي/ https://www.officena.net/ib/topic/112797-تعديل-كود-حفظ-ملف-نصي/

حقيقة انا لدي جداول عديدة و مليئة بالمعلومات ، وقمت بربطها بواسطة استعلام واحد ، والواجهة الرئيسية مرتبطة بالاستعلام مالحل رأيك اخي العزيز

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

السلام عليكم اخي الكريم تأكد من خاصية مصدر السجلات فقد يكون المصدر جدول لا يحوي اي سجل فيه او استعلام للقراءة فقط ولا يحوي اي سجل ايضا