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

السلام عليكم يمكن عن طريق رسم دائرة على الخلية الكود Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Target.Column > 7 And Target.Column < 31 And Target.Row > 5 Then Cancel = True Dim ws As Worksheet Set ws = ActiveSheet Dim shp As Shape For Each shp In ws.Shapes If Not Intersect(shp.TopLeftCell, Target) Is Nothing Then shp.Delete End If Next shp With ws.Shapes.AddShape(msoShapeOval, Target.Left, Target.Top, Target.Width, Target.Height) .Fill.Visible = msoFalse .Line.ForeColor.RGB = RGB(255, 0, 0) End With End If End Sub الملف دائرة حمراء.xls

السلام عليكم تم التعديل

اعرض الملف 🎁📅 :: المخطط السنوي للإجازات :: 🌼🌷 :: عرض جميع إجازات الموظفين على الجدول الزمني Gantt Cart دايناميكي 😊👌🏻 السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم هذه الهدية المتواضعة :: المخطط السنوي للإجازات :: وهو عبارة عن تقويم سنوي لإجازات الموظفين يتم رسمه دايناميكيا على مخطط رسم بياني يسمى Gantt Chart 👌 يمتاز التصميم بالسهولة والجمال والإبداعية وقد شرحت كيفية استخدامه في الفيديو التالي ✌ في التحديث الجديد 1.7 تم إضافة حقل لمجموع عدد الأيام سنويا ... مع دعم للإجازات عابرات القارات (الإجازات التي تمتد لعدة سنوات كالإجازات الدراسية الطويلة) ظهور عدد الأيام في جميع النوافذ من مميزات هذا المخطط: - عرض جميع الإجازات في صفحة واحدة يسهل من قرائتها ومراجعتها. - تصميم رائع وألوان جميلة . - سهل الاستخدام . - وكذلك هذا المخطط يمكن استخدامه للمشاريع بدل الإجازات أو عرض مدة الإيجارات أو .. أو .. أو ... حيث لا حدود للإبداع 🙂 :: وأخيرا وليس آخرا :: :: لا تنسونا ووالدينا من صالح دعواتكم الطيبة 🙂 🌹🌷 :: صاحب الملف Moosak تمت الاضافه 01 ينا, 2025 الاقسام قسم الأكسيس

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) أشارككم اليوم حلاً برمجياً لمشكلة شائعة تواجه مطوري و مبرمجي تطبيقات آكسيس عند التعامل مع اللغة العربية . المشكلة تتمثل في الحاجة لتغيير لغة النظام (System Locale) إلى العربية لضمان عرض النصوص العربية بشكل صحيح في التطبيق ، وضمان عمل المشروع دون مشاكل . 🎯 المشكلة: - عدم ظهور النصوص العربية بشكل صحيح في بعض أجزاء التطبيق - الحاجة المتكررة لتغيير إعدادات النظام يدوياً - صعوبة شرح الخطوات للمستخدمين النهائيين ✨ الحل: قمت بتطوير دالة برمجية تقوم بـ: 1. فحص لغة النظام الحالية 2. تغيير لغة النظام إلى العربية بشكل تلقائي 3. ضبط جميع الإعدادات الضرورية (CodePage, Locale, Keyboard Layout) 4. إعادة تشغيل النظام بشكل آمن لتطبيق التغييرات 🔑 المميزات: - تنفيذ التغييرات بنقرة زر واحدة - رسائل واضحة باللغة الإنجليزية للمستخدم - معالجة الأخطاء بشكل احترافي - تأكيد موافقة المستخدم قبل إجراء التغييرات - إتاحة وقت كافٍ لحفظ الملفات قبل إعادة التشغيل 📝 ملاحظات هامة: - سيتم إعادة تشغيل الجهاز بعد تطبيق التغييرات - الكود يعمل على جميع إصدارات Windows الحديثة وهذه صورة توضيحية للخطوات التي كان على المستخدم العادي أو المبرمج تنفيذها حتى يتلافى مشكلة اللغة العربية :- الكود المستخدم في المديول :- Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long #Else Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long #End If Private Const MSG_CHANGE_LANGUAGE As String = "Your program will not function correctly; the unicode language must be changed to Arabic. Would you like to proceed with changing the unicode language?" Private Const MSG_RESTART_NOTE As String = "Note: The computer will restart after the change" Private Const MSG_TITLE As String = "Change System Language" Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "The project cannot run without changing the system language to Arabic" Private Const MSG_ERROR As String = "System error occurred. Please contact your administrator" Private Function IsArabicLanguage() As Boolean Dim CodePage As Long CodePage = GetACP() IsArabicLanguage = (CodePage = 1256) End Function Public Function SetArabicLocale() As Boolean On Error GoTo ErrorHandler If Not IsArabicLanguage() Then Dim response As VbMsgBoxResult response = MsgBox(MSG_CHANGE_LANGUAGE & vbCrLf & MSG_RESTART_NOTE, _ vbQuestion + vbYesNo + vbDefaultButton2, _ MSG_TITLE) If response = vbYes Then Dim fso As Object Dim txtFile As Object Dim filePath As String filePath = Environ$("TEMP") & "\ChangeToArabic.bat" Set fso = CreateObject("Scripting.FileSystemObject") Set txtFile = fso.CreateTextFile(filePath, True) With txtFile .WriteLine "@echo off" .WriteLine "chcp 1256" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d 00000401 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d 00000401 /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d ar-JO /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d 00000409 /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sLanguage /t REG_SZ /d ARA /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d Jordan /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v iCountry /t REG_SZ /d 962 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v ACP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v OEMCP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v MACCP /t REG_SZ /d 10004 /f" .WriteLine "reg add ""HKCU\Keyboard Layout\Preload"" /v 1 /t REG_SZ /d 00000401 /f" .WriteLine "control.exe intl.cpl,, /f:""C:\Windows\System32\intl.cpl""" .WriteLine "timeout /t 5" .WriteLine "shutdown /r /t 15 /c ""سيتم إعادة تشغيل الجهاز بعد ( 15 ثانية ) لتطبيق إعدادات اللغة العربية"" /f" End With txtFile.Close Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") shellApp.ShellExecute filePath, "", "", "runas", 1 MsgBox MSG_RESTART_SOON & vbCrLf & MSG_SAVE_FILES, vbInformation SetArabicLocale = True Else MsgBox MSG_CANT_RUN, vbCritical SetArabicLocale = False End If Else SetArabicLocale = True End If Exit Function ErrorHandler: MsgBox MSG_ERROR, vbCritical SetArabicLocale = False End Function طبعاً رسالة التنبيه تم كتابتها باللغة الإنجليزية . في متغيرات متعددة ( السبب هو إحدى المحاولات للكتابة بالعربية مع تشفير النص ( Unicode ) ) . ولكني تجاهلت الفكرة لاحقاً . الآن يمكنك استدعاء الدالة في أول نموذج لك بالشكل التالي :- SetArabicLocale عند وجود اللغة العربية هي لغة الترميز في نسخة الويندوز ، لن تظهر لك رسالة ضرورة تغيير لغة الترميز الى العربية . ولم اقم بإضافات كبيرة خارج إطار الموضوع ، وللمبرمج حرية التعديل والإستفادة من الكود حيثما وكيفما يشاء . الملف المرفق مفتوح المصدر 👈 [ LanguageCheck.accdb ]

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) بالإشارة الى الموضوع الذي أعلنت عنه سابقاً في هذا الرابط هنا ، اسمحوا لي بأن أطرح هذه الفكرة الجديدة والتي تم تجربتها مراراً وتكراراً إلى أن خرجت بهذه النتيجة فيما يتعلق بموضوع التحديث الهوائي أو Online أو OTA ( Over-The-Air ) . الموضوع بداية بسيط جداً ولن يحتاج تعقيد في تنفيذ هذه الطريقة . حيث ما يلزمنا أولاً هو حساب على Google Drive ( لماذا ؟ = لأن 95 % من الأشخاص عندهم هذا الحساب ) . و حساب على موقع Dropbox ( لماذا ؟ = لأنه يعطينا امكانية التحميل برابط مباشر خلافاً في جوجل درايف ) وهو ما يميزه عن Google Drive . بناءً على ما سلف ، نبدأ شرح الخطوات والمتطلبات على بركة الله :- 1. سنحتاج جدول واحد مرفق وهو ( Settings ) ، ولا أنصح بالتلاعب به ما لم يكن على أساس صحيح ؛ ويحتوي على الحقول التالية :- الحقل Ver = رقمي = لتحديد الإصدار الحالي للنسخة الحالية في قاعدة البيانات الحالية. الحقل Link = نصي = لتحديد رابط الملف النصي الذي سيتم قراءة الإصدار الجديد منه ومقارنته مع قيمة الحقل Ver لتحديد ما اذا كان هناك نسخة جديدة أم لا . الحقل URLS = نصي = سيتم ادراج رابط التحميل للإصدار الجديد من خلال الكود تلقائياً. الحقل DBName = نصي = سيمكانك هنا من تحديد اسم قاعدة البيانات التي سيتم حفظ التحديث الجديد بها . وهنا لتسهيل فكرة اسم القاعدة القديمة واستبدالها بالنسخة الجديدة سيتم جلب القيمة تلقائياً . الحقل Auto_Check = نوع Yes/No = لتفعيل ميزة الفحص التلقائي للتحديثات ( فكرة شبيهة بتلك التي في أجهزة الجوال والمحمول عند تفعيلها يصلك إشعارك بوجود نسخة جديدة إن كانت الميزة مفعلة طبعاً ) 2. تحميل الإصدار الجديد على موقع Dropbox ونسخ رابط الملف ( مع التأكد أن الملف عند مشاركته قد تمت مشاركته للجميع - الموقع يجعلها قيمة افتراضية - ولكن للتأكيد ) . 3. ملف نصي واحد ( TxT. ) سميه ما شئت وهو ثابت غير قابل للتبديل ، ويكون محتواه ما يلي :- السطر الأول نضع رقم الإصدار الجديد . اي انه في الملف القديم لنفترض ان قيمة الحقل Ver = 0.1 . هنا في الملف النصي سنضع الإصدار الأحدث أي مثلاً ( 0.2 ). السطر الثاني نضع رابط النسخة الحديثة التي تم رفعها على Dropbox في النقطة السابقة 2 . أي انه سيكون لدينا ملف نصي يحتوي سطرين الأول رقم الإصدار الحديث والذي ستتم قراءته و مقارنته مع الحقل Ver في الإصدار الذي لدى العميل ، والسطر الثاني رابط النسخة الأحدث من دروب بوكس . 4. سنقوم برفع هذا الملف النصي على جوجل درايف ( السبب : دروب بوكس لم يدعم فكرة قراءة الملف النصي وجلب قيمة رقم الاصدار في السطر الأول لمقارنتها مع القيمة في النسخة التي لدى العميل في الحقل Ver ) . 5. ثم سنقوم بنسخ الرابط لهذا الملف النصي ومشاركته للجميع - أو بمعنى آخر لمن يملك الرابط - ولصقه في الجدول الثابت Settings في الحقل Link وهو هنا سيكون أيضاً قيمة ثابتة لن تتغير . أي أنك ستقوم بتغيير فقط رقم الإصدار في النسخة الجديدة في الحقل Ver . وإعادة رفع الملف النصي بعد تحديث قيمة رقم الاصدار الجديد فقط . طبعاً هنا بالإفتراض جدلاً وبعد تجربة متكررة أنه عندما تقوم برفع ملف موجود مسبقاً على أي موقع من ( جوجل درايف أو دروب بوكس ) فأن العنوان لهذا الملف لن يتغير لأنه سيتم استبدال الملف القديم بالجديد . ( وهي نقطة جيدة استفدنا منها لصالحنا ). 6. الآن الفكرة بشكل عام واضحة ولا تحتاج لتعقيد في الشرح ( وأي فكرة أو طريقة في البداية ستحتاج مرات معدودة لتصبح سهلة في تطبيقها عن ظهر قلب ) الآن وما هو مهم للجميع ، الكود التالي للمديول :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Public Function IsInternetConnected() As Boolean On Error GoTo ErrorHandler Dim xhr As Object Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", "https://www.google.com", False xhr.send IsInternetConnected = (xhr.Status = 200) Set xhr = Nothing Exit Function ErrorHandler: IsInternetConnected = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Public Function ConvertGoogleDriveLink(ByVal originalLink As String) As String On Error GoTo ErrorHandler Dim FileID As String If InStr(1, originalLink, "/d/") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "/d/") + 3) FileID = Left(FileID, InStr(1, FileID, "/") - 1) ElseIf InStr(1, originalLink, "id=") > 0 Then FileID = Mid(originalLink, InStr(1, originalLink, "id=") + 3) If InStr(1, FileID, "&") > 0 Then FileID = Left(FileID, InStr(1, FileID, "&") - 1) End If End If If Len(FileID) > 0 Then ConvertGoogleDriveLink = "https://drive.google.com/uc?id=" & FileID Else ConvertGoogleDriveLink = originalLink End If Exit Function ErrorHandler: ConvertGoogleDriveLink = originalLink End Function Public Function CheckForUpdate() As Boolean On Error GoTo ErrorHandler Dim currentVer As Double Dim onlineVer As Double Dim xhr As Object Dim onlineContent As String Dim driveLink As String Dim contentLines() As String Dim updateURL As String Dim currentDBName As String currentDBName = CurrentDb.Name currentDBName = Mid(currentDBName, InStrRev(currentDBName, "\") + 1) currentDBName = Left(currentDBName, InStrRev(currentDBName, ".") - 1) CurrentDb.Execute "UPDATE Settings SET DBName = '" & Replace(currentDBName, "'", "''") & "'" currentVer = DLookup("Ver", "Settings") If Not IsInternetConnected() Then Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم الإصدار: " & currentVer CheckForUpdate = False Exit Function End If driveLink = ConvertGoogleDriveLink(DLookup("Link", "Settings")) Set xhr = CreateObject("MSXML2.ServerXMLHTTP.6.0") xhr.SetOption 2, 13056 xhr.Open "GET", driveLink, False xhr.setRequestHeader "User-Agent", "Mozilla/5.0" xhr.send If xhr.ReadyState = 4 Then If xhr.Status = 200 Then onlineContent = Trim(xhr.responseText) contentLines = Split(onlineContent, vbCrLf) If UBound(contentLines) >= 1 Then onlineVer = Val(contentLines(0)) updateURL = Trim(contentLines(1)) If onlineVer > 0 Then If onlineVer > currentVer Then CurrentDb.Execute "UPDATE Settings SET URLS = '" & updateURL & "'" Forms!Frm_Index!Lbl_Load.Caption = " تحديث جديد متوفر الآن : " & onlineVer & " Ver - انقر للتحميل " Forms!Frm_Index!ImgUpdate.Visible = True CheckForUpdate = True Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus Else Forms!Frm_Index!Lbl_Load.Caption = "أنت تستخدم أحدث إصدار : " & onlineVer & " Ver " Forms!Frm_Index!Tx_User.Enabled = True Forms!Frm_Index!Tx_Pass.Enabled = True Forms!Frm_Index!Tx_User.SetFocus End If End If End If End If End If Set xhr = Nothing Exit Function ErrorHandler: CheckForUpdate = False If Not xhr Is Nothing Then Set xhr = Nothing End Function Sub UpdateURLSAndOpenNewDatabase() Dim UrlValue As String, NameValue As String Dim TargetDb As DAO.Database Dim rs As DAO.Recordset Dim CurrentDbPath As String Dim NewDbPath As String CurrentDbPath = CurrentProject.Path & "\" & Dir(CurrentProject.FullName) NewDbPath = CurrentProject.Path & "\Data\Update.accdb" If Dir(CurrentProject.Path & "\Data\Update.Dll") <> "" Then Name CurrentProject.Path & "\Data\Update.Dll" As NewDbPath Else MsgBox "الملف Update.Dll غير موجود", vbCritical Exit Sub End If On Error GoTo ErrorHandler UrlValue = Nz(CurrentDb.OpenRecordset("SELECT URLS FROM Settings").Fields("URLS").Value, "") NameValue = Nz(CurrentDb.OpenRecordset("SELECT DBName FROM Settings").Fields("DBName").Value, "") If UrlValue = "" Or NameValue = "" Then MsgBox "خطأ في تحميل التحديث", vbCritical Exit Sub End If Set TargetDb = DBEngine.OpenDatabase(NewDbPath) Set rs = TargetDb.OpenRecordset("Settings", dbOpenDynaset) If rs.EOF Then rs.AddNew rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update Else rs.MoveFirst rs.Edit rs.Fields("URLS").Value = UrlValue rs.Fields("DBName").Value = NameValue rs.Update End If rs.Close TargetDb.Close Shell "msaccess.exe """ & NewDbPath & """", vbNormalFocus Application.Quit Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical If Not rs Is Nothing Then rs.Close If Not TargetDb Is Nothing Then TargetDb.Close Exit Sub End Sub Public Function ExtractAttachmentFile() As Boolean On Error GoTo ErrorHandler Dim db As DAO.Database Dim rs As DAO.Recordset Dim rsAttach As DAO.Recordset2 Dim fld As DAO.Field2 Dim dataFolder As String dataFolder = CurrentProject.Path If Dir(dataFolder, vbDirectory) = "" Then MkDir dataFolder End If Set db = CurrentDb Set rs = db.OpenRecordset("Settings") If Not rs.EOF Then Set fld = rs.Fields("DBFiles") If Not IsNull(fld) Then Set rsAttach = fld.Value If Not rsAttach.EOF Then rsAttach.Fields("FileData").SaveToFile dataFolder & "\" & rsAttach.Fields("FileName").Value ExtractAttachmentFile = True End If rsAttach.Close End If End If CleanUp: If Not rs Is Nothing Then rs.Close Set rs = Nothing Set db = Nothing Exit Function ErrorHandler: ExtractAttachmentFile = False Resume CleanUp End Function وما يلي كود النموذج لجميع الأجزاء والمكونات داخله :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '*************** ( 28/12/2024 ) *************** Option Compare Database Option Explicit Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private bMessage20Displayed As Boolean Private bMessage35Displayed As Boolean Private bMessage50Displayed As Boolean Private LoginAttempts As Integer Dim TimeCount As Long Private Sub Btn_Quit_Click() Dim userResponse As VbMsgBoxResult userResponse = MsgBox("إغلاق النظام؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية الإغلاق") If userResponse = vbYes Then DoCmd.Quit ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If End Sub Private Sub Form_Load() ExtractAttachmentFile LoginAttempts = 0 Me.Caption = "Foksh - Officena.Net - 2025" DoEvents If Check_Auto = -1 Then Me.TimerInterval = 1000 Else Me.TimerInterval = 0 Me.Lbl_Load.Caption = "" End If End Sub Private Sub Form_Timer() Me.TimerInterval = 0 CheckForUpdate End Sub Private Sub ImgUpdate_Click() On Error GoTo ErrorHandler Dim userResponse As VbMsgBoxResult userResponse = MsgBox("التحديث الآن؟", _ vbYesNo + vbInformation + vbMsgBoxRight, "تأكيد عملية التحديث") If userResponse = vbYes Then UpdateURLSAndOpenNewDatabase ElseIf userResponse = vbNo Then DoCmd.CancelEvent End If ErrorHandler: Resume Next End Sub ما يتم تنفيذه عند استعمال الفكرة :- أولاً عند الفتح للمشروع سيتم استخراج ملف DLL مرفق داخل قاعدة البيانات . ثانياً عند اكتمال التحديث سيتم استبدال النسخة القديمة بالنسخة الجديدة ، وشأنه شأن أي عملية تحديث ؛ فإنك ستفقد النسخة القديمة كاملةً ( وهنا الحاجة الماسة لاعتماد فكرة تقسيم قاعدة البيانات ) . ملف الواجهة المرفق مفتوح المصدر 👈 [ Main.accdb ] * عذراً إن كانت طريقتي في العمل مزعجة أو غريبة نوعاً ما ، لكن هو طبعي 😅 . فماذا أفعل ؟؟!!

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

