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

اخي الكريم لتسهيل عملية التحديث اقترح عليك ان تستعين بــ Google drive بحيث تقوم برفع آخر نسخة من التعديلات الى Google drive و من خلال الكود سيتم تحميل هذه النسخة الى جهاز العميل او المستخدم الآخر و حتى يتم ذلك يجب ان تقوم بإنشاء Module جديد و الصق فيه الكود التالي Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As LongPtr, ByVal lpfnCB As LongPtr) As LongPtr #Else Private Declare Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownLoadToFileA" (ByVal pCaller As Long, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long #End If Function downloadFile( _ ByVal FileURL As String, _ ByVal FilePath As String) _ As Boolean Const ProcName As String = "downloadFile" On Error GoTo clearError URLDownloadToFile 0, FileURL, FilePath, 0, 0 downloadFile = True ProcExit: Exit Function clearError: Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _ & " " & "Run-time error '" & Err.Number & "':" & vbLf _ & " " & Err.Description Resume ProcExit End Function Sub downloadGoogleDrive(FilePath As String, FileID As String) Const UrlLeft As String = "http://drive.google.com/u/0/uc?id=" Const UrlRight As String = "&export=download" Dim Url As String: Url = UrlLeft & FileID & UrlRight Dim wasDownloaded As Boolean wasDownloaded = downloadFile(Url, FilePath) If wasDownloaded Then MsgBox "Success" Else MsgBox "Fail" End If End Sub Sub NewFileText() On Error Resume Next Dim FileSeveTo As String FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _ Len(CurrentProject.FullName) _ - InStrRev(CurrentProject.FullName, "\")) Dim GoogleFileID As String: GoogleFileID = "1DQqZYciRIs_dcBE6JLeoqiB3zjcq2SpL" Call downloadGoogleDrive(FileSeveTo, GoogleFileID) Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim oFile As Object Set oFile = fso.CreateTextFile(CurrentProject.Path & "\UpdateFile.cmd") oFile.WriteLine "@Echo OFF" oFile.WriteLine "SLEEP 3" oFile.WriteLine "copy " & """" & FileSeveTo & """" & " " & """" & CurrentProject.FullName & """" & " /Y" oFile.WriteLine "call " & """" & CurrentProject.FullName & """" oFile.WriteLine "exit" oFile.Close Set fso = Nothing Set oFile = Nothing 'تشغيل ملف النظام Dim RetVal RetVal = Shell(CurrentProject.Path & "\UpdateFile.cmd", 1) Application.CloseCurrentDatabase End Sub و للاستدعاء لتحميل الملف و استبدال النسخة الحالية للمستخدم استخدم الكود التالي في ازرار التحديث او في اي اجراء تستخدمه للتحديث (( لا تنسى وضع مفتاح الملف الذي حصلت عليه من قوقل )) '=========================================================================== Dim GoogleFileID As String: GoogleFileID = "مفتاح الملف من قوقل درايف" '=========================================================================== Dim FileSeveTo As String FileSeveTo = CurrentProject.Path & "\" & Right$(CurrentProject.FullName, _ Len(CurrentProject.FullName) _ - InStrRev(CurrentProject.FullName, "\")) Call downloadGoogleDrive(FileSeveTo, GoogleFileID)

يمكنك تحويل المعادلة الي كود مثلا لو أردنا تحويل العمود D نستعمل هذا الاجراء مع ربطه بزر مع حفظ الملف بصيفة تدعم الاكواد مثل xlsb Sub mrmas() Range("d2:d101").Formula = "=rand()" Range("d2:d101").Value = Range("d2:d101").Value End Sub بالتوفيق

يمكنك استعمال هذه الطريقة بوضع السيريلات المسموحة في مصفوفة myserials بينها فاصلة Private Sub Workbook_Open() myserials = Array("589CC486", "mr-mas.com", "") myhd = Hex(CreateObject("Scripting.FileSystemObject").Drives.Item("C:").SerialNumber) If Not UBound(Filter(myserials, myhd)) > -1 Then MsgBox "أي رسالة هنا" ThisWorkbook.Close savechanges = True End If End Sub بالتوفيق

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

