مطلوب الحفظ من خلال مربع الحوار المدمج ببرنامج أكسس

[أحمد العيسى]

السلام عليكم

فيما يلى إجراء يقوم بحفظ قاعدة بيانات فى صورة ملف أكسل 2003

على القطاع  E 

والمطلوب إظهار مربع حوار أكسس  ليتيح لى حرية اختيار المكان على الهارد قبل الحفظ

على أن يكون المكان الافتراضى E  فى حالة سماح تقسيم الهارد بذلك

مع جزيل شكرى مقدماً

Private Sub cm_ToExcel_Click()
    On Error GoTo Err_cm_ToExcel_Click

    Dim stDocName As String
    Dim Q As Integer
    stDocName = "tbl_Teacher" & [Year_name]
    Q = DCount("*", "tbl_Teacher")
    If Q > 0 Then
     DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", "E:\" & stDocName & ".xls", False
    MsgBox (" E:\   تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه على الـ " & Chr(13) & Chr(13) & stDocName & ".xls"), vbOKOnly + vbMsgBoxRight, "تنبيه"
    Else
     MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه"
    End If

Exit_cm_ToExcel_Click:
    Exit Sub

Err_cm_ToExcel_Click:
    MsgBox Err.Description
    Resume Exit_cm_ToExcel_Click
End Sub

[ابو البشر]

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

Private Sub cm_ToExcel_Click()
    On Error GoTo Err_cm_ToExcel_Click

    Dim stDocName As String
    Dim Q As Integer
    Dim sh As Object
    Dim folder As Object
    Dim FolderPath As String
    Dim FilePath As String

    stDocName = "tbl_Teacher_" & [Year_name]
    Q = DCount("*", "tbl_Teacher")

    If Q > 0 Then
        
        ' اختيار مجلد
        Set sh = CreateObject("Shell.Application")
        Set folder = sh.BrowseForFolder(0, "اختر مجلد حفظ الملف", 0)

        ' لو إلغاء
        If folder Is Nothing Then Exit Sub

        FolderPath = folder.Items().Item().Path
        FilePath = FolderPath & "\" & stDocName & ".xls"

        ' 🔥 التحقق من وجود الملف
        If Dir(FilePath) <> "" Then
            If MsgBox("الملف موجود بالفعل:" & vbCrLf & FilePath & vbCrLf & vbCrLf & _
                      "هل تريد استبداله؟", _
                      vbYesNo + vbQuestion + vbMsgBoxRight, "تأكيد") = vbNo Then
                Exit Sub
            End If
        End If

        ' التصدير
        DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", FilePath, False

        MsgBox "تم حفظ الملف بنجاح في:" & vbCrLf & FilePath, vbInformation + vbMsgBoxRight, "تم"

    Else
        MsgBox "لا يوجد سجلات لتصديرها", vbExclamation + vbMsgBoxRight, "تنبيه"
    End If

Exit_cm_ToExcel_Click:
    Exit Sub

Err_cm_ToExcel_Click:
    MsgBox Err.Description
    Resume Exit_cm_ToExcel_Click

End Sub

 

[أحمد العيسى]

تمام

شكراً  لك .. بارك الله فيك

قبل سؤالى استخدمت صفحة vba-code-doctor

فأنتج هذا الكود .. لكن به رسالة خطأ

أين المشكلة ...  هل المطلوب مكتبات معينة ، مع العلم أن الكود ليس به تحذير فى الــ Compile

