jjafferr

تم الاجابة على السؤال هنا:
 
جعفر

وعليكم السلام
 
بما انك عملت البحث ليعطي نتائجه بعد ادخال المعلومة (على حدث عند التغيير On Change) وبدون وجود زر خاص ، لهذا السبب لن نعرف متى انتهيت من البحث
لذلك ، وضعت لك الكود في حدث "عندما يفقد الحقل التركيز On Lost Focus" (وتستطيع وضعه على حدث عند الخروج من الحقل On Exit) ، 
يعني بعد ان تنتهي من البحث ، اضغط على Enter او Tab ، وستذهب الى الحقل الذي تريد ،
وبما ان الحقل الذي تريد نقل التركيز اليه موجود في نموذج فرعي ، لذا يتوجب اولا نقل التركيز الى النموذج الفرعي ثم نقل التركيز الى الحقل:
Private Sub n1_LostFocus() Me.تابع132.SetFocus Me.تابع132!rgmhsab.SetFocus End Sub  
جعفر
726.نقل موشر الماوس بعد التحديث.accdb.zip

تفضل ، المرفق بطريقة اخي رمهان
 
جعفر
724.1.55.accdb.zip

وعليكم السلام
 
انا لم اتدخّل في البرنامج/الكود ، ولا في تقريب الارقام ، إلا في التالي:

.
وهذا هو الكود
Private Sub أمر8_Click() Dim strSQL As String Dim Add_it As Double strSQL = "DELETE G2.[رقم القسط], G2.رقم, G2.التاريخ, G2.المبلغ, G2.[المبلغ كتابه] FROM G2 WHERE (((G2.رقم)=[FORMS]![f1]![رقم]));" DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings False Me.Requery DoCmd.GoToRecord , , acFirst For i = 0 To Forms![f1]![qastno] - 1 Me.رقم = Forms![f1]![رقم] Me.التاريخ = DateAdd("m", i, Forms![f1]![Date]) Me.المبلغ = Round(Forms![f1]![المبلغ] / Forms![f1]![qastno], 2) Add_it = Add_it + Nz(Me.المبلغ, 0) Me.المبلغ_كتابه = NoToTxt(Me.المبلغ, "ريال سعودي", "سنتيم") DoCmd.GoToRecord , , acNext Next 'Debug.Print Forms![f1]![المبلغ] & " >> " & Add_it If Add_it <> Forms![f1]![المبلغ] Then DoCmd.GoToRecord , , acNewRec Me.رقم = Forms![f1]![رقم] Me.التاريخ = DateAdd("m", i, Forms![f1]![Date]) Me.المبلغ = Forms![f1]![المبلغ] - Add_it Me.المبلغ_كتابه = NoToTxt(Me.المبلغ, "ريال سعودي", "سنتيم") End If DoCmd.Requery End Sub .
جعفر

وعليكم السلام
 
تفضل

.
وهذا هو الكود
Private Sub cmd_Next_Page_Click() On Error Resume Next Me.TabCtl0.Value = Me.TabCtl0.Value + 1 End Sub Private Sub cmd_Previous_Page_Click() On Error Resume Next Me.TabCtl0.Value = Me.TabCtl0.Value - 1 End Sub Private Sub cmd_lock_bbb_Click() Me.TabCtl0.Pages("bbb").Enabled = False End Sub Private Sub cmd_unlock_bbb_Click() Me.TabCtl0.Pages("bbb").Enabled = True End Sub  
جعفر
716.Tapages.accdb.zip

وعليكم السلام
 
جرب هذا الكود
Function Add_Sum() Me.sumation = Nz(Me.arab, 0) + Nz(Me.forgen, 0) End Function Private Sub arab_AfterUpdate() Call Add_Sum End Sub Private Sub forgen_AfterUpdate() Call Add_Sum End Sub Private Sub year_AfterUpdate() Me.id = Nz(DMax("[id]", "id", "[Glose]=" & [Forms]![main]![Glose]), 0) + 1 End Sub  
جعفر

1. هذا الكود لا يتعلق بحقل او جدول ، وانما بالعمليات الحسابية في هذه الوحدة Sub ،
لذلك كل وحدة Sub يجب ان يكون عندها اسم آخر لإصطياد رسائل الخطأ ، يعني ما تقدر تستخدم err_cmd_click لجميع Subs اللي عندك ،
2. انت كمبرمج يجب ان تبرمج على الحقل الصحيح ، مثلا (وهذا المثال لا علاقة له برسالة الخطأ ، وانما له علاقة بسؤالك) :
عندك حقلين: Date_From و Date_To وتريد ان تستخدمهم لتقرير ،
ومن المعروف بانه اذا احد الحقلين فاضي فقد تحصل على رسالة خطأ من الاستعلام (وطبعا ستحصل على نتيجة خطأ من الاستعلام) ،
لذلك ، يجب عليك التأكد ان هذه الحقول غير فارغة ، لذلك
وعلى حدث النقر على زر فتح/معاينة التقرير ، اكتب هذا الكود:
if len(me.Date_From & "")=0 then msgbox "رجاء ادخال قيمة في حقل: تاريخ_من" me.Date_From.setfocus exit sub elseif len(me.Date_To & "")=0 then msgbox "رجاء ادخال قيمة في حقل: تاريخ_الى" me.Date_To.setfocus exit sub endif  
جعفر

