Foksh

أخي العزيز الأستاذ عبد اللطيف ،
بداية هذه الرسالة تظهر وأعتقد لأنه يوجد لديك تطبيق واتس أب سطح المكتب ..
حيث ، انظر لهذا السطر على سبيل المثال :-
https://api.whatsapp.com/send/?phone=962787787573&text&type=phone_number&app_absent=0 لاحظ الرقم 0 في نهاية العنوان !! انظر لطبيعة ونوع الرسالة التي تظهر لك عندما يكون لديك تطبيق واتس اب سطح المكتب .
ثم جرب وعدل 0 = 1 ، وانظر الفرق بين الرسالتين !!!!
طبعاً في النهاية سيتم فتح التطبيق في حال تم تثبيته لأن له الأولوية على موقع الويب .
 

 

 
 
لكن في نهاية المطاف ، لتجربة أن الكود يقوم فعلاً بتنفيذ المطلوب ، قم بحذف تطبيق الواتس اب لديك من الكمبيوتر ، وجربه
 
ولاحظت أيضاً انه عندما لا يكون هناك ايميل ، فيظهر لك خطأ ..
قم بإضافة هذا السطر في بداية حدث النقر لمربع النص الخاص بإرسال الإيميل
Private Sub EMAIL_Click() If IsNull(Me.EMAIL) Or Me.EMAIL = "" Then Exit Sub  

تمام أخي الكريم ،،
نستطيع تلافي المشكلة بإخفاء النموذج بشكل مؤقت أثناء المعاينة !!
استخدم الكود التالي في زر المعاينة ، وجرب
Private Sub btnPrint_Click() If lstResults.ListCount = 0 Then MsgBox "لا توجد نتائج لطباعتها", vbExclamation: Exit Sub End If Dim sh As Worksheet, nextRow As Long, i As Long, j As Long Const REPORT_SHEET As String = "تقرير الغياب" Me.Hide On Error Resume Next: Application.DisplayAlerts = False Worksheets(REPORT_SHEET).Delete Application.DisplayAlerts = True: On Error GoTo 0 Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sh.Name = REPORT_SHEET For j = 0 To lstResults.ColumnCount - 1 sh.Cells(1, j + 1).Value = "العمود " & j + 1 Next j sh.Range("A1:" & sh.Cells(1, lstResults.ColumnCount).Address).Font.Bold = True nextRow = 2 For i = 0 To lstResults.ListCount - 1 For j = 0 To lstResults.ColumnCount - 1 sh.Cells(nextRow, j + 1).Value = lstResults.List(i, j) Next j nextRow = nextRow + 1 Next i sh.Columns.AutoFit sh.PageSetup.Orientation = xlPortrait sh.PageSetup.Zoom = False sh.PageSetup.FitToPagesWide = 1 sh.PageSetup.FitToPagesTall = 1 sh.PrintPreview Me.Show End Sub  

تفضل أخي الكريم ..
 
 
baseM.zip

وعليكم السلام ورحمة الله وبركاته ،،
وبما اني اتابع من الجوال ، ولم استطع من رؤية الملف . اعتقد ان هناك أكثر من فكرة !!!
الأولى قد تعتمد على دالة تتفقد جميع العناصر ذات النوع "مربع نص" بأنها تحتوي قيم وغير فارغة . وهذا قد يسبب مشكلة لأنه حينها لن يميز بين مربعات النص التي تريدها من مربعات نص أخرى على سبيل المثال .
الثانية أنه عند الحفظ وقبل إتمام عملية الحفظ التأكد من مربعات النص التي لها مصدر بيانات مرتبط بحقل وليس مربعات النص الغير مضمنة بمصدر بيانات ، وهنا قد تكون مشكلة أيضاً .
الثالثة وما أرجحها بشكل أفضل وأقوى ، وهو من خلال الـ TAG . بحيث تضع وسماً لجميع مربعات النص التي تريدها أن يتم التحقق منها ولنفترض = Ham
حيث من خلال زر الحفظ نستعمل كود بهذا الشكل تقريباً - ما لم أكن مخطئاً في بعض الأجزاء ..
 
