jjafferr

حتى يتم تطبيق كود الاحداث 
 
الكود ينادي الدالة MovCenter ويرسل لها معلومتين لهما علاقة بإرتفاع النافذة وعرضها 
 
لا ادري ، لم اتطلع على الكود ، وحتى لو اتطلعت عليها ، فقد تكون الدالة تنادي دالة ثانية ، وهكذا 🙂

تم الغاء السطر الاخير الفارغ ، فرجاء تجربته على هذا البرنامج ، وذاك 🙂
 
وتم اصطياد جميع رسائل الاخطاء ، بحيث يتم عرضها ، وعند التقر على OK ، يتم اغلاقها ،
ولا اريد ان اوقف هذه الرسائل ، حتى تعرف انك قمت بخطأ ما ،
والبرنامج يكتشف هذه الاخطاء فقط لما يفتح ملف الوورد ، فلا سبيل الى التنبئ بالخطأ خلافا لذلك 🙂
 
اما موضوع عمل جدول وجميع حقوله "مذكرة" ، فنعم تستطيع القيام به لتعجيل استيراد البيانات من ملف الوورد ، ولكنك ستتيه في بيانات الاكسس !!
ولا انصح بتعديل نوع حقوله من مذكرة الى رقم (مثلا) ، وانما يكون الافضل وجود جدول آخر به انواع الحقول بالطريقة الصحيحة ، ثم يتم استيراد بينات جدول المذكرات الى هذا الجدول ، وتتم عملية التنظيف خلال هذا الاستيراد ، ولكن لن يكون الامر سهلا 😁
 
جعفر
1322.7.تحويل.accdb.zip

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

وعليه تكون النتيجة بعد الاختيار :

.
جعفر
1334.Database1 (3).accdb.zip

السلام عليكم 🙂
 
هذه آخر محاولة لي ، وقد قمت بتغيير العمل:
Option Compare Database Option Explicit Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer 'unify endline characters, so that we can use Split function myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, Chr(10) & Chr(13), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) ' myValue = Replace(myValue, " ", " ") ' myValue = Replace(myValue, " ", " ") ' myValue = Replace(myValue, " ", " ") 'convert the one paragraph into different phrases separated by vbcrlf x = Split(myValue, vbCrLf) 'Loop through the phrases For j = 0 To UBound(x) 'remove the extra spaces on the Left x(j) = Trim(x(j)) If Len(x(j)) > 1 And j <> UBound(x) Then 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it 'only if the right character is a spcae and its not the last phrase x(j) = Trim(Mid(x(j), 1, Len(x(j)) - 1)) & vbCrLf End If 'Remove the Empty lines (one character length), and accumelate the rest of the lines If Len(x(j)) < 2 Then Else Remove_Extras = Remove_Extras & x(j) End If Next j 'this is an Access conversion error, so lets uninfy it like all endlines Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'replace the VT characters with vbcrlf 'if the last character is vbcrlf, remove it, so that we dont have extra empty line at the end If Right(Remove_Extras, 1) = vbCrLf Or Right(Remove_Extras, 1) = Chr(10) Or Right(Remove_Extras, 1) = Chr(13) Then Remove_Extras = Mid(Remove_Extras, 1, Len(Remove_Extras) - 2) End If End Function  
جعفر
 
أسطر3.zip

وبعد قراءتي لطلبك بتمعن اكثر ، انت لا تريد 20 20 ، وانما تسلسل واحد ، ولكن مجموعات 🙂
 
هذا الكود يقوم بالعمل:
Dim rst As DAO.Recordset Dim S As Integer Dim G As Integer Dim i As Integer Set rst = CurrentDb.OpenRecordset("Select * From all_data") S = 0 G = 1 'loop through the table Do Until rst.EOF S = S + 1 rst.Edit rst!OT_Seq = S rst!OT_Groups = G rst.Update 'If S = 20 Then 'Repeating 1-20 'S = 0 If Int(S / 20) = S / 20 Then 'No Repeat G = G + 1 End If rst.MoveNext Loop rst.Close: Set rst = Nothing MsgBox "Done"  
جعفر
1332.Report_Counter_20_ONLY.mdb.zip

تفضل 
 
