منتدى فيجوال بيسك لكل العرب | منتدى المبرمجين العرب

السلام عليكم ورحمة الله وبركاته

الاخوة الكرام

اسعد الله مساكم

سوف ارفق لكم كود وهو عباره عن استخراج البيانات من قاعدة بيانات اكسس وتفريغها في ملف اكسل وحيث انني اوجه صعوبه في ذلك فاريد ممن يجد في نفسة القدره علي تعديل الكود وتجربته اكون شاكر ومقدر له

ما اواجهه في الكود :

ان العملية يقوم بسحب عدة بيانات وليس كلها
ان العملية يوجد فيها تكرار للسجلات
ان العملية تقوم بسحب البيانات من الاكسس مباشره والمطلوب يسحبها من الداتا جريد واحدد البيانات التي اريد ان تخرج في الاكسل





code :


زر الحدث

Private Sub Command1_Click()
'On Error Resume Next
'Set rs = New ADODB.Recordset
Set DataGrid1.DataSource = rs
rs.Open "SELECT * FROM Infractions ORDER BY contract", cn, adOpenStatic, adLockOptimistic
If rs.RecordCount <= 0 Then
   MsgBox "áÇ ÊæÌÏ ÈíÇäÇÊ Ýí ÇáÞÇÚÏÉ ÇáÈíÇäÇÊ"