Private Sub cm_ToExcel_Click()
    On Error GoTo Err_cm_ToExcel_Click

    Dim stDocName As String
    Dim Q As Integer
    Dim fDialog As Office.FileDialog ' يتطلب مرجعًا إلى مكتبة كائنات Microsoft Office XX.0
    Dim strFilePath As String

    stDocName = "tbl_Teacher" & [Year_name]
    Q = DCount("*", "tbl_Teacher")

    If Q > 0 Then
        ' تهيئة مربع حوار الملف
        Set fDialog = Application.FileDialog(msoFileDialogSaveAs)

        With fDialog
            .AllowMultiSelect = False
            .Title = "اختر مكان حفظ ملف أكسل"
            .InitialFileName = stDocName & ".xls"
            .Filters.Clear
            .Filters.Add "Excel Workbooks", "*.xls", 1 ' تصفية لملفات .xls
            .FilterIndex = 1 ' تحديد الفلتر الأول افتراضيًا

            If .Show = True Then ' المستخدم ضغط على حفظ
                strFilePath = .SelectedItems(1)

                ' التأكد من أن الملف له امتداد .xls
                If Right(strFilePath, 4) <> ".xls" Then
                    ' التحقق مما إذا كان هناك امتداد موجود لاستبداله
                    If InStr(strFilePath, ".") > InStrRev(strFilePath, "\") Then
                        strFilePath = Left(strFilePath, InStrRev(strFilePath, ".") - 1) & ".xls"
                    Else
                        strFilePath = strFilePath & ".xls"
                    End If
                End If

                DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", strFilePath, False
                MsgBox ("تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه على الـ " & Chr(13) & Chr(13) & strFilePath), vbOKOnly + vbMsgBoxRight, "تنبيه"
            Else ' المستخدم ضغط على إلغاء
                MsgBox "تم إلغاء عملية الحفظ.", vbOKOnly + vbMsgBoxRight, "إلغاء"
            End If
        End With
    Else
        MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه"
    End If

Exit_cm_ToExcel_Click:
    Set fDialog = Nothing ' تنظيف كائن مربع حوار الملف
    Exit Sub

Err_cm_ToExcel_Click:
    MsgBox Err.Description
    Resume Exit_cm_ToExcel_Click
End Sub

 

تم تعديل بالامس في 18:47 بواسطه أحمد العيسى

[ابو البشر]

3 ساعات مضت, أحمد العيسى said:

Dim fDialog As Office.FileDialog ' يتطلب مرجعًا إلى مكتبة كائنات Microsoft Office XX.0

هذه هي المكتبة المطلوبة

[Foksh]

2 ساعات مضت, ابو البشر said:

هذه هي المكتبة المطلوبة

دعماً لما تفضل به أستاذنا ابو البشر ، المكتبة الموضحة في الصورة التالية :-

طبعاً الرقم 16.0 سيختلف حسب إصدار الأوفيس لديك . فللإصدارات التي أقل من 2016 سيكون الرقم 14.0

[أحمد العيسى]

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

وهى مضافة أصلاً للمشروع

لكن يبدو أنها غير كافية لهذا الإصدار

والمقصود بالعمل على أكسس 2003  هو توافق هذا العمل حتى على أحدث إصدار

لذلك عند التشغيل على أوفيس 2024  تم استبدال المكتبه بالإصدار 16 تلقائياً التى أشار إليها أخى Foksh

ومع ذلك عند التنفيذ ظهرت نفس رسالة الخطأ !!!!

تم تعديل منذ 14 ساعات بواسطه أحمد العيسى

[Moosak]

5 ساعات مضت, أحمد العيسى said:

ذلك عند التشغيل على أوفيس 2024  تم استبدال المكتبه بالإصدار 16 تلقائياً التى أشار إليها أخى Foksh

أرى الحل أنك تستغني عن المكتبات تماما بتعريف المتغيرات كـ Object ..
رجعت لنفس الأداة  وكتبت له : 

اقتباس

المطلوب إظهار مربع حوار أكسس  ليتيح لى حرية اختيار المكان على الهارد قبل الحفظ

على أن يكون المكان الافتراضى E  فى حالة وجود التقسيم E .
بدون استخدام مكتبات ، عرف المتغيرات ك object

والنتيجة : 

Private Sub cm_ToExcel_Click()
    ' تعلن عن المتغيرات المطلوبة
    Dim stDocName As String
    Dim Q As Integer
    Dim objFileDialog As Object ' كائن مربع حوار الملفات (يتم تعريفه كـ Object لعدم استخدام المكتبات)
    Dim varFilePath As Variant ' المسار الكامل للملف الذي سيتم حفظه (يتم تعريفه كـ Variant لاستقبال قيمة من مربع الحوار)
    Dim fso As Object ' كائن نظام الملفات للتحقق من وجود محرك الأقراص (يتم تعريفه كـ Object لعدم استخدام المكتبات)
    Dim drv As Object ' كائن محرك الأقراص (يتم تعريفه كـ Object لعدم استخدام المكتبات)
    Dim blnDriveEExists As Boolean ' علامة منطقية للتحقق مما إذا كان محرك الأقراص E موجودًا وجاهزًا
    Dim strDefaultPath As String ' المسار الافتراضي الذي سيتم عرضه في مربع الحوار

    ' تعيين معالج الأخطاء للانتقال إلى تسمية Err_cm_ToExcel_Click في حالة حدوث خطأ
    On Error GoTo Err_cm_ToExcel_Click

    ' بناء اسم المستند بناءً على اسم الجدول وقيمة حقل [Year_name]
    stDocName = "tbl_Teacher" & [Year_name]

    ' حساب عدد السجلات في جدول tbl_Teacher
    Q = DCount("*", "tbl_Teacher")

    ' التحقق مما إذا كانت هناك سجلات (أكثر من صفر) لتصديرها
    If Q > 0 Then
        ' --------------------------------------------------------------------
        ' الجزء الخاص بالتحقق من وجود محرك الأقراص E وتعيين المسار الافتراضي
        ' --------------------------------------------------------------------
        ' إنشاء كائن FileSystemObject بدون استخدام مكتبات (Late Binding)
        ' هذا يسمح بالتحقق من محركات الأقراص دون الحاجة إلى إضافة مرجع لمكتبة Microsoft Scripting Runtime
        Set fso = CreateObject("Scripting.FileSystemObject")
        blnDriveEExists = False ' تهيئة العلامة إلى False

        ' التكرار عبر جميع محركات الأقراص المتاحة للتحقق من وجود محرك الأقراص E
        For Each drv In fso.Drives
            If drv.DriveLetter = "E" Then ' إذا كان حرف محرك الأقراص هو "E"
                If drv.IsReady Then ' والتأكد من أن محرك الأقراص جاهز للاستخدام (ليس فارغًا أو غير متصل)
                    blnDriveEExists = True ' تعيين العلامة إلى True
                    Exit For ' الخروج من الحلقة بمجرد العثور على محرك الأقراص E الجاهز
                End If
            End If
        Next drv

        ' تعيين المسار الافتراضي لمربع الحوار بناءً على نتيجة التحقق
        If blnDriveEExists Then
            strDefaultPath = "E:\" ' إذا كان E موجودًا وجاهزًا، استخدمه كمسار افتراضي
        Else
            ' إذا لم يكن E موجودًا أو جاهزًا، استخدم مسار المشروع الحالي كمسار افتراضي
            strDefaultPath = CurrentProject.Path
        End If

        ' تحرير كائنات نظام الملفات لتحرير الذاكرة
        Set fso = Nothing
        Set drv = Nothing

        ' --------------------------------------------------------------------
        ' الجزء الخاص بعرض مربع حوار حفظ الملف للسماح للمستخدم باختيار الموقع
        ' --------------------------------------------------------------------
        ' إنشاء كائن مربع حوار الملفات (Application.FileDialog) بدون استخدام مكتبات (Late Binding)
        ' 2 يمثل msoFileDialogSaveAs (قيمة ثابتة لمربع حوار حفظ باسم)
        Set objFileDialog = Application.FileDialog(2)

        ' تهيئة خصائص مربع الحوار
        With objFileDialog
            .Title = "اختر مكان حفظ ملف الإكسل" ' تعيين العنوان الذي يظهر في أعلى مربع الحوار
            .InitialFileName = stDocName & ".xls" ' تعيين الاسم الافتراضي للملف الذي سيتم حفظه
            .InitialFolder = strDefaultPath ' تعيين المجلد الافتراضي الذي سيتم فتحه عند ظهور مربع الحوار
            .ButtonName = "حفظ" ' تعيين النص الذي يظهر على زر الحفظ في مربع الحوار
            .Filters.Clear ' مسح أي فلاتر ملفات موجودة مسبقًا
            .Filters.Add "ملفات إكسل (*.xls)", "*.xls" ' إضافة فلتر لملفات الإكسل القديمة (Excel 97-2003)
            .Filters.Add "جميع الملفات (*.*)", "*.*" ' إضافة فلتر لجميع أنواع الملفات
            .FilterIndex = 1 ' تعيين الفلتر الأول (ملفات إكسل) كفلتر افتراضي

            ' عرض مربع الحوار والتحقق مما إذا كان المستخدم قد ضغط على زر "حفظ"
            If .Show = -1 Then ' -1 يعني أن المستخدم ضغط على زر "حفظ" (OK)
                ' الحصول على المسار الكامل للملف المحدد من قبل المستخدم
                varFilePath = .SelectedItems(1)

                ' تصدير البيانات من جدول tbl_Teacher إلى ملف الإكسل بالمسار الذي اختاره المستخدم
                ' 0 يمثل acExport (قيمة ثابتة لعملية التصدير)
                ' 8 يمثل acSpreadsheetTypeExcel97 (قيمة ثابتة لنوع ملف الإكسل Excel 97-2003)
                DoCmd.TransferSpreadsheet 0, 8, "tbl_Teacher", varFilePath, False

                ' عرض رسالة نجاح للمستخدم تتضمن المسار الذي تم الحفظ فيه
                MsgBox ("تم استخراج ملف أكسل لبيانات الموظفيـن وحفظه في: " & Chr(13) & Chr(13) & varFilePath), vbOKOnly + vbMsgBoxRight, "تنبيه"
            Else
                ' إذا ألغى المستخدم عملية الحفظ (ضغط على Cancel)
                MsgBox "تم إلغاء عملية حفظ ملف الإكسل.", vbInformation + vbMsgBoxRight, "تنبيه"
            End If
        End With

        ' تحرير كائن مربع حوار الملفات لتحرير الذاكرة
        Set objFileDialog = Nothing

    Else
        ' عرض رسالة إذا لم تكن هناك سجلات في الجدول لتصديرها
        MsgBox ("لا يوجد سجلات لتصديرها "), vbOKOnly + vbMsgBoxRight, "تنبيه"
    End If

Exit_cm_ToExcel_Click:
    ' نقطة الخروج العادية من الإجراء
    Exit Sub

Err_cm_ToExcel_Click:
    ' معالج الأخطاء: عرض وصف الخطأ الذي حدث
    MsgBox Err.Description, vbCritical, "خطأ"
    ' استئناف التنفيذ عند نقطة الخروج العادية من الإجراء
    Resume Exit_cm_ToExcel_Click
End Sub

 

[أحمد العيسى]

شكراً أخى   Moosak  على مشاركتك

بنقل ما تفضلت به للمشروع لم يتغير شئ

الكود الوحيد الذى يعمل بلا مشاكل هو كود أخى ابو البشر

وإن كان فى حاجة لبعض الإضافات

لكنه هو الصحيح بلا أى مشكلة عندى

 

[أحمد العيسى]

عذراً  إخوانى للعودة لنفس الموضوع

قد يكون الموضوع أسهل إذا أرفقت مثال عملى

المطلوب أن يكون مربع حوار التصدير ( الحفظ ) مثل المربع الناتج من الضغط على النقاط الثلاث ( الفتح )

للتسهيل : ليكن فولدر الحفظ الإفتراضى (مع إمكانية الاختيار ) هو  D:\Access_Teacher

عند إستيراد الجدول (داخل مربع الحوار ) هنا لا داعى لوجود مربع اختيار التسمية والضغط على النقاط الثلاث بالنموذج

ولكن الفتح والاختيار من أى مكان على الهارد متاح مع  وجود فولدر الحفظ الافتراضى داخل الديالوج

Test.mdb

تم تعديل منذ 2 ساعات بواسطه أحمد العيسى

[Foksh]

منذ ساعه, أحمد العيسى said:

للتسهيل : ليكن فولدر الحفظ الإفتراضى (مع إمكانية الاختيار ) هو  D:\Access_Teacher

ليس لدي أوفيس 2003 ، ولكن جرب هذا التعديل لزر التصدير ..

Private Sub cm_ToExcel_Click()
    On Error GoTo Err_cm_ToExcel_Click

    Dim stDocName As String
    Dim filePath As String
    Dim defaultFolder As String
    Dim Q As Integer
    Dim fd As Object

    stDocName = "tbl_Teacher" & [Year_name]
    defaultFolder = "D:\Access_Teacher\"
    
    Q = DCount("*", "tbl_Teacher")

    If Q > 0 Then

        If Dir(defaultFolder, vbDirectory) = "" Then
            MkDir defaultFolder
        End If

        Set fd = Application.FileDialog(2)

        With fd
            .Title = "اختر مكان حفظ ملف الإكسل"
            .InitialFileName = defaultFolder & stDocName & ".xls"

            If .Show = -1 Then
                filePath = .SelectedItems(1)

                If LCase(Right(filePath, 4)) <> ".xls" Then
                    filePath = filePath & ".xls"
                End If

                DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", filePath, False

                MsgBox "تم استخراج ملف الإكسل بنجاح وحفظه في:" & vbCrLf & vbCrLf & _
                       filePath, vbInformation + vbMsgBoxRight, ""
            End If
        End With

    Else
        MsgBox "لا يوجد سجلات لتصديرها", vbOKOnly + vbMsgBoxRight, ""
    End If

Exit_cm_ToExcel_Click:
    Exit Sub

Err_cm_ToExcel_Click:
    MsgBox Err.Description, vbCritical + vbMsgBoxRight, "خطأ"
    Resume Exit_cm_ToExcel_Click
End Sub

 

قمت بتعديل الزر بحيث يعتمد اسم المسار الذي حددته لنا ، وإنشاء المجلد نفسه في المسار إذا لم يكن موجوداً ..

[أحمد العيسى]

18 دقائق مضت, Foksh said:

ليس لدي أوفيس 2003 ، ولكن جرب هذا التعديل لزر التصدير ..

 

ألله ينور عليك .. تمام

بالطبع تستطيع التنفيذ على أى أوفيس حتى يتم التجربة

وأنا أستطيع تعديل التوافقية إذا لزم الأمر

يتبقى دمج أوامر استيراد الجدول وأوامر النقاط الثلاث فى ديالوج يشبه زر التصدير بكود أمر واحد

والفتح إفتراضياً فى المجلد السابق

 

[Foksh]

55 دقائق مضت, أحمد العيسى said:

يتبقى دمج أوامر استيراد الجدول وأوامر النقاط الثلاث فى ديالوج يشبه زر التصدير بكود أمر واحد

والفتح إفتراضياً فى المجلد السابق

تمام ، تم الانتهاء من الشق الأول 👍

الثاني حال وصولي الى الكمبيوتر إن شاء الله ، لأنني خرجت من العمل