محتاج تعديل علي الكود ليعمل بشكل صحيح في تصدير ملف اكسيل منسق

[ahmed_204079]

'تصدير الي ملف الاكسيل
On Error GoTo err_cmd_Export_NEW_Click

Dim db As DAO.Database
Dim QDF2 As DAO.QueryDef
Dim i As Integer
Dim str_Sql As String, strWhere As String
Dim i_strSql As String
Dim i_strWorkBook As String
Dim i_strCellRef As String
Dim i_strWorkSheet As String
Dim i_strSaveAs As String

'*****************************
'Set db = CurrentDb()
If SearchListEXp.ItemsSelected.Count = 0 Or ListFields.ItemsSelected.Count = 0 Then
Beep
MsgBox "اختر الحقول مراد تصديرهم من خلال اختيار الجدول ثم اختيار الحقل", vbCritical + vbMsgBoxRight + vbMsgBoxRtlReading, "تنبيه"
Exit Sub
End If
 DoCmd.DeleteObject acQuery, "qryMyQuery"
'========================================================================QDF2
    str_Sql = "SELECT QForExport.* FROM QForExport "
    strWhere = "Where a1  IN( "
    For i = 0 To SearchListEXp.ListCount - 1
    If SearchListEXp.Selected(i) Then
    strWhere = strWhere & "'" & SearchListEXp.Column(0, i) & "', "
   End If
Next i
    strWhere = Left(strWhere, Len(strWhere) - 2) & ");"
    str_Sql = str_Sql & strWhere
Set QDF2 = CurrentDb.CreateQueryDef("qryMyQuery", str_Sql)
'========================================================================
      
  'check if Table or Query are selected
    If Len(Me.cmb_TQ & "") = 0 Then
        MsgBox "Please select Table or Query"
        Me.cmb_TQ.SetFocus
        Exit Sub
    End If
    
    'check if Table or Query Name is selected
    If Len(Me.cmb_TQ & "") = 0 Then
        MsgBox "Please select Table or Query Name"
        Me.cmb_TQ.SetFocus
        Exit Sub
    End If
    
    'check if Table or Query Name is selected
    If Len(Me.cmb_SaveFormat & "") = 0 Then
        MsgBox "Please select which Save Format you want to use"
        Me.cmb_SaveFormat.SetFocus
        Exit Sub
    End If
            
    i_strSql = i_strSql & str_Sql
    
    If Me.cmb_SaveFormat = 42 Then
        i_strWorkBook = Me.cmb_File_Name & Nz(Me.cmb_SaveFormat.Column(1), ".xls")
    Else
        i_strWorkBook = Me.cmb_File_Name
        
    End If
    
    i_strWorkSheet = Nz(Me.cmb_Sheet_Name, "")
    i_strCellRef = Nz(Me.cmb_Upper_Left_cell, "")
    i_strSaveAs = Nz(Me.cmb_SaveFormat, "")
    

 
    Call CopyRs2Sheet(i_strSql, i_strWorkBook, _
                      i_strWorkSheet, _
                      i_strCellRef, _
                      i_strSaveAs, _
                      Me.frm_Auto_Fit, _
                      Me.frm_Delete_Exisiting_File, _
                      Me.Open_The_File_on_Completion)
         
Beep
MsgBox "لقد تم تصدير البيانات بنجاح", vbInformation + vbMsgBoxRight, "عملية تصدير البيانات"
'DoCmd.Close
'DoCmd.OpenForm "Search", acNormal
    
    Exit Sub

err_cmd_Export_NEW_Click:

    If Err.Number = 53 Then
        'file not found
        Resume Next
    
    ElseIf Err.Number = 2450 Then
        MsgBox Err.Number & vbCrLf & Err.Description
        DoCmd.Hourglass False
        Exit Sub
    Else
        MsgBox Err.Number & vbCrLf & Err.Description
    End If
   'DoCmd.DeleteObject acQuery, "qryMyQuery"

End Sub