جزاك الله خيرا وزادك من علمه و فضله

السلام عليكم أخي الكريم إليك ما طلبت على أن تترك من لم يحصل على شيء دون إدخال أية قيمة تقبل تحياتي لك =IF(OR(C3="";Q3=0);"";IF(AND(O3>0;P3="");O3&$O$1;IF(AND(P3>0;O3="");P3&$P$1;IF(AND(O3>0;P3>0);CONCATENATE(O3;$O$1;"+";P3;$P$1))))) تجريبي كتاب تنفيذ.xlsx

ابشر اتفضل التعديل sa1.3.zip

استاذ احمد ... سؤالك متناقض كيف تريد تحويل ساعات الاستئذان الى ايام ومن ثم طرحها من الساعات الكلية ؟ المفروض ان الموظف لديه رصيد اجازات 3 ايام كل شهر (على سبيل المثال) .. ويوجد حقل بتجميع رصيد اجازات الموظف .. مثلا لديه رصيد 360 يوما لخدمة 10 سنوات نقوم بتحويل الرصيد من الايام الى ساعات بضربه *7ساعات فيكون رصيده من الاجازات بالساعة =2520 ساعة ثم نقوم بتجميع ساعات الاستئذان لكي نطرحها من رصيد الاجازات بالساعة ليظهر لنا ناتج الرصيد المتبقي من الاجازات الذي يمكن تحويله الى ايام او اشهر

Database5.accdb

بارك الله فيك وأكثر الله من امثالك

جميعا بإذن الله

شكراً لك استاذي واحسنت وبارك الله فيك

احسنت استاذ @jjafferr هذه الجزئية دخلت للاشارة لها ثم وجدت ردك فكان اكثر ايضاح بعد صنع الملف التنفيذي لن يتعامل مع القاعدة المستهدفة كونها ملف اكسس وانما كاي ملف موجود بالجهاز ☝️وفسر الماء بعد الجهد بالماء 😄

كان الموضوع شيقا ، ويفتح عالم جديد ، و لسببين رأينا اغلاق الموضوع قبل فتحة: 1. لأنه ليس برمجة الاكسس ، 2. لأنه سيحتاج الى دعم فني ، وكذلك لأنه ليس اكسس ، فليس مكانه هنا 😁 . الحمدلله ما قال: جعفر بيقول ان الموضوع سيكون مخالف 😂 جعفر

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

فورم اكسل لعرض صور متحركة وتحميل وأظهار عارض الصور الثلاثية الجزء الاول صور

اخ محمد صالح من بعض ماعندكم وحمد الله على السلامة ووحشنا تعليقاتك

إذا تولى سراة القوم أمرهم ... نما على ذاك أمــر القوم فازدادوا انعم واكرم بكم جميعا

ملف اكسل جاهز للعمل ..حول قاعدة بيانات بالاكسل لاعداد مخصصات الموظفين رصيد الاجازات ونهاية الخدمة والتذاكر . ملف احتساب رصيد مخصصات اجازات الموظفين ونهاية الخدمة بالاكسل.xlsx

متشكر جدا على ردودكم الطيبة ...بارك الله فيكم جميعا

احم احم سمعتوا شباب ، يعني في منا فائدة ،يا الله صيروا شطّار واسمعوا الكلام 😎

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

شكرا جزيلا

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

حسب فهمي للمطلوب تم تنفيذ المعادلة على العمود الأول E وإذا أردت تطبيقها على العمود التالي يمكنك تغيير الخلية $E$1 في المعادلة الموجودة في الصف الثاني بالتوفيق mas tableau.xlsx

وعليكم السلام دكتور محمد 🙂 هذه معلومة جديدة تضاف الى رصيدي ، شكرا لك 🙂 جعفر

الطريقة المذكورة في المشاركة السابقة لي أفضل واسرع بإذن الله

