ابو البشر

اضف هذا الكود تحت امر عند فتح النموذج الرئيسي لديك .... Set rst = CurrentDb.OpenRecordset("pu_inv8") With rst .AddNew .Fields("as_a1") = Forms!pu_inv8.as_a1.Value .Fields("as_a2") = Forms!pu_inv8.as_a2 .Update End With

بارك الله فيك اخي الكريم .... ولكن تظهر رسالة شبيه لرسالة الدكتور .... الاوفيس 16 - 32 bit

هل البرنامج لك فعلا اخي الكريم ... كيف حولته الى accdr ... اصدقني القول وساجيبك

جاري التجربة ... احسنت

حاول في سجلات جديدة اقصد قم باضافة سجلات واترك السجلات القديمة لانها تم اضافتها وقت التجارب السابقة قبل الوصول للكود المطلوب ... والدليل ان السجلين الظاهرين لديك موجودين في جدول الاضافة لو اضفت سجل جديد يقوم البرنامج باضافة السجل الجديد ويهمل السجلات الملحقة للجدول سابقا ...

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

وهذه مشاركة وايضا حسب فهمي .... ههههههه ماذا لو استخدمنا وحدة نمطية تسهل على المبرمج اعادة وكتابة هذه الاكواد كلما احتاج اليها .... وايضا منعنا التكرار .... Public Function MoveData(FromTableName As String, ToTableName As String, Optional AttachmentFieldName As String = "No Attachment", Optional IgnoreAttachment As Boolean = True) On Error GoTo HandleErr Dim rstFromTable As DAO.Recordset Dim rstToTable As DAO.Recordset Dim fldFrom As DAO.Field2 Dim rstToAttach As DAO.Recordset2 Dim fldAttach As DAO.Field2 Dim rstFromAttach As DAO.Recordset2 Err.Clear Set rstFromTable = CurrentDb.OpenRecordset(FromTableName) Set rstToTable = CurrentDb.OpenRecordset(ToTableName) If (rstFromTable.BOF And rstFromTable.EOF) Then Exit Function End If Do While rstFromTable.EOF = False rstToTable.AddNew ' main add record For Each fldFrom In rstFromTable.Fields If fldFrom.IsComplex = False Then rstToTable(fldFrom.Name).Value = fldFrom.Value Else If AttachmentFieldName <> "No Attachment" Then rstToTable.Update rstToTable.Bookmark = rstToTable.LastModified rstToTable.Edit Set rstFromAttach = fldFrom.Value Set rstToAttach = rstToTable(fldFrom.Name).Value If rstFromAttach.RecordCount > 0 Then If IgnoreAttachment = False Then Do While rstFromAttach.EOF = False rstToAttach.AddNew For Each fldAttach In rstFromAttach.Fields If (IsNull(fldAttach.Value) = False) And (fldAttach.Name <> "FileType") Then rstToAttach(fldAttach.Name).Value = fldAttach.Value End If Next 'fldAttach rstToAttach.Update rstFromAttach.MoveNext Loop End If End If End If End If Next fldFrom rstToTable.Update rstFromTable.MoveNext Loop rstFromTable.Close rstToTable.Close ExitHere: Set rstFromTable = Nothing Set rstToTable = Nothing Set rstFromAttach = Nothing Set rstToAttach = Nothing Exit Function HandleErr: Select Case Err.Number Case 53 Err.Clear Resume Next Case 91 Err.Clear Resume Next Case 3020 Err.Clear Resume Next Case 3021 Err.Clear Resume Next Case 3022 Err.Clear Resume Next Case Else Debug.Print "Error " & Err.Number & ": " & Err.Description End Select Resume ExitHere End Function الحاق البيانات.accdb

شكرا يا بطل .... هدية مقبولة ومشكورة

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

هذا الكود فيه نقص ... الرجاء ارفاق مثال للتعديل عليه ...

