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

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

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

هذا الموضوع يفيدك جدا ...

رائع اشكرك جزاك الله خيرا وافر التحية لشخصك زادكم الله علما ونفعكم بما تعلم ونفع بكم

بإذن الله يكون هذا هو المطلوب يمكنك استعمال هذه المعادلة في الخلية J3 =MAXIFS('m cost'!$D$3:$D$10,'m cost'!$A$3:$A$10,B3,'m cost'!$B$3:$B$10,"<="&S3,'m cost'!$C$3:$C$10,"<="&R3) بالتوفيق

تفضل استخدم هذه المعادلة بكل بساطة DateDiff("h";CDate([الانصراف]);CDate([بدايه الانصراف])) New Microsoft Access Database22222.zip

تفضل هذا التعديل ***** لكن قبل البدء يجب ان يكون اسم المفتاح الاساسي هو "ID" قي كل جدول Sub indexDelet() Public Function ReNumber() Dim db As DAO.Database Dim rs As DAO.Recordset Dim tdf As DAO.TableDef Dim idx As ADOX.Index Dim x As Integer Dim sSQL As String, S As String Set db = CurrentDb For Each tdf In db.TableDefs If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then sSQL = "ALTER TABLE [" & tdf.Name & "] ALTER COLUMN [id] LONG" db.Execute sSQL Set rs = CurrentDb.OpenRecordset(tdf.Name) If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) x = x + 1 rs.Edit rs.Fields("id") = x rs.Update rs.MoveNext Wend End If rs.Close Set rs = Nothing End If x = 0 Next MsgBox "تم اعادة الترقيم بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" End Function و في ازرار اعادة الترقيم ضع التالي Call ReNumber

بعد اذن استاذى العزيز ومعلمى القدير الاستاذ @kanory شوف يا دكتور @الحلبي علشـــــــان انا بس بحــــــــبك الاستاذ القدير كنورى حول استعلام التحديث فى المرفق بتاعى بس لكود سيكوال علشان تقدر تستخدمه فى كل النماذج من محرر الاكواد -- طيب ليه حصل مشكلة معاك لان اكيد مربح الاحتيار مش موجود فى النموذج شوف اول مرفق لى للنموذج فى وضع التصميم تجد مربع اختيار مخفى --------- طيب حابب تحول استعلام التحديث لكود داخل روتين عام يستخدم مع اى جدول حتى لو غيرت اسم الجدول او حتى غيرت اسماء الحقول فى الجدول ومع اى نموذج وتنادى عليه لتستخدمه فى زوايا التطبيق اتفضل يا دكتور اعمل موديول وقم بوضع الاسطر الاتية Public Function GoOnUpdatChkBox(ByVal strTableName As String, ByVal strFieldNameUbdt As String, ByVal strFieldNameWher As String, ByVal strXuser As String, ByVal strUpdatChkBox As String) CurrentDb.Execute "UPDATE [" & strTableName & "] SET [" & strTableName & "].[" & strFieldNameUbdt & "] = '" & strUpdatChkBox & "' WHERE [" & strFieldNameWher & "] = '" & strXuser & "' ;" strTableName = vbNullString strFieldNameUbdt = vbNullString strFieldNameWher = vbNullString strXuser = vbNullString strUpdatChkBox = vbNullString End Function وفى النموذج ضع الكود الاتى على زر الامر تفعيل Call GoOnUpdatChkBox("t2", "yesno", "xuser", Me.xuser, -1) Me.t2_subform.Requery ولزر الامر الغاء التفعيل بس غير فى الكود السابق قيمة -1 الى 0 اى خدمه يا دكتور والطريقة دى من وجهة نظرى افضل من طريقة اللوب ------------------------------- طيب مش حاب الكود فى الموديول يكون روتين عام وحابب تستخدمة بطريقة مباشرة باسم الجدول والحقول كما هى استخدم الكود الاتى فى الموديول بدلا من السابق Public Function GoOnUpdatChkBox(ByVal strXuser As String, ByVal strUpdatChkBox As String) CurrentDb.Execute "UPDATE t2 SET t2.yesno = '" & strUpdatChkBox & "' WHERE (xuser = '" & strXuser & "');" strXuser = vbNullString strUpdatChkBox = vbNullString End Function وفى النموذج ضع الكود الاتى على زر الامر تفعيل Call GoOnUpdatChkBox(Me.xuser, -1) Me.t2_subform.Requery ولزر الامر الغاء التفعيل بس غير فى الكود السابق قيمة -1 الى 0 المرفق الى يوضح الافكار بالطرق الثلاث خانة الاختيار - 5.accdb

