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

اضافة لمشاركة استاذنا الكبير محمد البرناوي جزاه الله خير ممكن ايضا تحديد السجلات والغاء التحديد عن طريق مصدر السجلات لتحديد الكل Dim rs As Recordset Dim a As Integer Set rs = CurrentDb.OpenRecordset("tab_name") For a = 1 To rs.RecordCount rs.Edit rs!DELETE = -1 rs.Update rs.MoveNext Next a -------- لالغاء التحديد للكل نغيير السطر السادس الى rs!DELETE = 0 تحياتي

بل انا من يستفيد اكثر ونتعلم منكم علما وخلقا تحياتي

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

وهذا الملف ايضا بعد التعديل : تحديد الكل الغاء تحديد الكل الف شكر @Barna على امل ان يكون طلبي طلب الاخرين للاستفادة ... delete_data_table.zip

جرب حسب فهمي للموضوع .. delete_t.accdb

نفس طريقة اخواني محمد و خالد ، ولكن بدون الرجوع الى الجدول مصدر بيانات النموذج الفرعي ، وانما كل شيء من النموذج مباشرة : Dim rst As DAO.Recordset Set rst = Me.USER_PRIVILLAGE.Form.RecordsetClone rst.MoveFirst Do Until rst.EOF rst.Edit rst!DELETE = -1 rst.Update rst.MoveNext Loop جعفر

بارك الله فيك استاذي @مبرمج متقاعد منك نستفيد .... وعودا حميدا

طريقة اخرى على قد حالي طبعا حسب طلب الاستاذ يونس نسخ الحقول ماعدا حقل التفاصيل وانا استثنيت حقل id لانه ترقيم تلقائي وحقل التاريخ يكون تاريخ تكرار السجل ويمكن اعادته للمصفوفة ليكون a(5) ممكن نعمل مصفوفة نحمل فيها فقط الحقول المطلوب تكرارها If Me.NewRecord Then Exit Sub Dim x As Variant Dim a As Variant x = ([NSSA] & "|" & [NSSB] & "|" & [NSSC] & "|" & [RQMA] & "|" & [NSSE]) DoCmd.GoToRecord , , acNewRec a = Split(x, "|") [NSSA] = a(0) [NSSB] = a(1) [NSSC] = a(2) [RQMA] = a(3) [NSSE] = a(4) [TAREKA] = Date DoCmd.GoToControl "RQMB" وممكن نستغني عن المصفوفة باستخدام حلقة تكرارية تمر على الحقول وتستثني حقل الملاحظات والترقيم التلقائي ثم تكرر الحقول غير المستثناه وهنا لا داعي لكتابة اسماء الحقول ولكني ساكتفي بهذه المشاركة --------------------------------------------------- رجاء خاص من لم تعجبه المشاركة فليقل خيرا او يصمت لا تكرهونا في موقع اصبح متنفسنا الوحيد ملاحظة انا مبرمج متقاعد من عدة سنوات وتعاملي مع اكسس قليل جدا واغلب معلوماتي قديمة منذ نظام التشغيل dos واعترف بان اغلب المشاركين يفوقوني علما ومعرفة فخذ ما يعجبك او اترك