السلام عليكم بداية الكود كانت من الاستاذ الفاضل @ابوخليل يشرفني ان ارسل لكم تعديل بارسال المرفقات عبر واتساب ويب اي نوع مرفق يمكن ارساله (مستند / صورة /فديو /اكسيل -وارد - يمكنك اضافة اي امتداد بالكود وسيقوم بارساله - يمكنك ارسال تقرير مياشرة او تحديد مرفق - يقوم بالارسال لعدد غير محدود الارقام المضافة لديكم وغير المضافة . تغير وزيادة نوع المستند او المرفق من هنا AttachmentPath = reportPath ' تحديد نوع المرفق بناءً على المسار المحفوظ If InStr(reportPath, ".pdf") > 0 Then AttachmentType = 1 ' ملف PDF ElseIf InStr(reportPath, ".doc") > 0 Or InStr(reportPath, ".docx") > 0 Or InStr(reportPath, ".xls") > 0 Or InStr(reportPath, ".xlsx") > 0 Or InStr(reportPath, ".ppt") > 0 Or InStr(reportPath, ".pptx") > 0 Then AttachmentType = 1 ' ملف PDF ElseIf InStr(reportPath, ".jpg") > 0 Or InStr(reportPath, ".jpeg") > 0 Or InStr(reportPath, ".png") > 0 Or InStr(reportPath, ".gif") > 0 Or InStr(reportPath, ".bmp") > 0 Or InStr(reportPath, ".tif") > 0 Or InStr(reportPath, ".tiff") > 0 Or InStr(reportPath, ".webp") > 0 Or InStr(reportPath, ".svg") > 0 Then AttachmentType = 2 ' صورة ElseIf InStr(reportPath, ".mp4") > 0 Or InStr(reportPath, ".avi") > 0 Or InStr(reportPath, ".mov") > 0 Or InStr(reportPath, ".wmv") > 0 Then AttachmentType = 2 ' صورة ElseIf InStr(reportPath, ".sticker") > 0 Then AttachmentType = 6 ' ملصق Else ' يمكنك إضافة المزيد من الامتدادات إلى هنا إذا لزم الأمر AttachmentType = 0 ' غير معروف End If ملحوظة عند اي تحديث لواتساب يجب تعديل خاصية send key ( ' إرفاق المرفق إذا كان موجودًا If AttachmentPath <> "" Then ' الانتقال لزر إرسال المرفقات الجديد ' الانتقال لزر إدراج المستندات الجديد SendKeys "+{TAB}" ' الرجوع خطوة واحدة SendKeys "+{TAB}" ' الرجوع خطوة إضافية إذا لزم الأمر SendKeys "~" ' الضغط على الزر Sleep 1000 ' الانتظار لفتح مربع اختيار الملف ) كنت من فتره طورت الكود لصديقي وقفلت الموضوع اليوم طلبه مني صديق اخر احببت اشارك الجميع الكود ربما ينتفع به غيرنا كما تعلمنا من هذا الجروب العظيم يشهد الله اني تعلمت الاكسس من هذا الجروب العظيم وكل شخص فيه له فضل عليا ولم يقصر اي شخص في المساعدة. cash1.rar

أبدعت ... أبدعت ... أبدعت ... بسم الله ما شاء الله 😄👏👏👏 طيب أيش رايك في ذي الفكرة : LanguageCheck V 2.1.accdb

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

تم التخلص من المديول ، ودمج الفكرة داخل نموذج البداية ، والذي اعتمدت في تصميمه على ما يلي :- ⏱️ جعلته يبدو كرسالة بمحتوى عربي بدلاً من الرسائل الإنجليزية والتي قد تربك المستخدم أو من كانت خبرته باللغة الإنجليزية ليست بالقوية . ⏱️ من خلال الكود أصبح بإمكان المبرمج اختيار البلد الذي يريد أن تكون له اللغة العربية في اللغة الإدارية ( Unicode ) . arabicSettings = GetArabicCountrySettings("Jo") ⏱️ من خلال التعديل الجديد عندما يفتح النموذج اذا كانت اللغة الإدارية تدعم العربية فسيتم اغلاق النموذج المرفق وفتح النموذج الخاص بالمشروع بك ( التعديل من الكود ) ⏱️ تم دعم بلدان الدول العربية ( كافة إلى حد ما وما استطعت من الحصول على LocalID الخاص بها .. ) الكود الكامل للنموذج بعد التحديث :- '********************************************** '*** *** '*** FFFFFF OOO KK KK SSSS HH HH *** '*** FF O O KK KK SS HH HH *** '*** FFFFF O O KKK SS HHHHHH *** '*** FF O O KK KK SS HH HH *** '*** FF OOO KK KK SSSSS HH HH *** '*** *** '********************************************** Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long #Else Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long #End If Private Type ArabicCountry LocaleName As String LocaleID As String CountryName As String countryCode As String End Type Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "Your project cannot run without changing the system local to Arabic" Private arabicSettings As ArabicCountry Private Function IsArabicLanguage() As Boolean Dim CodePage As Long CodePage = GetACP() IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As ArabicCountry Select Case UCase(countryCode) Case "AE", "UAE", "EMIRATES" With GetArabicCountrySettings .LocaleName = "ar-AE" .LocaleID = "00003801" .CountryName = "United Arab Emirates" .countryCode = "971" End With Case "BH", "BAHRAIN" With GetArabicCountrySettings .LocaleName = "ar-BH" .LocaleID = "00003C01" .CountryName = "Bahrain" .countryCode = "973" End With Case "DZ", "ALGERIA" With GetArabicCountrySettings .LocaleName = "ar-DZ" .LocaleID = "00001401" .CountryName = "Algeria" .countryCode = "213" End With Case "EG", "EGYPT" With GetArabicCountrySettings .LocaleName = "ar-EG" .LocaleID = "00000C01" .CountryName = "Egypt" .countryCode = "20" End With Case "IQ", "IRAQ" With GetArabicCountrySettings .LocaleName = "ar-IQ" .LocaleID = "00000801" .CountryName = "Iraq" .countryCode = "964" End With Case "JO", "JORDAN" With GetArabicCountrySettings .LocaleName = "ar-JO" .LocaleID = "00000409" .CountryName = "Jordan" .countryCode = "962" End With Case "KW", "KUWAIT" With GetArabicCountrySettings .LocaleName = "ar-KW" .LocaleID = "00003401" .CountryName = "Kuwait" .countryCode = "965" End With Case "LB", "LEBANON" With GetArabicCountrySettings .LocaleName = "ar-LB" .LocaleID = "00003001" .CountryName = "Lebanon" .countryCode = "961" End With Case "LY", "LIBYA" With GetArabicCountrySettings .LocaleName = "ar-LY" .LocaleID = "00001001" .CountryName = "Libya" .countryCode = "218" End With Case "MA", "MOROCCO" With GetArabicCountrySettings .LocaleName = "ar-MA" .LocaleID = "00001801" .CountryName = "Morocco" .countryCode = "212" End With Case "OM", "OMAN" With GetArabicCountrySettings .LocaleName = "ar-OM" .LocaleID = "00002001" .CountryName = "Oman" .countryCode = "968" End With Case "QA", "QATAR" With GetArabicCountrySettings .LocaleName = "ar-QA" .LocaleID = "00004001" .CountryName = "Qatar" .countryCode = "974" End With Case "SA", "SAUDI" With GetArabicCountrySettings .LocaleName = "ar-SA" .LocaleID = "00000401" .CountryName = "Saudi Arabia" .countryCode = "966" End With Case "SD", "SUDAN" With GetArabicCountrySettings .LocaleName = "ar-SD" .LocaleID = "00002C01" .CountryName = "Sudan" .countryCode = "249" End With Case "SY", "SYRIA" With GetArabicCountrySettings .LocaleName = "ar-SY" .LocaleID = "00002801" .CountryName = "Syria" .countryCode = "963" End With Case "TN", "TUNISIA" With GetArabicCountrySettings .LocaleName = "ar-TN" .LocaleID = "00001C01" .CountryName = "Tunisia" .countryCode = "216" End With Case "YE", "YEMEN" With GetArabicCountrySettings .LocaleName = "ar-YE" .LocaleID = "00002401" .CountryName = "Yemen" .countryCode = "967" End With Case Else With GetArabicCountrySettings .LocaleName = "ar-SA" .LocaleID = "00000401" .CountryName = "Saudi Arabia" .countryCode = "966" End With End Select End Function Private Sub ChangeLanguage() On Error GoTo ErrorHandler Dim fso As Object Dim txtFile As Object Dim filePath As String filePath = Environ$("TEMP") & "\ChangeToArabic.bat" Set fso = CreateObject("Scripting.FileSystemObject") Set txtFile = fso.CreateTextFile(filePath, True) With txtFile .WriteLine "@echo off" .WriteLine "chcp 1256" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & arabicSettings.LocaleName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sLanguage /t REG_SZ /d ARA /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & arabicSettings.CountryName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v iCountry /t REG_SZ /d " & arabicSettings.countryCode & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v ACP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v OEMCP /t REG_SZ /d 1256 /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\CodePage"" /v MACCP /t REG_SZ /d 10004 /f" .WriteLine "reg add ""HKCU\Keyboard Layout\Preload"" /v 1 /t REG_SZ /d " & arabicSettings.LocaleID & " /f" .WriteLine "control.exe intl.cpl,, /f:""C:\Windows\System32\intl.cpl""" .WriteLine "timeout /t 5" .WriteLine "shutdown /r /t 15 /c ""سيتم إعادة تشغيل الجهاز بعد ( 15 ثانية ) لتطبيق إعدادات اللغة العربية"" /f" End With txtFile.Close Dim shellApp As Object Set shellApp = CreateObject("Shell.Application") shellApp.ShellExecute filePath, "", "", "runas", 0 ' MsgBox MSG_RESTART_SOON & vbCrLf & MSG_SAVE_FILES, vbInformation Exit Sub ErrorHandler: Resume Next End Sub Private Sub Btn_Yes_Click() If Not IsArabicLanguage() Then ChangeLanguage Else MsgBox "اللغة الإدارية الحالية في جهازك هي فعلاً اللغة العربية", vbInformation, arabicSettings.CountryName & " : اللغة العربية الحالية" End If End Sub Private Sub Btn_No_Click() MsgBox MSG_CANT_RUN, vbCritical DoCmd.Close acForm, Me.Name End Sub Private Sub Form_Load() arabicSettings = GetArabicCountrySettings("Jo") Txt_ConteryName.Value = arabicSettings.CountryName If IsArabicLanguage() Then DoCmd.Close acForm, Me.Name MsgBox "استبدل هذه الرسالة بكود فتح النموذج الرئيسي", , "عندما تكون اللغة = العربية" Else Btn_Yes.Visible = True Btn_No.Visible = True End If End Sub PALESTINE الملف المرفق مفتوح المصدر 👈 [ LanguageCheck V 2.0.accdb ]

أهلا أستاذ @kanory >> يسعدني مرورك العطر أولاً ثانيا لم أتابع الموضوع الذي أشرت إليه لأني فعلاً لم ابحث عن هذه المواضيع في المنتدى .. وثالثاً وهو المهم .. لا يتم استخدام اي ايميل او باسوورد لأي حساب داخل الأكواد .. يلزم المبرمج رابط الملف النصي فقط لإضافته في جدوله .. والباقي عمل الكود .. دعمت الفكرة بأن يكون التحميل من ملف خارجي يتم استخراجه من داخل الجدول المرفق في ملفي . ( فكرة جديدة ) في فكرتي لم ولن ولا اعتمد على برامج تلزم المبرمج بتثبيت برامج في جهاز العميل . لا يوجد روابط داخل الأكواد ، كلها يتم استدراجها وجلبها إل الجدول بشكل خفي منحت المستخدم فكرة الكشف التلقائي عن التحديثات حال وجودها . ففي الجدول هناك حقل Auto_Check من خلاله يستطيع المبرمج استغلاله بحيث :- Private Sub Form_Load() DoEvents If Check_Auto = -1 Then Me.TimerInterval = 1000 Else Me.TimerInterval = 0 End If End Sub Private Sub Form_Timer() Me.TimerInterval = 0 CheckForUpdate End Sub التعامل مع معلومات التنزيل للتحديث بإحترافية ( بحيث يتم عرض شريط تحميل حقيقي لحجم الملف الذي تم تحميله وعرض سرعة الإنترنت والوقت المتبقي لإكمال عملية التحديث ) والعديد موجود في الملف الذي يتم استخراجه لتنفيذ عملية التحديث الصامت بالنسبة لفكرتي مختلفة تماماً إلا أنها في الهدف متشابهة .

بالعكس استاذنا الفاضل @Eng.Qassim ، يسعدني تعدد الإجابات وطرح الأفكار المتنوعة 😇 . لا تشغل بالك ، انتهى الأمر بأجابتك وإجابتي كأنهما واحد 🤗 .

طيب فعلا والله مش فاضى الان غصب عنى ابشر بعد ان انتهى من عملى سوف اضع المرف ان لم يسبقنى اليه احد لكن الجزء الاخير خالص من الكود هو الزتونه ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

السلام عليكم ... إذا كانت قاعدة البيانات مثلا تحتوي على 10 سجلات مرقمة من 01 إلى 10 ، فإذا حذفنا سجل 01 فسيتبقى 09 سجلات ، فعند إدخال سجل جديد من المفروض يكون الرقم التلقائي 10 ، و هذا لا يحدث فقاعدة البيانات تعطيه مباشرة الرقم 11. سؤالي : كيف نتخطى هذا الإشكال؟، بحيث بعد عملية الحذف يكون الترقيم تسلسلي ؟ الترقيم التلقائي.accdb

طيب جرب التعديل الجديد ربما يعجبك ............. 1 (11).accdb

ماشاءالله .... بارك الله فيك استاذنا العزيز kanory... هذا كان المطلوب... شكراجزيلا..❤️❤️❤️❤️ شكرا جزيلا استاذ العزيز kkhalifa1960 الفكرة جميلة عاشت ايديك...

تفضل اضغط دبل كليك على الحقل وعلمنا ..... 1 (11).accdb

أخي الكريم احذف الحدث اللي في زر الاستعادة ، واستبدله بالتالي VBA Dim strSQL As String Dim RecordNumber As Long RecordNumber = Me![الرقم].Value strSQL = "UPDATE الإجمالية " & _ "SET [سبب الحذف] = '" & Null & "', [محذوف] = False " & _ "WHERE [الرقم] = " & RecordNumber & ";" DoCmd.RunSQL strSQL MsgBox "تم تحديث السجل بنجاح", vbInformation DoCmd.Close acForm, "Frm_Delete"

مشاركةً مع استاذي @kanory تفضل استاذ @Luqman Khooshnaw المرفق . DDSearchWithCondition.rar

جرب هذا Dim searchText As String Dim fieldValue As String ' النص الذي تبحث عنه searchText = "Ca" ' أدخل الكلمة أو جزء الكلمة المراد البحث عنها fieldValue = Nz(Me!Field1, "") ' جلب القيمة من الحقل Field1 مع التعامل مع القيم الفارغة ' التحقق إذا كانت القيمة تحتوي على النص المطلوب If InStr(1, fieldValue, searchText, vbTextCompare) > 0 Then ' فتح النموذج Form1 إذا تحقق الشرط DoCmd.OpenForm "Form1" Else ' عرض رسالة توضيحية إذا لم يتحقق الشرط MsgBox "الحقل لا يحتوي على النص المطلوب.", vbInformation, "تحذير" End If

أشكرك جزيل الشكر على مجهوداتك و نصائحك القيمة .

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

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

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

استاذي الغالي الدروب بوكس ايضا تستطيع من خلاله قراءة النصوص .... جرب المرفق ووافني بالنتيجة .... KAN_1.accdb

باعتقادي لأنك تستعمل حقل الترقيم التلقائي ( AutoNumber ) . أما فيما يخص الترقيم فهنا أمامك طريقان :- أن كان الترقيم ليس مفتاح اساسي مشترك ومرتبط مع جداول أخرى ( وبالنسبة لي هذا لا اشجعه ولا اعتمده في الترقيم الفريد للموظفين أو الزبائن أو العملاء ... إلخ ) أي بمعنى آخر هو فقط مجرد حقل لا تستخدمه للربط فأمر الترقيم غير مهم لأنهك هنا ستضطر لعمل ضغط وإصلاح للقاعدة كلما حذفت سجل للمحافظة على تسلسل الترقيم التالي ، يعني لو عندك 10 سجلات وحذفت السجل 10 ، سيكون التالي 11 في كلا الحالتين ، ولو حذفت الـ 10 كاملة وأضفت سجل فسيكون الأول أيضاً ترقيمه 11 .. إذا لا مفر من أتباع نهج وطريق آخر ,, أما اذا كان حقل الترقيم مفتاح أساسي ( وكما أخبرتك سابقاً أنني لا أشجع هذه الفكرة ) ، لا انصحك بالتلاعب بالترقيم لأن ذلك يؤثر على سير العلاقات بين الجداول ( خصوصاً إن كان هذا الحقل ذو علاقة رأس بأطراف مع جدول آخر ) .. أتمنى أن تكون الفكرة قد توضحت لك .. ولكن إجابةً لسؤالك راجع هذا الموضوع ، قد تجد ضالتك فيه .

اخي الكريم ، حتى تتضح لك الصورة أكثر ، ولا نخوض في موضوع ثاني ونخالف قواعد المنتدى .. نستطيع تقسيم العملية إلى أجزاء وطباعة كل جزء بشكل منفصل لفهم كيفية حساب القيمة النهائية ، على سبيل المثال :- حساب مجموع القروض (Loan_Made) للسنة السابقة :- Dim LoanMadePreviousYear As Double LoanMadePreviousYear = Nz(DSum("[Loan_Made]", "[tbl_Loans]", "Year([Auto_Date])=" & Me.txtYear - 1 & " And [Loan_ID] > 0 And [Nr] >= 6"), 0) Debug.Print "LoanMadePreviousYear: " & LoanMadePreviousYear حساب مجموع المدفوعات (Payment_Made) للسنة الحالية :- Dim PaymentMadeCurrentYear As Double PaymentMadeCurrentYear = Nz(DSum("[Payment_Made]", "[tbl_Loans]", "Year([Auto_Date])=" & Me.txtYear & " And [Loan_ID] > 0 And [Nr] > 5"), 0) Debug.Print "PaymentMadeCurrentYear: " & PaymentMadeCurrentYear حساب القيمة المتبقية (Remaining) :- Me.Remaining = LoanMadePreviousYear - PaymentMadeCurrentYear Debug.Print "Remaining: " & Me.Remaining ستظهر لك النتيجة بهذا الشكل .. LoanMadePreviousYear: 65000 PaymentMadeCurrentYear: 0 LoanMadePreviousYear: 65000 Remaining: 65000 أرجو أن تكون الصورة قد توضحت لك ,, وأكتفي بهذا القدر حتى لا نتعدى الصلاحيات .

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

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

ما رأيك بهذا الإقتراح ، لتلافي استخدام DCount المتكرر .. On Error GoTo Ops Dim recordCount As Long recordCount = DCount("[Id]", "[Add_Custorm_QR]") If recordCount = 0 Then Me.cmdPrevious.Enabled = False Me.cmdFirst.Enabled = False Me.cmdLast.Enabled = False Me.cmdNext.Enabled = False Me.cmDelete.Enabled = False Else Me.cmDelete.Enabled = True Me.cmdPrevious.Enabled = (txtRec > 1) Me.cmdFirst.Enabled = (txtRec > 1) Me.cmdLast.Enabled = (txtRec < recordCount) Me.cmdNext.Enabled = (txtRec < recordCount) End If Exit Sub Ops: MsgBox "Error: " & Err.Description & " (" & Err.Number & ")" Exit Sub استخدامت المتغير txtRec لمقارنة المواضع بدل ما يتم استدعاء DCount المتكرر

جرعة من الدافعية المعنوية والراحة النفسية 😊😊✌ شكراً لمرورك العاطر 🌼😊🌷 أهم شي خاصية الـ Noise cancelling 😂😂😂 يا رجل كنت أسمع النمل حتى 😅😂

بصراحة انا لم انتبه لاجابتك استاذنا العزيز @Foksh الا بعدما اكملت الملف وارفقته بالمشاركة كل الاعتذار منك استاذنا ..ولو اني اعرف بأنك جاوبت لما اكملت الملف

الفكرة حلوة ولكن تنفيذها استغرق منك استعلامات ونموذج فرعي وقوائم وخلف هذه القوائم اكواد وجمل برمجية طويلة .. انظر لطريقتي في تنفيذ الفكرة الاولى في Database6 والتي استخدمها في برامجي للحجب الثانية في Database7 وهي اختصار للأولى واستخدمها للاختيار عند الطباعة Downloads.rar

تبارك الرحمن ، ما شاء الله ، عمل إبداعي يتحدث عن نفسه . عاش الصوت وصاحبه والمايكات الجديدة .. التصميم والألوان شيء يبعث الراحة في النفس .. دقة في التصميم والتنفيذ .. وسهولة العمل عليه شيء في منتهى االروعة 👌🏻 عاشت ايدينك مهندسنا الغالي

مشاركةً مع اساتذتي تفضل استاذ @مهند محسن المرفق بعد التعديل حسب مافهمت . Database6-1.rar

غفر الله لك ولوالديك .. ولكم بالمثل وأكثر مما دعيتم مهندسنا الغالي ,, بالنسبة لطلبك فابشر بهما ,, في التالي سأقوم بالتعديل لجعل الموضوع أكثر مرونة باختيار الدولة التي تريدها ، ولكن بعد تجربتها على عدة أجهزة لضمان نجاحها . أما بخصوص ملف الباتش فهو فعلاً يتم انشاؤه في مجلد %TEMP% داخل الويندوز ليتم التعديل وتمرير الفكرة من خلال الجملة التالية .WriteLine "control.exe intl.cpl,, /f:""C:\Windows\System32\intl.cpl""" لكني سأزودك به منفصلاً

ArabicDigits =Chrw(1632) & Chrw(1633) & Chrw(1634) & Chrw(1635) & Chrw(1636) & Chrw(1637) & Chrw(1638) & Chrw(1639) & Chrw(1640) & Chrw(1641) الصق هذا بدل أرقام عريي وهذا تعديل على ملف تحويل الارقام من العربية الى الانجليزية.xlsm

أخي @Hussein888 في Excel 365 يوجد خاصية تلقائية تعرف بـ AutoComplete التي تجعل القوائم المنسدلة تتفاعل بشكل ديناميكي مع الحروف التي تكتبها في الخلية حيث يتم تحديث القائمة لتظهر القيم التي تطابق ما كتبته لكن في Excel 2016 لا توجد هذه الخاصية بشكل افتراضي في القوائم المنسدلة المعتمدة على Data Validation ولكن هناك حل بديل باستخدام VBA كما في المثال التالي بما أنك لم تقم بإرفاق ملفك لتحديد النطاقات المطلوبة إليك الكود يمكنك تعديله بما يناسبك Option Compare Text Dim a() Private Sub Worksheet_SelectionChange(ByVal Target As Range) ' تحديد نطاق القوائم المنسدلة If Not Intersect([A2:A10], Target) Is Nothing And Target.Count = 1 Then ' (الأسماء) تحديد نطاق البيانات Set Rng = Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row) Set tbl = CreateObject("Scripting.Dictionary") tbl.CompareMode = vbTextCompare For Each c In Rng If c.Value <> "" Then tbl(c.Value) = "" Next c a = tbl.Keys 'ترتيب ابجدي tri a, 1, UBound(a) With Me.ComboBox1 .List = a: .Top = Target.Top: .Left = Target.Left: .Width = Target.Width .Height = Target.Height + 3: .Visible = True: .Activate End With Else Me.ComboBox1.Visible = False End If End Sub Private Sub ComboBox1_Change() If Me.ComboBox1.Text <> "" Then Set tbl = CreateObject("Scripting.Dictionary") tmp = "*" & UCase(Me.ComboBox1.Text) & "*" ' البحث عن النص في أي مكان For Each c In a If UCase(c) Like tmp Then tbl(c) = "" Next c Me.ComboBox1.List = tbl.Keys Me.ComboBox1.DropDown End If ActiveCell.Value = Me.ComboBox1.Text End Sub Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) Me.ComboBox1.List = a Me.ComboBox1.Activate Me.ComboBox1.DropDown End Sub Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer) If KeyCode = 13 Then ActiveCell.Offset(1).Select End Sub Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub Test-Data Validation.xlsb

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