Public Sub CopyRs2Sheet(strSql As String, strWorkBook As String, _
                        Optional strWorkSheet As String, _
                        Optional strCellRef As String, _
                        Optional strSaveAs As String, _
                        Optional strAutofit As Integer, _
                        Optional strDeleteOriginal As Integer, _
                        Optional strOpenTheFile As Integer)

    'Copied from:
    'http://www.pcreview.co.uk/forums/export-data-specific-field-excel-possible-t1667759.html
    '
    'modified by jjafferr on Sep 18th 2014
    '
    'Uses the Excel CopyFromRecordset method
    'strSql: Sql Select string
    'strWorkBook: Full path and name to target wb, will create if doesn't exist
    'strWorkSheet: Name of target worksheet, will create if doesn't exist
    'strCellRef: Upper Left cell for data, defaults to A1


    On Error GoTo ProcError
    DoCmd.Hourglass True

    'using late binding on Excel
    Dim objXLApp As Object 'Excel.Application
    Dim objXLWb As Object 'Excel.Workbook
    Dim objXLSheet As Object 'Excel.Worksheet
    Dim objXLCell As Object 'Excel.Range
    Dim rs As DAO.Recordset
    Dim fld As DAO.field
    Dim i As Integer
    Dim j As Integer
    Dim iSheets As Integer
    Dim Last_Dot As String
    Dim File_Name As String
    Dim A_strCellRef As String
    Dim N_strCellRef  As Integer
    Dim strCellRef_Plus_One As String
    
    'Delete the old queryDef , if exists
     'DoCmd.DeleteObject acQuery, "NewQueryDef"

    
    'delete the old file
    If strDeleteOriginal = 2 Then
        'Delete ALL files with the same name, regardless of extension
        'Last_Dot = InStrRev(strWorkBook, ".")
        'File_Name = Mid(strWorkBook, 1, Len(strWorkBook) - Len(Mid(strWorkBook, Last_Dot)))
        'Kill File_Name & ".*"
        
        'Delete the file with this extension only
        Kill strWorkBook & ".*"
    End If
   

    'set rs from sql, table or query
    Set rs = CurrentDb.OpenRecordset(strSql, dbOpenSnapshot)

    'start Excel
    Set objXLApp = CreateObject("Excel.Application")

    'only create workbooks with 1 sheet
    iSheets = objXLApp.SheetsInNewWorkbook 'save user's setting
    objXLApp.SheetsInNewWorkbook = 1 'set for only 1 sheet
    
    Set objXLWb = objXLApp.Workbooks.Open(strWorkBook)
    objXLApp.SheetsInNewWorkbook = iSheets 'restore user's setting

    'select a worksheet, if sheet doesn't exist
    If strWorkSheet = "" Then
        strWorkSheet = "Sheet1"
    End If
    

    'If Range is missing default to A1
    If strCellRef = "" Then
        strCellRef = "A1"
    End If
   

    'Save Format
    If strSaveAs = "" Then
        strSaveAs = "xls"
    End If
    
    
    'select desired worksheet حدد ورقة العمل المطلوبة
    Set objXLSheet = objXLWb.Worksheets(strWorkSheet)
    
    'Separate the Alpha from the Numeric in the strCellRefافصل الحروف عن الارقام
    For i = 1 To Len(strCellRef)
        If IsNumeric(Mid(strCellRef, i, 1)) = True Then GoTo Got_Numeric
    Next i

Got_Numeric:
    A_strCellRef = Mid(strCellRef, 1, i - 1)    'Alpha part
    N_strCellRef = Mid(strCellRef, i)           'Numeric part
    
'------------------------------------------------------------------------
    'Dose the user want the field names, their captions, or none  نسخ الحقول او العناوين لملف الاكسيل
    'With Field Names
    If Me.frm_Field_Names = 1 Then
        Set objXLCell = objXLSheet.Range(strCellRef)
        For i = 0 To rs.Fields.Count - 1
            objXLCell(, i + 1) = rs.Fields(i).Name
        Next i
        strCellRef_Plus_One = A_strCellRef & Val(N_strCellRef) + 1