تفضل هذه المحاولة لكن استفسارك ماهو واضح للأسف Database81.zip

أقترح تنفيذ ذلك يدويا وليس بالكود عن طريق عمل لصق كقيم paste as values بدلا من لصق paste ورمزها (123) في القائمة المختصرة للخلية والتي تظهر بعد عمل كلك يمين عليها وإذا كنت حريصا على استخدام الكود فيمكنك وضع هذا الاجراء في موديول جديد وربطه بزر وليكن اسمه لصق Sub pst Selection.PasteSpecial Paste:=xlPasteValues End Sub وهو للصق ما تم نسخه في الخلية المحددة ولاستخدام هذا الاجراء عند الضغط على CTRL+V يمكن وضع هذا الكود في حدث المصنف ThisWorkbook Private Sub Workbook_Activate() Application.OnKey "^v", "pst" End Sub Private Sub Workbook_Deactivate() Application.OnKey "^v" End Sub بهذه الطريقة تحافظ على تنسيق الملف الذي يتم اللصق فيه عند استخدام الزر المرتبط بالكود أو اللصق باستخدام ctrl+v بالتوفيق

الخطأ هو أن العمود رقم 9 فارغ ولا يتم ترحيل بيانات إليه لذا يمكن تغيير هذا السطر erow = sh1.Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).Row إلى erow = sh1.Cells(Rows.Count, 4).End(xlUp).Offset(1, 0).Row بالتوفيق

حسب فهمي للمطلوب يمكنك إضافة هذا الكود في نهاية إجراء الطباعة Sub PRINT_OUT lr = Cells(Rows.Count, 1).End(xlUp).Row For r = 8 To lr rw = Application.WorksheetFunction.Match(Range("A" & r).Value, Sheets("التحميل").Range("A:A"), 0) Sheets("التحميل").Range("Q" & rw).Value = "تم الصرف" Next r وهو للحصول على رقم الصف الذي يحتوي على رقم المستند الموجود في الخلية A8 وما بعدها عند البحث عنه في العمود A في شيت التحميل ثم تغيير قيمة الخلية Q في نفس الصف إلى تم الصرف بالتوفيق

تفضل هذا التعديل لتجاوز الخطأ Public Function importExcel(Tablename As String, FilePath As String) On Error Resume Next Dim xlApp As Excel.Application Dim xlWb As Excel.Workbook Dim xlWs As Excel.Worksheet Dim intLine As Long Dim strSqlDml As String Dim strColumn1 As String, strColumn2 As String, strColumn3 As String Set xlApp = New Excel.Application xlApp.Visible = False Set xlWb = xlApp.Workbooks.Open(FilePath) Set xlWs = xlWb.Worksheets(1) intLine = 2 'سيتم استيراد الصفوف بدء من الصف رقم 2 Do strColumn1 = Trim(xlWs.Cells(intLine, 1).Value) 'رقم 1 يعني العمود رقم 1 في ملف الاكسل strColumn2 = Trim(xlWs.Cells(intLine, 2).Value) 'رقم 2 يعني العمود رقم 2 في ملف الاكسل strColumn3 = Trim(xlWs.Cells(intLine, 3).Value) 'رقم 3 يعني العمود رقم 3 في ملف الاكسل strSqlDml = "INSERT INTO [" & Tablename & "] VALUES('" & strColumn1 & "', '" & strColumn2 & "', '" & strColumn3 & "')" CurrentDb.Execute strSqlDml, dbFailOnError xlWs.Cells(intLine, 1).Select intLine = intLine + 1 Loop Until IsEmpty(xlWs.Cells(intLine, 1)) xlWb.Close False xlApp.Quit Set xlApp = Nothing Set xlWb = Nothing Set xlWs = Nothing End Function

اتفضل السبب فى الخطأ ان حضرتك وضعت فى مصدر بيانات مربع النص fullName التعبير الاتى =[firstName] & " " & [secondName] & " " & [thirdName] & " " & [fourthName] ولذلك تم بالفعل نجميع الاسم الرباعى ولكن اصبح مربع النص fullName غير منضم ترى فيه النتيجة بالفعل ولكن لم تتم ادراج القيمة فى الجدل فى الحقل المطلوب fullName.accdb