هذا النموذج ، بزر استيراد بيانات اول صفحة ، وزر حفظ البيانات في الاكسل:

 
والكود (لاحظ اسم ومسار ملف الاكسل ، في الحدثين):
Option Compare Database Dim ExcelApp As Object 'Excel.Application Dim WkBk As Object 'Excel.Workbook Private Sub cmd_Import_From_Excel_Click() File_Path = Application.CurrentProject.Path & "\372.62293-SER OH.xls" Set ExcelApp = CreateObject("Excel.Application") Set WkBk = ExcelApp.Workbooks.Open(FileName:=File_Path) 'With WkBk.Sheets("input data") With WkBk.Sheets(1) Me.Control_No = .Range("B2").Value Me.SN = .Range("B3").Value Me.DATE = .Range("B4").Value Me.TS_Name = .Range("B5").Value Me.Component_PN = .Range("B7").Value Me.Description = .Range("B8").Value Me.JIC_NO = .Range("B10").Value Me.JIC_Rev_NO = .Range("B11").Value Me.JIC_Rev_Date = .Range("B12").Value Me.CMM_JIC_Approval = .Range("B13").Value Me.CMM = .Range("B14").Value End With If Not (ExcelApp Is Nothing) Then ExcelApp.Quit Set WkBk = Nothing Set ExcelApp = Nothing End Sub Private Sub cmd_Save_to_Excel_Click() File_Path = Application.CurrentProject.Path & "\372.62293-SER OH.xls" Set ExcelApp = CreateObject("Excel.Application") Set WkBk = ExcelApp.Workbooks.Open(File_Path) ExcelApp.Application.Visible = False 'True 'With WkBk.Sheets("input data") With WkBk.Sheets(1) 'WkBk.Sheets(1).Range("B2").Value = Me.Control_No .Range("B2").Value = Me.Control_No .Range("B3").Value = Me.SN .Range("B4").Value = Me.DATE .Range("B5").Value = Me.TS_Name .Range("B7").Value = Me.Component_PN .Range("B8").Value = Me.Description .Range("B10").Value = Me.JIC_NO .Range("B11").Value = Me.JIC_Rev_NO .Range("B12").Value = Me.JIC_Rev_Date .Range("B13").Value = Me.CMM_JIC_Approval .Range("B14").Value = Me.CMM End With WkBk.Save WkBk.Close Set WkBk = Nothing Set ExcelApp = Nothing MsgBox "Done" End Sub 372.Database1.mdb.zip
جعفر

وعليكم السلام 🙂
 
في 99.99% من الوقت ، نعم يمكن 🙂
اضف حقل اسم الشركة الى الجدول ، مفهرس ، التكرار مقبول ، عبئ بيانات الحقل ، ولما تنتهي من هذا العمل لجميل الجداول ، ادمج الجداول مع بعض ،
وفي استعلاماتك ، وللتمييز بين بيانات شركة واخرى ، استخدم اسم الشركة كمعيار 🙂
 
جعفر

تم حل هذه الاشكالية بالمرفق الجديد ،
فيصبح حدث النقر المزدوج في الحقل:
Private Sub EH_DblClick(Cancel As Integer) Dim lng_Mno As Long 'send the "UnSaved Text" (to retain the text position as is), and the click position to the Function Get_Number 'to retrieve the number clicked on lng_Mno = Get_Number(Me.EH.Text, Me.EH.SelStart) 'once the Function returns the value, examin it If lng_Mno = 0 Then MsgBox "لم يتم الحصول على رقم" ElseIf lng_Mno = 1 Then MsgBox "لم يتم التعرف على الخطأ" Else DoCmd.OpenForm "مسند", , , "[Mno]=" & lng_Mno End If End Sub  
والدالة في الوحدة النمطية:
Option Compare Database Option Explicit Public Function Get_Number(fld As String, P As Long) As Long On Error GoTo err_Get_Number ' 'fld = Field content 'P = Position left mouse was double clicked in the field 'max_Length = maximun length of numeric field, default is 10 on each side = 20 characters 'C = the character to check 'Add_C = Adds the numeric Characters ' '1. check the characters to the Left <----| '2. check the characters to the Right |----> ' ' jjafferr ' v.1 : 21-01-13 : initial re;ease ' v.1.1 : 21-01-14 : added error traping for noe numeric values ' Dim i As Integer Dim Add_C As String Dim C As String Dim max_Length As Integer max_Length = 10 'What dose Access Read: -10 to 10 = 20 letters/characters 'C = Mid(fld, P - max_Length, max_Length) & vbCrLf & Mid(fld, P + 1, max_Length) 'Debug.Print C 'Get the numbers on the Left side of the click For i = P To (P - max_Length) Step -1 C = Mid(fld, i, 1) 'loop through the characters one at a time If IsNumeric(C) Then 'test the character to our condition Add_C = C & Add_C 'passed the condition, Concatenat it Else Exit For 'did NOT pass the condition, get out of the loop End If Next i 'Debug.Print Add_C 'Get the numbers on the Right side of the click P = P + 1 For i = P To (P + max_Length) C = Mid(fld, i, 1) If IsNumeric(C) Then Add_C = Add_C & C Else Exit For End If Next i 'Convert the concatenated string to Long, and 'return the number value Get_Number = CLng(Add_C) Exit_Get_Number: Exit Function err_Get_Number: If Err.Number = 13 Then Get_Number = 0 ElseIf Err.Number = 5 Then Get_Number = 1 Else Get_Number = 1 MsgBox Err.Number & vbCrLf & Err.Description End If 'don't break the code, so Resume by exiting from the Function Resume Exit_Get_Number End Function  
 
 
انا لم اقل هذا ، وإنما قلت 
 
 
جعفر
1326.2.Get Number between text.accdb.zip

