Moosak

كما قال المهندس @Eng.Qassim .. تم فقد الاتصال بقاعدة البيانات الخلفية .. وإليك هذا الكود لفحص إذا كانت الجداول المرتبطة متصلة أم لا .. عندما يكون البرنامج مقسم لنسختين FE و BE وضيفة الكود أن تعطيه اسم أحد الجداول المرتبطة فيفحصه إذا كان متصل أم لا ويعطيك النتيجة True / False .. وبعدها يمكنك إعطاء أي أمر في حال تم فقد الإتصال كغلق البرنامج مثلا .. Private Function TableLinkOkay(strTableName As String) As Boolean 'Function accepts a table name and tests first to determine if linked 'table, then tests link by performing refresh link. 'Error causes TableLinkOkay = False, else TableLinkOkay = True Dim CurDB As dao.Database Dim tdf As TableDef Dim strFieldName As String On Error GoTo TableLinkOkayError Set CurDB = DBEngine.Workspaces(0).Databases(0) Set tdf = CurDB.TableDefs(strTableName) TableLinkOkay = True If tdf.Connect <> "" Then '#BGC updated to be more thorough in checking the link by opening a recordset 'ACS 10/31/2013 Added brackets to support spaces in table and field names strFieldName = CurDB.OpenRecordset("SELECT TOP 1 [" & tdf.Fields(0).Name & "] FROM [" & tdf.Name & "];", dbOpenSnapshot, dbReadOnly).Fields(0).Name 'Do not test if nonlinked table End If TableLinkOkay = True TableLinkOkayExit: Exit Function TableLinkOkayError: TableLinkOkay = False GoTo TableLinkOkayExit End Function '==========================================(مجربة تمام)==(وهذي دالة ثانية تقوم بنفس الوظيفة) Public Function IsConnectedToBE(strLinkedTable As String) As Boolean Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb On Error Resume Next Set rs = db.TableDefs(strLinkedTable).OpenRecordset IsConnectedToBE = (Err = 0) Set rs = Nothing Set db = Nothing End Function طريقة الاستدعاء : TableLinkOkay("strTableName")

تفضل أخي مهند 🙂 opppol.accdb

جرب بنفسك وأخبرنا عن تجربتك .. هذا كان تكملة الجملة وهي القاعدة التي ساعدتنا في التعلم .. 🙂

جرب 🙂