dim ctl as control, missing as string for each ctl in me.controls if lcase(trim(ctl.tag)) = "Ham" then if nz(ctl.value, "") = "" then missing = missing & vbcrlf & ctl.name end if end if next if missing <> "" then msgbox " : الحقول التالية فارغة" & vbcrlf & missing, vbinformation+ vbmsgboxright, "" exit sub end if docmd.runcommand accmdsaverecord docmd.gotorecord,,acnewrec
طبعاً ، إذا كنت من الأشخاص الذين يتركون اسم مربع النص كما هو من مصدره من الجدول ، فقد قمت بإضافة فكرة تحديد اسماء المربعات النصية التي لم يتم ادخال بيانات فيها .
بكل الأحوال جرب وأخبرنا بالنتيجة ، عل أحد الأساتذة والأخوة يتابع معك من كمبيوتر 🥴
على كل حال جرب 
 
 
خطر على بالي نقطة أخرى من خلال السطر :-
missing = missing & vbcrlf & ctl.name بأن نستبدله بالسطر التالي :-
missing = missing & vbcrlf & ctl.controls(0).caption فهنا سيأقرأ التسمية ( label ) المرتبطة بكل مربع نص بدلاً من اسم مربع النص نفسه .

هذه فكرة بسيطة ..
 
Foksh.accdb

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :-
Sub ExtractAbsentEmployees() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim targetDate As Date Dim dayNum As Integer Dim targetCol As Integer Dim lastRow As Long Dim i As Long Dim reportRow As Long Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي") wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents targetDate = wsReport.Range("C2").Value dayNum = Day(targetDate) targetCol = 3 + dayNum If targetCol < 4 Or targetCol > 34 Then MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation Exit Sub End If lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 5 For i = 4 To lastRow If wsMain.Cells(i, targetCol).Value = "غ" Then wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value wsReport.Cells(reportRow, 4).Value = targetDate reportRow = reportRow + 1 End If Next i If reportRow = 5 Then MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation End If End Sub  
وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :-
Sub GenerateMonthlyAbsenceReport() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim startDate As Date, endDate As Date Dim currentDate As Date Dim dayNum As Integer, targetCol As Integer Dim lastRow As Long, reportRow As Long, i As Long Dim empName As String, empJob As String Dim dateList As String, dayList As String Dim dateCount As Integer Dim dayName As String Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري") If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, "" Exit Sub End If startDate = wsReport.Range("C2").Value endDate = wsReport.Range("C3").Value If startDate > endDate Then MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsReport .Range("A6:F" & .Rows.Count).ClearContents .Range("6:" & .Rows.Count).RowHeight = 15 End With lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 6 For i = 4 To lastRow empName = wsMain.Cells(i, 2).Value empJob = wsMain.Cells(i, 3).Value If empName = "" Then GoTo NextEmployee dateList = "" dayList = "" dateCount = 0 currentDate = startDate Do While currentDate <= endDate dayNum = Day(currentDate) targetCol = 3 + dayNum If targetCol >= 4 And targetCol <= 34 Then If wsMain.Cells(i, targetCol).Value = "غ" Then dayName = wsMain.Cells(2, targetCol).Value If dateList <> "" Then dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd") dayList = dayList & vbLf & dayName Else dateList = Format(currentDate, "yyyy-mm-dd") dayList = dayName End If dateCount = dateCount + 1 End If End If currentDate = DateAdd("d", 1, currentDate) Loop If dateCount > 0 Then With wsReport .Cells(reportRow, 1).Value = reportRow - 5 .Cells(reportRow, 2).Value = empName .Cells(reportRow, 3).Value = empJob .Cells(reportRow, 4).Value = dateCount .Cells(reportRow, 5).Value = dateList .Cells(reportRow, 6).Value = dayList .Cells(reportRow, 5).WrapText = True .Cells(reportRow, 6).WrapText = True If dateCount > 1 Then .Rows(reportRow).RowHeight = 15 * dateCount End If End With reportRow = reportRow + 1 End If NextEmployee: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If reportRow > 6 Then ' MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, "" End If End Sub  
وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة  ..
 
 
 
