التعديل على كود التصدير الى اكسيل

[Ahmed_J]

السلام عليكم

يوجد  بالمرفق برنامج لاحد الاخوة  في الموقع وهو يعمل بصورة جيدة

المطلوب: التعديل على كود التصدير الى اكسل   بحيث بعد التصدير ياخذ اسم الجدول او الاستعلام الموجود في القائمة المنسدلة (ChooseTble) .

اي يكون ملف الاكسل بعد التصدير على سطح المكتب (TB1  او TB2 او TB3 او Query1) حسب الاختيار من القائمة المنسدلة.

وشكرا لتعاونكم

export excel.rarFetching info...

تم تعديل يونيو 25, 2021 بواسطه Ahmed_J

[jjafferr]

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

 

تفضل :

بدل هذا السطر     
'curPath = DTPath & "\salah- " & Format(Date, "dd-mm-yyyy") & ".xlsx"
     
  
  استعمل هذا
  curPath = DTPath & "\" & Me.ChooseTble & ".xlsx"

 

وكذلك تم تغيير مكان هذه الاسطر في الكود ، ليصبح كود التصدير الى اكسل:

Private Sub أمر26_Click()
On Error Resume Next
Dim curPath As String
    Dim xlApp1 As Object  'Excel.Application
    Dim xlWB1 As Object   'Excel.Workbook

If IsNull(Me.ChooseTble) Then
Beep
MsgBox "اختر الجداول المراد تصديرهم"
Exit Sub
End If
If Box.ItemsSelected.Count = 0 Then
Beep
MsgBox "اختر الحقول مراد تصديرهم"
Exit Sub

End If

     DTPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
     'curPath = DTPath & "\salah- " & Format(Date, "dd-mm-yyyy") & ".xlsx"
     curPath = DTPath & "\" & Me.ChooseTble & ".xlsx"

Dim Ssql As String
    For Each varItm In Box.ItemsSelected
    Ssql = Ssql & "[" & Box.ItemData(varItm) & "] ,"
        
    Next varItm
    Ssql = Mid(Ssql, 1, Len(Ssql) - 1)
Ssql = "select " & Ssql
Ssql = Ssql & " from " & ChooseTble

Set QFEx = CurrentDb.CreateQueryDef("Qtoexport", Ssql)
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12Xml, "Qtoexport", curPath, , "Qtoexport"
    'DoCmd.OutputTo acOutputQuery, "Qtoexport", acViewPreview
DoCmd.DeleteObject acQuery, "Qtoexport"

      Set xlApp1 = CreateObject("Excel.Application")
    xlApp1.Visible = False   'True
    
    Set xlWB1 = xlApp1.Workbooks.Open(curPath)
    Set xlWs1 = xlWB1.Worksheets("Qtoexport")
    
    xlWs1.DisplayRightToLeft = True
    
     xlWB1.Save
    
      xlApp1.Quit
    Set xlWs1 = Nothing
    Set xlWB1 = Nothing
    Set xlApp1 = Nothing
        
MsgBox "لقد تم تصدير البيانات بنجاح"
End Sub

 

جعفر

[Ahmed_J]

السلام عليكم استاذ @jjafferr

استاذي الغالي
يعجز اللسان عن وصفك لان وصفك لا ياتي من اللسان
ولاالقلم لان القلم اذا تجرأ وحاول ان يكتب عنك
سيخجل حبره ويجف احترااااااااااااماَ  لك
شكرا لك استاذي ومعلمي العزيز

بارك الله فيك

[jjafferr]

وعليكم السلام اخي احمد 🙂

 

شكرا لك على جميل كلماتك ، وان شاء الله يتقبل الله منا هذا القليل 🙂

جعفر

[abouelhassan]

  في 25‏/6‏/2021 at 21:29, Ahmed_J said:

السلام عليكم استاذ @jjafferr

استاذي الغالي
يعجز اللسان عن وصفك لان وصفك لا ياتي من اللسان
ولاالقلم لان القلم اذا تجرأ وحاول ان يكتب عنك
سيخجل حبره ويجف احترااااااااااااماَ  لك
شكرا لك استاذي ومعلمي العزيز

بارك الله فيك

Expand  

فعلا والله استاذى جعفر يعجز اللسان عن شكرك وكرمك والله كل شئ فيك جميل والله اضم صوتى اليك اخى احمد

هذا الرجل انا احبه فى الله وادعوا له عن ظهر غيب دائما لانه صاحب معروف كبير

اخيك باحترام

[jjafferr]

شكرا جزيلا اخوي ابوالحسن 🙂

 

جعفر