هذا كود لتنصيب الخطوط المضمنة في البرنامج إلى مجلد بجانب البرنامج وضيفة الكود هو استخراج الخطوط المخزنة في جدول الخطوط FontsT إلى مجلد Fonts بجانب قاعدة البيانات ثم يضيفها لبرنامج الأكسس بدون تنصيبها على الجهاز .. وذلك لكي تعمل معك الخطوط التي صممت بها البرنامج. لكي يعمل الكود معك : 1- قم بإنشاء جدول في برنامجك واسمه FontsT وبه حقل مرفقات اسمه Fonts ويتم تخزين الخطوط داخله 2 - قم بإضافة المكتبة التالية : Microsoft Scripting Runtime 3 - قم بمناداة الدالة التي تقوم بالمهمة AddFonts() من أي مكان تريده ( هنا أنا وضعتها في ماكرو Autoexec) Option Compare Database Option Explicit 'Designed By: Moosa AlKalbani Private Declare PtrSafe Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" ( _ ByVal lpFileName As String) As Long Public Function AddFonts() Dim ExtractPath As String Dim FontPath As String Dim FSO As Object Dim File As File Dim FontFolder As Folder Set FSO = CreateObject("Scripting.FileSystemObject") ' إنشاء مجلد للخطوط بجانب قاعدة البيانات ExtractPath = CurrentProject.Path & "\fonts" If Not FSO.FolderExists(ExtractPath) Then FSO.CreateFolder (ExtractPath) ' استخراج جميع الخطوط من الجدول إلى مجلد الخطوط ExtractAllAttachments "FontsT", "Fonts", ExtractPath Set FontFolder = FSO.GetFolder(ExtractPath) For Each File In FontFolder.Files If Right(File.Name, 3) = "TTF" Or Right(File.Name, 3) = "OTF" Then FontPath = ExtractPath & "\" & File.Name Debug.Print vbCr & FontPath AddOneFont FontPath Debug.Print File.Name, "Added" End If Next Set FSO = Nothing End Function Public Function AddOneFont(Font_Name_Path As String) Dim result As Long result = AddFontResource(Font_Name_Path) ' MsgBox result & " fonts added" End Function Public Function ExtractAllAttachments(ByVal TableName As String, ByVal AttchmentColumnName As String, ByVal ExtractToFolder As String) ' TableName : اسم الجدول ' AttchmentColumnName : اسم حقل المرفقات ' ExtractToFolder: المكان المراد استخراج الملفات إليه مثال : "C:\ExtractHere" Dim RsMainrecords As dao.Recordset2 Dim RsAttachments As dao.Recordset2 Set RsMainrecords = CurrentDb.OpenRecordset("select " & AttchmentColumnName & _ " from " & TableName & _ " where " & AttchmentColumnName & ".FileName is not Null") Do Until RsMainrecords.EOF Set RsAttachments = RsMainrecords.Fields(AttchmentColumnName).Value Do Until RsAttachments.EOF Dim OutputFileName As String OutputFileName = RsAttachments.Fields("FileName").Value OutputFileName = ExtractToFolder & "\" & OutputFileName If Len(Dir(OutputFileName, vbDirectory)) = 0 Then On Error Resume Next Debug.Print OutputFileName RsAttachments.Fields("FileData").SaveToFile OutputFileName End If RsAttachments.MoveNext Loop RsAttachments.Close RsMainrecords.MoveNext Loop RsMainrecords.Close Set RsMainrecords = Nothing Set RsAttachments = Nothing End Function ويمكنك استدعائه عن طريق مناداة الدالة باسمها : AddFonts() مثال : Add Fonts.accdb

وعليكم السلام .. ضع المرفق

وعليكم السلام 🙂 هذا كود لحفظ أو استخراج المرفقات من حقل نوع مرفق إلى جهاز الكمبيوتر .. الدالة الأولى هي دالة استخراج المرفقات .. الدالة الثانية هي دالة الحصول على مسارات المجلدات الخاصة ( سطح المكتب مثلا ..) Public Sub AttachmentToDisk(strTableName As String, _ strAttachmentField As String, strPrimaryKeyFieldName As String) Dim strFileName As String Dim db As DAO.Database Dim rsParent As DAO.Recordset2 Dim rsChild As DAO.Recordset2 Dim fld As DAO.Field2 Dim strPath As String On Error Resume Next strPath = SpecialFolderPath("MyDocuments") & "\" & Form_Main.TB1.Value & "\" ' مكان حفظ المرفقات ' strPath = " Application.CurrentProject.Path" & " \ " & Form_Main.TB1.Value & "\" Set db = CurrentDb Set rsParent = db.OpenRecordset(strTableName, dbOpenSnapshot) With rsParent If .RecordCount > 0 Then .MoveFirst While Not .EOF ' our picture is in the field "pics" Set rsChild = rsParent(strAttachmentField).Value If rsChild.RecordCount > 0 Then rsChild.MoveFirst While Not rsChild.EOF ' this is the actual image content Set fld = rsChild("FileData") ' create full path and filename strFileName = strPath & .Fields(strPrimaryKeyFieldName) & "\" & rsChild("FileName") ' create directory if it does not exists If Len(Dir(strPath & .Fields(strPrimaryKeyFieldName), vbDirectory)) = 0 Then VBA.MkDir strPath & .Fields(strPrimaryKeyFieldName) ' remove any previous picture from disk it there is any If Len(Dir(strFileName)) <> 0 Then Kill strFileName ' save our picture to disk fld.SaveToFile strFileName ' move to next attachment rsChild.MoveNext Wend ' move record pointer of parent .MoveNext Wend End With Set fld = Nothing Set rsChild = Nothing Set rsParent = Nothing Set db = Nothing End Sub Public Function SpecialFolderPath(strFolder As String) As String ' Find out the path to the passed special folder. User on of the following arguments: ' Options For specical folders ' AllUsersDesktop ' AllUsersStartMenu ' AllUsersPrograms ' AllUsersStartup ' Desktop ' Favorites ' Fonts ' MyDocuments ' NetHood ' PrintHood ' Programs ' Recent ' SendTo ' StartMenu ' Startup ' Templates On Error GoTo ErrorHandler 'Create a Windows Script Host Object Dim objWSHShell As Object Set objWSHShell = CreateObject("WScript.Shell") 'Retrieve path SpecialFolderPath = objWSHShell.SpecialFolders(strFolder & "") CleanUp: ' Clean up Set objWSHShell = Nothing Exit Function '************************************** '* Error Handler '************************************** ErrorHandler: MsgBox "Error finding " & strFolder, vbCritical + vbOKOnly, "Error" Resume CleanUp End Function

