اذهب الي المحتوي
أوفيسنا

سامي الحداد

الخبراء
  • Posts

    295
  • تاريخ الانضمام

  • تاريخ اخر زياره

  • Days Won

    1

مشاركات المكتوبه بواسطه سامي الحداد

  1. في 16‏/5‏/2024 at 18:02, jo_2010 said:

    المطلوب: اريد حذفها من الفولدر الخاص بها واذا كان الفولدر فارغ يتم حذف الفولدر ايضا

    مشاركة  مع الاخ العزيز @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

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

    وارجو المعذرة لانني كنت في العمل وعملت الكود على عجالة ولم اجربه كفايه.

    MyArchfa.accdb

    • Thanks 1
  3. السلام عليكم

    مشاركة مع الاستاذ  @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

  4. تفضل استاذ @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

  5.   

    20 ساعات مضت, waheidi2005 said:

    اخي الكريم هل هناك مجال عند تسجيل غياب لنفس الطالب في تاريخ مختلف ان تكون خانة ملاحظات فارغة مثل ما يتم تفريغ مربع الاختيار وبارك الله فيك

    نعم تفضل اخي الكريم

    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

    بالتوفيق

    • Like 1
  6.   

    الان انتبهت انك غيرت طلبك .  

    هذا طلبك الاول : وقد رايت كود الاستاذ @AlwaZeeR وهو يعمل بكفاءه.

    في 1‏/4‏/2024 at 19:29, شامل2 said:

    كيف يمكن عرض الصور والمستندات المصورة في المثال بامتدادات مختلفة.

    بعض الصور امتدادها jpg يتم عرضها  والاخر امتدادها png لا تعرض

    في 1‏/4‏/2024 at 20:18, شامل2 said:

    وكيف يمكن استدعاء الصور اذا كانت في اكثر من مجلد؟

    وهدا طلبك الثاني : هل هو المطلوب ام ان هناك تغير ثالث؟  أخي الكريم انت عضو فضي وتعرف قوانين المنتدى .

    على العموم قمت بتغير الكود للتالي فقط الغي الكود السابق وضع هذا الكود 

    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
    

    تحياتي 

    • Like 1
  7. في 1‏/4‏/2024 at 19:29, شامل2 said:

    كيف يمكن عرض الصور والمستندات المصورة في المثال بامتدادات مختلفة.

    بعض الصور امتدادها jpg يتم عرضها  والاخر امتدادها png لا تعرض

    وعليكم السلام 

    مشاركة مع الاساتذة بازك الله فيهم هل هذا هو المطلوب ؟

    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

    • Like 1
  8. أحسنت وأحسن الله اليك اخي الاستاذ @Foksh

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

    اشكرك جزيل الشكر اخي الفاضل على هذه الاضافات ربي يسعدك.

  9.  السلام عليكم ورحمة الله وبركاته

    تفضل اخي الكريم @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

  10. 10 ساعات مضت, طير البحر said:

    ان طلبي محدد من البداية الصفخات الفارغة اى يجب ان تكون فارغة من اى محتوى

    اخي الكريم

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

    سؤال هل فعلا جربت الكود لإني على يقين حضرتك لم تجرب الكود. وإلا لكان رأيت عمل الكود بالضبط. 

    الاخوة الكرام من يستطيع ان يجرب الكود ويعلمني اذا كان يعمل او لا . ربما اكون مخطئ.

    وهذا الكود مرة اخرى 

    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

     

  11.   

    11 ساعات مضت, طير البحر said:

    ولكن دعنا نجعل المحتوى صورة او اى شئ اخر غير النص 
    سيقوم بحذفه فورا؟

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

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

    تحياتي

    • Like 1
  12. 19 ساعات مضت, kkhalifa1960 said:
     

    اقرأ هذا المحتوي ونزل الطابعة  (How to Convert Access Report to JPEG) 

     

    15 ساعات مضت, Foksh said:

    انا عن نفسي استخدم الطريقة التي أشار إليها الاستاذ خليفة

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

    • Haha 1
  13. 4 ساعات مضت, طير البحر said:

    للاسف لم يؤدي الكود الوظيفة المرجوة

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

    انظر للفيديو المرفق

     

    Delete Empty Word Pages.rar

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

    بالتوفيق

     

     

     

     

    jpg.rar شرج عمل برنامج Universal Document Converter.rar

    • Like 2
  15. السلام عليكم 

    هذه  مشاركتي مع الاخوة الكرام.

    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

    بالتوفيق

  16. مشاركة مع الاخ @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

    • Like 2
    • Thanks 1
  17. نعم ممكن عملها كما عملت  وهذه طريقتي اليك التعديل 

    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
    

    بالتوفيق

  18.   

    5 ساعات مضت, طير البحر said:

    لديا فى الفورم كائن صورة به صورة غير منضمة فى جدول ولا مسار هل يمكن استخلاصها وحفظها على الجهاز

    نعم ممكن اليك الكود 

    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

  19. وعليكم السلام

    تفضل اخي التعديل على الكود حسب ما فهمت 

    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

    بالتوفيق

×
×
  • اضف...

Important Information