'------------------------------------------------------------------------
    'With Field Captions
    ElseIf Me.frm_Field_Names = 2 Then
        Set objXLCell = objXLSheet.Range(strCellRef)
        For i = 0 To rs.Fields.Count - 1
            objXLCell(, i + 1) = rs.Fields(i).Properties("Caption")
          
      rs.MoveFirst
    i = 1
    Do While Not rs.EOF
        For j = 0 To rs.Fields.Count - 1
            objXLCell.Cells(i, j + 1).Value = rs(j)
     Next j
        i = i + 1
      rs.MoveNext
    Loop
  Next i
    With objXLCell
        .Font.Bold = True
        .Font.Size = 16
        .Interior.Color = RGB(255, 255, 0)
        .HorizontalAlignment = -4108
    End With
    With objXLCell.Range(objXLCell.Cells(7, 2), objXLCell.Cells(i - 1, rs.Fields.Count))
        .Font.Size = 14
        .Font.Bold = True
        .HorizontalAlignment = -4108
        .Borders.LineStyle = 1
    End With
        strCellRef_Plus_One = A_strCellRef & Val(N_strCellRef) + 1
 '------------------------------------------------------------------------
    'Without Field Names
    ElseIf Me.frm_Field_Names = 3 Then
        strCellRef_Plus_One = strCellRef
    End If
'-------------------------------------------------------------------------
    'insert recordset into Excel Worksheet using CopyFromRecordset method  نسخ البيانات لملف الاكسيل
    objXLSheet.Range(strCellRef_Plus_One).CopyFromRecordset rs
    
'--------------------------------------------------------------------------
    
    'Auto fit
    If strAutofit = 1 Then
        objXLSheet.Columns.AutoFit
    End If
   
    objXLWb.Save
    objXLWb.Close
   

    'close up other rs objects
    If Not rs Is Nothing Then rs.Close
    Set rs = Nothing

    'clear memory
    Set objXLSheet = Nothing
    Set objXLWb = Nothing

    'quit Excel
    If Not objXLApp Is Nothing Then objXLApp.Quit
    Set objXLApp = Nothing
    
    DoCmd.Hourglass False

    'Shall we open the file after creation
    If strOpenTheFile = 1 Then
        'Application.FollowHyperlink i_strWorkBook
        Call fHandleFile(strWorkBook, WIN_NORMAL)
    End If
    
    
   Exit Sub
    


ProcError:

    Select Case Err
        Case 7874   'could not find QueryDef
            
            Resume Next
            
        Case 9 'Worksheet doesn't exist
            objXLWb.Worksheets.Add
            Set objXLSheet = objXLWb.ActiveSheet
            objXLSheet.Name = strWorkSheet

            Resume Next

        Case 1004 'Workbook doesn't exist, make it
            objXLApp.Workbooks.Add
            Set objXLWb = objXLApp.ActiveWorkbook
            objXLWb.SaveAs strWorkBook, FileFormat:=strSaveAs
                          
            Resume Next

        Case 53 'file not found
            Resume Next
            
        Case 3270   'Field Caption not found, use field name
            objXLCell(, i + 1) = rs.Fields(i).Name
            
            Resume Next
            
        Case 3061   'too few parameters, expected 1 or more
            
            'this error occurs when trying to run a query which needs its parameters from a Form,
            'the Form should be open with the parameter, then this code take the values properly
            
            Dim qdf As QueryDef
            Dim prm As Parameter
            
            'Set qdf = CurrentDb.QueryDefs("strSql")
            Set qdf = CurrentDb.CreateQueryDef("NewQueryDef", strSql)
            For Each prm In qdf.Parameters
                prm.Value = Eval(prm.Name)
            Next prm

            Set rs = qdf.OpenRecordset(dbOpenDynaset)
            DoCmd.DeleteObject acQuery, "NewQueryDef"
            
            Resume Next
                
            
        Case Else
            DoCmd.Hourglass False
            MsgBox Err.Number & " " & Err.Description
          
            Exit Sub
            Resume 0
            
    End Select
End Sub