ضع مرفق أخي سامر .. 🙂

تفضل 🙂 استخدم هذا الكود على زر أمر بحيث تغير رابط الملف النصي وتغير اسم مربع النص اللي بيلصق النص فيه: Private Sub btnGetText_Click() ' Declare variables to hold the text from the online file and the textbox Dim strText As String Dim txtTarget As TextBox ' Set the URL of the online text file Dim strURL As String strURL = "http://www.website.com/text.txt" ' Use the XMLHTTP object to retrieve the text from the online file Dim objXMLHTTP As Object Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP") objXMLHTTP.Open "GET", strURL, False objXMLHTTP.Send ' Check if the request was successful If objXMLHTTP.Status = 200 Then ' Get the text from the response strText = objXMLHTTP.responseText ' Get a reference to the textbox on the form Set txtTarget = Me.txtTextBox ' Put the text from the online file into the textbox txtTarget.Value = strText Else ' Show an error message if the request was not successful MsgBox "There was an error retrieving the text from the online file." & vbCrLf & _ "HTTP Status: " & objXMLHTTP.Status, vbExclamation End If ' Clean up Set objXMLHTTP = Nothing Set txtTarget = Nothing End Sub وهذا مثال : Read Online Txt File.accdb

🙂

وعليكم السلام ورحمة الله وبركاته 🙂 حبذا لو تدعم طلبك بمثال مرفق .

وعليكم السلام ورحمة الله وبركاته .. حياك الله أخي @TQTHAMI 🙂 لو تضع نوع المشاكل التي واجهتك بالتحديد لسهلت الموضوع على الإخوة 🙂 وأعتقد أنا أغلب المشاكل هي دوال ال API وطريقة جعلها تعمل على النواتين 32 بت و 64 بت .. ولحلها يمكنك مراجعة هذا الموضوع للمهندس الكبير @jjafferr : ويمكنك البحث عن المواضيع المشابهة عن طريق برنامج البحث الرائع في مواضيع المنتدى للحصول على الحل المناسب لك :

وعليكم السلام ورحمة الله وبركاته باش مهندسنا 🙂 وهذه رااائعة من روائعك لم تعط حقها من الإشادة .. بارك الله فيك وأحسن الله إليك وجعلها في ميزان حسناتك تمت التجربة بنجاح ولله الحمد 😉👌🏼 وتم إضافة الموضوع لـ:

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

أخي @سامر محمود أنت تسأل عن طريقة عمل استعلام وليس معيار 🙂

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

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

خلي الكود يفتحلك مستعرض الملفات وتختار منه الملف بدل ما هو مكتوب في الكود أخوي طلال 🙂

تشريف أخي العزيز @دروب مبرمج ☺️

