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

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) بالإشارة الى الموضوع الذي أعلنت عنه سابقاً في هذا الرابط هنا ، اسمحوا لي بأن أطرح هذه الفكرة الجديدة والتي تم تجربتها مراراً وتكراراً إلى أن خرجت بهذه النتيجة فيما يتعلق بموضوع التحديث الهوائي أو 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 ] * عذراً إن كانت طريقتي في العمل مزعجة أو غريبة نوعاً ما ، لكن هو طبعي 😅 . فماذا أفعل ؟؟!!

إن كان الأمر متوقف على التسمية؛ فإشارة ✔️ كافية..

هو المطلوب شكرا جزيلا أخي الفاضل وبارك الله فيك وأكثر الله من أمثالك

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

غفر الله لك ولوالديك ، وأسكن الله موتاكم وموتانا وموتى المسلمين مساكن الأنبياء والصالحين والصديقين والشهداء وحسن أولئك رفيقا .. وزادك الله من علمه وهداه وتقواه، وأغناك الله من واسع فضله، وفتح لك فتوح العارفين، وألبسك لباس الصالحين .. يارب العالمين 🙂🤲🏻🌷🌹 ما شاء الله .. قطعة فنية نسجها محترف عارف بها 😊✌ جربتها .. وهي شغالة 10/10 تبارك الرحمن .. 😎👌🏻

إحنا نروح الشرطة

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

امامك عدة حلول ، 1. تحويل البرنامج ليعمل على إصدار 32 بت بأن تقوم بحفظ النسخة الجديدة من اصدار 32 بت . 2. تعديل الأكواد لتكون متوافقة مع الإصدارين 32 و 64 . 3. تثبيت نسخة 64 بت على الأجهزة الثانية . 4. وهناك حل آخر وهو استخدام Access Runtime (32 بت) ، بأن يتم تثبيته على الاجهزة التي تريدها .

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

مرفق ملف للتجرية معادلة الرصيد.xlsx

تفضل استاذ @2saad محاولتي حسب ما فهمت .ووافني بالرد . شغل التقرير من الفورم . New Microsoft Access Database-111.rar

وعليكم السلام ورحمة الله وبركانه اضطررت الى تعديل الجدول قليلا في صفحة جدوال الشرائح الكود Sub CalculateRanges() Dim wsClients As Worksheet Dim wsRanges As Worksheet Dim lastRowClients As Long Dim i As Long, j As Long, k As Long Dim count As Long Dim total As Double Dim depositValue As Double Dim rangeStart As Double Dim rangeEnd As Double Dim ranges As Variant Dim colIndex As Variant Dim infiniteRows As Variant Set wsClients = ThisWorkbook.Sheets("العملاء") Set wsRanges = ThisWorkbook.Sheets("جدوال الشرائح") lastRowClients = wsClients.Cells(wsClients.Rows.count, 1).End(xlUp).Row ranges = Array(Array(3, 7, 3), Array(10, 14, 4), Array(17, 21, 5), Array(24, 28, 6), Array(31, 35, 7)) infiniteRows = Array(7, 14, 21, 28, 35) For k = LBound(ranges) To UBound(ranges) wsRanges.Range("D" & ranges(k)(0) & ":F" & ranges(k)(1)).ClearContents For i = ranges(k)(0) To ranges(k)(1) rangeStart = wsRanges.Cells(i, "B").Value If IsInArray(i, infiniteRows) Then rangeEnd = Application.WorksheetFunction.Large(wsClients.Range("C2:C" & lastRowClients), 1) * 10 ' اعتبار القيمة ما لا نهاية Else rangeEnd = wsRanges.Cells(i, "C").Value End If count = 0 total = 0 For j = 2 To lastRowClients depositValue = wsClients.Cells(j, ranges(k)(2)).Value If depositValue >= rangeStart And depositValue <= rangeEnd Then count = count + 1 total = total + depositValue End If Next j wsRanges.Cells(i, "D").Value = count wsRanges.Cells(i, "E").Value = total Next i wsRanges.Cells(ranges(k)(1) + 1, "D").Formula = "=SUM(D" & ranges(k)(0) & ":D" & ranges(k)(1) & ")" wsRanges.Cells(ranges(k)(1) + 1, "E").Formula = "=SUM(E" & ranges(k)(0) & ":E" & ranges(k)(1) & ")" Next k End Sub Function IsInArray(valueToFind As Variant, arr As Variant) As Boolean Dim i As Long For i = LBound(arr) To UBound(arr) If arr(i) = valueToFind Then IsInArray = True Exit Function End If Next i IsInArray = False End Function الملف شرائح.xlsb