Else
       
 
   CommonDialog1.CancelError = True
   On Error GoTo ErrHandler
   
  'CommonDialog1.Filter = "Excel files: ( *.xls ) |*.xls|"
  'CommonDialog1.FileName = "Book1"
  'CommonDialog1.ShowSave
   
 '  If CommonDialog1.FileName = "" Then Exit Sub
   Set xlApp = CreateObject("Excel.Application")
   xlApp.SheetsInNewWorkbook = 1
   xlApp.Visible = True
   Set xlBook = xlApp.Workbooks.Add
   xlApp.Windows(1).ActiveSheet.Name = "sheet"
   
   'ÍÝÙ ãáÝ ÇßÓá
  'xlBook.SaveAs FileName:=CommonDialog1.FileName
   
   
   Set xlSheet = xlBook.Worksheets("Sheet")
   
   'áÕÞ ÇáÈíÇäÇÊ ãä ÇáÞÇÚÏÉ ÇáÈíÇäÇÊ Çáì ãáÝ ÇßÓá
       xlSheet.Range("B6").CopyFromRecordset rs
   'ØÈÇÚÉ ÊÇÑíÎ Çáíæã
    xlSheet.Cells(3, 3).Value = Date
    xlSheet.Cells(3, 1).Value = "Report printed "


   'ÊÛííÑ ÚÑÖ ÇáÚãæÏ
   xlSheet.Cells(5, 2).ColumnWidth = 5
   xlSheet.Cells(5, 1).ColumnWidth = 5
   'xlSheet.cells(3, 2).Value = "ÊÞÑíÑ ÌÇåÒíÉ ÇáÚãá"

   'ØÈÇÚÉ ÞíãÉ Ýí ÇáÎáíÉ
   xlSheet.Cells(5, 1).Value = "Ê"
   xlSheet.Cells(5, 1).ColumnWidth = 3
     
   xlSheet.Cells(5, 2).ColumnWidth = 10
   xlSheet.Cells(5, 2).Value = "ÇáÔÑßå ÇáãäÝÐå"
   
   xlSheet.Cells(5, 3).ColumnWidth = 10
   xlSheet.Cells(5, 3).Value = "äæÚ ÇáãÎÇáÝå"
   
   xlSheet.Cells(5, 4).ColumnWidth = 14
   xlSheet.Cells(5, 4).Value = "ÊÝÇÕíá ÇáãÎÇáÝå"
   
   xlSheet.Cells(5, 5).ColumnWidth = 10
   xlSheet.Cells(5, 5).Value = "ÑÞã ÇãÑ ÇáÚãá"
   
   xlSheet.Cells(5, 6).ColumnWidth = 10
   xlSheet.Cells(5, 6).Value = "ÇáßÈíäå"
   
   xlSheet.Cells(5, 7).ColumnWidth = 10
   xlSheet.Cells(5, 7).Value = "ÇáãÏíäå"
   
   xlSheet.Cells(5, 8).ColumnWidth = 10
   xlSheet.Cells(5, 8).Value = "ÇáãÔÑÝ / ãÞÇæá"
   
   xlSheet.Cells(5, 9).ColumnWidth = 10
   xlSheet.Cells(5, 9).Value = "ÇáãÝÊÔ"
   
   xlSheet.Cells(5, 10).ColumnWidth = 10
   xlSheet.Cells(5, 10).Value = "ÊÇÑíÎ ÊÓÌíá ÇáãÎÇáÝå"
   
   xlSheet.Cells(5, 11).ColumnWidth = 10
   xlSheet.Cells(5, 11).Value = "ÑÞã ÇáßÈíäå"


   xlSheet.Range("a5:z5").Font.Bold = True
   
   'ØÈÇÚÉ ÞíãÉ 1 æ2  Êã ÊÚÈÆÉ ÈÇÞÓ ÇáÍÞæá ÊáÞÇÆíÇð
   xlSheet.Cells(6, 1).Value = 1
   xlSheet.Cells(7, 1).Value = 2
   
   xlSheet.Range("a6:AB").AutoFill Destination:=xlSheet.Range("a6:B" & rs.RecordCount + 5), Type:=xlLinearTrend

   'Êßæíä ÍÏæÏ ÇáÌÏæá
   xlSheet.Range("a5:AB" & rs.RecordCount + 5).Borders.Weight = xlThin
   'ÊäÓíÞ ÍÌã ÇáÎØ
   xlSheet.Range("a5:AB" & rs.RecordCount + 7).Font.Size = 10
     'ÊäÓíÞ áæä ÇáÎáíå
   xlSheet.Range("a5:AB" & rs.RecordCount + 7).Font.Color = &H404080

   'ÊäÓíÞ äæÚ ÇáÎØ
   xlSheet.Range("a5:AB" & rs.RecordCount + 7).Font.Name = "Times New Roman"
   'ÊäÓíÞ ÇáÍÇÐÇÉ ÇáÇÝÞíÉ ááÎáíÉ
   xlSheet.Range("a5:AB" & rs.RecordCount + 7).HorizontalAlignment = xlCenter
   'ÊäÓíÞ ÇáÍÇÐÇÉ ÇáÚãæÏíÉ ááÎáíÉ
   xlSheet.Range("a5:AB" & rs.RecordCount + 7).VerticalAlignment = xlVAlignCenter
   
   'ÇáßÊÇÈÉ ÖíÛÉ ÑíÇÖíÉ Ýí ÎáíÉ
   'xlSheet.Range("F6").Formula = "=D6*E6"
   'ÊÚÈÆÉ ÇáÕíÛÉ ÇáÑíÇÖíÉ Ýí ÈÇÞí ÇáÎáíÇ ÇáãÍÏÏÉ
  ' xlSheet.Range("F6").AutoFill Destination:=xlSheet.Range("F6:F" & rs.RecordCount + 5), Type:=xlGrowthTrend
   
  ' xlSheet.Range("E" & rs.RecordCount + 7).Value = "ÇáãÌãæÚ Çáßáí"
   'ßÊÇÈÉ ÕíÛÉ ÑíÇÖÉ áÍÓÇÈ ÇáãÌãæÚ Çáßáí
   'xlSheet.Range("F" & rs.RecordCount + 7).Formula = "=SUM(F6:F" & rs.RecordCount + 5 & ")"
   'ÊäÓíÞ ØÑíÞÉ ÚÑÖ ÇáÇÑÞÇã
   xlSheet.Range("F" & rs.RecordCount + 7).NumberFormat = "###,##0.00"
   xlSheet.Range("E" & rs.RecordCount + 7 & ":F" & rs.RecordCount + 7).Font.Bold = True
   xlSheet.Range("E" & rs.RecordCount + 7 & ":F" & rs.RecordCount + 7).Borders.Weight = xlThin
 '  xlSheet.cells.Interior.Color = 0
   
   
   'ÇÞÝÇá ÇáãáÝ ãÚ ÍÝÙ ÇáÊÚÏíáÇÊ
 '  xlBook.Close saveChanges:=True
 '  xlApp.Quit
 '  Set xlSheet = Nothing
 '  Set xlBook = Nothing
 '  Set xlApp = Nothing