وعليكم السلام ورحمة الله وبركاته 🙂 استغن عن الأكسبلورر بهذا الكود ( ضعه في وحدة نمطية ) واستخمه كالتالي : Option Compare Database Option Explicit Enum AttacmentsType Image = 1 Sticker = 2 Document = 3 End Enum #If VBA7 Or Win64 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #Else Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #End If Private Const VK_NUMLOCK = &H90 Public Sub SendToWhatsApp(txtPhone As String, txtMSG As String, Optional txtAttchmentPath As String = "", Optional AttachmentType As AttacmentsType = Image) '---------------------------------------(التحقق من اكتمال البيانات) If Len(txtMSG & "") = 0 Then MsgBox "يرجى كتابة الرسالة": Exit Sub If txtAttchmentPath <> "" Then If Len(Dir(txtAttchmentPath, vbDirectory)) = 0 Then MsgBox "المرفق غير موجود .. تأكد من الرابط": Exit Sub End If txtMSG = Replace(txtMSG, vbCrLf, " %0a ") txtMSG = Replace(txtMSG, Chr(10), " %0a ") txtMSG = Replace(txtMSG, Chr(13), " %0a ") '---------------------------------------(بداية الإرسال) Dim Path As String Path = "whatsapp://send?phone=" & txtPhone & "&text=" & txtMSG CreateObject("Shell.Application").Namespace(0).ParseName(Path).InvokeVerb "Open" ' إرسال الرسالة Sleep 2000 SendKeys "~" Sleep 500 SendKeys "~" ' إرسال المرفق إن وجد If txtAttchmentPath <> "" Then SendKeys "+{TAB}" SendKeys "~" Sleep 1000 Select Case AttachmentType Case Is = 1 ' صورة SendKeys "{UP}" ' لإرسال الصور ' SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 2 ' ملصق SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 3 ' مستند SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال End Select SendKeys "~" Sleep 1000 SendKeys txtAttchmentPath, True SendKeys "~" Sleep 2000 SendKeys "~" Sleep 1000 SendKeys "~" End If 'If NumLock is off, turn it on If GetKeyState(VK_NUMLOCK) = 0 Then 'Send NumLock key press to turn it on SendKeys "{NUMLOCK}" End If '---------------------------------------( إعادة التركيز لبرنامج الأكسس) SetForegroundWindow Application.hWndAccessApp MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" End Sub Sub test() ' لا تنس إضافة كود الدولة SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image End Sub طريقة الاستخدام : SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image راجع :

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

أهلا بك أخي @يحي عبد الله 🙂 ببساطة يمكنك عمل استعلام تحديث .. والتحديث سيكون : [حقل تاريخ انتهاء العقد] + 30

عن طريق تقرير رئيسي وبه تقارير فرعية تكون مربوطة ببعضها البعض عن طريق العلاقات كما قال أخي @Mohameddd200300 ..

وأحب أن أشير لهذا الموضوع الذي له صلة بما ذكرته لك 🙂 :

ما شاء الله تبارك الرحمن ☺️🌹 ممتاز جدا .. ويفتح آفاق عديدة لتحسين العمل على الأكسس .. 🙂👌🏼 عندي لا تظهر الأسماء العربية .. هل هناك ضبط معين لها ؟ مع العلم أن الأسماء تظهر جيدا عندما أفتح الملف الذي ينشأ بجانب القاعدة مباشرة .. أيضا لي تساؤل أعلم أنه ممكن ولكن لا أعلم كيفية تنفيذه .. 🙂 هل يمكن عرض رسومات بيانية بشكل حديث ومطور بلغة ال HTML لبيانات مصدرها جدول أو استعلام ؟ وهل يمكن طباعة نفس الرسومات البيانية في التقارير ؟ كيف يمكن عمل ذلك ؟ نطمع في دروس تفصيلية مما وهبك الله ☺️🖐🏼️ بارك الله فيك أخي @دروب مبرمج وفتح الله عليك 🙂