تفضل ..... Private Sub Command_Click() Call DeleteImageFiles DoCmd.Quit End Sub Sub DeleteImageFiles() Dim fso As Object Dim folderPath As String Dim file As Object ' تحديد مسار المجلد المطلوب folderPath = CurrentProject.Path & "\Data\QR_images\" ' التأكد من وجود المجلد If Dir(folderPath, vbDirectory) = "" Then MsgBox "المجلد غير موجود: " & folderPath, vbExclamation, "خطأ" Exit Sub End If ' إنشاء كائن FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' التحقق من الملفات داخل المجلد For Each file In fso.GetFolder(folderPath).Files ' التحقق إذا كان الملف صورة (حسب الامتداد) If LCase(file.Name) Like "*.jpg" Or _ LCase(file.Name) Like "*.jpeg" Or _ LCase(file.Name) Like "*.png" Or _ LCase(file.Name) Like "*.bmp" Or _ LCase(file.Name) Like "*.gif" Then ' حذف الملف file.Delete True End If Next file MsgBox "تم حذف جميع ملفات الصور بنجاح!", vbInformation, "عملية ناجحة" ' تحرير الكائنات Set fso = Nothing End Sub

موضوعك بسيط لا يحتاج إلى أكواد لكنه لم يكن واضح لي بشكل كامل وخصوصا باستخدامك مسلسل من 1 إلى 9 والتي توقعتها مضاعافات الساعة. توقيت البداية_03.xlsx

وعليكم السلام ورحمة الله تعالى وبركاته لم توضح أخي @علي بطيخ سالم هل الزيادة ستنفد على العمودين معا او الى فقط اليك محاولة مني بالاكواد لتثبيث الزيادة في عمود ( من) بساعة دائما وزيادة مدة الدقائق المدخلة في عمود (الى) Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim crWS As Worksheet: Set crWS = Me Dim tmp As Date, n As Double, lastRow As Long, i As Long If Not Intersect(Target, crWS.Range("A2,B2")) Is Nothing Then If crWS.Range("A2").Value = "" Or Application.WorksheetFunction.IsText(crWS.Range("A2").Value) Then _ MsgBox "يرجى إدخال توقيت البداية", vbExclamation: Exit Sub If Not IsNumeric(crWS.Range("B2").Value) Or _ crWS.Range("B2").Value <= 0 Then: MsgBox "يرجى إدخال مدة الزيادة بالدقائق", vbExclamation: Exit Sub tmp = crWS.Range("A2").Value n = crWS.Range("B2").Value / 1440 lastRow = crWS.Cells(crWS.Rows.Count, "E").End(xlUp).Row If lastRow < 2 Then Exit Sub Application.ScreenUpdating = False crWS.Range("C2:D" & crWS.Cells(crWS.Rows.Count, "C").End(xlUp).Row).ClearContents For i = 2 To lastRow If crWS.Cells(i, "E").Value <> "" Then crWS.Cells(i, "C").Value = Format(tmp, "hh:mm") crWS.Cells(i, "D").Value = Format(tmp + n, "hh:mm") tmp = tmp + TimeSerial(1, 0, 0) ' لتنفيد الزيادة بالدقائق على العمودين من و الى ' tmp = tmp + n End If Next i Application.ScreenUpdating = True End If End Sub في حالة الرغبة بتنفيد الزيادة على العمودين tmp = tmp + n توقيت البداية.xlsb

حسب ما فهمته: توقيت البداية_02.xlsx

ظهرت مشاكل في الملف السابق وتم حلها هنا تفضل Book2معدل3.xlsm