بارك الله فيكم جميعاً الطريقة الاولي للمهندس علي مشيت معاي تمام الف شكر استاذ محمد صالح

طيب ... ركز معي اخي الكريم هذا المرفق يعمل كالتالي :::: عند فتح نموذج التسليم .... اذا كانت الجمعية جديد يقوم البرنامج تلقائيا بتهيئة البيانات المطلوب وذلك بعد ظهور الرسالة التى تؤكد بدايتها اما اذا كان البرنامج به جمعية سابقة لم تنتهي فيعمل مباشرة دون اي رسائل واذا كان البرنامج به جمعية سابقة ولكن دورتها منتهية أي تم تسليم الجميع مستحقاتهم ... يقوم البرنامج تلقائيا بتجديد دورة اخر جديدة ======================================== ملاحظة هامة الاشخاص الذين تم استلامهم لاشهر سابقة لن تظهر اسمائهم في نموذج التسليم مرة اخرى ... حتى تستكمل الدورة للجميع ... ثم تعاد اسمائهم في الدورة الجديدة ======================================== امور فنية : الجدول المسمى distribution هو جدول لترحيل بيانات التسليم مع كل ضغطت زر للتسليم الجدول المسمى Kan_distribution هو جدول لوضع علامة امام كل مستلم حتى لايظهر اسمه قبل نهاية الدورة ..... ومع الدورة الجديد تزال تلك العلامات ========================================= انظر الصور .... مع تجربة المرفق .... وأعلمنا بالنتيجة الجمعية.accdb