السلام عليكم تم التعديل ان شاء الله عمل احصائية.xlsm

وهذه هي الاداة () يمكنك فك الضغط عنها وتثبيتها . pdftk.rar

هذه مساهمة متواضعة تحقق المطلوب وبعد إذن الأخ الفاضل / أبو أحمد أخى الفاضل / ناصر المصرى ضع هذه المعادلة للأعداد العشرية =IF(A4="الأول";MOD(100*TRUNC(SUM(C4;B4/100)*7%;2);100);MOD(100*TRUNC(SUM(C4;B4/100)*5%;2);100)) وهذه المعادلة للأعداد الصحيحة =IF(A4="الأول";INT(TRUNC(SUM(C4;B4/100)*7%;2));INT(TRUNC(SUM(C4;B4/100)*5%;2))) هذا وبالله التوفيق للجميع

المفروض ان تضع عينة للنتائج المتوقعة على ورقة العميل للتأكد من الخلايا المرحلة والأعمدة المرحل اليها حاول تعديل الكود التالي بما يناسبك Sub test() Dim srcWS As Worksheet, dest As Worksheet Dim f As String, Lr As Long Dim a(1 To 1, 1 To 3) As Variant Set srcWS = Sheets("تسجيل") f = srcWS.Range("C8").Value On Error Resume Next Set dest = ThisWorkbook.Sheets(f) On Error GoTo 0 If dest Is Nothing Then: MsgBox "ورقة العميل '" & f & "' غير موجودة", vbExclamation: Exit Sub If srcWS.Range("C7").Value = "اجل" Then a(1, 1) = Format(Date, "dd/mm/yyyy") ' التاريخ a(1, 2) = srcWS.[C4].Value & " " & srcWS.[C5].Value 'الوصف مع الكود a(1, 3) = srcWS.[C6].Value 'سعر البيع Lr = dest.Cells(dest.Rows.Count, "B").End(xlUp).Row + 1 dest.Range(dest.Cells(Lr, "B"), dest.Cells(Lr, "D")).Value = a MsgBox "تم الترحيل بنجاح إلى ورقة العميل " & f, vbInformation End If End Sub

