kanory

مشاركة مع حبيبنا الاستاذ . حسام استبدل الكود بهذا >>>>>> If Me.m1.ListCount = 0 Then Me.m1.AddItem "م" & ";" & "الصنف" & ";" & "عدد" & ";" & "المبلغ" Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount Else Me.m1.AddItem Me.id & ";" & Me.tex_snf & ";" & Me.tex_count & ";" & Me.tex_ammount End If Dim i As Long, SumTotal As Long SumTotal = 0 For i = 1 To (Me.m1.ListCount - 1) SumTotal = SumTotal + Nz(Me.m1.ItemData(i), 0) Next i txtTotal = SumTotal

كان وضعت مثال للتطبيق .... على كل حال جرب الكود التالي .... أو ارفق ملفك للتعديل . On Error Resume Next If IsNull(Me.readtbl.Column(0)) Then MsgBox "The List Empty or Items in list not selected", vbCritical, "Caution" Exit Sub End If Me.ProgBar.Visible = True Dim x As Integer For x = x To 30000 Me.ProgBar.Value = x If x = 30000 Then Me.ProgBar.Visible = False End If Next x Dim i As Integer Dim tbl As String Dim SDest As String Dim SFileName As String SDest = Me.txtPath SFileName = Me.txtFileName For i = 0 To Me.readtbl.ListCount - 1 If Me.readtbl.Selected(i) = True Then tbl = Me.readtbl.Column(0, i) DoCmd.TransferSpreadsheet acExport, , tbl, SDest & "\" & SFileName & ".xlsx" End If Next i MsgBox "تم بحمد الله الانتهاء من عملية التصدير ", 0 + 64 + 1572864, "مبروك"

المنتدى مليئ بهذه الامثلة .... جرب البحث في المنتدى تجد ما يسرك ...

برنامج القلعة النماذج منبثقة ومشروطة انظر >>>>>>>

تفضل .... Dim db As DAO.Database Dim rstFrom As Recordset Dim rstTo As Recordset Set db = CurrentDb Dim RC, i As Integer Set rstTo = db.OpenRecordset("table2", dbOpenDynaset) Set rstFrom = db.OpenRecordset("table1", dbOpenDynaset) RC = rstFrom.RecordCount rstFrom.MoveFirst For i = 1 To RC rs.AddNew rstTo!codhesab = rstFrom!codhesab rs.Update rstFrom.MoveNext Next i rstTo.Close rstFrom.Close Set rstTo = Nothing Set rstFrom = Nothing Set db = Nothing

اعطينا معلومات اكثر <<<< هل البرنامج من تصميمك .... ربما عمل ليعمل لفترة ( حماية ) ما هي الرسالة التى تظهر ؟؟؟؟ ممكن ارفات الملف !!!

وهذه مشاركة مع الاستاذ. @Shivan Rekany >>>>>>> Kan_324.accdb

وهذه مشاركة مع أخي الاستاذ . حسام Kanory.rar

مجرد رأي : ملف الاكسل واحد ... صحيح عند تصدير الفصل أ ثم تصدير الفصل ب ثم ج د هـ تجد مشكلة في اسماء الطلاب وتداخلها ... فتضطر لمسح ملف الاكسل كل مرة ( ماذا لو جعلت ملف الاكسل قالب ) تكون افضل وفي كل مرة تصدير يطلب منك البرنامج اسم جديد ... اقضل انظر للمرفق الجديد وملف الاكسل الموجود فيه هو قالب لا يتغير بل يطلب منك اسم لكل تصدير وموقع للتصدير .... جرب المرفق وأعلمنا بالنتيجة .... kanory.rar

هذه الكلمه وغيرها من الكلمات يجب على المبرمج ان ينساها تماما ........... جرب المرفق ...... مثال.accdb

جرب هذه الكود تحت نفس زر التصدير بعد مسح الكود القديم الصق هذا الكود On Error Resume Next CurrentDb.Execute ("Delete * From temp") DoCmd.SetWarnings False DoCmd.RunSQL " SELECT qryElemnts1.stname INTO temp " & _ " FROM qryElemnts1;" DoCmd.SetWarnings True Dim TheFile As String Dim BackFile As String Dim lngColumn As Long Dim xlx As Object, xlw As Object, xls As Object, xlc As Object Dim dbs As DAO.Database Dim rst As DAO.Recordset Dim blnEXCEL As Boolean, blnHeaderRow As Boolean blnEXCEL = False blnHeaderRow = False On Error Resume Next Set xlx = GetObject(, "Excel.Application") If Err.Number <> 0 Then Set xlx = CreateObject("Excel.Application") blnEXCEL = True End If Err.Clear On Error GoTo 0 xlx.Visible = True TheFile = CurrentProject.Path & "\ms.xlsx" BackFile = CurrentProject.Path & "\äÓÎÉ ÇÍÊíÇØíÉ ãä ms.xlk" Set xlw = xlx.Workbooks.Open(TheFile) Set xls = xlw.Worksheets("students") 'ÇÓã æÑÞÉ ÇáÚãá Set xlc = xls.Range("B6") 'Çæá ÎáíÉ Ýí ãáÝ ÇáÇßÓá ÊÈÏà ÇáÊÚÈÆÉ ãäåÇ Set dbs = CurrentDb() Set rst = dbs.OpenRecordset("temp", dbOpenDynaset) 'ÇÓã ÇáÇÓÊÚáÇã If rst.EOF = False And rst.BOF = False Then rst.MoveFirst If blnHeaderRow = True Then For lngColumn = 0 To rst.Fields.Count - 1 xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).name Next lngColumn Set xlc = xlc.Offset(1, 0) End If Do While rst.EOF = False For lngColumn = 0 To rst.Fields.Count - 1 rst.Edit 'rst!datasheat = rst!stname & HyperlinkPart(rst.Fields("datasheat"), acAddress) rst.Update xlc.Offset(0, lngColumn).Value = rst.Fields(lngColumn).Value Next lngColumn rst.MoveNext Set xlc = xlc.Offset(1, 0) Loop End If rst.Close Set rst = Nothing dbs.Close Set dbs = Nothing Set xlc = Nothing Set xls = Nothing xlw.Close True Set xlw = Nothing If blnEXCEL = True Then xlx.Quit Set xlx = Nothing Kill (BackFile)