السلام عليكم ورحمة الله تعالى وبركاته عندما نتحدث عن توسيط النماذج والتقارير لابد من الأخذ فى الاعتبار ان خاصية PopUp لها تأثير كبير فإن كانت PopUp = True لها أكواد تقوم بعمل التوسيط للنماذج والتقارير داخل الشاشة خاصة ولا تقوم بعملها ان كانت PopUp = False والعكس كذلك واحيانا ننسى ذكر هذا الأمر عند عرض الاكواد والامثلة ولذلك تعمل عند البعض ولا تعمل عند اخرين بل واحيانا اثناء التصميم ننسى هذا الامر ايضا ومن أجل ذلك بعد البحث المرير وترتيب الأفكار بفضل الله تعالى تم دمج الأكواد حتى تعمل تبعا للخاصية PopUp ايما كان اعدادها حتى وان نسى المستخدم ذلك الامر أوحتى إن كان لا يدرى عنه شئ المرفق الاتى ان شاء الله به حل المشكلة تماما طيب ما الفرق بين عمل الاكواد مع خاصية PopUp ان كانت PopUp = True يتم توسيط داخل الشاشة نفسها تبعا لابعاد شاشة العرض نفسها مهما اختلف مقاس الشاشة اما ان كان PopUp = False يتم التوسيط داخل اطار تطبيق الاكس نفسه الاكواد كالاتى اولا كلاس ولابد ان يكون اسم الكلاس clsAutoCenter وان احببتم تغيير الاسم فيجب تعديله فى الاكواد التى تخص الموديول بنفس الاسم الجديد اولا الكلاس : clsAutoCenter '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT 'RECT structure used for API calls. Left As Long Top As Long Right As Long Bottom As Long End Type Private Type POINTAPI 'POINTAPI structure used for API calls. X As Long Y As Long End Type Private m_hWnd As Long 'Handle of the window. Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window. Private Const m_ERR_INVALIDHWND = 1 Private Const m_ERR_NOPARENTWINDOW = 2 #If VBA7 Then Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWndPtr As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long 'Returns the handle of the parent window of the specified window. #Else Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _ ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long 'Moves and resizes a window in the coordinate system of its parent window. Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long 'After calling, the lpRect parameter contains the RECT structure describing the sides of the window in screen coordinates. Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long 'Converts lpPoint from screen coordinates to the coordinate system of the specified client window. Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long 'Returns the handle of the parent window of the specified window. #End If Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String) 'Raises a user-defined error to the calling procedure. Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc End Sub Private Sub UpdateWindowRect() 'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow. Dim ptCorner As POINTAPI If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates. If Not Me.Parent Is Nothing Then 'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Left .Y = m_rctWindow.Top End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Left = ptCorner.X .Top = ptCorner.Y End With 'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates. With ptCorner .X = m_rctWindow.Right .Y = m_rctWindow.Bottom End With apiScreenToClient Me.Parent.hWnd, ptCorner With m_rctWindow .Right = ptCorner.X .Bottom = ptCorner.Y End With End If Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Sub Public Property Get hWnd() As Long 'Returns the value the user has specified for the window's handle. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then hWnd = m_hWnd Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let hWnd(ByVal lngNewValue As Long) 'Sets the window to use by specifying its handle. 'Only accepts valid window handles. If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then m_hWnd = lngNewValue Else RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle." End If End Property Public Property Get Left() As Long 'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Left = m_rctWindow.Left Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Left(ByVal lngNewValue As Long) 'Moves the window such that its left edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Top() As Long 'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect Top = m_rctWindow.Top Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Top(ByVal lngNewValue As Long) 'Moves the window such that its top edge falls at the position indicated '(measured in pixels, in the coordinate system of its parent window). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Width() As Long 'Returns the current width (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Width = .Right - .Left End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Width(ByVal lngNewValue As Long) 'Changes the width of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property '---------------------------------------------------- Public Property Get Height() As Long 'Returns the current height (in pixels) of the window. If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow Height = .Bottom - .Top End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Let Height(ByVal lngNewValue As Long) 'Changes the height of the window to the value provided (in pixels). If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then UpdateWindowRect With m_rctWindow apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True End With Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If End Property Public Property Get Parent() As clsAutoCenter 'Returns the parent window as a clFormWindow object. 'For forms, this should be the Access MDI window. Dim fwParent As New clsAutoCenter Dim lngHWnd As Long If m_hWnd = 0 Then Set Parent = Nothing ElseIf apiIsWindow(m_hWnd) Then lngHWnd = apiGetParent(m_hWnd) fwParent.hWnd = lngHWnd Set Parent = fwParent Else RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid." End If Set fwParent = Nothing End Property ثانيا الموديول ولن يفرق اسم الموديول فى شئ '|---01/11/2021__________________________________________________________________________________________| '|___www.officena.net_______________________|___________________________________________________________| '| | | '| __ _ | _ +-----------officena-----------+ _ | '| \ `/ | | /o) | ||||| | (o\ | '| \__`! | / / | @(~O^O~)@ | \ \ | '| / ,' `-.__________________ | ( (_ | _ ----oOo--Moh--oOo----- _ | _) ) | '| '-'\_____ U `-. | ((\ \) +/o)----------3ssam---------(o\+ (/ /)) | '| \____()-=O=O=O=O=O=[]====--) | (\\\ \_/ / \ \_/ ///) | '| `.___ ,-----,_______...-' | \ / \ / | '| / .' | \____/________Mohammed Essam________\____/ | '| / .' | | '| / .' | 01/11/2021 | '| `-' | | '|_____www.officena.net_____________________|___________________________________________________________| '|_____Thank you for visiting https://www.officena.net__________________________________________________' Option Compare Database Option Explicit Private Type RECT X1 As Long Y1 As Long X2 As Long Y2 As Long End Type #If VBA7 Then Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long #Else Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Boolean Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long #End If Private Const WU_LOGPIXELSX = 88 Private Const WU_LOGPIXELSY = 90 ' Call CenterForm(Me) ' Call CenterReport(Me) Sub CenterForm(F As Form) If F.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = F.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf F.PopUp = True Then Dim formWidth As Long, formHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim formAllMarginsHeight As Long, formAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 formAllMarginsHeight = F.WindowHeight - F.Section(acDetail).Height formAllMarginsWidth = F.Width formWidth = formAllMarginsWidth formHeight = formAllMarginsHeight If formHeight < F.WindowHeight Then formHeight = F.WindowHeight End If DoCmd.MoveSize (ScreenWidth - formWidth) / 2, (ScreenHeight - formHeight) / 2, formWidth, formHeight End If End Sub Sub CenterReport(R As Report) If R.PopUp = False Then Dim fw As New clsAutoCenter fw.hWnd = R.hWnd With fw .Top = (.Parent.Height - .Height) / 2 .Left = (.Parent.Width - .Width) / 2 End With Set fw = Nothing ElseIf R.PopUp = True Then Dim ReportWidth As Long, ReportHeight As Long Dim MaxWidth As Long, maxHeight As Long Dim ScreenWidth As Long, ScreenHeight As Long Dim ReportAllMarginsHeight As Long, ReportAllMarginsWidth As Long GetScreenResolution ScreenWidth, ScreenHeight ScreenWidth = ConvertPixelsToTwips(ScreenWidth, 0) ScreenHeight = ConvertPixelsToTwips(ScreenHeight, 0) MaxWidth = ScreenWidth * 0.6 maxHeight = ScreenHeight * 0.9 ReportAllMarginsHeight = R.WindowHeight - R.Section(acDetail).Height ReportAllMarginsWidth = R.Width ReportWidth = ReportAllMarginsWidth ReportHeight = ReportAllMarginsHeight If ReportHeight < R.WindowHeight Then ReportHeight = R.WindowHeight End If DoCmd.MoveSize (ScreenWidth - ReportWidth) / 2, (ScreenHeight - ReportHeight) / 2, ReportWidth, ReportHeight End If End Sub Function ConvertTwipsToPixels(lngTwips As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertTwipsToPixels = (lngTwips / nTwipsPerInch) * lngPixelsPerInch End Function Function ConvertPixelsToTwips(lngPixels As Long, lngDirection As Long) As Long Dim lngPixelsPerInch As Long Const nTwipsPerInch = 1440 #If VBA7 Then Dim lngDC As LongPtr #Else Dim lngDC As Long #End If lngDC = GetDC(0) If (lngDirection = 0) Then lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSX) Else lngPixelsPerInch = GetDeviceCaps(lngDC, WU_LOGPIXELSY) End If lngDC = ReleaseDC(0, lngDC) ConvertPixelsToTwips = (lngPixels * nTwipsPerInch) / lngPixelsPerInch End Function Private Sub GetScreenResolution(ByRef Width As Long, ByRef Height As Long) Dim R As RECT Dim RetVal As Long #If VBA7 Then Dim hWnd As LongPtr #Else Dim hWnd As Long #End If hWnd = GetDesktopWindow() RetVal = GetWindowRect(hWnd, R) Width = R.X2 - R.X1 Height = R.Y2 - R.Y1 End Sub ويتم استدعاء كود توسيط النماذج من خلال السطر الاتى فى حدث عند الفتح Call CenterForm(Me) ويتم استدعاء كود توسيط التقارير من خلال السطر الاتى فى حدث عند الفتح Call CenterReport(Me) فى حالة كانت PopUp = True يتم توسيط النماذج والتقارير فى وسط شاشة الحاسب الالى تمام تبعا لابعاد الشاشة اما فى حالة PopUp = False يتم توسيط النماذج والتقارير فى داخل اطار برنامج الاكسس نفسه والان اليكم المرفق بالمثال العملى AutoCentre.mdb