السلام عليكم. أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة. كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة . لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة . الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم ملف للتحميل تعريف الحدث هو كالتالي: Public Sub OnMouseWheelScroll( _ ByVal UserForm As Object, _ ByVal obj As Object, _ ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _ ByVal X As Long, _ ByVal Y As Long, _ ByRef Cancel As Boolean _ ) على كل- الكود بأكمله على النحو التالي: 1 - كود في موديول عادي : Option Explicit Public Enum CTRL_KEY_PRESS_STATE Released Pressed End Enum Public Enum WHEEL_ROTATION Forward Backward End Enum Private Type POINTAPI X As Long Y As Long End Type Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type #If Win64 Then Private Type MSG hwnd As LongLong message As Long wParam As LongLong lParam As LongLong time As Long pt As POINTAPI End Type #Else Private Type MSG hwnd As Long message As Long wParam As Long lParam As Long time As Long pt As POINTAPI End Type #End If #If VBA7 Then #If Win64 Then Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long #Else Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long #End If Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr) Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private hwnd As LongPtr, hObjUnderMouse As LongPtr, lPtr As LongPtr #Else Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer Private hwnd As Long, hObjUnderMouse As Long #End If Private oCurrentUserForm As Object, oCurrentIgnoreList As Variant Private oCollection As Collection Private objUnderMouse As Object Private WheelRotation As WHEEL_ROTATION Private CtrlKey As CTRL_KEY_PRESS_STATE Private tMsg As MSG Private tCurPos As POINTAPI, tPt As POINTAPI, tWinRect As RECT, tClient As RECT Private oIA As IAccessible, oIACtrl As IAccessible, oIAPage As IAccessible Private oTempCtrl As Control, oCtrl As Control, oTempPage As Control Private vKid As Variant Private lLeft As Long, lTop As Long, lAccResult As Long, lPtInRectlResult As Long, i As Long Private bCancel As Boolean Public Property Let EnableWheelScroll(ByVal UserForm As Object, Optional IgnoreList As Variant, ByVal Enable As Boolean) Call KillTimer(hwnd, 0) If Enable = False Then Set oCollection = Nothing Else Set oCurrentUserForm = UserForm oCurrentIgnoreList = IgnoreList Call IUnknown_GetWindow(UserForm, VarPtr(hwnd)) Set oCollection = New Collection Call SetTimer(hwnd, 0, 0, AddressOf TimerProc) End If End Property '________________________________PRIVATE SUBS___________________________________ Private Sub TimerProc() Const SCROLL_CHANGE = 20 ' <== Change Const as required '// '///////////////////////////////////////////////////////////// Const CHILDID_SELF = &H0& Const S_OK As Long = &H0 Const WM_NCLBUTTONDOWN = &HA1 Const WM_TIMER = &H113 Const WM_MOUSEWHEEL = &H20A Const WHEEL_DELTA = 120 Const PM_REMOVE = &H1 Const MK_CONTROL = &H8 Const GA_ROOT = 2 Const POINTSPERINCH As Long = 72 Const LOGPIXELSX As Long = 88 Const LOGPIXELSY As Long = 90 On Error Resume Next 'RETRIEVE AND STORE THE LOCATION OF EACH CONTROL. For Each oIACtrl In oCurrentUserForm.Controls Set oTempCtrl = oIACtrl If IsError(Application.Match(TypeName(oTempCtrl), oCurrentIgnoreList, 0)) Then Call oIACtrl.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) If TypeName(oTempCtrl) = "MultiPage" Then Set oIAPage = oTempCtrl.Pages(oTempCtrl.Value) Call oIAPage.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) Set oTempPage = oIAPage oCollection.Add oTempPage, CStr(lLeft & lTop & oTempCtrl.Name & oTempCtrl.Pages(oTempCtrl.Value).Caption) End If oCollection.Add oTempCtrl, CStr(lLeft & lTop) End If Next 'RETRIEVE ELEMENTS UNDER THE MOUSE POINTER. Call GetCursorPos(tCurPos) Call GetWindowRect(hwnd, tWinRect) #If Win64 Then Call CopyMemory(lPtr, tCurPos, LenB(tCurPos)) lAccResult = AccessibleObjectFromPoint(lPtr, oIA, vKid) hObjUnderMouse = WindowFromPoint(lPtr) lPtInRectlResult = PtInRect(tWinRect, lPtr) #Else lAccResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid) hObjUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y) lPtInRectlResult = PtInRect(tWinRect, tCursPos.X, tCursPos.Y) #End If 'EXIT TIMER PROC IF MOUSE OUTSIDE FORM RECT. If lPtInRectlResult = 0 Then Call KillTimer(hwnd, 0) GoTo Xit End If If lAccResult = S_OK Then Call oIA.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF) Set objUnderMouse = oCollection.Item(lLeft & lTop) If GetAncestor(hObjUnderMouse, GA_ROOT) <> hwnd Then If TypeName(objUnderMouse) <> "ComboBox" Then Exit Sub End If End If For Each oCtrl In oCurrentUserForm.Controls If TypeName(oCtrl) = "MultiPage" Then Set objUnderMouse = oCollection.Item(lLeft & lTop & oCtrl.Name & oCtrl.Pages(oCtrl.Value).Caption) End If Next If oIA.accName(CHILDID_SELF) = oCurrentUserForm.Caption Then Set objUnderMouse = oCurrentUserForm End If 'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS. If Not objUnderMouse Is Nothing Then Call GetMessage(tMsg, 0, 0, 0) 'EXIT TIMER PROC WHEN MOVING THE FORM. If tMsg.message = WM_NCLBUTTONDOWN Then Call KillTimer(hwnd, 0) Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) GoTo Xit End If tPt = tMsg.pt Call GetClientRect(hwnd, tClient) Call ScreenToClient(hwnd, tPt) If GetAsyncKeyState(vbKeyLButton) = 0 And tPt.Y <= 0 Then Call KillTimer(hwnd, 0) GoTo Xit End If 'EXIT TIMER PROC WHEN MOVING THE FORM. If tPt.Y <= 0 Then If tMsg.message = WM_TIMER Then Call KillTimer(hwnd, 0) Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) GoTo Xit End If End If If tMsg.message = WM_MOUSEWHEEL Then CtrlKey = IIf(loword(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released) If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then WheelRotation = Forward Else WheelRotation = Backward End If 'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE oCurrentUserForm MODULE. Call oCurrentUserForm.OnMouseWheelScroll(oCurrentUserForm, objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel) 'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING. If Not bCancel Then If TypeName(objUnderMouse) = "TextBox" Then With objUnderMouse .SetFocus If i = 0 Then .SelStart = 0 Else .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart) End If If WheelRotation = Forward Then .CurLine = .CurLine - 1 Else .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1) End If End With i = i + 1 End If If TypeName(objUnderMouse) = "ScrollBar" Then With objUnderMouse If WheelRotation = Forward Then .Value = IIf(.Value - objUnderMouse.SmallChange > .Min, .Value - objUnderMouse.SmallChange, .Min) Else .Value = IIf(.Value + objUnderMouse.SmallChange < .Max, .Value + objUnderMouse.SmallChange, .Max) End If End With End If If TypeName(objUnderMouse) = "ListBox" Or TypeName(objUnderMouse) = "ComboBox" Then With objUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .TopIndex = .TopIndex - 1 Else .TopIndex = .TopIndex + 1 End If Else .SetFocus If WheelRotation = Forward Then SendKeys "{LEFT}", True DoEvents SendKeys "{RIGHT}", True Else SendKeys "{RIGHT}", True DoEvents SendKeys "{RIGHT}", True End If End If End With End If If TypeName(objUnderMouse) <> "ComboBox" Then Call EnumWindows(AddressOf HideDropDown, ByVal 0) End If With objUnderMouse If CtrlKey = Released Then If WheelRotation = Forward Then .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE) Else .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE) End If Else If WheelRotation = Forward Then .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE) Else .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE) End If End If End With End If End If End If End If Call TranslateMessage(tMsg) Call DispatchMessage(tMsg) Exit Sub Xit: Call SetTimer(hwnd, 0, 0, AddressOf TimerProc) End Sub Private Function loword(DWord As Long) As Integer If DWord And &H8000& Then loword = DWord Or &HFFFF0000 Else loword = DWord And &HFFFF& End If End Function Private Function hiword(ByVal DWord As Long) As Integer hiword = (DWord And &HFFFF0000) \ &H10000 End Function #If Win64 Then Private Function HideDropDown(ByVal hwnd As LongLong, ByVal lParam As Long) As Long #Else Private Function HideDropDown(ByVal hwnd As Long, ByVal lParam As Long) As Long #End If Dim sClassName As String * 256 Call GetClassName(hwnd, sClassName, 256) If Left(sClassName, 2) = "F3" Then Call ShowWindow(hwnd, 0) HideDropDown = 0 Exit Function End If HideDropDown = 1 End Function 2 - كود في اليوزرفورم موديول Option Explicit Private Sub UserForm_Initialize() Dim i As Long For i = 1 To 100 Me.ListBox1.AddItem i Me.ComboBox1.AddItem i Next i End Sub Private Sub UserForm_Activate() EnableWheelScroll(Me) = True End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) EnableWheelScroll(Me) = False With Sheet1 .[a9].ClearContents .[a12].ClearContents .[a15].ClearContents .[a18].ClearContents .[a21].ClearContents .[a24].ClearContents .[a27].ClearContents End With End Sub Private Sub CommandButton1_Click() UserForm2.Show vbModeless End Sub Private Sub CommandButton2_Click() Unload Me End Sub '-------------------- 'Public Generic event 'Set the Cancel Argument to TRUE to disable scrolling Public Sub OnMouseWheelScroll( _ ByVal UserForm As Object, _ ByVal obj As Object, _ ByVal WheelRotation As WHEEL_ROTATION, _ ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _ ByVal X As Long, _ ByVal Y As Long, _ ByRef Cancel As Boolean _ ) With Sheet1 If TypeName(obj) = "Page" Then .[a12] = obj.Parent.Name & "." & obj.Name Else .[a12] = obj.Name End If .[a9] = UserForm.Name .[a15] = IIf(WheelRotation = Forward, "Forward", "Backward") .[a18] = IIf(CtrlKey = Pressed, "Pressed", "Released") .[a21] = IIf(CtrlKey = Pressed, "Horizontal", "Vertical") .[a24] = X .[a27] = Y End With End Sub أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك. وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى

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