اعتقد المشكلة في نوع الاستعلام لانه يعتمد على التصفية في النموذج ..... الحل المؤقت : هو انشاء جدول مؤقت Temp من الاستعلام qryElemnts ثم تربط ما تريد به مباشرة ويتم حذفة بعد تصدير البيانات مباشرة

استعمل .... Do Until rst.EOF بدلا من ..... DoCmd.GoToRecord , , acFirst For i = 1 To Me.kan + 1 جرب واعلمنا بالنتيجة

للاسف ليس لدي win7 للتجربة .... لكن نحتاج أحد الاخوة لدية للتجربة حتى نعرف هل هو من جهازك أو بسبب الويندوز ماهو اصدار الاوفيس لديك ؟؟؟ ايش اخبار ارسال الصور معك .... هل وصل لنتيجة ؟؟؟؟

نعم صحيح أخي @jjafferr بارك الله في اعتمامك

يعمل الكود بكفاءة .....

ملاحظة ..... عند اعادة هذا السطر للعمل عمل البرنامج طبيعي .... 'Langauge ELanguage.en

الكود يقوم بفتح المتصفح ويصل حتى برنامج الواتس ولايقوم بلصق الرسالة ( جلب الرساله ) وتكون فارغة الكود الذي وضعته انا قبل تحويل اللغة كانت تعطي نفس نتيجة كودك انت .... وعدما حولت اللغة الى العربية قبل نسخ الرساله ثم قبل لصق الرسالة في برنامج الواتس احولها الى الانجليزية كانت تظهر الرسالة وبدون مشاكل ( بدون ظهور الرسالة بشكل فراغ أو رموز غريبة ) لكن الكود الذي قام بادراجه الاستاذ . @ابوآمنة هنا يقوم بجلب الرسالة بدون الحاجة لتغيير اللغة

ابشر ..... جاري التجربة

جربت الكود ماشاء الله عليك أخي @ابوآمنة بارك الله فيك ...... ولا حاجة لنسخ الرسالة للحافظة ثم اللصق .... شكرا جزيلا لك ......

فكرة اغلاق صفحات الانترنت وبرنامج الواتس أضافة رائعة اخي الكريم ...... بارك الله فيك

أخي الكريم تابع هذا الموضوع هنا ... التكمله هنا

السلام عليكم ورحمة الله وبركاته طرح في موضوع سابق موضوع رسائل الواتس اضع بين يديكم برنامج يقوم بارسال رسائل الواتس بدون حفظ الرقم في جهات الاتصال ويمكن استخدامه وتطويره لارسال رسائل للعملاء مثلا جربوه واعطونا انطباعكم حوله لتطويره والاستفادة منه ملاحظة هامة يجب تنصيب رنامج الواتس في جهازك ليعمل البرنامج هناك مدة زمنية وضعتها في الكود للتنفيذ مقدارها 40 يمكنك تغييرها ليتناسب مع سرعة جهازك ...... الطريقة سهله أوضحها باختصار مع اقتران كل شرح بالصورة ..... أولا : الذهاب للرابط https://www.whatsapp.com/download وتحميل برنامج الواتس حسب نسخة الويندوز لديك ( 64 - 32 )bit ثانيا: تشغيل برنامج الواتس والتسجيل عن طريق حسابك في الواتس وذلك بمسح البركود الظاهر في البرنامج من خلال البرنامج ( حسب الصورة ) ثالثا : عند اول تشغيل تظهر لك من خلال المتصفح رسالة بالسماح بفتح الارتباط بهذا النوع ( ضع علامة صح مثل الصورة ) رابعا : عند عمل البرنامج للمرة الثانية لا يحتاج تكرار هذه العمليات ( فقط انتظر اتمام المهمة ) هناك في الكود زمن افتراضي وضعته هو 40 ثانية أن رأيت جهازك والنت سريع حاول تقليل الزمن لكسب سرعة في الارسال أو العكس بالعكس تسجيل الارقام بالصيغة الدولية .... منتظر انطباعاتكم حول البرنامج ؟؟؟؟ WhatsApp_kan.accdb هنا تجدون الموضوع السابق ......

اعتقد مشكلة اللغة العربية في تحويل اللغة من العربية الى الانجليزية والعكس ........

اكتب هذا الكود تحت حدث عند النقر للزر AAA Forms!Lab_All.SetFocus Forms!Lab_All!BBB.SetFocus