تفضل استاذ @zero1111330566 هذا مشروع كنت عملته لأحد رواد المنتدي لكني طورته لكي يعمل بكل طلباتك أقرأ التعليمات بأعلى الفورم . وجرب ووافني بالرد . DDImport & Export.rar

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

السلام عليكم ورحمة الله وبركاته اشتغلت في بعض برامجي على الصور وملفات pdf ، وجمعتها هنا بطريقة سهلة ، حتى يسهل فهم طرق الربط والاستفادة منها ، كما اني كنت اريد تصفح جميع ملفات مجلد ما ، فعملت له برنامج خاص به لتسهيل العمل عليّ وعلى المستخدمين ، ولكني لم اتعامل مع الماسح الضوئي ، فقررت النظر في افضل الطرق واسهلها ، وانا أؤمن بأن للأكسس حدود معينة (مثله مثل اي برنامج) ، فانا دائما استخدم البرامج المساعدة لمساعدتي في عمل المطلوب ، مثل النجار اللي عنده جميع الادوات للاستعمال ، لهذا السبب فهو لا يستخدم المطرقة لكل اعماله ، لهذا ، انا استخدم الاداة الصح ، للعمل الصح ، وفي الكثير من الاحيان ، هذه الاداة لا تكون برنامج الاكسس البرنامج (معلومات عن الحيوانات ) يقوم بالتالي: ربط الصور وملفات pdf بالسجلات مباشرة ربط الصور وملفات pdf بالسجلات بالجملة تشغيل واستخدام الماسح الضوئي لجلب الصور وملفات pdf ولأن الصور والملفات مرتبطة بالبرنامج (اي غير مضمنه فيه) ، ترى ان حجم البرنامج صغير وسريع الصفحة الرئيسية في البرنامج: . 1. . لدينا نموذج رئيسي ، ندخل فيه اسم الحيوان ، والبرنامج يعطي هذا الحيوان رقم تلقائي (نوع الحقل هو رقم وليس رقم تلقائي) ، اسم الحيوان اساسي ولا يمكن حفظ السجل بدونه ، في النموذج الفرعي ، يمكن ادخال اي عدد من السجلات ، وكل سجل بصورته ، عن طريق ايقونة المجلد نستطيع ان نختار اي صورة فردية بصيغة jpg ، او بصيغة pdf (حسب مكان الايقونة) ، ويقوم البرنامج: عمل مجلد (في نفس مجلد البرنامج) اسمه images ، وهذا المجلد سيحتوي على جميع صور وملفات pdf البرنامج ، للنموذج الاساسي والفرعي. عمل مجلدات فرعية لكل حيوان (اسم المجلد هو رقم الحيوان) ، بأخذ هذه الصورة/pdf من المكان الذي هو فيه ، واعطاءه الرقم الصحيح ، ويحفظه في المجلد الصحيح ، ثم يقوم بحذف الصورة الاصلية. 2. . هنا نستطيع ادخال الصور للنموذج الرئيسي والفرعي ، بالجملة: 1. ايقونة اختيار المجلد الذي به الصور ، 2. يظهر اسم المجلد هنا ، 3. وتظهر اسماء الصور التي بصيغة jpg والموجودة في المجلد ، 4. عند النقر على الاسم ، سترى الصورة في 4 ، كما يمكن استخدام السهم اعلى و اسفل للتنقل بين اسماء الصور ، ورؤيتها ، 5. عندما ترى صورة الحيوان الذي تريده ، انقر مرتين على اسم الحيوان ، وسيأخذ البرنامج هذه الصورة من المكان الذي هي فيه ، واعطاءها الرقم الصحيح ، وحفظها في المجلد الصحيح ، ثم يقوم بحذف الصورة الاصلية ، وبما ان الصورة حذفت من المكان الاصلي ، سيختفي اسم الصورة من 3 ، 6. يقوم بنفس عمل 5 ، ولكنه يعمل عند إدخال رقم الحيوان (تصور ان لديك صور وصولات/فواتير ، وكل وصل عليه رقم ، فيمكن استعمال هذا الرقم لربط صورة الوصل بالسجل) ، ثم النقر على 9 إدراج (مع ابقاء رقم المنزل فاضي ، او ادخال الرقم صفر فيه) ، 7. يقوم بنفس عمل 5 ، ولكنه لأسماء منازل الحيوانات ، 8. نفس عمل 7 ولكن بطريقة 6 10. يمكن فتح الصورة المختارة عن طريق البرنامج الافتراضي للوندوز. 3. . نفس طريقة عمل النموذج 2 ، ولكن لإدخال ملفات pdf. 4. . هنا نبدأ بالتعامل مع الماسح الضوئي Scanner 1. للبحث في السجلات ، 2. هذه هي الخطوة الاساسية للتعامل مع الماسح الضوئي Scanner: البرنامج الوسيط الذي استعمله هو NAPS2 (موجود ضمن المرفق ولا يحتاج الى تنصيب ، والتعامل معه يكون مع برنامج الاكسس) ، وهذا رابطه http://sourceforge.net/projects/naps2/ رجاء النظر الى المادة التالية 5 ، لهذه الخطوة ، يحتاج هذا البرنامج الى NET. ، اصدار 4 ، والذي عادة يكون منصوبا على الكمبيوتر ، وهذه روابط التنزيل اذا احتجت لها: Latest(web installer) http://www.microsoft.com/en-us/download/details.aspx?id=42643 Latest(Stand alone) http://www.microsoft.com/en-us/download/details.aspx?id=42642 for XP http://blogs.msdn.com/b/dotnet/p/dotnet4xp.aspx 3. عند الانتهاء من التعامل مع 2 اعلاه ، يجب النقر على هذا الزر ، حتى نستورد تضبيطات NAPS2 ، وهي بيانات خصائص الماسح الضوئي ، والتي على اساسها يعمل الماسح الضوئي ، والنقر على هذا الزر سيحذف جميع سجلات NAPS2 التي في قاعدة بياناتنا ويستبدلها بالمستوردة حاليا (ولكن سنرى اننا لم نفقد شئ بهذا العمل) ، 4. نستطيع إضافة سجلات جديدة (تضبيطات/خصائص جديدة للماسح الضوئي) ، 5. نستطيع تغيير كافة تضبيطات/خصائص الماسح الضوئي من خلال تغيير البيانات هنا ، 6. ولكن لا نستطيع تغيير التضبيطات التي باللون الاحمر ، 7. هذا هو الاسم الذي نكتبه نحن للتعرف على التضبيطات/الخصائص التي سنستخدمها ، ولا يمكن تكرار الاسم ، تابع 4 . عند الضغط على الزر 2. اعلاه ، سيفتح لنا برنامج NAPS2 ، ولكن لن نتعامل مع البرنامج كاملا (طبعا تستطيع ان تتعامل مع الماسح الضوئي بالكامل مع هذا البرنامج والذي به خصائص وميزات) ، 1. يجب ان نعمل Profile واحد على الاقل باستخدام NAPS2 لكل جهاز Scanner مربوط بالكمبيوتر ، ونستطيع ان نضيف خصائص وتضبيطات اخرى من خلال 4.4 اعلاه ، عند النقر على Profiles ، تظهر نافذه جديدة ، 2. نضغط على الزر Add لنضيف Profile جديد (طبعا يمكن اضافة اي عدد من Profiles من خلال هذه النافذة) ، وعند النقر على هذا الزر ، تظهر لنا نافذة جديدة ، 3. نضغط على هذا الزر لإختيار اي Scanner مرتبط بالكمبيوتر ، 4. نختار Scanner ، 5. نوافق على الاختيار ، 6. مثل 4.7 اعلاه ، 7. عمل التضبيطات والخصائص المطلوبة لكل عمل (مثل المسح من الزجاج Glass ، او من وحدة تغذية المستندات التلقائية ADF ، او المسح من جانبي الورقة Duplex ، بالاضافة الى الخصائص الاخرى) ، 8. الضغط على موافق لحفظ هذه الخصائص والتضبيطات ، ولا تنسى ان تضغط على 4.3 اعلاه ، حتى يستورد برنامجنا الاكسس هذه الخصائص والتضبيطات ، 5. . هنا تتم عملية المسح من الماسح الضوئي Scanner ، 1. لبحث اسم Profile الذي نريد استخدامه للمسح ، 2. يمكن عمل اي تغيير لخصائص الماسح الضوئي ، والذي سيتم حفظه تلقائيا في Profiles ، ولاحظ ان لدينا 4 سجلات هنا ، اي 4 Profiles ، 3. نختار اين نريد حفظ الملف ، 4. ونكتب اسم الملف (البرنامج سيقوم بحذف اي ملف سابق بنفس الاسم في المجلد) ، 5. صورة المسح ستظهر هنا ، 10. وهنا سيظهر اسم الصورة التي تم مسحها ، 6. يمكن النقر مرتين على اسم الحيوان (كما تم شرحه سابقا) ، 7. كما تم شرحه سابقا ، 8. 9. النقر على هذا الزر يجعل الماسح الضوئي يعمل حسب الخصائص الموجودة في السجل (انظر 2 اعلاه) ، تابع 5 . عند النقر على 9 اعلاه ، نرى هذه الشاشة والتي تختفي عند الانتهاء من عملية المسح الضوئي ، 6. البرنامج NAPS2 يحتفظ بصور مؤقتة لكل عملية مسح يقوم بها ، فاذا توقف الماسح الضوئي لأي سبب ، فيمكنك ان ترى الصور التى تم مسحها ضوئيا ، وان تتعامل معها كيف شئت ، وذلك بالنقر على هذا الزر والذي سيفتح نافذة مجلد الصور المؤقتة ، 7. قبل الخروج من البرنامج ، فان البرنامج سيقوم بحذف جميع الصور المؤقته ، ثم سيغلق البرنامج ، لذلك ، اذا لأي سبب كان ، اردت الصور المؤقته ، فيجب عليك نسخها من مجلدها (انظر 6 اعلاه) قبل النقر على زر الخروج. عند فك ضغط الملف المرفق ، سترى فيه البرنامج والمجلدات التالية: . الملف والمجلدات التي داخل المربع الاحمر ، يجب ان تكون دائما في نفس المجلد مع البرنامج ، اما المجلد Different_Pictures فيمكن نقله الى اي مجلد ، وقد وضعت في هذا المجلد بعض الصور والتي يمكن استخدامها لتجربة البرنامج. في الواقع البرنامج غني بعدة انواع من الكود ، ويمكن ملاحظت الكود عن طريق عمل البرنامج. اقتراحات / تعديلات ، انا في الخدمة قدر المستطاع جعفر طريقة عمل NAPS2 كبرنامج متكامل: http://www.thewindowsplanet.com/2793/scan-your-paper-documents-and-save-them-to-pdf-tiff-jpeg-png-and-other-file-formats.htm Scan_Link_Images_pdf_Files.zip

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