قبل البدأ في البرنامج ..... ابحث في المنتدى تجد العديد والعديد من مثل تلك البرامج ..... حتى تستطيع جمع افكارك .... ثم ابدأ بالفكرة .... وحال توقفك في نقطة ... ممكن تسأل عنها .

السلام عليكم ..تمام .. تسلم

عليكم السلام السطر الذي يقوم بالطباعة هو sh.Range("a1:q30").PrintOutt نقوم بتغييره إلى sh.Range("a1:q30").PrintOutt Copies:=2 بالتوفيق

لدي ملف فيه 2 شيت الاول فيه تكلفة شهرية للمنتج والمبيعات واريد في خانة التكلفة في شيت المبيعات جلب التكلفة المناسبة ( عندما يكون شهر البيع اكبر من او يساوي شهر التكلفة ) يعني في المثال في الملف شهر البيع في اغسطس وفي تغير في التكلفة في 7 يجيب تكلفة شهر 7 officena many vlookup.rar

company LTD.xlsx

تفضل جرب Nz(DSum("[Loan_Payment]", "[tbl_Loans]", "Format([Loan_AwardMonth],'yyyy') Like '*" & Me.txtYear & "*' And [Loan_Type] Like 'Cridi'"), 0)

استاذنا ملف المبيعات هيكون فيه مبيعات شهر يناير وفبراير ومارس ...... حتى اغسطس عايز مبيعات يناير تاخد تكلفة يناير ومبيعات فبراير ومارس حتى يوليو تأخذ تكلفة فبراير لانه لم يوجد تغيير حتى يوليو ولن بداية من اغسطس تأخذ تكلفة يوليو مش عارف هل ممكن عمل حاجة زي كده والا لازم اعملها يدوي زي كده officena many vlookup.rar