راح اتأكدلك بكرى .. رغم اني متأكد

تفضل ..... Dim db As DAO.Database Dim qdf As DAO.QueryDef Dim strSQL As String Set db = CurrentDb strSQL = "SELECT sub.* FROM sub WHERE " strSQL = strSQL & "[No] " & Me![cboFirstOperator] & "" & Me![txtCostCenter] & "" db.QueryDefs.Delete "qryMyQuery" Set qdf = db.CreateQueryDef("qryMyQuery", strSQL) Filter (2).accdb

تفضل هذا التعديل Filter.accdb

تفضل 🙂 Barcode.accdb

السلام عليكم 🙂 حياك الله اخوي @ناقل بين اخوتك ، لنا الفخر ان نلصق هذه التسمية على صدرك ، فانت اهل لها 🙂 والشباب اللي شمشموا الخبر من البارحة ، فالخبر نضج الآن ، وحياكم الله 🙂 جعفر

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

مشاركة مع اخي ناقل ضع زر الطباعة في التقرير ..واجعل خاصية Display When لزر الطباعة = Screen Only ثم ضع الكود التالي في حدث عن الضغط على زر الطباعة Private Sub CmdPrint_Click() DoCmd.RunCommand acCmdPrint End Sub و لا تنسى ان تجعل نمط العرض عند فتح التقرير acViewPreview

تفضل ... DoCmd.RunCommand acCmdPageSetup

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

بارك الله فيك أخي محمد يحياوي وهذا هو الكود العكسي إلغاء تثبيت وظيفة إضافية sub UnInstall_Addin() Dim oXLAddin As AddIn For Each oXLAddin In Application.AddIns If oXLAddin.FullName = "C:\MyAddIn.xla" Then oXLAddin.Installed = False End If Next oXLAddin End Sub وكل عام أنتم بخير

بارك الله لك أخي محمد يحيى موضوع رائع واسمح لي بالمساهمة فيه ولو بالقليل ..... كود لعرض شريط القوائم وشريط الأدوات القياسي وشريط التنسيق (الخاصين بأوفيس 2003) في أوفيس 2007 أو 2010 في الإكسل نستعمل الكود التالي Sub show2003() On Error Resume Next Dim cb As CommandBar Dim ctrl As CommandBarControl Set cb = CommandBars.Add("Mas2003Menu") For Each ctrl In CommandBars("Worksheet Menu Bar").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 Set cb = CommandBars.Add("Mas2003Standard") For Each ctrl In CommandBars("Standard").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 Set cb = CommandBars.Add("Mas2003Formatting") For Each ctrl In CommandBars("Formatting").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 End Sub وفي الوورد والباور بوينت نستعمل الكود التالي Sub show2003() On Error Resume Next Dim cb As CommandBar Dim ctrl As CommandBarControl Set cb = CommandBars.Add("Mas2003Menu") For Each ctrl In CommandBars("Menu Bar").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 Set cb = CommandBars.Add("Mas2003Standard") For Each ctrl In CommandBars("Standard").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 Set cb = CommandBars.Add("Mas2003Formatting") For Each ctrl In CommandBars("Formatting").Controls ctrl.Copy cb Next ctrl cb.Visible = 1 End Sub وهذا كود حذفهم جميعاً Sub hide2003() On Error Resume Next CommandBars("Mas2003Menu").Delete CommandBars("Mas2003Standard").Delete CommandBars("Mas2003Formatting").Delete End Sub تحياتي للجميع وكل عام أنتم بخير بمناسبة أفضل ايام الدنيا عشر ذي الحجة

أسعد الله ايامك أخي سعد كود بسيط وجميل جدا جزاك الله كل خير

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

شكرا لك أخي سعد بارك الله لك

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

أنت الأصل أخي عماد أنت صاحب الفكرة الأولى

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