السلام عليكم ورحمة الله وبركاته التطبيق اهداء الى منتدانا الحبيب ورواد المنتدى العمل حتى يخرج بهذه الصورة يعلم الله وحده الجهد المبذول به اسال الله تعالى ان يتقبل هذا العمل صدقة جارية الى ما شاء الله تعالى ms access becomes an authorized e-invoicing solution provider in Saudi Arabia by www.officena.net Start your e-invoicing journey حسب متطلبات هيئة الزكاة والضريبة والجمارك السعودية يتم قراءة الرمز الناتج ان شاء الله عبر القارىء الرسمي الخاص بالهيئة ( تطبيق جوال ) حمل من هنا : التطبيق الرسمي لهيئة الزكاة والضريبة والجمارك يتم قراءة الرمز الناتج ان شاء الله عبر قارىء خاص ( تطبيق جوال ) حمل من هنا : تطبيق قرائة رمز الاستجابة طبقات لمتطلبات هيئة الزكاة والضريبة والجمارك التطبيق المقدم لكم تمت تجربته وهو متوافق مع النواتين 32 , 64 تم تصميم الاكواد داخل روتين عام ليسهل التعامل معها بكل سهولة ممكنة حاولت جاهدا جمع الاكواد المستخدمة فى موديول ليسهل نقله يتم التعامل مع الروتين باسناد فقط اسماء الحقول من النموذج المستخدم والتى يمكن تغير اسمائها تبعا لتصميمك كالاتى Call CreateInvoice(ID, SellerName, VatNo, TimeStamp, InvoiceWithVat, VatTotal) ID >>-----> اسم الحقل الدال على رقم الفاتورة وهذا ليتم تسمية ملف رمز الاستجابة الناتج بناء عليه SellerName >>-----> اسم الحقل الدال على اسم البائع VatNo >>-----> اسم الحقل الدال على الرقم الضريبي TimeStamp >>-----> اسم الحقل الدال على الوقت وتاريخ انشاء الفاتورة InvoiceWithVat >>-----> اسم الحقل الدال على القيمة الاجمالية للفاتورة VatTotal >>-----> اسم الحقل الدال على القيمة الاجمالية لمبلغ الضريبة فقط بعد تشفير البيانات يتم اسناد الشفرة الى متغير عام باسمstrHashCode والذى من خلاله يت حفظ البيانات المشفرة داخل الجدول تبعا لكل سجل ---------------------------------------------- الية العمل بعد اسناد اسماء الحقول الى الروتين يتم تمرير البيانات من تلك الحقول الى الملف التنفيذى الملحق مع القاعدة والذى بدورة يقوم بانشاء كل من 1- رمز الاستجابة السريع بعد تشفير البيانات طبقا للمطلبات from string to hex to base64 2- انشاء ملف نص به تشفير البيانات بعد ذلك تقوم باقى الاكواد بجلب البيانات المشفرة من ملف النص واسنادها الى المتغير الذى تم تخصيصه لذلك --------------------------------------------- تفاصيل الاكواد داخل الموديول كالتالى الروتين MkDir لعمل المجلدات عند الحاجة دوال الـ API الخاصة بـ ShellWait والمتوافقة مع كلتا النواتان 32 , 64 وتمت التجربة بنجاح على اوفيس 32 تارة واوفيس 64 تارة اخرى بفضل الله بنجاح حيث يتم ارسال البيانات من الحقول الى الملف التنفيذى الملحق من خلال الروتين Shell_n_Wait ليتم انشاء رمز الاستجابة السريع من خلال الروتين الخاص به وهو CreateInvoice وانشاء الملف النصى بجوار الملف التنفيذى فى نفس المسار لالحاق البيانات المشفرة طبقا للمطلبات from string to hex to base64 وبعد ذلك يتم جلب البيانات المشفرة من خلال الروتين ReadFileToText ولابد من استخلاص التشفير من خلال الروتين StripSpChars للاحتفاظ بالنص دون اى زيادات وبعد ذلك يتم الحاق البيانات المشفرة الى المتغير الذى قمت بتخصيصه لذلك وهو يحمل الاسم strHashCode والذى يتم الحاق البيانات من خلاله لكل سجل الى الحقل المخصص به للاحتفاظ بتلك الشفرة حسب طلبات السادة رواد المنتدى الكرام الملف التنفيذى تم عمله من خلال الفيجوال دوت نت ليقوم بتحويل النص طبقا للمطلبات from string to hex to base64 وتم دمج ملفات الـ Dll الخاصة بانشاء رمز الاستجابة بداخل الملف التنفيذى لسهولة التعامل معه من خلال الاكسس ليكون ملف تنفيذى واحد فقط يتم التعامل معه من خلال الـ Command Line دون الحاجة لتثبيت او تسجيل او الاستعانة بأى مكتبات خارجية او حتى ملحقة بالاكسس وذلك لسهولة نقل الموديول الى اى قاعدة دون التقيد باى مكتبات --------------------------------------------- تنبيه هام جدا جدا جدا بجوار قاعدة البيانات فى نفس مسارها مجلد باسم KSA-QR-Tool لايمكن تغيير اسم المجلد والا يحدث خلل وان استدعت الحاجة تغيير الاسم يجب ذلك داخل المدويول يتم كذلك انشاء ملف نصى اليا داخل المجلد KSA-QR-Tool لذلك يجب تحرى الحذر عند محاولة تغيير اسم المجلد داخل الموديول لذلك يرجى عدم محاولة تغير اسم المجلد كذلك داخل المجلد السابق ذكرة الملف التنفيذى KSAQR.exe لا تحاول تغيير اسم الملف لان الاكواد كذلك تتعامل مع هذا الملف من خلال اسمه كذلك لا يمكن نقل المجلد او الملف من مسار قاعدة البيانات الا بالتعديل على الاكواد وفى الختام فضلا وكرما وليس امرا الرجاء الاهتمام بالرد بما يفيد نتيجة تجربتكم الشخصية وتقييم تلك التجربة فلا تبخلوا علينا بذلك... لكم منا خالص الشكر واتمنى لكم تجربة ممتعة ومن يريد طريقتى والتى احبها وافضلها وتعلمتها من استاذى الجليل ومعلمى الجليل الاستاذ @jjafferr بتحميل الملف التنفيذى داخل القاعدة للتأكد دائما من عدم حذفه لا يتردد فى طلب ذلك فقط حاولت تقديم القاعدة بأبسط شكل حتى يقف كل من يريد استخدامها او نقلها الى تطبيقه الخاص على الاكواد المهمة فقط من خلال موديول واحد فقط تيسيرا وتسهيلا عليه وحتى تعم الفائدة هذه الاكواد المستخدمة فى الملف التنفيذى الذى تم انشاؤه من خلال الـ فيجوال دوت نت بناء على رغبة استاذى الجليل ومعلمى القدير و والدى الحبيب الاستاذ @ابوخليل لمن يريد التعلم من اكواد التشفير وبناء على طلب استاذى القدير @ابوآمنة Imports System.Drawing Imports System.IO Imports System.Text Imports QRCoder Module Module1 Sub Main() Try Dim sellerName As String = "" Dim vatNumber As String = "" Dim timeStamp As String = "" Dim invoiceTotal As String = "" Dim vatTotal As String = "" Dim imagePath As String = "" Dim filePath As String = "" If My.Application.CommandLineArgs.Count >= 6 Then sellerName = My.Application.CommandLineArgs(0) vatNumber = My.Application.CommandLineArgs(1) timeStamp = My.Application.CommandLineArgs(2) invoiceTotal = My.Application.CommandLineArgs(3) vatTotal = My.Application.CommandLineArgs(4) imagePath = My.Application.CommandLineArgs(5) filePath = My.Application.CommandLineArgs(6) Else Environment.Exit(0) End If If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, String.Join(" ", sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal), Encoding.UTF8) End If End Dim tlvInvoice = CreateInvoice(sellerName, vatNumber, timeStamp, invoiceTotal, vatTotal) Dim qrGenerator As New QRCodeGenerator() Dim qrData As QRCodeData = qrGenerator.CreateQrCode(tlvInvoice, QRCodeGenerator.ECCLevel.Q) Dim qrCode As QRCode = New QRCode(qrData) Dim qrCodeImage As Bitmap = qrCode.GetGraphic(20) qrCodeImage.Save(imagePath) If Not String.IsNullOrEmpty(filePath) Then File.WriteAllText(filePath, tlvInvoice, Encoding.UTF8) End If Catch ex As Exception End Try End Sub Function CreateInvoice(sellerName As String, vatNumber As String, timeStamp As String, invoiceTotal As String, vatTotal As String) As String Dim invoiceHex As String = "" For i = 1 To 5 Dim txt As String = "" Select Case i Case 1 txt = sellerName Case 2 txt = vatNumber Case 3 txt = timeStamp Case 4 txt = invoiceTotal Case 5 txt = vatTotal End Select Dim hexTxt As String = StringToHex(txt) Dim hexLen As String = Hex(Encoding.UTF8.GetBytes(txt).Length) If hexLen.Length = 1 Then hexLen = "0" & hexLen End If invoiceHex = invoiceHex & "0" & i & hexLen & hexTxt Next Return HexToBase64(invoiceHex) End Function Function StringToHex(txt As String) As String Dim b As Byte() = Encoding.UTF8.GetBytes(txt) Return BitConverter.ToString(b).Replace("-", "") End Function Function HexToBase64(txt As String) As String Dim bytes = New Byte((txt.Length \ 2) - 1) {} For i = 0 To bytes.Length - 1 Dim mi = txt.Substring(i * 2, 2) bytes(i) = Convert.ToByte(mi, 16) Next i Return Convert.ToBase64String(bytes) End Function End Module E-Invoicing.zip Ksa Qr 32x 64x 2007 to 2021 _Last Version.zip