نفس الحال اخي الكريم الكود الموجود في المرفق عبارة عن تايمر فقط لا اكثر تستطيع اضافة ما تريده عند انتهاء الوقت لكن لا علاقة له بأساس الموضوع Static OldcontrolName As String Static OldFormName As String Static ExpiredTime As String Dim ActivecontrolName As String Dim ActiveFormName As String Dim ExpiredMinutes As String '<<<<< ابو نادر >>>>> On Error Resume Next ActivecontrolName = Screen.ActiveControl.Name ActiveFormName = Screen.ActiveForm.Name Me.txtActiveForm = ActiveFormName If (OldcontrolName = "") Or (OldFormName = "") _ Or (ActiveFormName <> OldFormName) _ Or (ActivecontrolName <> OldcontrolName) Then OldcontrolName = ActivecontrolName OldFormName = ActiveFormName ExpiredTime = 0 Else ExpiredTime = ExpiredTime + Me.TimerInterval End If 'ExpiredMinutes = (ExpiredTime \ 1000) \ 60 'للدقائق ExpiredMinutes = (ExpiredTime \ 1000) 'للثاوني Me.txtIdelTime = ExpiredMinutes If ExpiredMinutes >= 50 Then 'لتفيير الوقت ExpiredTime = 0 Application.quit acQuitSaveAll ' <<<<<<<<<<<<<<<<<<<<< هذا الأمر يقوم بإنهاء الأكسس بالكامل تستطيع استبداله >>>>>>>>>>>>>>>>>>>>>>>>>> 'Call AllForms 'DoCmd.OpenForm "frm-UserLogon" End If

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

بارك الله فيك وأكثر الله من أمثالك

هذا الموضوع تمت مدارسته أكثر من مرة في منتدانا الرائع لمن يريد التعلم بفضل الله إن شاء اللّه تفيدك هذه النتائج https://www.officena.net/ib/search/?q="كشف حساب عميل"&type=forums_topic&nodes=135&updated_after=any&sortby=relevancy&search_and_or=and عليك أن تبدأ بتعلمها ووضع الأكواد أو المعادلات المطلوبة وإذا تعثرت في نقطة أو اثنتين يمكن عرضها في موضوع جديد بالتوفيق

تسلم ايدك كلك ذووق

كود الترحيل ليس به أخطاء الأخطاء في تنظيم الملف والكتابة فيه أكثر من مرة مع عدم الحذف ++ وأول الأخطاء الموجودة هو عدم وجود بيانات في الصف الثاني إلا في الأعمدة F & G & H وكود LR الذي يحمل الصف الأخير مضافا عليه 1 لن يكون مضبوطا لأن الصف الثاني هو المقصود رغم انه به بيانات * وحل هذه المشكلة هو وضع العناوين في الصف الثاني أو كتابة أي شيء في الصف الثاني مثل ======== بحيث يكون أول صف بعد المكتوب فيه هو 3 ++ ثاني مشكلة يوجد كتابة في وسط الشيت تمنع من وصول المتغير lr لمكانه الصحيح * والحل هو الوقوف في الخلية A2 ثم ضغط ctrl وسهم لأسفل سيقف المؤشر عند خلية معينة يتم تحديد صف هذه. الخلية وكل الصفوف التي بعده إلى ما بعد الكتابة ثم حذف هذه الصفوف وليس حذف المحتويات (كلك يمين على رقم الصف ثم حذف) الصواب بعد الضغط على ctrl وسهم لأسفل أن يصل المؤشر إلى آخر خلية في الشيت A1048576 ++ وثالث مشكلة هي اعتمادك على العمود A في تحديد الصف الأخير في شيت الصف الرابع والذي يكون غير دقيق بسبب وجود معادلات في هذا العمود تجعل آخر صف هو 534 في حين أن الصواب 219 * والحل هو أن تعتمد على العمود B في جلب الصف الأخير lr = sh1.Cells(Rows.Count, 2).End(xlUp).Row ++ رابع مشكلة هي أنك تريد ترحيل عمود الفصل إلى العمود 14 ولكن استعملت في الكود العمود 13 مما يجعله يرحل الفصل إلى عمود التوزيع * والحل تعديل سطر الترحيل إلى sh2.Cells(erow, 14) = sh1.Cells(i, 5) بعد حل هذه المشكلات يتم تطبيق كود الترحيل بطريقة سليمة ولمزيد من الاحترافية في تطبيق كود الترحيل ينبغي في بداية الكود تنظيف محتويات الشيت المرحل إليه أولا باستعمال كود مثل sh2.Range("a3:o1000").ClearContents بالتوفيق