وعليكم السلام
 
تقدر تستخدم هذا الكود:
Private Sub Command1_Click() TerminateProcess ("calc.exe") End Sub Private Sub TerminateProcess(app_exe As String) Dim Process As Object For Each Process In GetObject("winmgmts:").ExecQuery("Select Name from Win32_Process Where Name = '" & app_exe & "'") Process.Terminate Next End Sub  
واذا ما فادك ، استعمل الكود من هنا:
http://www.vbforums.com/showthread.php?318582-Terminating-Running-EXE&p=1878673#post1878673
 
جعفر

وعليكم السلام
 
اعمل التغيير التالي على استعلامك 

.
بدل Current_User اكتب اسم حقل المستخدم اللي في النموذج ،
وفي حدث "تحميل" النموذج اكتب : me.requery
 
جعفر

تفضل
 
1. نفكك السنة والشهر واليوم (هذا بسبب وجود صفر في اليوم/الشهر ، والذي سنحوله الى 1)

.
2. والنتيجة:

.
3. الآن نضع المعادلات اعلاه في الامر DateSerial لتحويلها لصيغة تاريخ ، في استعلام تحديث:

.
4. والنتيجة المطلوبة:

.
جعفر
.
706.نموذج بيروت بيانات.accdb.zip

في عدة طرق ، 
بس الاسهل ، مع الحدث بعد تحديث n1 ، مع الضغط على زر البحث:
Private Sub أمر176_Click() Me.n1 = Me.n1 - 1 Call n1_AfterUpdate Call أمر20_Click End Sub Private Sub أمر183_Click() Me.n1 = Me.n1 + 1 Call n1_AfterUpdate Call أمر20_Click End Sub  
جعفر

وعليكم السلام
 
انا عملت حسب طلبك ، ولكن الظاهر كان في اشياء اخرى انت لم تخبرنا عنها ، وانا لم انتبه لها
1. احذف زر الحفظ ، لأن النموذج الرئيسي يأخذ بياناته من الجدول ،
2. استعمل الكود التالي بدلا عن السابق
Dim rst As DAO.Recordset Set rst = Me.Parent.RecordsetClone rst.FindFirst "[التسلسل]=" & Me.التسلسل Me.Parent.Bookmark = rst.Bookmark 'او Me.Parent.RecordsetClone.FindFirst "[التسلسل]=" & Me.التسلسل Me.Parent.Bookmark = Me.Parent.RecordsetClone.Bookmark 3. التعديل يتم حفظه مباشرة في الجدول ، وبدون زر الحفظ
 
جعفر

انا اعتذر منك ، لم اجرب الكود قبل ان اضعه لك
 
واليك التغيير ، بعد التجربة:
Dim rst As DAO.Recordset Dim C 'As Integer Set rst = CurrentDb.OpenRecordset("Select * From qry_workscope_utility") rst.MoveLast: rst.MoveFirst rst.MoveNext C = rst!VisitNo rst.MovePrevious rst.Edit If C <> "NA" Then rst!VisitNo = C + 1 End If rst.Update rst.Close: Set rst = Nothing Me.frm_WORKSCOPE.Requery  
جعفر

وعليكم السلام اخي سلمان
 
تفضل
Private Sub cmd_ReSeq_Click() Dim rst As DAO.Recordset Set rst = CurrentDb.OpenRecordset("Select * From TB_1 Where isNull(m_RegMin1)=False Order By No_Common") rst.MoveLast: rst.MoveFirst RC = rst.RecordCount 'set all id2 to zero DoCmd.SetWarnings False DoCmd.RunSQL ("UPDATE TB_1 SET Id2 = 0") DoCmd.SetWarnings True For i = 1 To RC rst.Edit rst!id2 = i rst.Update rst.MoveNext Next i rst.Close: Set rst = Nothing MsgBox "Done" End Sub  
جعفر
695.sa.accdb.zip

وعليكم السلام اخوي ابو عبدالله
 