ههههههههههههههههه .... اشكرك اخي المهندس ولكن العبارة ليست لي ولست عالم بل طويلب علم .... العبارة للعلامة أخي @مبرمج سابق اشكرك على حسن ظنك بي ...

تفضل هذا الكود يقوم باللازم ... يقوم بانشاء مجلد برقم ID السجل اذا كان المجلد غير موجود .... ثم يحفظ ملف الووورد الخاص بالسجل داخله ... جرب واخبرنا Dim MWordDocCopyOf As String Dim NWordDocCopyOf As String Dim LWordDocOriginal As String Dim LWordDocCopyOf As String Dim Warning As String If Dir(CurrentProject.Path & "\" & Me.المعرف & "\", vbDirectory) <> "" Then Else MkDir CurrentProject.Path & "\" & Me.المعرف & "\" End If LWordDocOriginal = CurrentProject.Path & "\asd.docx" LWordDocCopyOf = CurrentProject.Path & "\" & Me.المعرف & "\" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" If IsFileLocked(LWordDocCopyOf) = True Then MsgBox "يرجى غلق ملف الوورد!" Application.FollowHyperlink LWordDocCopyOf Exit Sub Else FileCopy LWordDocOriginal, LWordDocCopyOf MWordDocCopyOf = LWordDocCopyOf NWordDocCopyOf = Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") LWordDoc.Documents.Open MWordDocCopyOf LWordDoc.Visible = True LWordDoc.ActiveDocument.Bookmarks("A1").Select LWordDoc.Selection.InsertAfter Nz(b1.Value, "") LWordDoc.ActiveDocument.Bookmarks("A2").Select LWordDoc.Selection.InsertAfter Nz(b2.Value, "") LWordDoc.ActiveDocument.Bookmarks("A3").Select LWordDoc.Selection.InsertAfter Nz(b3.Value, "") LWordDoc.ActiveDocument.Bookmarks("A4").Select LWordDoc.Selection.InsertAfter Nz(b4.Value, "") LWordDoc.ActiveDocument.Bookmarks("A5").Select LWordDoc.Selection.InsertAfter Nz(b5.Value, "") LWordDoc.Application.Documents(NWordDocCopyOf).Save End If LWordDoc.Quit Set LWordDoc = Nothing Warning = MsgBox("تم تصدير البيانات للملف ....... هل تريد فتح الملف المصدر", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then Application.FollowHyperlink MWordDocCopyOf Else DoCmd.CancelEvent End If

وفيك بارك ... سعدت بمرورك على ردي ... جزاك الله خيرا .. منكم نتعلم

واياك .... جزاك الله خيرا على هذه الدعوات ولك بمثله ..

اسف اخي الكريم نسيت الفانك الصق هذا الفانك في النموذج ..... Public Function IsFileLocked(PathName As String) As Boolean On Error GoTo ErrHandler Dim i As Integer If Len(Dir$(PathName)) Then i = FreeFile() Open PathName For Random Access Read Write Lock Read Write As #i Lock i Unlock i Close i Else Err.Raise 53 End If ExitProc: On Error GoTo 0 Exit Function ErrHandler: Select Case Err.Number Case 70 IsFileLocked = True Case Else End Select Resume ExitProc Resume End Function

تفضل ...... Dim MWordDocCopyOf As String Dim NWordDocCopyOf As String Dim LWordDocOriginal As String Dim LWordDocCopyOf As String Dim Warning As String LWordDocOriginal = CurrentProject.Path & "\asd.docx" LWordDocCopyOf = CurrentProject.Path & "\" & "الملفات" & "\" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" If IsFileLocked(LWordDocCopyOf) = True Then MsgBox "يرجى غلق ملف الوورد!" Application.FollowHyperlink LWordDocCopyOf Exit Sub Else FileCopy LWordDocOriginal, LWordDocCopyOf MWordDocCopyOf = LWordDocCopyOf NWordDocCopyOf = Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") LWordDoc.Documents.Open MWordDocCopyOf LWordDoc.Visible = True LWordDoc.ActiveDocument.Bookmarks("A1").Select LWordDoc.Selection.InsertAfter Nz(b1.Value, "") LWordDoc.ActiveDocument.Bookmarks("A2").Select LWordDoc.Selection.InsertAfter Nz(b2.Value, "") LWordDoc.ActiveDocument.Bookmarks("A3").Select LWordDoc.Selection.InsertAfter Nz(b3.Value, "") LWordDoc.ActiveDocument.Bookmarks("A4").Select LWordDoc.Selection.InsertAfter Nz(b4.Value, "") LWordDoc.ActiveDocument.Bookmarks("A5").Select LWordDoc.Selection.InsertAfter Nz(b5.Value, "") LWordDoc.Application.Documents(NWordDocCopyOf).Save End If LWordDoc.Quit Set LWordDoc = Nothing Warning = MsgBox("تم تصدير البيانات للملف ....... هل تريد فتح الملف المصدر", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then Application.FollowHyperlink MWordDocCopyOf Else DoCmd.CancelEvent End If

تقضل جرب Dim MWordDocCopyOf As String Dim NWordDocCopyOf As String Dim LWordDocOriginal As String Dim LWordDocCopyOf As String Dim Warning As String LWordDocOriginal = CurrentProject.Path & "\asd.docx" LWordDocCopyOf = CurrentProject.Path & "\" & "الملفات" & "\" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" FileCopy LWordDocOriginal, LWordDocCopyOf MWordDocCopyOf = LWordDocCopyOf NWordDocCopyOf = Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") LWordDoc.Documents.Open MWordDocCopyOf LWordDoc.Visible = True LWordDoc.ActiveDocument.Bookmarks("A1").Select LWordDoc.Selection.InsertAfter Nz(b1.Value, "") LWordDoc.ActiveDocument.Bookmarks("A2").Select LWordDoc.Selection.InsertAfter Nz(b2.Value, "") LWordDoc.ActiveDocument.Bookmarks("A3").Select LWordDoc.Selection.InsertAfter Nz(b3.Value, "") LWordDoc.ActiveDocument.Bookmarks("A4").Select LWordDoc.Selection.InsertAfter Nz(b4.Value, "") LWordDoc.ActiveDocument.Bookmarks("A5").Select LWordDoc.Selection.InsertAfter Nz(b5.Value, "") LWordDoc.Application.Documents(NWordDocCopyOf).Save LWordDoc.Quit Set LWordDoc = Nothing Warning = MsgBox("تم تصدير البيانات للملف ....... هل تريد فتح الملف المصدر", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then Application.FollowHyperlink MWordDocCopyOf Else DoCmd.CancelEvent

تم معالجة المشكلة هل لا زالت المشكلة ... هل جربتها هل تظهر المشكلة في لحظة فتح الملف ام في التصدير

استبدل الكود بهذا ..... Dim MWordDocCopyOf As String Dim LWordDocOriginal As String Dim LWordDocCopyOf As String Dim Warning As String LWordDocOriginal = CurrentProject.Path & "\asd.docx" LWordDocCopyOf = CurrentProject.Path & "\" & "الملفات" & "\" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" FileCopy LWordDocOriginal, LWordDocCopyOf MWordDocCopyOf = LWordDocCopyOf Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") LWordDoc.Documents.Open MWordDocCopyOf LWordDoc.Visible = True LWordDoc.ActiveDocument.Bookmarks("A1").Select LWordDoc.Selection.InsertAfter Nz(b1.Value, "") LWordDoc.ActiveDocument.Bookmarks("A2").Select LWordDoc.Selection.InsertAfter Nz(b2.Value, "") LWordDoc.ActiveDocument.Bookmarks("A3").Select LWordDoc.Selection.InsertAfter Nz(b3.Value, "") LWordDoc.ActiveDocument.Bookmarks("A4").Select LWordDoc.Selection.InsertAfter Nz(b4.Value, "") LWordDoc.ActiveDocument.Bookmarks("A5").Select LWordDoc.Selection.InsertAfter Nz(b5.Value, "") LWordDoc.Application.Documents(Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx").Save LWordDoc.Quit Set LWordDoc = Nothing Warning = MsgBox("تم تصدير البيانات للملف ....... هل تريد فتح الملف المصدر", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then Application.FollowHyperlink CurrentProject.Path & "\" & "الملفات" & "\" & Format(Now(), "dd_mm_yyyy_hh_mm_AM/PM") & ".docx" Else DoCmd.CancelEvent End If كل هذا ممكن .... بس خلينا نخلص من اخونا @حامل المسك وابشر استاذ @عمر ضاحى

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

استخدم هذا الكود ..... Dim LWordDocOriginal As String Dim LWordDocCopyOf As String Dim Warning As String LWordDocOriginal = CurrentProject.Path & "\asd.docx" LWordDocCopyOf = CurrentProject.Path & "\" & "الملفات" & "\" & Format(Date, "dd-mm-yyyy") & ".docx" FileCopy LWordDocOriginal, LWordDocCopyOf Dim LWordDoc As Object Set LWordDoc = CreateObject("Word.Application") LWordDoc.Documents.Open CurrentProject.Path & "\" & "الملفات" & "\" & Format(Date, "dd-mm-yyyy") & ".docx" LWordDoc.Visible = True LWordDoc.ActiveDocument.Bookmarks("A1").Select LWordDoc.Selection.InsertAfter b1 LWordDoc.ActiveDocument.Bookmarks("A2").Select LWordDoc.Selection.InsertAfter b2 LWordDoc.ActiveDocument.Bookmarks("A3").Select LWordDoc.Selection.InsertAfter b3 LWordDoc.ActiveDocument.Bookmarks("A4").Select LWordDoc.Selection.InsertAfter b4 LWordDoc.ActiveDocument.Bookmarks("A5").Select LWordDoc.Selection.InsertAfter b5 LWordDoc.Application.Documents(Format(Date, "dd-mm-yyyy") & ".docx").Save LWordDoc.Quit Set LWordDoc = Nothing Warning = MsgBox("تم تصدير البيانات للملف ....... هل تريد فتح الملف المصدر", vbYesNo + vbQuestion, "تحذير") If Warning = vbYes Then Application.FollowHyperlink CurrentProject.Path & "\" & "الملفات" & "\" & Format(Date, "dd-mm-yyyy") & ".docx" Else DoCmd.CancelEvent End If

جرب .... New Microsoft Office Access Application.mdb

طيب ممكن مثال مصغر مع ملف الوورد ... للتعديل عليه ...

وعليكم السلام ورحمة الله جرب كده ...... OpenClsword (CurrentProject.Path & "\asd.docx") Objwrd.ActiveDocument.Bookmarks("A1").Select Objwrd.Selection.InsertAfter Jhhh Objwrd.ActiveDocument.Bookmarks("A1").Select Objwrd.Selection.InsertAfter Subsader Objwrd.ActiveDocument.Bookmarks("A3").Select Objwrd.Selection.InsertAfter Datesader Objwrd.ActiveDocument.Bookmarks("A4").Select Objwrd.Selection.InsertAfter annexes Objwrd.ActiveDocument.Bookmarks("A3").Select Objwrd.Selection.InsertAfter sndOfficialn Objwrd.SaveAs2 CurrentProject.Path & "\" & Date & ".docx" Objwrd.Close False

وهذا نفس كودك مع تصريف بسيط ...... frm.Section(acHeader).BackColor = GetSetting("FormColor", "ColorOption", "HeaderColor", 12874308) frm.Section(acDetail).BackColor = GetSetting("FormColor", "ColorOption", "DetailColor", 16769023) frm.Section(acFooter).BackColor = GetSetting("FormColor", "ColorOption", "FooterColor", 12874308)