تقييم الموضوع :
  • 0 أصوات - بمعدل 0
  • 1
  • 2
  • 3
  • 4
  • 5
ارجوا مساعدتي في تحليل وتعديل الكود
#1
السلام عليكم ورحمة الله وبركاته

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

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

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

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

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






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   'ورقة العمل

الرموز الغير واضحه هذي تعريفات الكود ووضائفها باللغه العربيه
الرد }}}
تم الشكر بواسطة:
#2
مرحبا محمد
اود القول اخي الفاضل ما هكذا تورد الابل يا عكرمة
اعمل مثال بسيطة ااربع قاعدة بيانات حط الادوات على الفورم
شغله المشروع صور المشكلة مثلا
وارفق المثال في المشاركة
هكذا لم تعد عليك حجة
اما كود اشبه ما يكون لبرنامج كامل
مرهق جدا على من سيحاول المساعدة يا صديقي
بالتوفيق
سبحان الله والحمدلله ولا إله إلا الله والله أكبر
 اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
الرد }}}
تم الشكر بواسطة: Ahmed_Mansoor , Ahmed_Mansoor , الطالب , starwarr2005
#3
تسلم يالغالي وضعت شرح المشكله علي اليوتيوب واتمنى ان تكون الصوره واضحه والكود تجدونه في مشاركتي الاولي

تحياتي ،،،

رابط شرح مشكلت الكود علي اليوتيوب
الرد }}}
تم الشكر بواسطة: الطالب
#4
شوف
مشكلتك في جملة الاتسعلام اللي تستخدمها تحت البوتون اللي يرسل البيانات الى شيت الاكسل
خلي جملة الاستعلام هي نفسها اللى اظهرت لك تفاصيل المخالفات
هذا الحل يا كابتن
ثم اني ملاحظ انك لما ضغط لارسال البيانات للاكسل اختفت من شبكة عرض البيانات
سبحان الله والحمدلله ولا إله إلا الله والله أكبر
 اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
الرد }}}
تم الشكر بواسطة: الطالب , ابومحمد1979
#5
السلا م عليكم

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

يعطيك العافية
(( يَا أَيَّتُهَا النَّفْسُ الْمُطْمَئِنَّةُ ارْجِعِي إِلَى رَبِّكِ رَاضِيَةً مَرْضِيَّةً فَادْخُلِي فِي عِبَادِي وَادْخُلِي جَنَّتِي ))

الرد }}}
تم الشكر بواسطة: الطالب , أبو عمر , ابومحمد1979
#6
جزاكم الله خير فردا فردا ورزقكم صحة الابدان وطول العمر علي الطاعه سوف ارسل المشروع باذن الله هذا اليوم

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

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


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

https://youtu.be/YO-uTr7PMKk



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

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



سبحان الله والحمدلله ولا إله إلا الله والله أكبر
 اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
الرد }}}
تم الشكر بواسطة: Ahmed_Mansoor , Ahmed_Mansoor
#8
(11-09-15, 10:16 PM)أبو عمر كتب : مرحبا ابو محمد 
للاسف لم استطع تجربة المشروع لان به ادوات ليست في الجهاز 
لكن نفذ اللي في الصور ورد لي خبر




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

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

الرد }}}
تم الشكر بواسطة:
#9
دوس debog
وهات صورة
سبحان الله والحمدلله ولا إله إلا الله والله أكبر
 اللهم اغْفِرْ لِلمؤمنين والمؤمنات والمسلمين والمسلمات الأحياء منهم والأموات
الرد }}}
تم الشكر بواسطة:
#10
علي رابط اليوتيوب

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


https://youtu.be/mkplOIPro7U
الرد }}}
تم الشكر بواسطة:


المواضيع المحتمل أن تكون متشابهة .
الموضوع : الكاتب الردود : المشاهدات : آخر رد
  مساعدة في هذا الكود layan2000 4 1,359 15-01-22, 09:58 PM
آخر رد: layan2000
  أريد من ذوي الخبرة تزويدي ببرنامج ترتيب الكود في فيجول بيسك rami_cis 4 2,124 24-11-20, 04:07 AM
آخر رد: rami_cis
  [سؤال] الى الاخوة في المنتدى ارجو مساعدتي في هذا المشروع sher 2 1,989 08-09-18, 09:41 PM
آخر رد: جاسم عبد
  السلام عليكم الرجاء مساعدتي جربت جميع الطرق 1000 2 2,052 03-05-18, 08:20 AM
آخر رد: 1000
  [vb6.0] الأخوة الأعزاء أرجو مساعدتي للضرورة القصوى ....وجزاكم الله تعالى عني كل خير Rami_Mezo 5 2,519 08-11-17, 05:49 PM
آخر رد: Amir_Alzubidy
  [vb6.0] اخوتي الكرام / لدي مشروع اريد من الاخوة و الاصدقاء مساعدتي في انجازه AYA2017 8 3,540 06-09-17, 02:20 AM
آخر رد: عبد العزيز البسكري
  انشاء ملف dll واضاقه على مشروع ارجوا مساعده nader309 2 1,930 07-07-17, 08:28 AM
آخر رد: nader309
  [vb6.0] ارجوا التعديل على المشروع حيث يتكرر اسم المشروع في combobox1 عبدالقادرعواد 2 1,858 21-02-17, 03:36 PM
آخر رد: عبدالقادرعواد
  [vb6.0] ارجو المساعدة والتعديل في هدا الكود عمور2016 2 1,969 10-07-16, 12:15 PM
آخر رد: عمور2016
  ارجوا برنامج للتحزيم hisoma 3 2,412 05-06-16, 09:53 AM
آخر رد: aboezzat84

التنقل السريع :


يقوم بقرائة الموضوع: بالاضافة الى ( 1 ) ضيف كريم