هذا عمل الكود ،
فالكود يحاول من جانبه مرارا ، الى ان ينتهي المستخدم الآخر ، فيقوم الكود بحفظ البيانات لهذا المستخدم

وعليكم السلام 🙂
 
هذا تقرير ، ولو ارفقت لنا برنامجك وبه بيانات كافية لعمله ، لساعدك الشباب هنا 🙂
 
جعفر

وعليكم السلام 🙂
 

.

.
Like "*" & [Forms]![الاستعلام]![inspictor] & "*" .

.
جعفر

وعليكم السلام 🙂
 
كان ياما كان في قديم الزمان ، كان فيه نسخة الاكسس رقمها 2010 ، وعملوا فيها إضافة ، وهي عملها على الانترنت ،
وعلشان يعملوا تنسيق للاكواد ، عملوا تعديلات على نظام الماكرو ، واصبح افضل واشمل 🙂
ولكنهم لاحقا اوقفوا هذه الخاصية.

الماكرو اسهل ولا تحتاج معرفة في البرمجة ، 
ولكن في نظر معظم المبرمجين ، الكود افضل ، لسهولته ومرونته ومقدرته التعامل مع الملفات والبرامج الخارجية 🙂
 
جعفر

وهذه تجربتي
 
Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String Dim myStr As String myStr = "=IIf([xname] Is Null, '', " & "Replace([" & strFieldName & "], '" & FindAsType & "', '" & strTagStart & FindAsType & strTagEnd & "'))" 'Debug.Print myStr StrHighLight = myStr End Function ونناديها Me.txtxname.ControlSource = StrHighLight("xname", FindAsType)  
جعفر
وتعديل نهائي
Public Function StrHighLight(ByVal strFieldName As String, ByVal FindAsType) As String Dim myStr As String myStr = "=IIf([" & strFieldName & "] Is Null, '', " & "Replace([" & strFieldName & "], '" & FindAsType & "', '" & strTagStart & FindAsType & strTagEnd & "'))" 'Debug.Print myStr StrHighLight = myStr End Function  
جعفر

وعليكم السلام 🙂
 
 

.

.
 
ثم في حدث عند تنسيق قسم التفصيل Detail من التقرير ، نضع هذا الكود الذي يخفي الحقل الفارغ ويجعل ارتفاعه = صفر اذا كان الحقل فارغ ، وإلا فيتركه كما هو :
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) On Error Resume Next Dim ctl As Control Dim txt As String Dim lbl As String For Each ctl In Me.Controls If ctl.ControlType = acComboBox Then txt = ctl.Name lbl = ctl.Name & "_تسمية" If Me(txt).Text = "" Then ctl.Visible = False ctl.Height = 0 Me(lbl).Visible = False Me(lbl).Height = 0 Else ctl.Visible = True ctl.Height = 0.2188 * 1440 Me(lbl).Visible = True Me(lbl).Height = 0.2188 * 1440 End If End If Next End Sub .
والنتيجة

.
جعفر
1314.الجدولي اليومي.accdb.zip

وعليكم السلام 🙂
 

.

.
الآن نريد معرفة رقم الزر F5 :
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) MsgBox KeyCode End Sub .
وعند فتح النموذج ، نضغط على الزر F5 ، فنحصل على رقمه :

.
الآن نعود الى الحدث اعلاه ، ونخبر الاكسس ما نريد عمله عند الضغط على الزر F5 (الذي رقمه 116) :
حدث النقر على الزر الاحمر "الرسالة Private Sub cmd_F5_Click() MsgBox "السلام عليكم" End Sub Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) If KeyCode = 116 Then Call cmd_F5_Click '<---- ننادي الحدث اعلاه End If End Sub .
والنتيجة

.
جعفر
1315.Press_F5.accdb.zip

الحقول لم تكن Null وانما كانت فارغة !!
 
استعمل هذا الاستعلام :