تفضل لك ما طلبت العملاء.xlsm

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

وعليكم السلام 🙂 الصق هذا الكود في حدث التقرير : Private Sub Report_NoData(Cancel As Integer) MsgBox "لا توجد سجلات للطباعة" Cancel = True End Sub جعفر

السلام عليكم ورحمة الله خصص زر فى الفورم و ضع به هذا الكود Private Sub CommandButton1_Click() arr = Array("B5", "C5", "F5", "C8", "E9", "G10") tmp = Array(TextBox1.Value, TextBox4.Value, TextBox3.Value, _ TextBox2.Value, TextBox5.Value, TextBox6.Value) For i = LBound(arr) To UBound(arr) Range(arr(i)) = tmp(i) Next End Sub

الامر غير واضح مثلا هناك خلط بين كود البحث عن سجل وتصفية السجلات اذا كان الكود باستخدام Me.Filter او DoCmd.ApplyFilter هذه تسمى تصفية ولن تستطيع العودة للسجلات الغير مطابقة الا بعد انهاء عامل التصفية اما اذا كنت تستخدم DoCmd.SearchForRecord او Me.id.SetFocus DoCmd.FindRecord tx2, , True, , True فهذة عملية بحث وما يحصل هو انتقال المؤشر الى السجل المطلوب ومن المفترض انك تستطيع العودة للسجل الاخير مع كل ذلك فهذه اجابة افتراضية فلا اعلم ماهي طريقتك في اضافة السجلات تحياتي

