سامي الحداد

مشاركة مع الاخ العزيز @Foksh اليك التعديل والاضافة على الكود Private Sub Del_Click() On Error Resume Next If IsNull(Me.MyList) Then MsgBox "يجب اختيار الملف اولا " & vbNewLine & vbNewLine & " اختـار اسـم الملـف من القائمة", vbCritical + vbMsgBoxRight, "تنبيه" Else Dim sSQL As String Dim aFile As String Dim folderPath As String Dim FDS_path As String Dim fso As Object Dim FileCount As Integer aFile = DLookup("[Attachment_Path]", "[tbl_AttachmentList]", "[Attachment_NO]=[forms]![Attacheds]![MyList]") folderPath = Left(aFile, InStrRev(aFile, "\") - 1) FDS_path = Left(folderPath, InStrRev(folderPath, "\") - 1) If MsgBox("هل تريد حذف المرفق ؟", vbYesNo + vbMsgBoxRight + vbCritical) = vbYes Then Kill aFile Set DB = CurrentDb sSQL = "DELETE FROM tbl_AttachmentList WHERE [Attachment_NO]= " & Me.MyList DB.Execute sSQL MsgBox "تم حذف المرفق ... بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" Me.MyList.Requery Me.Show_Files.Requery Set fso = CreateObject("Scripting.FileSystemObject") If fso.FolderExists(FDS_path) Then DeleteEmptySubfolders fso, FDS_path If fso.GetFolder(FDS_path).Files.Count = 0 And fso.GetFolder(FDS_path).SubFolders.Count = 0 Then fso.DeleteFolder FDS_path, True End If End If Set fso = Nothing End If End If End Sub Private Sub DeleteEmptySubfolders(fso As Object, folderPath As String) Dim folder As Object Dim subFolder As Object Set folder = fso.GetFolder(folderPath) For Each subFolder In folder.SubFolders DeleteEmptySubfolders fso, subFolder.Path If fso.GetFolder(subFolder.Path).Files.Count = 0 And fso.GetFolder(subFolder.Path).SubFolders.Count = 0 Then fso.DeleteFolder subFolder.Path, True End If Next subFolder End Sub والملف بعد التعديل بالتوفيق Lab_2024 - 2.rar

بعد التجربة وجدت ان عملية الحفظ تأخذ وقتا حتى تظهر الرسالة اليك التعديل النهائي وارجو المعذرة لانني كنت في العمل وعملت الكود على عجالة ولم اجربه كفايه. MyArchfa.accdb

تفضل اخي الكريم التعديل شكرا للاخ @Foksh على الملاحظة . MyArchfa.accdb

السلام عليكم مشاركة مع الاستاذ @Foksh جزاه الله خيرا اليك التعديل حسب ما طلبت Private Sub cmdSave_Click() If IsNull(Me.book_Bath) Or Me.book_Bath = "" Then MsgBox "الملف غير محدد" Exit Sub End If SourceFile = Me.book_Bath Dim targetFolder As String If Me.book_Type = "وارد" Then targetFolder = CurrentProject.Path & "\" & "\Files\Wared\" ElseIf Me.book_Type = "صادر" Then targetFolder = CurrentProject.Path & "\" & "\Files\Sader\" Else MsgBox "نوع الكتاب غير معروف" Exit Sub End If If Dir(targetFolder, vbDirectory) = "" Then MkDir targetFolder End If Dim fileExt As String fileExt = Split(SourceFile, ".")(UBound(Split(SourceFile, "."))) DestinationFile = targetFolder & "\" & Me.book_Num & "." & fileExt FileCopy SourceFile, DestinationFile Me.book_Bath = DestinationFile Me.imageType = fileExt MsgBox "تم حفظ الكتاب" Me.Requery End Sub Private Sub ComView_Click() On Error Resume Next If IsNull(book_Num) Then Beep MsgBox "رقم الكتاب مطلوب" Exit Sub End If If IsNull(Me.imageType) Then MsgBox "نوع الصورة مطلوب" Exit Sub End If Dim filePath As String Dim fileName As String Dim foundFilePath As String fileName = Me.book_Num & "." & Me.imageType foundFilePath = FindFile(CurrentProject.Path & "\Files\", fileName) If foundFilePath = "" Then MsgBox "لا يوجد كتاب" Exit Sub End If ShellExecute Me.hwnd, "open", foundFilePath, "", "", 1 End Sub Function FindFile(ByVal folderPath As String, ByVal fileName As String) As String Dim fso As Object Dim folder As Object Dim subFolder As Object Dim file As Object Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(folderPath) For Each file In folder.Files If file.Name = fileName Then FindFile = file.Path Exit Function End If Next file For Each subFolder In folder.SubFolders FindFile = FindFile(subFolder.Path, fileName) If FindFile <> "" Then Exit Function Next subFolder Set fso = Nothing Set folder = Nothing Set subFolder = Nothing Set file = Nothing FindFile = "" End Function واليك الملف بعد التعديل بالتوفيق MyArchfa.rar

تفضل استاذ @jo_2010 هذا بالنسبة لطلبك الثاني Private Sub Form_MouseWheel(ByVal Page As Boolean, ByVal Count As Long) On Error Resume Next If Not Me.Dirty Then If (Count < 0) And (Me.CurrentRecord > 1) Then DoCmd.GoToRecord , , acPrevious ElseIf (Count > 0) And (Me.CurrentRecord <= Me.Recordset.RecordCount) Then DoCmd.GoToRecord , , acNext End If Dim parentForm As Form Dim labReqForm As Form Dim pnameValue As String Dim recordFound As Boolean Set parentForm = Me.Parent If parentForm.Controls("Lab_Patient").Form.CurrentView = 0 Then MsgBox "Lab_Patient subform is not open." Exit Sub End If Set labReqForm = parentForm.Controls("Lab_Sub_REQ").Form pnameValue = parentForm.Controls("Lab_Patient").Form.Controls("PNAME").Value labReqForm.Recordset.FindFirst "Pname = '" & pnameValue & "'" If Not labReqForm.Recordset.NoMatch Then labReqForm.Controls("Requests").BackColor = RGB(255, 0, 0) recordFound = True Else ' MsgBox "Record not found in Lab_Sub_REQ." recordFound = False End If End If End Sub بالتوفيق LAB_GOOD 2.rar

نعم تفضل اخي الكريم Private Sub أمر63_Click() DoCmd.SetWarnings False DoCmd.RunSQL "INSERT INTO TBLgiab (MainId, stclass, sttype, StName, remarks, G_date) " & _ "SELECT student.Stno, student.Stclass, student.sttype, student.StName, student.empty, " & _ "[forms]![frmgiab]![Text40] AS Expr1 FROM student WHERE student.ck = True;" DoCmd.RunSQL "UPDATE student SET student.ck = 0, student.Empty = Null;" DoCmd.SetWarnings True Forms![FrmGiab]![نموذج فرعي TBLgiab1].Form.Requery End Sub بالتوفيق

الان انتبهت انك غيرت طلبك . هذا طلبك الاول : وقد رايت كود الاستاذ @AlwaZeeR وهو يعمل بكفاءه. وهدا طلبك الثاني : هل هو المطلوب ام ان هناك تغير ثالث؟ أخي الكريم انت عضو فضي وتعرف قوانين المنتدى . على العموم قمت بتغير الكود للتالي فقط الغي الكود السابق وضع هذا الكود Private Sub Form_Current() Dim Psh As String Dim fileName As String Dim folderPath As String Dim folderName As Variant On Error GoTo Err fileName = [ID] Dim folders() As String folders = Split("picto,picto1,Picto2", ",") For Each folderName In folders folderPath = CurrentProject.Path & "\" & folderName & "\" If Dir(folderPath & fileName & ".jpg") <> "" Then Psh = folderPath & fileName & ".jpg" Exit For ' Exit loop once file is found ElseIf Dir(folderPath & fileName & ".png") <> "" Then Psh = folderPath & fileName & ".png" Exit For End If Next folderName pic.Picture = Psh Exit Sub Err: pic.Picture = "" Exit Sub End Sub تحياتي

وعليكم السلام مشاركة مع الاساتذة بازك الله فيهم هل هذا هو المطلوب ؟ Private Sub Form_Current() Dim Psh As String Dim filePath As String Dim fileName As String On Error GoTo Err fileName = [ID] filePath = CurrentProject.Path & "\picto\" & fileName If Dir(filePath & ".jpg") <> "" Then Psh = filePath & ".jpg" ElseIf Dir(filePath & ".png") <> "" Then Psh = filePath & ".png" Else Psh = "" End If pic.Picture = Psh Exit Sub Err: pic.Picture = "" Exit Sub End Sub والملف بعد التعديل التعامل مع الصور 2.rar

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

السلام عليكم ورحمة الله وبركاته تفضل اخي الكريم @UserUser2 تم تنفيذ الخطوات التالية: 1. سيتم إنشاء مجلد "Documents" بجانب قاعدة البيانات. 2. سيتم إنشاء مجلد "PDF" تحت مجلد "Documents". 3. سيتم إنشاء مجلد "JPEG" تحت مجلد "Documents". الغرض من إنشاء هذه المجلدات هو تلبية طلب الأخ السائل، الذي رغب في حفظ الصورة عند التصدير في مجلد محدد برقم العميل واسم الصورة تحمل اسم العميل والتاريخ الموجود في النموذج. ونظرًا لصعوبة تنفيذ هذا الطلب بالنسبة للصور بواسطة برنامج وسيط ، اما بالنسبة للــ PDF فآمره سهل جدا وهو ما تم عمله اولا فقد تم تنفيذ الخطوات التالية بعد إنشاء المجلدات: 1. يتم حفظ الملف بالأسماء المذكورة والتاريخ بصيغة PDF. 2. يتم إرسال الملف للطابعة الافتراضية "Universal Documents Converter". 3. يتم تحديد الصيغة المطلوبة، وفي حالتنا نريد صيغة الصور JPEG. 4. يتم إنشاء الملف المطلوب بكلا الصيغتين PDF و JPEG. 5. يتم حفظ الملف تحت المجلد الخاص به. الاكواذ المستخدمة Option Compare Database Option Explicit Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _ (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _ ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Sub CmdPrint_Click() Dim Fs As Object Dim StrFolder As String, FilePathPDF As String, FileName As String Set Fs = CreateObject("Scripting.FileSystemObject") StrFolder = CurrentProject.Path & "\Documents" If Not Fs.FolderExists(StrFolder) Then On Error Resume Next Fs.CreateFolder StrFolder On Error GoTo 0 If Err.Number <> 0 Then MsgBox "حدث خطأ أثناء إنشاء المجلد الرئيسي: " & Err.Description, vbCritical + vbOKOnly, "خطأ" Err.Clear Exit Sub End If End If Dim PDFFolder As String PDFFolder = StrFolder & "\PDF" If Not Fs.FolderExists(PDFFolder) Then On Error Resume Next Fs.CreateFolder PDFFolder On Error GoTo 0 If Err.Number <> 0 Then MsgBox " PDF خطأ في إنشاء مجلد فرعي " & Err.Description, vbCritical + vbOKOnly, "خطأ" Err.Clear Exit Sub End If MsgBox "الفرعي بنجاح PDF تم إنشاء المجلد", vbInformation + vbOKOnly, "تأكيد" End If FileName = Me.ID & " - " & Me.CNo & " - " & Me.CName & " - " & Format([iDate], "dd-mm-yyyy") FilePathPDF = PDFFolder & "\" & FileName & ".PDF" DoCmd.OpenReport "Report1", acViewPreview, , "[ID] = " & Me.ID DoCmd.OutputTo acOutputReport, "Report1", acFormatPDF, FilePathPDF, False DoCmd.Close acReport, "Report1", acSaveNo ShellExecute 0, "Open", FilePathPDF, vbNullString, vbNullString, vbNormalFocus ShellExecute 0, "Print", FilePathPDF, vbNullString, vbNullString, vbNormalFocus Dim JPEGFolder As String JPEGFolder = StrFolder & "\JPEG" If Not Fs.FolderExists(JPEGFolder) Then On Error Resume Next Fs.CreateFolder JPEGFolder On Error GoTo 0 If Err.Number <> 0 Then MsgBox " JPEG خطأ في إنشاء مجلد فرعي " & Err.Description, vbCritical + vbOKOnly, "خطأ" Err.Clear Exit Sub End If MsgBox "الفرعي بنجاح JPEG تم إنشاء المجلد", vbInformation + vbOKOnly, "تأكيد" End If End Sub بالنسبة للطابعة يجب ان تحفظ اعدادت موقع حفظ الملف Documents \Jpeg مثال : C:\Users\LENOVO\Downloads\TEST IMAGE\Documents\JPEG وهذا هو المرفق بالتوفيق TEST IMAGE 2.rar

اخي الكريم وهذا ما عملته بالضبط يجب ان تكون الصفحة خالية تماما من اي محتوى،،، والكود يقوم بهذه المهة فقط. سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ. وهذا الكود مرة اخرى Option Compare Database Option Explicit Private Sub Command0_Click() CleanUpWordDocument End Sub Public Function DeleteBlankPages(wd As Word.Document) Dim par As Paragraph For Each par In wd.Paragraphs If Len(par.Range.Text) <= 1 Then par.Range.Delete End If Next par End Function Public Sub CleanUpWordDocument() Dim wdApp As New Word.Application Dim wdDoc As Word.Document Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار DeleteBlankPages wdDoc MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد" wdDoc.Save wdDoc.Close wdApp.Quit Set wdDoc = Nothing Set wdApp = Nothing End Sub

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

اخي الكريم اسف على التاخير سوف انظر في المرفق غدا ان شاءالله تعالى

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

اخي الكريم ارفق ملفك للتعديل عليه وأبشر خيرا ان شاءالله

عجيب كيف لم يؤدي الوظيفة؟ الا اذا كنت تقصد شيئا اخر ! ملاحظة برنامج Word يجب ان يكون مفلقا حتى يتم عمل الكود. انظر للفيديو المرفق Delete Empty Word Pages.rar

السلام عليكم ورحمة الله وبركاته بالإضافة لما تفضل به الأستاذ موسى جزاه الله خيرا انا استخدم هذا البرنامج Universal Document Converter وهذا موقع الشركة: https://www.print-driver.com/download بعد إتمام عملية تنصيب البرنامج تابع الفيديو . ومرفق ملفك بعد التعديل. بالتوفيق jpg.rar شرج عمل برنامج Universal Document Converter.rar

السلام عليكم هذه مشاركتي مع الاخوة الكرام. Option Compare Database Option Explicit Private Sub Command0_Click() CleanUpWordDocument End Sub Public Function DeleteBlankPages(wd As Word.Document) Dim par As Paragraph For Each par In wd.Paragraphs If Len(par.Range.Text) <= 1 Then par.Range.Delete End If Next par End Function Public Sub CleanUpWordDocument() Dim wdApp As New Word.Application Dim wdDoc As Word.Document Set wdDoc = wdApp.Documents.Open("C:\Users\LENOVO\Documents\Test1.docx")' استبدل المسار DeleteBlankPages wdDoc MsgBox "تمت عملية حذف الصفحات الفارغة", vbInformation + vbMsgBoxRight, "تأكيد" wdDoc.Save wdDoc.Close wdApp.Quit Set wdDoc = Nothing Set wdApp = Nothing End Sub بالتوفيق

اللهم آمين وإياك إن شاء الله، الله يجعلك من اهل الجنة ويرحم والديك في الدنيا والاخرة الشكر لله عز وجل ربي يسعدك.

مشاركة مع الاخ @Foksh Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق بالتوفيق Database313.accdb

هل هذا هو المطلوب ؟ حسب ما فهمت هل هذا هو المطلوب؟ Private Sub Form_Load() Dim pdfPath As String pdfPath = "C:\Users\LENOVO\Documents\1222.pdf" ' استبدل المسار Me.WebBrowser0.Object.Navigate pdfPath End Sub

نعم ممكن عملها كما عملت وهذه طريقتي اليك التعديل Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String Dim SpecificFileName As String SpecificFileName = "Image1" sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("SELECT * FROM MsysResources WHERE [type]='img' AND [Name]='" & SpecificFileName & "';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation + vbMsgBoxRight, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub بالتوفيق

نعم ممكن اليك الكود Option Compare Database Option Explicit Private Sub Command2_Click() ExtractImage End Sub Public Sub ExtractImage() Dim Db As DAO.Database Dim Rs_p As DAO.Recordset2 Dim Rs_c As DAO.Recordset2 Dim sPath As String Dim sFile As String sPath = CurrentProject.Path & "\Images\" Set Db = CurrentDb Set Rs_p = Db.OpenRecordset("select * from MsysResources where [type]='img';", dbOpenDynaset) With Rs_p If Not (.BOF And .EOF) Then .MoveFirst MKDir sPath Do Until .EOF Set Rs_c = .Fields("Data").Value sFile = sPath & .Fields("Name") & "." & .Fields("Extension") If Len(Dir$(sFile)) <> 0 Then Kill sFile End If Rs_c.Fields("FileData").SaveToFile sFile Set Rs_c = Nothing .MoveNext Loop MsgBox " : تمت عملية إستخراج الصور الى " & sPath, vbInformation, "تأكيد" End If .Close End With Set Rs_p = Nothing Set Db = Nothing End Sub Public Sub MKDir(ByVal sPath As String) Dim var As Variant, v As Variant Dim sPth As String var = Split(sPath, "\") On Error Resume Next For Each v In var sPth = sPth & v VBA.MKDir sPth sPth = sPth & "\" Next v End Sub سيتم إنشاء مجلد بجانب قاعدة البيانات باسم Images يمكنك تغير اسم المجلد كما تريد وسيتم استخراج كافة الصور و الايقونات من قاعدة البيانات وحفظها في المجلد. وهذا ملفك مع الكود وتم إضافة ايقونات 2 للتجربة بالتوفيق saveimage2.accdb

أخي انت لم تستخدم الكود الذي ذكرته لك وحتى لم تكلف نفسك بتجربته على العموم نفس الكود اعلاه يعمل. فقط كلف نفسك وانقله الى ملفك يعني نسخ ولصق . وهذا ملفك مع نفس الكود اعلاه error (1).accdb

وعليكم السلام تفضل اخي التعديل على الكود حسب ما فهمت Private Sub Command0_Click() Dim Result As Variant Result = DLookup("feq", "test_tbl") If Len(Result & "") = 0 Then MsgBox "Equation not found or is empty.", vbExclamation Else If IsNumeric(Result) Then Me.E = Result Else Me.E = DLookup("result", "test_order_tbl", "[tcode] = 17") / DLookup("result", "test_order_tbl", "[tcode] = 16") End If End If End Sub بالتوفيق