End If

ErrHandler:
' User pressed Cancel button.
  Exit Sub

End Sub


التصريح العام :

Public cn  As New ADODB.Connection
Dim WithEvents rs1 As Recordset
Public rs As New ADODB.Recordset
Public xlApp As Excel.Application
Public xlBook As Excel.Workbook 'المصنف
Public xlSheet As Excel.Worksheet   'ورقة العمل

---

الرموز الغير واضحه هذي تعريفات الكود ووضائفها باللغه العربيه

مرحبا محمد
اود القول اخي الفاضل ما هكذا تورد الابل يا عكرمة
اعمل مثال بسيطة ااربع قاعدة بيانات حط الادوات على الفورم
شغله المشروع صور المشكلة مثلا
وارفق المثال في المشاركة
هكذا لم تعد عليك حجة
اما كود اشبه ما يكون لبرنامج كامل
مرهق جدا على من سيحاول المساعدة يا صديقي
بالتوفيق

تسلم يالغالي وضعت شرح المشكله علي اليوتيوب واتمنى ان تكون الصوره واضحه والكود تجدونه في مشاركتي الاولي

تحياتي ،،،

رابط شرح مشكلت الكود علي اليوتيوب

شوف
مشكلتك في جملة الاتسعلام اللي تستخدمها تحت البوتون اللي يرسل البيانات الى شيت الاكسل
خلي جملة الاستعلام هي نفسها اللى اظهرت لك تفاصيل المخالفات
هذا الحل يا كابتن
ثم اني ملاحظ انك لما ضغط لارسال البيانات للاكسل اختفت من شبكة عرض البيانات

السلا م عليكم

اخي الكريم انا ادرك تماما ان لبرامجك بعض الخصوصية
لذلك اتمنى عليك ارفاق نسخة من البرنامج وبها معلومات وهمية لكي يتم معرفة السبب من قبل الاعضاء المحترمين وحل المشكلة باذن الله

يعطيك العافية

جزاكم الله خير فردا فردا ورزقكم صحة الابدان وطول العمر علي الطاعه سوف ارسل المشروع باذن الله هذا اليوم

---

الاخوة الكرام

السلام عليكم ورحمة الله وبركاته


لقد تم وضع شرح للمشكله بشكل ادق وتم رفعها علي اليوتيوب ولمشاهدة ذلك قم بزيارة الصفحة

https://youtu.be/YO-uTr7PMKk



ولتحميل المشروع من حسابي في القوقل درايف استخدم الرابط ادناه

تحميل المشروع هنا

مرحبا ابو محمد 
للاسف لم استطع تجربة المشروع لان به ادوات ليست في الجهاز 
لكن نفذ اللي في الصور ورد لي خبر

(11-09-15, 10:16 PM)أبو عمر كتب : [ -> ]مرحبا ابو محمد 
للاسف لم استطع تجربة المشروع لان به ادوات ليست في الجهاز 
لكن نفذ اللي في الصور ورد لي خبر

يملا العافية الامور تمام بس فيه اشكال لما اسحب ملف اكسل واحفظة ثم ارجع واغير الشركة من الشاشه الرئيسيه يطلع لي خطأ برمجي لازم اقفل البرنامج وارجع اشغله ثاني مره علشان تروح المشكله والصوره ارفقتها ادناه

والامر الاخر ابي ترقيم تلقائي يعني اذا عشر او عشرين او 100 سجل يرقمها تسلسلي

دوس debog
وهات صورة

علي رابط اليوتيوب

والله اشغلتكم معي جعل الفدروس نزلكم ووالدينا ووالديكم


https://youtu.be/mkplOIPro7U