موقف غياب موظفين.zip

وعليكم السلام ورحمة الله وبركاته ,,
حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :-
Private Sub Btn_1_Click() Dim wsMain As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long Dim i As Long Dim targetCol1 As String, targetCol2 As String Dim sourceCol1 As String, sourceCol2 As String Set wsMain = ThisWorkbook.Sheets("F") Dim targetSheetName As String targetSheetName = wsMain.Range("F6").Value On Error Resume Next Set wsTarget = ThisWorkbook.Sheets(targetSheetName) On Error GoTo 0 If wsTarget Is Nothing Then MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, "" Exit Sub End If If wsMain.Range("G6").Value = "قوى" Then sourceCol1 = "L" sourceCol2 = "M" targetCol1 = "H" targetCol2 = "I" ElseIf wsMain.Range("G6").Value = "تامين" Then sourceCol1 = "O" sourceCol2 = "P" targetCol1 = "H" targetCol2 = "I" Else MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, "" Exit Sub End If wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row) For i = 6 To lastRow If wsTarget.Range(sourceCol1 & i).Value <> "" Then wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value End If If wsTarget.Range(sourceCol2 & i).Value <> "" Then wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value End If Next i MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, "" End Sub  
جرب المرفق وأخبرنا بالنتيجة ..
 
BB.zip

السبب هو أنه يوجد خلايا مدمجة ، فكيف سيتم تمييز في اي خلية سيتم ادراج التاريخ و الوقت !!!!!
قمت بتعديل مواضع الـ CheckBox في ملفك ، وتعديل الدالة بحيث تتعامل مع الخلايا المدمجة ، لتصبح كالتالي :-

 
Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long, colNum As Long Dim targetCell As Range Dim cbValue As Long On Error GoTo SafeExit Set chk = ActiveSheet.CheckBoxes(Application.Caller) cbValue = chk.Value If chk.TopLeftCell Is Nothing Then Exit Sub Set rng = chk.TopLeftCell rowNum = rng.Row colNum = rng.Column Set targetCell = Cells(rowNum, colNum + 1) If targetCell.MergeCells Then Set targetCell = targetCell.MergeArea.Cells(1, 1) End If If cbValue = xlOn Then If IsEmpty(targetCell.Value) Then targetCell.Value = Now End If ElseIf cbValue = xlOff Then targetCell.MergeArea.ClearContents End If SafeExit: End Sub  
 
 
اختيار التاريخ.xlsm

طيب تمام ، جرب هذه الفكرة السريعة ، وباعتقادي قد تجد أفكار أفضل 100% من الأخوة والأساتذة والمعلمين هنا ..
 
 
الجمعية 29.zip

وعليكم السلام ورحمة الله وبركاته ,,
هذه محاولة بسيطة قد لا تكون بدقة فكرة الأستاذ @hegazee :-
Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, val As String Dim regex As Object Set regex = CreateObject("VBScript.RegExp") regex.Pattern = "^\d{1,2}-([a-zA-Z][1-9]\d*|[1-9]\d*[a-zA-Z]?)$" For Each c In Intersect(Target, Columns("E")) If Not IsEmpty(c) Then val = c.Value If Not regex.Test(val) Or Len(val) > 8 Then MsgBox "صيغة غير صحيحة! يجب أن تكون:" & vbCrLf & vbCrLf & _ "تستخدم شرطة (-) فقط (.1)" & vbCrLf & _ "لا تبدأ الأرقام بصفر (.2)" & vbCrLf & _ "لا يوجد صفر بعد الحرف الإنجليزي (.3)" & vbCrLf & _ "(12-a1234 :مثال ) الحد الأقصى 8 أحرف (.4)", _ vbExclamation + vbMsgBoxRight, "تصحيح" Application.Undo End If End If Next c End Sub  
جربها وأخبرنا بالنتيجة ..