وعليكم السلام 🙂 جرب هذا الرابط جعفر

احسنت استاذنا العزيز والاجر على الله

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

فعلا أستاذنا العزيز ،، نسخة الأكسس 2003 تكوم بكتابة الكود تلقائيا في محرر الأكواد .. بينما النسخ الأحدث منه تضيف الأمر على شكل ماكرو . 🙂

بالتوفيق لك استاذ يونس علما بان تكرار السجل على طريقة استاذنا الفاضل موسى موجودة ضمن معالجات access ويقوم اكسس بكتابة الامر بشكل تلقائي تحياتي

أخي الكريم حسب فهمي للمطلوب ضع هذه المعادلة في الخلية B26 =SUMPRODUCT(B6:B22,$Y$6:$Y$22) بالتوفيق

السلام عليكم ورحمة الله من تبويب Formula اختر Calculation Option ثم Automatic و ينتهى الامر

السؤال واضح وضوح الشمس في النهار اسمح لي اخوي لوكان ردي يزعلك : ردك اعلاه ما فهمت منه شي ، هل انت عربي ؟؟ اذا انت لست عربيا عذرناك

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

انتبه من فضلك فعليك استخدام خاصية البحث بالمنتدى ,فطلبك تكرر كثير جداً وشوف بنفسك https://www.officena.net/ib/search/?q=متفرقة&quick=1&type=forums_topic&nodes=135

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