ايش رايك بهذه الطريقة ، اختيار اعضاء الفريق ، هو الذي يقرر التشكيل ،
والكود يذكرك بالاعضاء المختارين ، كلما تختار الفريق:

 
وهذا هو الكود:
Private Sub List0_AfterUpdate() On Error GoTo err_List0_AfterUpdate List2.RowSource = "" List2.RowSource = "Select TypID,MemprName From MemprsTbl Where TypID=" & Me.List0.Column(0) 'everytime we click in List0, we look in Text4 items, 'every item in Text4, we select it in List2 'now show the items selected before, and exist Text4 now Dim x() As String 'split each line of Text4 based on vbCrLf x = Split(Nz(Me.Text4, ""), vbCrLf) 'loop through all the lines For i = LBound(x) To UBound(x) For j = 0 To List2.ListCount - 1 'now loop through List2 strSelected = Me.List2.Column(1, j) & ";" & Me.List2.Column(0, j) If x(i) = strSelected Then 'select List2 item if it is the same as Text4 Me.List2.Selected(j) = True End If Next j Next i Exit Sub err_List0_AfterUpdate: If Err.Number = 94 Or Err.Number = 9 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub Private Sub List2_Click() On Error GoTo err_List2_Click 'everytime we click in List2, we look in Text4 items, 'if there are Selected in List2, we leave it in Text4, 'if there are Not Selected in List2, we remove them from Text4 'loop through List2 items For i = 0 To List2.ListCount - 1 strSelected = Me.List2.Column(1, i) & ";" & Me.List2.Column(0, i) If Me.List2.Selected(i) Then 'is List2 item selected, add it to Text4 'but is it there already If InStr(Nz(Me.Text4, ""), strSelected) = 0 Then Me.Text4 = Me.Text4 & strSelected & vbCrLf End If Else 'Remove from Text4 Me.Text4 = Replace(Me.Text4, strSelected & vbCrLf, "") End If Next i Exit Sub err_List2_Click: If Err.Number = 94 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub  
جعفر
693.TestList2.mdb.zip

وعليكم السلام اختي
 
تفضلي:
 

.

.
جعفر

تفضل
 
ضع بياناتك التي في ملف الاكسل في الجدول: M1_BKAWEST_Original
ثم افتح النموذج Form1 ، وانقر على الزر Fix imported Excel
وسترى النتيجة في الجدول: M1_BKAWEST
 
وهذا هو الكود الذي يقوم بالعمل:
Private Sub cmd_Fix_Click() On Error GoTo err_cmd_Fix_Click Dim rstS As DAO.Recordset Dim rstD As DAO.Recordset Set rstS = CurrentDb.OpenRecordset("Select * From M1_BKAWEST_Original") Set rstD = CurrentDb.OpenRecordset("Select * From M1_BKAWEST") rstS.MoveLast: rstS.MoveFirst RCs = rstS.RecordCount For i = 1 To RCs If rstS!Field1 = "محافظة" Then rstS.MoveNext Field8 = rstS!Field1 Field9 = rstS!Field2 Field10 = rstS!Field3 Field11 = rstS!Field4 Field12 = rstS!Field5 rstS.MoveNext rstS.MoveNext End If rstD.AddNew rstD![الشهرة] = Replace(rstS!Field1, Chr(34), "") rstD![الاسم] = Replace(rstS!Field2, Chr(34), "") rstD![اسم الاب] = Replace(rstS!Field3, Chr(34), "") rstD![اسم الام] = Replace(rstS!Field4, Chr(34), "") rstD![تاريخ الولادة] = Replace(rstS!Field5, Chr(34), "") rstD![رقم السجل] = Replace(rstS!Field6, Chr(34), "") rstD![المذهب] = Replace(rstS!Field7, Chr(34), "") rstD![محافظة] = Replace(Field8, Chr(34), "") rstD![قضاء] = Replace(Field9, Chr(34), "") rstD![البلدة او الحي] = Replace(Field10, Chr(34), "") rstD![طائفة اللائحة] = Replace(Field11, Chr(34), "") rstD![الجنس] = Replace(Field12, Chr(34), "") rstD.Update rstS.MoveNext Next i Exit_cmd_Fix_Click: rstS.Close: Set rstS = Nothing rstD.Close: Set rstD = Nothing MsgBox "Done" Exit Sub err_cmd_Fix_Click: If Err.Number = 3021 Then Resume Exit_cmd_Fix_Click ElseIf Err.Number = 94 Then Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub  
جعفر
691.tarek.accdb.zip

وعليكم السلام
 