بعد إذن صديقي العزيز @Ali Mohamed Ali هذه الحيلة لن تفيد مع دمج الرقم 100 مع 10 لأن الناتج سيكون 10010 عشرة آلاف وعشرة وليس 1010 لذا أقترح وضع هذه المعادلة في C1 =SUM(1000,A1) وفي هذه الحالة يمكن الاستغناء عن العمود B مرفق الملف بعد التعديل ليتناسب مع الأرقام بعد 9 بالتوفيق TEST.xlsx

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

استاذى الحبيب الغالى لقلبى د.كاف يار طبقت كل المكتوب بالضبط ولا يتم ارجاع الترقيم التلقائى بارك الله فيك وبك ولك اللهم امين احترامى ترقيم تلقائى كود.accdb

انشئ Module جديد و الصق فيه الشفرة التالية Public Function ReNumber() On Error Resume Next Dim db As DAO.Database Dim rs As DAO.Recordset Dim tdf As DAO.TableDef Dim x As Integer Dim sSQL As String Set db = CurrentDb For Each tdf In db.TableDefs If Not (tdf.Name Like "MSys*" Or tdf.Name Like "~*" Or tdf.Name Like "exl*") Then sSQL = "ALTER TABLE [" & tdf.Name & "] Add [ID_New] Number" db.Execute sSQL Set rs = CurrentDb.OpenRecordset(tdf.Name) If Not rs.BOF And Not rs.EOF Then rs.MoveFirst While (Not rs.EOF) x = x + 1 rs.Edit rs.Fields("ID_New") = x rs.Update rs.MoveNext Wend End If rs.Close Set rs = Nothing End If x = 0 Next MsgBox "تم اضافة ترقيم لجميع الجداول بنجاح", vbInformation + vbMsgBoxRight, "تأكيد" End Function و في النموذج ازرار اعادة ترقيم ضع الأمر التالي Call ReNumber

جرب هذي المحاولة الجمعية.accdb

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

انشئ Module جديد و الصق الشفرة التالية فيه Option Explicit Public Function StartTimer(NumberOfSeconds As Variant, ReportName As String) On Error Resume Next Dim PauseTime, Start, Finish, TotalTime PauseTime = NumberOfSeconds Start = Timer Do While Timer < Start + PauseTime DoEvents Loop Finish = Timer TotalTime = Finish - Start DoCmd.Close acReport, ReportName, acSaveYes End Function في ازرار فتح التقرير و بعد أمر فتح التقرير اعطي الأمر لتشغيل التايمر / المؤقت بعد اعطائه عدد الثواني و اسم التقرير StartTimer(«NumberOfSeconds»; «ReportName») مرفق التعديل tbl.accdb

الشكر لله خالص دعواتي بالتوفيق

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

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

يمكن ربط الوورد بملف اكسل على الجهاز ويمكن بملف في جوجل درايف إذا تم تثبيت برنامج جوجل درايف على الجهاز بالتوفيق

رائع أستاذ @Ali Mohamed Ali ولإثراء الموضوع يمكن جلب الجزء الأول بالمعادلة التالية المختصرة =LEFT(AD1,FIND("-",AD1)-1) بالتوفيق

خالص دعواتي بالتوفيق