تفضل هذا كود تكرار السجل : 🙂 Private Sub DublicateRecBtn_Click() On Error GoTo Err_DublicateRecBtn_Click DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdCopy DoCmd.RunCommand acCmdRecordsGoToNew DoCmd.RunCommand acCmdSelectRecord DoCmd.RunCommand acCmdPaste Exit_DublicateRecBtn_Click: Exit Sub Err_DublicateRecBtn_Click: MsgBox Err.Description Resume Exit_DublicateRecBtn_Click End Sub

السلام عليكم 🙂 اي شيء يُكتب بعد الامر DoCmd.Quit مثل (acQuitPrompt او acQuitSaveAll او acQuitSaveNone) هو لحفظ التغيير في تصميم النموذج/قاعدة البيانات ، وليس لحفظ السجل 🙂 فالامر DoCmd.Quit يكون كافيا 🙂 ولكن هناك ملاحظة في مساعد الاكسس: فإذن الامر الاصح للخروج من البرنامج هو : Application.Quit جعفر

ابحث في الموقع تجد العديد من الموضوعات مثل هذا <><><><><><>

جرب المرفق هناك معادلة في العمود m من m3:m انسخها الى الاسفل حسب عدد البيانات ولا تعدل في الخلية m2 اتركها بون معادلة الرجاء المساعده (1).xlsm