وعليكم السلام ورحمة الله وبركاته ..
رغم أنك الى حد ما قريب من تحقيق هدفك في محاولتك داخل الزر .. إلا ان بعض النقاط قد غابت عنك ، مثل :-
تنسيق التاريخ بشكل صحيح . استخدام دالة DLookup بطريقة سليمة عند مقارنة التواريخ . يفضل استخدام Format عند التعامل مع التواريخ في SQL لتفادي أخطاء اللغة الإقليمية وتنسيق التواريخ .  
على العموم ، جرب هذا التعديل على ملفك الصلي إن كان صحيحاً :-
Private Sub أمر24_Click() Dim numFonct As Long Dim dateGrade As Date Dim critereRecherche As String Dim resultat As Variant numFonct = Nz(Me!num, 0) dateGrade = Nz(Me!date_grade_poste_actuel, #1/1/2000#) critereRecherche = "code_fonct = " & numFonct & " AND date_nomination = #" & Format(dateGrade, "yyyy-mm-dd") & "#" resultat = DLookup("code_fonct", "tbl_masser_mihani", critereRecherche) If Not IsNull(resultat) Then MsgBox "هذه المعلومات موجودة من قبل", vbExclamation + vbMsgBoxRight, "" Exit Sub End If DoCmd.SetWarnings False DoCmd.RunSQL _ "INSERT INTO tbl_masser_mihani (code_fonct, loi_fondamontale, grade, sinf, date_nomination, numero_visa_cf, date_visa_cf) " & _ "SELECT num_fonctionnaire, loi_fondamontale, grade_poste_actuel, categorie, date_grade_poste_actuel, num_visa_grade_poste_actuel, date_visa_grade_poste_actuel " & _ "FROM tbl_info_fonctionnaire " & _ "WHERE num_fonctionnaire = " & numFonct DoCmd.SetWarnings True MsgBox "تمت الإضافة بنجاح", vbInformation + vbMsgBoxRight, "نجاح" End Sub  

وعليكم السلام ورحمة الله وبركاته ..
المعطيات من خلال الملف المرفق :-
1. نوع التنسيق = نسبة مئوية ( Percent ) .
2. النتيجة في المربعات النصية التي فيها المشكلة = #Num! دلالة على أنه غير قادر على إدراج النتيجة 0 كنسبة مئوية ..
جرب في مربع النص d67 داخل ا لتقرير استخدام الجملة التالية :-
=IIf([d55]=0,0,([d63]+[d61]+[d59])/[d55]) بدلاً من التعبير السابق :-
=([d63]+[d61]+[d59])/[d55]  
وبناءً عليه قم بالتطبيق بنفس الأسلوب 🤗 

وعليكم السلام ورحمة الله وبركاته ..
 
ملاحظة مهمة بخصوص المتغيرين i و ii :-
حيث تم تعريفهما كـ String ، بينما من الواضح ( وبناءً على ما أذكر من مشاركات سابقة ) أنهما يمثلان رقم الترم المخزن في العمود الأول (Column(0)) من الـ ComboBox . صحيح ؟؟
 
Private Sub Report_Open(Cancel As Integer) Dim i As Long, ii As Long i = Forms!frm_Reports!ComboSaf.Column(0) ii = Forms!frm_Reports!termNum.Column(0) Me.tsmya1.Caption = funSanahDrasyahDate() If ii = 2 Then Me.tsmya2.Caption = "الدور الأول" Else Me.tsmya2.Caption = "الدور الثاني" End If DoCmd.Maximize End Sub  

وعليكم السلام ورحمة الله وبركاته ,,
 
تفضل
 
 
saffar2.zip

انا افتكرت ان الفكرة واضحة ،
على العموم اجعل مصدر بيانات النموذج = الجدول trans وحدد لكل كومبوبوكس مكانه في الجدول 
هذا اذا كنت فاهمك صح طبعاً 😅 

حسناً أخي الكريم ، ولا يهمك .. بسيطة
جرب هذا التعديل على قاعدتك التي تحتوي بيانات أكبر ، وتأكد من أخذ نسخة احتياطية منها ( أو نسخة أخرى اعملها للتجربة ) :-
Private Sub أمر1069_Click() On Error GoTo ErrorHandler Dim db As DAO.Database Dim rsSource As DAO.Recordset Dim rsDest As DAO.Recordset Dim strSQL As String Dim currentCode As Long DoCmd.SetWarnings False Set db = CurrentDb db.Execute "DELETE FROM tab_degree_mauel", dbFailOnError db.Execute "INSERT INTO tab_degree_mauel(code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision) " & _ "SELECT code_fonct, nom_prenom, grade_actuel, categorie, numero_indice_categorie, degre, numero_indice_degre, duree, date_effet, faid_31_12, date_signature_decision, date_reunion_comession, date_calcul_faid_31_12, num_decision " & _ "FROM tab_degree_saisie", dbFailOnError strSQL = "SELECT t1.code_fonct, t1.nom_prenom, t1.degre, t1.numero_indice_degre, t1.date_effet " & _ "FROM tab_degree_saisie t1 " & _ "INNER JOIN (SELECT nom_prenom, MAX(degre) AS MaxDegre " & _ "FROM tab_degree_saisie " & _ "GROUP BY nom_prenom) t2 " & _ "ON t1.nom_prenom = t2.nom_prenom AND t1.degre = t2.MaxDegre" Set rsSource = db.OpenRecordset(strSQL, dbOpenDynaset) If Not (rsSource.EOF And rsSource.BOF) Then rsSource.MoveFirst Do Until rsSource.EOF currentCode = Nz(rsSource!code_fonct, 0) Set rsDest = db.OpenRecordset("SELECT * FROM tbl_info_fonctionnaire WHERE num = " & currentCode, dbOpenDynaset) If rsDest.EOF Then rsDest.AddNew rsDest!num = currentCode Else rsDest.Edit End If rsDest!grade = rsSource!degre rsDest!num_indice_grade = Nz(rsSource!numero_indice_degre, 0) rsDest!date_effet_grade_actuel = Nz(rsSource!date_effet, Date) rsDest.Update rsDest.Close rsSource.MoveNext Loop End If MsgBox "تم تحديث البيانات بنجاح", vbInformation + vbMsgBoxRight, "" Cleanup: On Error Resume Next If Not rsSource Is Nothing Then rsSource.Close Set rsSource = Nothing End If If Not rsDest Is Nothing Then rsDest.Close Set rsDest = Nothing End If Set db = Nothing DoCmd.SetWarnings True Me.Requery Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical + vbMsgBoxRight, "خطأ" Resume Cleanup End Sub  

وعليكم السلام ورحمة الله وبركاته ,,,
تمام فهمتك ، جرب التعديل ده :-
 
Private Sub Worksheet_Change(ByVal Target As Range) Dim c As Range, valToCheck As Variant Dim duplicateFound As Boolean Dim lastRow As Long, i As Long On Error Resume Next Set c = Intersect(Target, Columns("E")) If c Is Nothing Then Exit Sub Application.EnableEvents = False valToCheck = c.Value If valToCheck <> "" Then lastRow = Cells(Rows.Count, "E").End(xlUp).Row duplicateFound = False For i = 1 To lastRow If i <> c.Row And Cells(i, "E").Value = valToCheck Then If WorksheetFunction.CountBlank(Range("K" & i & ":N" & i)) = 4 Then MsgBox "الحالة سبق ادخالها ولم يتم بشانها اجراء", vbExclamation + vbMsgBoxRight, "تنبيه" c.ClearContents duplicateFound = True Exit For End If End If Next i If Not duplicateFound Then Cells(c.Row, "D").Value = Date End If End If Application.EnableEvents = True End Sub  

جرب هذا التعديل !!!
 
 
 
saffar.zip

وعليكم السلام ورحمة الله وبركاته ,,
تفضل هذا التعديل :-
 
DDCompanyLogos.zip

وعليكم السلام ورحمة الله وبركاته 🤗..
جرب هذا التعديل أخي الكريم :-
Private Sub Workbook_Open() Dim filePath As String ' المسار الكامل للملف filePath = "C:\Program Files\new\officeteam.txt" ' تحقق من وجود الملف If Dir(filePath) = "" Then MsgBox "ليس لديك الاذن في الاستخدام, يرجى التواصل مع مالك النظام . تنبيه.", vbCritical ThisWorkbook.Close SaveChanges:=False End If End Sub المشكلة أن الكود الذي كتبته يحتوي على خطأ في طريقة تحديد المسار ، حيث إنك قمت بدمج filePath مع requiredFile مرتين  .
 

جرب هذه المحاولة ..
Data125.zip
 
تركت التنسيق لك طبعاً 😅
Data125.zip

تفضل :-
 
القاعدة 2.zip

وعليكم السلام ورحمة الله وبركاته ..
اتمنى أن لا يكون هناك أمور لم تأت على ذكرها 😅😅
 
جرب في حدث عند التحميل لأي نموذج يحتوي الزر المطلوب ، الكود التالي
 
Private Sub Form_Load() If Time() > #3:00:00 PM# Then Me.Alborg.Visible = False Else Me.Alborg.Visible = True End If End Sub  

السبب في مشكلتك ليست في الأكواد أو الأدوات ، وإنما من بنية الجدول في اكسيس لديك !!!
على سبيل المثال :-
العمود E ويمثل alsaf_Id في اكسل وقيمته على سبيل المثال = كي جي1 .
بينما نظيره في جدول اكسيس = الحقل alsaf_Id ، وهو حقل رقمي  .
فكيف سيتم نقل قيمة نصية الى حقل رقمي !!!!!!!!!
 
إذا عرف السبب بطل العجب وهنا ينتهي دوري للأسف  .

لا أعلم لم لا يتم التقيد بسياسة المنتدى عند فتح اي موضوع أخي الكريم 🙄
فلم تأتِ على ذكر ان الكود جزء من مديول ، هذا أولاً .
ثانياً لا يتم الأمر بالصورة التي تتوقعها ، ولكن سيكون هناك دالة منفصلة على هذا الطلب .
 
على العموم ، في مديول جديد أو موجود ، انسخ الدالة التالية ، والصقها في مشروعك :-
Public Sub FokshBTN(btn As commandButton, ByVal PNAME As String, ByVal Kind As String, Optional ByVal JO_Title As String = "تأكيد طباعة") On Error Resume Next Dim msg As String msg = "الخاص " & btn.Caption & " هـل . . . . . تريـد طبـاعة تقريـر" & vbNewLine & vbNewLine & _ " بـــ " & PNAME & " " & Kind If MsgBox(msg, vbQuestion + vbMsgBoxRight + vbYesNo, JO_Title) = vbYes Then DoCmd.PrintOut DoCmd.Close acReport, Reports(0).Name Else DoCmd.Close acReport, Reports(0).Name End If End Sub ثم في أي زر ، يتم الاستدعاء بالشكل التالي :-
FokshBTN Me.ActiveControl, PNAME, Kind  
 
😅