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

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

السلام عليكم

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