تفضل TEST2.xlsm

إخواني الأعزاء هذا برنامج صغير لمتابعة الوثائق والتقرير عنها بأكثر من طريقة وبه إمكانية إضافة بيانات وثائق جديدة أو تعديل أو حذف الموجود مع إمكانية البحث بأكثر من طريقة إلى جانب وجود تقرير إفتتاحي عند فتح الملف بالوثائق المنتهية الصلاحية ومنه يوجد تقرير عن الساري الصلاحية وتقرير عن كل الوثائق لن أطيل الشرح وإن شاء الله تجدوه واضح وكلمة مرور فتح الملف هي 123 ويمكن تغييرها من داخل الكود . وقد وعدت أحد الإخوة بعمله بعد طرح فكرة التقرير الذي يظهر بالوثائق منتهية الصلاحية في مشاركة سابقة وكان ينقصه ظهور باقي الوثائق إن زاد عددها فأرجو أن يكون هذا مناسب . تقبلوا تحياتي أبو عبدالله برنامج نظام الوثائق.rar

جرب المرفق داتا-1 (2).xlsm

تسوية عهدة.xlsm سلام عليكم هذا ملف لتسوية العهدة النقدية للموظفين أولا : يرجي كتابة أسماء حاملي العهد في شيت الرئيسية وأيضا رصيد اول المدة ثانيا : ندخل على صفحة الادخال لعمل التسويات ثالثا : من صفحة التقارير يمكنك طباعة العهدة بشكل جميل بتاريخ العهدة ملحوظة ضروري كتابه تاريخ العهد في نفس تاريخ التسوية وليست تواريخ الفواتير تحياتي لكم ♥