وعليكم السلام-دائماً وأبداً لابد من تدعيم اى مشاركة بملف موضح فيه المطلوب بكل دقة...فيمكنك استخراج الرقم 2018 بالمعادلة التالية =LEFT(AD1,LEN(AD1)-FIND("-",AD1)) أما 2019 بالمعادلة التالية =RIGHT(AD1,LEN(AD1)-FIND("-",AD1))

جميعا بإذن الله هل معنى هذا أن الملف أصبح طبيعيا معك وتستطيع إضافة الماكرو وحذفه؟؟

نعم تعمل بصورة ممتازة فأنا حاليا استخدمه و لا اواجه اي مشكلة نهائيا

هل تعلم أنك يمكنك جعل ملف الوورد ينطق محتوياته بالإنجليزية؟؟ افتح الملف المرفق ووافق على تمكين الكود وستجد ما يسرك للأمانة الكود منقول مع بعض التصرف mas-word.rar

ذكريات جميلة من 2009 شكرا جزيلا لكل من دعم وشجع بالكلمة الطيبة ومشاركة المعلومة مع جميع الأصدقاء وتذكر دائما لو بخل بها غيرك ما وصلت إليك

للرفع حتى تعم الفائدة للجميع

حتى لا يتشعب الموضوع سنبقى في مجال نسخ الملفات والمجلدات داخل اكسس وسأعدل العنوان حتى يكون اشمل في الدلالة بالنسبة لنسخ الملفات من مكان لآخر فاكسس لديه اداة جاهزة وهي filecopy مثال : FileCopy "C:\filename", "C:\filename" اما نسخ المجلدات فالصق هذه في المكان المناسب حيث يمكنك جعلها في النموذج او في وحدة نمطية عامة ونقل حدث الزر الى النموذج Private Type SHFILEOPSTRUCT hwnd As Long wFunc As Long pFrom As String pTo As String fFlags As Integer fAnyOperationsAborted As Long hNameMappings As Long lpszProgressTitle As String ' only used if FOF_SIMPLEPROGRESS End Type Private Const FOF_MULTIDESTFILES = &H1 Private Const FOF_CONFIRMMOUSE = &H2 Private Const FOF_SILENT = &H4 Private Const FOF_RENAMEONCOLLISION = &H8 Private Const FOF_NOCONFIRMATION = &H10 Private Const FOF_WANTMAPPINGHANDLE = &H20 Private Const FOF_CREATEPROGRESSDLG = &H0 Private Const FOF_ALLOWUNDO = &H40 Private Const FOF_FILESONLY = &H80 Private Const FOF_SIMPLEPROGRESS = &H100 Private Const FOF_NOCONFIRMMKDIR = &H200 Private Const FO_MOVE = 1 Private Const FO_COPY = 2 Private Const FO_DELETE = 3 Private Const FO_RENAME = 4 Private Declare Function SHFileOperation Lib "shell32.dll" (lpFileOp As SHFILEOPSTRUCT) As Long Public Function CopyFolder(ByVal strSource As String, ByVal strDest As String) As Boolean '========================================================================================== Dim varFOS As SHFILEOPSTRUCT With varFOS .fFlags = FOF_NOCONFIRMATION Or FOF_SILENT Or FOF_NOCONFIRMMKDIR .wFunc = FO_COPY .pFrom = strSource .pTo = strDest End With Call SHFileOperation(varFOS) CopyFolder = (varFOS.fAnyOperationsAborted = 0) End Function Private Sub Command1_Click() CopyFolder "d:\foldeName", "d:\foldeName" End Sub

بالفعل أخي الفاضل محمد طاهر هذا الكود يعتمد على الناطق الموجود في الويندوز وأوافقك الرأي في أن له استخدامات كثيرة منها ما ذكرت حضرتك ( رسالة ترحيببية) ويمكن تطوير المثال بصور أخرى كعمل شريط أدوات به زر تشغيل وتوقف وإيقاف مؤقت *** أما بالنسبة لنطق النص العربي فهذا الموضوع شائك جدا ويجب كتابة النص العربي مشكلا تشكيلا تاما حتى يتم نطقه

كنت أفكر فيها فسبقتني لها أخي الكريم المايسترو فهنيئا لك اللهم تقبل منه وعافه واعف عنه وأسكنه فسيح جناتك يا رب العالمين

أعتقد أنه تم حل موضوع مشابه هنــــا

ياريت مزيد من التوضيح

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