في اكثر من طريقة ، ولكن اليك الاسهل:
expression.TransferSpreadsheet(TransferType, SpreadsheetType, Table/ Query Name, FileName, HasFieldNames, Range, UseOA) واستعمالها DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "Employees", "C:\Temp\Newemps.xls", True او expression.OutputTo(ObjectType, Table/ Query Name, OutputFormat, OutputFile, AutoStart, TemplateFile, Encoding, OutputQuality) واستعمالها DoCmd.OutputTo acOutputTable, "Employees", acFormatXLS, "C:\Temp\Newemps.xls", True او
 
جعفر

السلام عليكم
 
شكرا أخوي ابو خليل ، فانت شجعتني ان اقوم بأخذ البيانات من النموذج الفرعي ، بدل زيارة الجدول ، وهذه ستكون اسرع الطرق
عملت زر جديد ، ووضعت عليه هذا الكود:
Private Sub cmd_Search2_Click() On Error GoTo error_Capture2 تابع15.Requery Dim rst As DAO.Recordset Dim rst2 As DAO.Recordset Set rst = Me.تابع15.Form.RecordsetClone 'إيرادات rst.Filter = "[نوع السند]='إيرادات'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Erad_From = rst2![رقم السند] rst2.MoveLast Me.Erad_To = rst2![رقم السند] 'اجل rst.Filter = "[نوع السند]='اجل'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Aajel_From = rst2![رقم السند] rst2.MoveLast Me.Aajel_To = rst2![رقم السند] 'مصاريف rst.Filter = "[نوع السند]='مصاريف'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Masareef_From = rst2![رقم السند] rst2.MoveLast Me.Masareef_To = rst2![رقم السند] 'سداد rst.Filter = "[نوع السند]='سداد'" rst.Sort = "[رقم السند]" Set rst2 = rst.OpenRecordset Me.Sadad_From = rst2![رقم السند] rst2.MoveLast Me.Sadad_To = rst2![رقم السند] Exit_error_Capture2: rst.close: Set rst = Nothing rst2.close: Set rst2 = Nothing Exit Sub error_Capture2: If Err.Number = 3021 Then MsgBox "لا توجد بيانات" Resume Exit_error_Capture2 Else Debug.Print Err.Number MsgBox Err.Number & vbCrLf & Err.Description End If End Sub  
جعفر
688.1.لازام نطوره - Copy.mdb.zip

وعليكم السلام
 
في الجدول ، اذهب الى الحقول التي لا تريدها ان تكون فاضية ، واجعلها:

.
جعفر

وعليكم السلام
 
تفضل
=DCount("*","المراجعين","[اسماء الموظفين]='سالم'")  
المعادلة لا تبدو بالطريقة الصحيحة ، لأنها تحتوي على حقول عربية ، ولكن اعمل نسخ للكود اعلاه ، ولصق في الحقل (بدل المعادلة التي عندك)
 
جعفر
681.دالة تظهر عدد النص.accdb.zip

وعليكم السلام
 
وبدون انزال المرفق ، واعتمادا على شرحك ،
البيانات في النموذج ليست محفوظة في الجدول بعد ، لذا يجب حفظها قبل ان تفتح التقرير ، واختار احد هذه الطرق لحفظ البيانات:
سيتم حفظ البيانات بغض النظر اذا تم تعديل عليها او لا docmd.runcommand accmdsaverecord او يحفظ البيانات فقط اذا تم عمل تغيير عليها if me.dirty=true then me.dirty=false او سيتم حفظ البيانات بغض النظر اذا تم تعديل عليها او لا Refresh  
جعفر

تفضل برنامجي
 
واضفت سطر في الكود لكي يتأكد من عدم وجود رقم تسلسلي في حقل النموذج
 
جعفر
679.ترقيم جديد كل سنة جديدة وبجداول جديدة.accdb.zip

وعليكم السلام
 
في احد برامجي اضطررت ان اقوم بشيء شبيه لما تريد عمله ، ولكن ليس بتمرير الفأرة ، وانما بالنقر على زر في السجلات ، والكود المرفق هو لذلك الزر ،
الزر في النموذج الفرعي frm_Beads ،
واسم النموذج الرئيسي frm_M_Beads ،
ونموذج الصورة اسمه frm_Show_Image ،
 
Private Sub cmd_frm_Show_Image_Click() DoCmd.OpenForm "frm_Show_Image" 'get the BE path BE_Path = application.currentproject.path Image_Name = Format(Forms!frm_M_Beads!frm_Beads!Auto_Date, "yyyy_mm_dd-hh_nn_ss") Forms!frm_Show_Image!Scan.Picture = BE_Path & "\Images\Items\" & Image_Name & ".jpg" Exit Sub err_cmd_frm_Show_Image_Click: If Err.Number = 2465 Or Err.Number = 2450 Then 'Form Not open Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description End If End Sub  
جعفر

تفضل
 

.
جعفر