اخي ..لقد دققت في الكود الخاص بك جيدا وعملت كود يعطي نفس النائج ولكن بطريقة اخري نفذ الكود الخاص بي ونفذ الكود الخاص بك ودقق في النتائج ستجد انهم متطابقين تمام بعد عن تقنية ADO وهو سريع جدا ..واخبرنى هل زالت المشكلة ام لا المصنف4.xlsm

بعد اذن الاستاد هشام واثراء للموضوع هذا حل اخر بالاكواد Option Explicit Sub test() Dim ws As Worksheet: Set ws = Sheets("Feuil2") Dim lr1, r Dim x1, x2 r = 2 Application.ScreenUpdating = False ws.Range("g2:j1000").ClearContents With Sheets("Feuil1") lr1 = .Cells(Rows.Count, 1).End(3).Row For x1 = 1 To 4 For x2 = 7 To 11 If .Cells(1, x1).Text = ws.Cells(1, x2).Text Then .Cells(2, x1).Resize(lr1).Copy ws.Cells(2, x2).Resize(lr1) GoTo 1 End If Next x2 1: Next x1 End With Application.ScreenUpdating = True End Sub Copie de TRANSFER-COLONE_Marcel32-v12.xlsm

شاهد المرفق اخي مشكلة في تنسيق الارقام.xlsm

شيْ كهذا؟ الطباعه.xlsm

السلام عليكم الفراغ الموجود في بعض الأرقام هو الحرف الذي رمزه 160 (ليس هو "المسافة" Espace التي رمزها 32)، لهذا أبدلت الدالة SUM بالدالة SUMPRODUCT وأضفت لها الدالة SUBSTITUATE لاستبدال الحرف الذي رمزه 160 بلا شيء (بمعنى آخر حذف هذا الحرف من الأعداد التي تحتويه)... أرجو أن تفي الغرض المطلوب... ordre virement.xls

وعليكم السلام مشاركه مع اخوانى واساتذتى الافاضل جزاهم الله خيرا اطلع على هذه المشاركه لاختنا الغاليه زهره ام عهود جزاها الله خيرا ان شاء الله تفى لحل سؤالك http://arabteam2000-forum.com/index.php?/topic/82843-كود-لجعل-البرنامج-demo-لفترة/&do=findComment&comment=427294 بالتوفيق اخى

اضع بين ايديكم مجموعه من البرامج الجاهزة من اعداد فريق عمل مايكروسوفت اتمنى لكم الفائدة المشاريع 2018.rar الموظفين والعملاء.rar قاعدة البيانات31.rar قاعدة البيانات41.rar

الإخوة الكرام كل عام أنتم بخير أنا لا أتأخر عن أحبابي إذا كان المطلوب في استطاعتي وللعلم لا أملك أي ملف للتفقيط بدون كود الذي أملكه هو هذا الملف للتفقيط العربي والإنجليزي بخيارات متعددة وهو للأكسس والإكسل ArEnTafkeet.rar

إخواني الكرام كي لا تضيع الكنوز إليكم أفضل ملف رأيته في موضوع التفقيط من وجهة نظري وهو للأخ الكريم أسامة البراوي حفظه الله ورعاه وسدد خطاه وجعل أعماله في ميزان حسناته يوم القيامة :fff: :gift2: والملف يشمل اللغة العربية والإنجليزية .. Tafket OB.rar

السلام عليكم ورحمة الله وبركاته رمضان كريم يا جماعة لعيونكم استطعت بفضل الله كسر حماية الملف وإلغاء جميع كلمات السر به ها هو في المرفق Convert numbers into words unprotcted.rar