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

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

السلام عليكم

فيما يلى إجراء يقوم بحفظ قاعدة بيانات فى صورة ملف أكسل 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

 

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