.
UPDATE Tabl_1 SET Tabl_1.A1 = f_A1(IIf(Len([A1] & "")=0,"|",[A1])), Tabl_1.A2 = f_A2(IIf(Len([A2] & "")=0,"|",[A2])), Tabl_1.A3 = f_A3(IIf(Len([A3] & "")=0,"|",[A3])), Tabl_1.A4 = f_A4(IIf(Len([A4] & "")=0,"|",[A4])), Tabl_1.A5 = f_A5(IIf(Len([A5] & "")=0,"|",[A5])); .
جعفر
1312.Database2.accdb.zip

جرب هذا التعديل
If len(me.Filddate & "")=0 then Me.Allowedits = true else Me.Allowedits = false endif  
جعفر

1. لابد من طريقة لعمل معيار لتصفية البيانات الى عدد محدد ، وممكن انك تعمل استعلام وتعمل فيه هذه المعايير والتصفية ، ومن ثم تعمل الدوران على اساس الاستعلام بالسجلات الباقية 🙂
2. هذا الكلام غير دقيق ، ولكنك قد لا تلاحظ الوقت ، او ان المعالج في السرفر اقوى بكثير من معالج كمبيوترك ، فتلاحظ هذا الفرق في الوقت 🙂
 
جعفر

هذا اللي يعمل صفحة جديدة 🙂
 
في قسم "التفصيل" Detail ، على حدث "عند التنسيق" OnFormat اكتب (على فرض اسم كائن فرض الصفحة الجديدة: nPage :
if me.Page=me.pages then nPage.visible=false else nPage.visible=true endif  
جعفر

وعليكم السلام 🙂
 
لا يمكن عمل هذا من الاكسس ،
ولكنك تستطيع استعمال برنامج خارجي لعمل الدمج ، بحيث تعطي امر لهذا البرنامج بدمج الملفات الاربعة ، وهذا الامر يكون بعد تصدير ملف pdf الاخير :
 
 
جعفر

وعليكم السلام 🙂
 
في التقرير :
1. قبل ان تضع الكود على اي حدث ، تأكد ان تضعه في القسم الصحيح ، والكائنات موجودة عندك في هذا القسم :

.
2. الحدث الصحيح لعمل التنسيق المطلوب هو ، إما حدث "عند التنسيق" او "عند الطباعة" ،
عليه ، يصبح كودك هكذا :
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer) ' Me.Degree1.SetFocus 'Me.TXTEDARI = DLookup("EMP_NAME", "AllEmpInfTbl", "job_title='رئيس القسم الإداري'") Me.CK1.Value = False Me.CK2.Value = False Me.CK3.Value = False Me.CK4.Value = False Me.CK5.Value = False If Me.Degree1 = "ممتاز" Then Me.CK1.Value = True ElseIf Me.Degree1 = "جيد جدا" Then Me.CK2.Value = True ElseIf Me.Degree1 = "جيد" Then Me.CK3.Value = True ElseIf Me.Degree1 = "مقبول" Then Me.CK4.Value = True ElseIf Me.Degree1 = "ضعيف" Then Me.CK5.Value = True End If End Sub  
جعفر

وعليكم السلام 🙂
 
انزل البرنامج من رابط هذا المرفق ، واصلح برنامجك
 
 
جعفر

وعليكم السلام 🙂
 
في اعدادات النموذج ، اعمل Allow Edits = False
 
جعفر

هل تاريخ جهازك انجليزي او هجري ؟
 
رجاء تجرب هذا المرفق
1307.1.يومية مورد.accdb.zip

الآن تم اخفاء زر Show Pedo ، والصورة تظهر حسب اختيارك من الحقل Kind ،
 
لا يوجد مكان خاص للكيار وآخر للاطفال ، هو مكان واحد للإثنين معا ،
1. التنسيق الشرطي : لعمل لون جديد (او لتغيير لون سابق) ، يجب هذا اللون ان يتطابق مع لون الضرس في الصورة :
 - لا تختار اللون مباشرة ، وانما اذهب الى more colors 

.
الآن اختار الالوان (تستطيع ان تختارها من التبويب Standard ) ، ولكن يجب ان تأتي الى هذا التبويب لمعرفة ارقام الالوان ، هنا الارقام R=احمر=0 ،  G=اخضر=51 ، B=ازرق=102 

.
 
2. اما في الكود ، فنعمل نسخ من المربع الاحمر (جميع الاسطر الاربعة) الى الشرط الجديد (الحشو) ، مع تغيير اللون RGB ليطابق اللون الذي تم اختياره اعلاه :

.
جعفر
1303.1.YOUSSEF_2020 OK.accdb.zip