Foksh

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

السؤال المهم أولاً !!! هل قاعدة البيانات لديك مقسمة الى قاعدة بيانات خلفية ( الجداول ) وقاعدة البيانات الأمامية ( باقي المكونات ) ؟؟؟؟؟ اذا كنت قد قمت بتقسيم القاعدة فمن المفترض ان يتم تفعيل هذا الإجراء بشكل تلقائي دلالة على ان القاعدة الأمامية مرتبطة بقاعدة البيانات الخلفية ( للجداول ) . التوضيح التالي يعتمد على إجابتك !!

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

Dangerous File Blocked قم بضغط الملف ورفعه هنا ، او ارفع قاعدة البيانات مضغوطة دون الحاجة لتحويلها لملف تنصيبي

بعد الاطلاع على الملف ، مشكلتك في أكواد الحدث في الحالي للنموذج "ادخال" ، تحقق من الأجزاء والمكونات ان كانت موجودة فعلاً أم لا .. وجهة نظر

أيضاً تحقق مما إذا كانت النماذج التي لا تظهر معك لها الخاصيتين :- ( مشروط = نعم / Modal = Yes ) ( منبثق = نعم / Pop Up = Yes )

اخي @moho58 .. جرب هذا السلوك :- Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Dim newKeyCode As Integer Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyRight newKeyCode = vbKeyLeft KeyCode = newKeyCode Case vbKeyLeft newKeyCode = vbKeyRight KeyCode = newKeyCode End Select End Sub

محاولاتي معك بعيدة عن الكمبيوتر ، غدا إن كان في العمر بقية سنحاول المتابعة للوصول الى حل

ما قصدته بالتحايل ،، Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyLeft Me.SetFocus SendKeys "{TAB}" Case vbKeyRight Me.SetFocus SendKeys "+{TAB}" End Select End Sub عكس المفاتيح لنفس الوظيفة ما قصدته

تحايل على الكود بعكس الوظيفتين ، أو جرب هذا التعديل 🤔 . Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyRight Me.SetFocus Screen.PreviousControl.SetFocus SendKeys "{TAB}" Case vbKeyLeft Me.SetFocus Screen.PreviousControl.SetFocus SendKeys "+{TAB}" End Select End Sub

ولأنني غير متواجد حاليا أمام الكمبيوتر ، سأحاول غدا تقديم اقتراح ما لم تحصل على إجابتك من المعلمين والأساتذة 😇 .

مشاركة عالطاير ، جرب هذا التعديل :- Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer) On Error Resume Next Select Case KeyCode Case vbKeyDown DoCmd.GoToRecord , , acNext Case vbKeyUp DoCmd.GoToRecord , , acPrevious Case vbKeyRight Me.SetFocus SendKeys "{TAB}" Case vbKeyLeft Me.SetFocus SendKeys "+{TAB}" End Select End Sub

الملف يعمل على 32 بت ، وانا لدي 64 بت للأسف 😪

وبهذا التعديل : Public Function RoundToNearestHalf(ByVal inputValue As Double) As Double Dim absValue As Double absValue = Abs(inputValue) If absValue - Int(absValue) = 0 Then RoundToNearestHalf = inputValue ElseIf absValue - Int(absValue) < 0.5 Then RoundToNearestHalf = Sgn(inputValue) * (Int(absValue) + 0.5) Else RoundToNearestHalf = Sgn(inputValue) * (Int(absValue) + 1) End If End Function

يعني تم حل مشكلتك اخي الكريم ؟؟؟

بما ااني حالياً اتابع من الجوال ، لنجرب هذه الفكرة :- Public Function RoundCustom(inputValue As Double) As Double Dim absValue As Double absValue = Abs(inputValue) RoundCustom = Sgn(inputValue) * (Int(absValue) + IIf(absValue - Int(absValue) <= 0.5, 0.5, 1)) End Function والاستدعاء سيكون في الخلية B1 مثلاً :- =RoundCustom(A1) لست ضليعاً في اكسل لهذا الحد ، ولكن هي فكرة وانتظر تجربتها 😅 من طرفكم أستاذنا الكريم.

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

في نموذجك ،، اجعل مصدر سجلاته استعلام يضم الحقول التي تريدها ، وفي الحقل الفريد المشترك بينهم وافترض انه رقم الموظف ، اجعل شرطه الكومبوبوكس الذي تريد منه اختيار الموظف ، واجعل مصدر صفه = حقلين من جدول الموظفين ، الأول رقم الموظف والثاني اسم الموظف . ثم في حدث بعض التحديث اجعله يقوم بتحديث النموذج.. لم أكتب لك ولاااا اي كود 😅

رغم أنك في قسم الآكسيس ، والمفترض ان تطرح سؤالك في قسم الويندوز والبرامج على ما اعتقد ، إلا أنه قد يكون هناك فرصة باستخدام الـ PowerShell كالآتي كمحاولة :- Get-ChildItem -File | Group-Object { $_.BaseName } | ForEach-Object { Compress-Archive -Path $_.Group.FullName -DestinationPath "$($_.Name).zip" } في داخل المجلد الذي يحتوي ملفاتك ، اضغط مفتاح Shift داخل المجلد والزر الأيمن للماوس اختر Open PowerShell window here من القائمة . ثم الصق السطر السابق .

استاذنا @AbuuAhmed ، يسعدنا دائما زياراتكم في قسمنا 🤗 . بالنسبة لي اعتمدت هذه الفكرة التي طرحتها وتم تعديلها سابقاً ، كونها لا تؤثر على مجرى العمليات الحسابية ( اذا اعتمدنا على مساواة القيمة الحقيقية والظاهرة من خلال التنسيقات ) . لذا ذهبت الى تحويل الكود الى دالة عامة كالآتي :- Public Function RoundCustom(ByVal inputValue As Double) As Double Dim absValue As Double absValue = Abs(inputValue) RoundCustom = Sgn(inputValue) * (Int(absValue) + IIf(absValue - Int(absValue) <= 0.5, 0.5, 1)) End Function وللإستدعاء بشكل منفرد لكل عنصر نصي ( مربع نص ) في حدث بعد التحديث مثلاً :- Private Sub Text0_AfterUpdate() Text0 = RoundCustom(Text0) End Sub أما من خلال الإستعلام ، فلنا حاجة للإستدعاء كالآتي :- SELECT RoundCustom([اسم_الحقل]) AS RoundedValue FROM اسم الجدول; كمثال للتوضيح :- SELECT RoundCustom([Salary]) AS RoundedSalary FROM Employees; التعليق هو أطراف أفكار ليس إلا .. 😅 رغم ان الموضوع قد تم حسمه وإغلاقه بأفضل إجابة 😁 .

لا اعلم طريقة وبنية الملف الاصلي .. اذا كان بنائه بنفس الاسلوب فحتما ستواجه مشكلة .. هل انتبهت للحدث عند النقر التالي :- Private Sub اقسام_العمل_Click() [Forms]![اقسام العمل]![اقسام العمل] = [اقسام العمل] End Sub

بإذن الله ، قريباً جداً مهندسنا الغالي

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

الحل بسيط

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) سأقدم لكم فيما بعد ( مرحلة التطوير والتعديل الأخيرة ) فكرة لتنفيذ عملية التحديث الهوائي ( Online ) . فيما يلي صورة لفكرة التحديث من مشروع قيد التحضير لصديق لي .. انتظرونا