السلام عليكم ورحمة الله وبركاتة تحياتى الى الجميع نواصل معا تميز منتدى الاكسيل فى اوفيسنا عن سائر المنتديات العربية حل مشكلة اعتراض حماية اورق الملف لتنفيذ الماكرو هو الحل النهائى لهذه المشكلة والتى لايأتى بعده حلول نهائيا . كما نعرف جميعا انه عند حماية اوراق الملف وعند تنفيذ ماكرو به بعض الاوامر يتم اعتراض تنفيذها نتيجة الحماية ودائما الحل فى الدواء المكرر والمعاد دائما وهو رفع الحماية فى بداية عمل الماكرو ثم وضعها مرة اخرى فى نهايتة ولكن الحل هنا فى منتدى الاكسيل لاول مرة على مستوى المنتديات . وعلى سبيل المثال لا الحصر لهذه الاوامر التى تسبب توقف عمل الماكرو ادراج او الغاء صفوف او اعمدة تغير لون الخلية او لون الخط والكثير من الاحداث الاخرى التى تتوقف بسبب الحماية . فيلجأ البعض منا مما له دراية بالاكواد بعمل عدد 2 ماكرو منفصلين الاول يعمل على الغاء الحماية والثانى يعمل على تنفيذ الحماية ثم عند تصميم اى ماكرو يقوم بوضع اسم الماكرو الاول فى بداية المكرو الذى يقوم بتصميمة ويضع اسم الماكرو الثانى فى نهاية الماكرو الذى يقوم بتصميمة بمعنى فى حالة اعترض الحماية يجب رفع الحماية فى بدية الماكرو ثم اعادة وضع الحماية مرة اخرى فى نهاية هذا الماكرو حتى يتم تنفيذ هذا الماكرو بدون اعتراض . ولكن الاكسل وفر لنا الكثير والكثير ولكن العقبة هى عدم الوصول الى هذه المعرفة وكثرت مشاكل اعتراض الحماية لتنفيذ الماكرو الذى يحتوى على بعض الاوامر التى اشرت اليها فى بداية الحديث ولكن توجد اضافة لامر الحماية لم الحظ ان احدا يقوم بأستخدامها وهى الامر UserInterfaceOnly:=True التى توضع فى امر الحماية ويمكن بذلك تنفيذ اى ماكرو بدون اعتراض مسيو اكسيل وبخصوص هذا الامر عند حفظ الملف تفرض الحماية كاملة وينهى عمل هذا الاستثناء وعليه عند فتح الملف يجب الاعلان عن ان الحماية مشمولة بهذا الامر ولذلك يجب ادراج كود الحماية بأحد هاتين الطريقتين : اولا : اما عن طريق ماكرو التنفيذ التلقائى عند الفتح الذى ينفذ اى اوامر مدرجة به عند فتح الملف Sub AUTO_OPEN() ثانيا : عن طريق حدث فتح الملف الاتوماتيكى الذى ينفذ اى اوامر مدرجة به عند فتح الملف Private Sub Workbook_Open() فأذا اردنا ان يكون كود الحماية فى ماكرو الفتح (Sub AUTO_OPEN) يكون الماكرو على هذه الصورة بفرض ان كلمة السر هى (123) Sub AUTO_OPEN() MyPassword = "123" For Each MySheet In ActiveWorkbook.Sheets MySheet.Protect _ Password:=MyPassword, _ DrawingObjects:=False, _ Contents:=True, _ Scenarios:=True, _ UserInterfaceOnly:=True Next MySheet End Sub اما اذا اراد المترسين بالاكواد بوضع كود الحماية فى حدث فتح الملف يكون على الشكل التالى بفرض ان كلمة السر هى (123) Private Sub Workbook_Open() MyPassword = "123" For Each MySheet In ActiveWorkbook.Sheets MySheet.Protect _ Password:=MyPassword, _ DrawingObjects:=False, _ Contents:=True, _ Scenarios:=True, _ UserInterfaceOnly:=True Next MySheet End Sub بذلك يمكن تنفيذ اى ماكرو بدون اعترض وتتجنب تكرار فك الحماية فى بداية الماكرو ثم اعادتها مرة اخرى فى نهاية الماكرو مع تحياتى فى استخدام الاوامر التى لم نتطرق اليها قبل ذلك لاثراء معلوماتنا ومنتدانا بكنوز الاكسيل