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

السلام عليكم ورحمة الله وبركاته الحمد لله والشكر لله الأخوة الكرام / حفظكم الله أقدم لكم أكواد للتعامل مع الحافظة (Clipboard) للنواتين 32x و 64x 1- كود لنسخ ولصق النصوص 2- كود لنسخ ولصق الملفات بجميع أنوعها ------------------------------------------------------------------------------------------------------------------ 1- كود لنسخ ولصق النصوص قم بعمل MODULE جديد ثم أنسخ الكود إليه * المصدر {https://www.devhut.net/vba-save-string-to-clipboard-get-string-from-clipboard/} وستجدون في هذا الموقع العديد من الاكواد الاحترافية. Option Explicit #If VBA7 Then Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As LongPtr #Else Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long 'bug in Microsoft File! #End If Const CF_UNICODETEXT As Long = 13& #If VBA7 Then Public Sub SetClipboard(sUniText As String) Dim iStrPtr As LongPtr Dim iLen As LongPtr Dim iLock As LongPtr Dim iUnlock As LongPtr Const GMEM_MOVEABLE As Long = &H2 Const GMEM_ZEROINIT As Long = &H40 'Const CF_UNICODETEXT As Long = &HD iLen = LenB(sUniText) + 2& iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen) iLock = GlobalLock(iStrPtr) lstrcpy iLock, StrPtr(sUniText) GlobalUnlock iStrPtr OpenClipboard 0& EmptyClipboard SetClipboardData CF_UNICODETEXT, iStrPtr CloseClipboard End Sub Public Function GetClipboard() As String Dim iStrPtr As LongPtr Dim iLen As Long Dim iLock As LongPtr Dim sUniText As String 'Const CF_UNICODETEXT As Long = 13& OpenClipboard 0& If IsClipboardFormatAvailable(CF_UNICODETEXT) Then iStrPtr = GetClipboardData(CF_UNICODETEXT) If iStrPtr Then iLock = GlobalLock(iStrPtr) iLen = GlobalSize(iStrPtr) sUniText = String$(iLen \ 2& - 1&, vbNullChar) lstrcpy StrPtr(sUniText), iLock GlobalUnlock iStrPtr End If GetClipboard = sUniText End If CloseClipboard End Function #Else Public Sub SetClipboard(sUniText As String) Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long Const GMEM_MOVEABLE As Long = &H2 Const GMEM_ZEROINIT As Long = &H40 'Const CF_UNICODETEXT As Long = &HD iLen = LenB(sUniText) + 2& iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen) iLock = GlobalLock(iStrPtr) lstrcpy iLock, StrPtr(sUniText) GlobalUnlock iStrPtr OpenClipboard 0& EmptyClipboard SetClipboardData CF_UNICODETEXT, iStrPtr CloseClipboard End Sub Public Function GetClipboard() As String Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long Dim sUniText As String 'Const CF_UNICODETEXT As Long = 13& OpenClipboard 0& If IsClipboardFormatAvailable(CF_UNICODETEXT) Then iStrPtr = GetClipboardData(CF_UNICODETEXT) If iStrPtr Then iLock = GlobalLock(iStrPtr) iLen = GlobalSize(iStrPtr) sUniText = String$(iLen \ 2& - 1&, vbNullChar) lstrcpy StrPtr(sUniText), iLock GlobalUnlock iStrPtr End If GetClipboard = sUniText End If CloseClipboard End Function #End If مثال للاستخدام حتي تنسخ نص الي الحافظة Call SetClipboard(Me.txt_FirstName) حتي تستخدم النص الموجود بالحافظة Me.txt_FirstName = GetClipboard() 2- كود لنسخ ولصق الملفات بجميع أنوعها قم بعمل MODULE جديد ثم أنسخ الكود إليه وجدت كود يعمل علي 32X وقمت بتعديله "بفضل الله" ليدعم النواتين 32x و 64x * مصدر الكود يدعم 32x فقط {https://learn.microsoft.com/en-us/answers/questions/893207/copy-file-into-clipboard-for-excel-64bit} Option Explicit ' Required data structures Private Type POINTAPI x As Long y As Long End Type #If VBA7 Then ' Clipboard Manager Functions Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long ' Other required Win32 APIs Private Declare PtrSafe Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As LongPtr, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long Private Declare PtrSafe Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As LongPtr, lpPoint As POINTAPI) As Long Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr Private Declare PtrSafe Function GlobalFree Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) #Else ' Clipboard Manager Functions Private Declare Function EmptyClipboard Lib "user32" () As Long Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long Private Declare Function CloseClipboard Lib "user32" () As Long Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long ' Other required Win32 APIs Private Declare Function DragQueryFile Lib "shell32.dll" Alias "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, ByVal lpStr As String, ByVal ch As Long) As Long Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal hDrop As Long, lpPoint As POINTAPI) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) #End If ' Predefined Clipboard Formats Private Const CF_TEXT = 1 Private Const CF_BITMAP = 2 Private Const CF_METAFILEPICT = 3 Private Const CF_SYLK = 4 Private Const CF_DIF = 5 Private Const CF_TIFF = 6 Private Const CF_OEMTEXT = 7 Private Const CF_DIB = 8 Private Const CF_PALETTE = 9 Private Const CF_PENDATA = 10 Private Const CF_RIFF = 11 Private Const CF_WAVE = 12 Private Const CF_UNICODETEXT = 13 Private Const CF_ENHMETAFILE = 14 Private Const CF_HDROP = 15 Private Const CF_LOCALE = 16 Private Const CF_MAX = 17 ' New shell-oriented clipboard formats Private Const CFSTR_SHELLIDLIST As String = "Shell IDList Array" Private Const CFSTR_SHELLIDLISTOFFSET As String = "Shell Object Offsets" Private Const CFSTR_NETRESOURCES As String = "Net Resource" Private Const CFSTR_FILEDESCRIPTOR As String = "FileGroupDescriptor" Private Const CFSTR_FILECONTENTS As String = "FileContents" Private Const CFSTR_FILENAME As String = "FileName" Private Const CFSTR_PRINTERGROUP As String = "PrinterFriendlyName" Private Const CFSTR_FILENAMEMAP As String = "FileNameMap" ' Global Memory Flags Private Const GMEM_FIXED = &H0 Private Const GMEM_MOVEABLE = &H2 Private Const GMEM_NOCOMPACT = &H10 Private Const GMEM_NODISCARD = &H20 Private Const GMEM_ZEROINIT = &H40 Private Const GMEM_MODIFY = &H80 Private Const GMEM_DISCARDABLE = &H100 Private Const GMEM_NOT_BANKED = &H1000 Private Const GMEM_SHARE = &H2000 Private Const GMEM_DDESHARE = &H2000 Private Const GMEM_NOTIFY = &H4000 Private Const GMEM_LOWER = GMEM_NOT_BANKED Private Const GMEM_VALID_FLAGS = &H7F72 Private Const GMEM_INVALID_HANDLE = &H8000 Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT) Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT) Private Type DROPFILES #If VBA7 Then pFiles As LongPtr #Else pFiles As Long #End If pt As POINTAPI fNC As Long fWide As Long End Type Public Function ClipboardCopyFiles(Files() As String) As Boolean Dim data As String Dim df As DROPFILES #If VBA7 Then Dim hGlobal As LongPtr Dim lpGlobal As LongPtr #Else Dim hGlobal As Long Dim lpGlobal As Long #End If Dim i As Long ' Open and clear existing crud off clipboard. If OpenClipboard(0&) Then Call EmptyClipboard ' Build double-null terminated list of files. For i = LBound(Files) To UBound(Files) data = data & Files(i) & vbNullChar Next data = data & vbNullChar ' Allocate and get pointer to global memory, ' then copy file list to it. hGlobal = GlobalAlloc(GHND, Len(df) + Len(data)) If hGlobal Then lpGlobal = GlobalLock(hGlobal) ' Build DROPFILES structure in global memory. df.pFiles = Len(df) Call CopyMem(ByVal lpGlobal, df, Len(df)) Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal data, Len(data)) Call GlobalUnlock(hGlobal) ' Copy data to clipboard, and return success. If SetClipboardData(CF_HDROP, hGlobal) Then ClipboardCopyFiles = True End If End If ' Clean up Call CloseClipboard End If End Function Public Function ClipboardPasteFiles(Files() As String) As Long #If VBA7 Then Dim hDrop As LongPtr #Else Dim hDrop As Long #End If Dim nFiles As Long Dim i As Long Dim desc As String Dim filename As String Dim pt As POINTAPI Const MAX_PATH As Long = 260 ' Insure desired format is there, and open clipboard. If IsClipboardFormatAvailable(CF_HDROP) Then If OpenClipboard(0&) Then ' Get handle to Dropped Filelist data, and number of files. hDrop = GetClipboardData(CF_HDROP) nFiles = DragQueryFile(hDrop, -1&, "", 0) ' Allocate space for return and working variables. ReDim Files(0 To nFiles - 1) As String filename = Space(MAX_PATH) ' Retrieve each filename in Dropped Filelist. For i = 0 To nFiles - 1 Call DragQueryFile(hDrop, i, filename, Len(filename)) Files(i) = TrimNull(filename) Next ' Clean up Call CloseClipboard End If ' Assign return value equal to number of files dropped. ClipboardPasteFiles = nFiles End If End Function Private Function TrimNull(ByVal sTmp As String) As String Dim nNul As Long ' ' Truncate input sTmpg at first Null. ' If no Nulls, perform ordinary Trim. ' nNul = InStr(sTmp, vbNullChar) Select Case nNul Case Is > 1 TrimNull = Left(sTmp, nNul - 1) Case 1 TrimNull = "" Case 0 TrimNull = Trim(sTmp) End Select End Function Public Sub ClearClipboard() ' Open the clipboard If OpenClipboard(0&) Then ' Empty the clipboard Call EmptyClipboard ' Close the clipboard Call CloseClipboard End If End Sub مثال للاستخدام لإضافة ملفات إلي الحافظة يمكنك إضافة ملفات متنوعة من مسارات مختلفة afile(2) الرقم 2 الموجود هنا يمثل إجمالي عدد الملفات - 1 Sub Test_CopyFilesToClipboard() Dim afile(2) As String afile(0) = "C:\Test\File1.jpg" afile(1) = "C:\Test\File2.pdf" afile(2) = "C:\Any\File3.xlsx" Debug.Print ClipboardCopyFiles(afile) End Sub بالتوفيق

بالفعل عمل رائع لاستاذنا ,ومعلمنا @kkhalifa1960 واستاذنا ومعلمنا @Foksh لسيادتكم أفضل الإجابات ساستخدم كلا. الحلين لكما منى كل التحية والتقدير

سنشرح الفكرة والأكواد .. بداية قمت بإنشاء متغيرين في أول الأكواد ، هما :- Private Const TimeoutMinutes As Integer = 1 قمت بإنشاء متغير ثابت ( Const ) يسمى ( TimeoutMinutes ) ، ويتم تعيين قيمته إلى 1 تعبيراً عن دقيقة واحدة. ( وطبعاً تستطيع تغييره كما تريد ) سنستخدم هذا المتغير لتحديد المدة الزمنية (بالدقائق) التي يجب أن يمر ولا توجد فيها حركة للماوس حتى يتم اعتبار النموذج في وضع الخمول . Private LastMouseMoveTime As Date هنا سنقوم بإنشاء متغير خاص (Private) يسمى ( LastMouseMoveTime ) ويتم تحديده كنوع ( Date ) لأنه سيتم تخزين قيمة بصيغة وقت . يُستخدم هذا المتغير لتخزين الوقت الأخير الذي حدثت فيه حركة الماوس على النموذج. الآن بدأت في حدث عند التحميل لتثبيت قيمتين ، هما :- أولاً المتغير الخاص لتكون قيمته كمتغير الوقت الذي تم فتح النموذج فيه LastMouseMoveTime = Now ثانياً قمت بتشغيل الأمر كل دقيقة بالسطر التالي Me.TimerInterval = 60000 وفي حدث تحريك الماوس ، قمت بجعله يأخذ قيمة الوقت الحالي مرة أخرى كحدث عند التحميل LastMouseMoveTime = Now وفي حدث الوقت سيتم التحقق من أن الماوس لم يتم تحريكه منذ آخر قيمة تم تسجيلها في المتغير آخر حركة للماوس سابقاً ، بالكود التالي تخطي الخطأ لأنه سيتقوم بمهمة تغيير في النموذج عند مرور الوقت ، فوجب تلافي الخطأ لأنه لن يؤثر على النموذج On Error Resume Next سيتم التحقق من آخر مدة زمنية لتحريك الماوس ما إذا تخطيناها أم لا. If Now - LastMouseMoveTime > TimeValue("00:00:" & TimeoutMinutes * 60) Then اذا تحقق الشرط وكان الوقت المسجل في المتغير أقل بدقيقة من الوقت الحالي فستظهر رسالة ولك حرية حذفها بالمهمة التي تريدها . MsgBox "تم تسجيل الخروج بسبب عدم تحريك الماوس", vbInformation بعد الرسالة سيتم اغلاق آكسيس . طبعاً تستطيع هنا أن تعدل الأحداث كما ترغب . DoCmd.Quit End If

وهذه مشاركتي البسيطة مع الأستاذ خليفة Sleep Mode.accdb

تفضل استاذ @Abdelaziz Osman مرفق من مكتبتي . Main_Form Close After 15 minute.rar

برنامج حسابات شركات المقاولات المتكامل The Fastest 2023 مع الكراك رابط تحميل البرنامج https://www.mediafire.com/file/fyr7mwpun0hevps/The+Fastest+2023.rar/file روابط شرح البرنامج على يوتيوب YouTube 1- المقدمة ودليل الحسابات https://www.youtube.com/watch?v=JgvfkAPZIwo&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=1&t=221s 2- الأصول الثابتة https://www.youtube.com/watch?v=6GDuQOPJ1xo&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=2 3- المقابسات والمستخلصات https://www.youtube.com/watch?v=nSjE5wO6Q8E&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=3 4- عقود ومستخلصات مقاولين الباطن وسراك المعدات والعمالة https://www.youtube.com/watch?v=k7sC_WoUWSo&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=4 5- المشتريات والمخازن https://www.youtube.com/watch?v=qBJl2ATd428&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=5 6- المشتريات المستوردة وتكلفة الرسائل https://www.youtube.com/watch?v=JjI3OXvZTeg&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=6 7- البنوك والشيكات وأوراق القبض https://www.youtube.com/watch?v=BFpfrU6G0Jw&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=7 8- شئون العاملين والأجور والمرتبات https://www.youtube.com/watch?v=gKPJP0oNW7w&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=8 9- أدوات البرنامج والوظائف المتعددة لإدارة النظام https://www.youtube.com/watch?v=T9xhsBO5mNI&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=9 10 – ربط البرنامج على شبكة داخلية وعلى الانترنت https://www.youtube.com/watch?vyto1eP0oNW7w&list=PLchJFI-EXcEi2ryUFq3lW3STScg7O4yOZ&index=8 ضع ردا للإظهار باقي ابط

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) اليوم جئتكم ببرنامج المنبه الذكي هدية بسيطة لأعضاء منتدانا الغالي وصف البرنامج :- إمكانية تغيير الثيم من داخل الساعة . إمكانية تغيير نغمة رنين المنبه . نغمة تنبيه كل ساعة . دعم للغفوة كما في أجهزة الموبايل . إمكانية تعديل مدة العفوة حسب الحاجة . إمكانية عمل تنبيه متكرر حسب اليوم ، أو التنبيه لأيام محددة . صور من المنبه الذكي :- عند فتح المنبه لأول مرة لوحة التحكم بالإعدادات واجهة المنبه شاشة وقت التنبيه شاشة ضبط المنبه شاشة عرض المنبهات الفعالة والآن مع التحميل بدايةً النسخة 64 ، وقريباً النسخة الثانية بإصدار 32 إن شاء الله :- 64.zip ملاحظة:- تم حفظ البرنامج بصيغة Accde كونه قيد التطوير والتعديل حالياً وعدناكم بإضافة جديدة وهي إضافة حالة الطقس في شاشة المنبه الذكي ، والحمد لله الذي قدرني على توظيف هذه الميزة داخل التطبيق . وكما ذكرت سابقاً الخدمة تحتاج إتصال إنترنت . من الإعدادات > قم باختيار البلد > ثم تطبيق . وسيتم الإتصال بالسيرفر تلقائياً وإدراج درجة الحرارة في شاشة المنبه الرئيسية . ملاحظة :- درجة الحرارة التي يتم عرضها حالياً هي للعواصم العربية فقط ، وسيتم العمل على إدراج معظم المدن في الدول العربية في تحديثات لاحقة . الملف مفتوح المصدر ، وأطلب منكم فقط الدعاء لوالديّ Smart Alarm.zip وباب الحوار مفتوح للمناقشة

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

Private Sub CommandButton4_Click() Dim WS As Worksheet: Set WS = Sheets("Home") Dim dest As Worksheet: Set dest = Sheets("Daily") Dim search As Range, Rng As Range Set search = WS.[F13]: Set Rng = WS.[F4:F13] If Application.WorksheetFunction.CountA(Rng) = 0 Or search = Empty Then MsgBox "المرجوا إدخال البيانات", vbExclamation, "Admin" Exit Sub Else If Application.WorksheetFunction.CountIf(dest.Range("j:j"), search) > 0 Then MsgBox " تم حفظ هذا اليوم مسبقا" & " " & search, vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub a = Array([F4], [F5], [F6], [F7], [F8], [F9], [F10], [F11], [F12], [F13]) dest.[a65000].End(xlUp).Offset(1).Resize(, 10) = a dest.Range("j4:j" & Rows.Count).NumberFormat = "dd/mm/yyyy" Rng.ClearContents MsgBox "تم حفظ البيانات بنجاح" & " " & search & " " & "بنجاح", _ vbInformation, "Done" End If End Sub تقرير بورتوفيق.xlsm

جرب Private Sub SaveButton_Click() Dim wsHome As Worksheet Dim wsDaily As Worksheet Dim inputDate As Date Dim checkDate As Range Set wsHome = ThisWorkbook.Sheets("Home") Set wsDaily = ThisWorkbook.Sheets("Daily") 'Get the date from cell F13 in the Home sheet inputDate = wsHome.Range("F13").Value 'Check if the date is already in column J in the Daily sheet With wsDaily Set checkDate = .Columns("J").Find(inputDate, LookIn:=xlValues, lookat:=xlWhole) End With 'If the date is found, prevent saving and show a message If Not checkDate Is Nothing Then MsgBox "تم حفظ تقرير لهذا التاريخ مسبقاً في الجدول اليومي" Exit Sub End If 'Save the data if the date is not found 'Add your code here to save the data to the Daily sheet End Sub تأكد من تغيير اسماء الشيتات ("Home" و "Daily") وتعديل موضع الخطأ في حالة وجود أي اختلاف في اسماء الشيتات.

جرب Private Sub SaveButton_Click() Dim wsInput As Worksheet Dim wsData As Worksheet Dim inputDate As Date Dim lastRow As Long Dim checkDate As Range Set wsInput = ThisWorkbook.Sheets("واجهة الادخال") Set wsData = ThisWorkbook.Sheets("جدول البيانات") 'Get the date from the input form inputDate = wsInput.Range("A2").Value 'Check if the date is already in the data table With wsData lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row Set checkDate = .Range("A2:A" & lastRow).Find(inputDate, LookIn:=xlValues, lookat:=xlWhole) End With 'If the date is found, prevent saving and show a message If Not checkDate Is Nothing Then MsgBox "تم حفظ تقرير لهذا التاريخ مسبقاً" Exit Sub End If 'Save the data if the date is not found 'Add your code here to save the data to the data table End Sub

جزاك الله خيرا وجعلة الله في ميزان حسناتك استاذي وعلمي الفاضل

تسلم ايدك بارك الله فيك ..

هذا هو مطلوب أخي kkhalifa1960 جزاك الله خيرا

تفضل اخي الكريم @حسين العربى تم إضافة كود بسيط يجعل الدالة في المديول تطبق نفسها على جميع العناصر التي من النوع TextBox في الحدث عند التحميل للتقرير باستخدام هذا الكود :- Private Sub Form_Load() Dim ctl As Control For Each ctl In Me.Controls If TypeOf ctl Is TextBox Then Call getTextPrts (ctl) End If Next ctl End Sub وفي المديول تم إيقاف السطر التالي mytxt = rs!HRA ليتم التطبيق على جميع الحقول. ، طبعاً تستطيع تطبيق نفس الفكرة على جميع النماذج والتقارير لديك. وهذا الملف مع التعديلات 🤗 color All.accdb

أحسنت أستاذ Foksh عمل بالطبع ممتاز ويتحدث عن نفسه وغنى عن الوصف بارك الله فيك وزادك الله من فضله

تفضل هذا التعديل الصحيح chartofaccounts.accdb

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

مشكور على الهدية أخي الكريم ، وزادك الله من فضله وكرمه وجوده وعلمه 💐 DoCmd.GoToRecord , , acNewRec

السطر الذي تشير إليه يقوم ب لاستخدام الكائن Dictionary. يمكنك فعل ذلك من خلال اتباع الخطوات التالية: 1. في محرر VBA، انتقل إلى القائمة "Tools" ثم "References" (أو "Tools" ثم "References" في Excel 2010). 2. ابحث عن "Microsoft Scripting Runtime" في القائمة. 3. حدد المربع بجانب "Microsoft Scripting Runtime". 4. انقر فوق "OK" لحفظ التغييرات.

جرب Sub ProcessData() Dim ws1 As Worksheet, ws2 As Worksheet Dim lastRow As Long, i As Long Dim officeName As String, dateValue As String, claimNumber As String Dim uniqueOffices As New Collection Dim officeDates As New Dictionary Dim officeClaims As New Dictionary ' Set references to the worksheets Set ws1 = ThisWorkbook.Sheets("Sheet1") ' Change "Sheet1" to the actual name of your worksheet Set ws2 = ThisWorkbook.Sheets("Sheet2") ' Change "Sheet2" to the actual name of your worksheet ' Find the last row in worksheet 1 lastRow = ws1.Cells(ws1.Rows.Count, "O").End(xlUp).Row ' Loop through the data in worksheet 1 For i = 1 To lastRow ' Get the office name officeName = ws1.Cells(i, "O").Value ' Add the office name to the uniqueOffices collection On Error Resume Next uniqueOffices.Add officeName, CStr(officeName) On Error GoTo 0 ' Get the date value dateValue = CStr(ws1.Cells(i, "P").Value) ' Get the claim number claimNumber = CStr(ws1.Cells(i, "Q").Value) ' Add the date and claim number to the dictionaries if they don't already exist If Not officeDates.Exists(officeName) Then officeDates.Add officeName, dateValue officeClaims.Add officeName, claimNumber ElseIf InStr(1, officeDates(officeName), dateValue) = 0 Then officeDates(officeName) = officeDates(officeName) & " + " & dateValue ElseIf InStr(1, officeClaims(officeName), claimNumber) = 0 Then officeClaims(officeName) = officeClaims(officeName) & " + " & claimNumber End If Next i ' Write the unique office names to worksheet 2 Dim office As Variant Dim rowIndex As Long: rowIndex = 1 For Each office In uniqueOffices ws2.Cells(rowIndex, 1).Value = office ' Write the dates for each office ws2.Cells(rowIndex, 2).Value = officeDates(office) ' Write the claim numbers for each office ws2.Cells(rowIndex, 3).Value = officeClaims(office) rowIndex = rowIndex + 1 Next office MsgBox "Process complete." End Sub يرجى تغيير اسمي الورقتين "Sheet1" و "Sheet2" إلى الأسماء الفعلية للورقتين الخاصتين بك.

في حدث Private Sub Worksheet_Activate ضع الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) Dim a, i&, k&, b$, S$, lRow& Dim WS As Worksheet: Set WS = Sheets("البيانات") Dim desWS As Worksheet: Set desWS = Sheets("البحث") b = desWS.[E2] On Error Resume Next Application.ScreenUpdating = False If Not Intersect(Target, Target.Worksheet.Range("E2")) Is Nothing Then If Target.Cells.Value = "" Or IsEmpty(Target) Then Exit Sub desWS.Range("A5:j" & Rows.Count).ClearContents a = WS.Range("A3:J" & WS.[a65000].End(xlUp).Row) For i = 1 To UBound(a) If a(i, 4) = b Or a(i, 7) = b Or a(i, 10) = b Then desWS.Cells(k + 5, 1).Resize(, 10) = Application.IfError(Application.Index(a, i, Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10)), "") k = k + 1 ActiveWindow.DisplayZeros = False End If Next lRow = desWS.Range("A:J").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set Rng = desWS.Range("A5 :J" & lRow) desWS.Range("A5:J500").Borders.LineStyle = xlNone For Each c In Rng.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next Application.ScreenUpdating = True End If End Sub السيارات 24.xlsb

شكرا جزيلا وبارك الله فيك

أساتذتي الكرام، ربنا يبارك فيكم و يحفظكم ما زلت تلميذًا وما زلتُ أتعلم

هدية مشروع صيدلية متكامل كنت قد سويته لصديق ويعمل عنده للحين. طبعاً هناك آراء وتوجيهات . فقلبي وعقلي يتسع للجميع . واليكم المرفق https://www.mediafire.com/file/r06g7b7zwdqkq7q/Tariq+Farmacy.rar/file

اعتذر عن الانقطاع لظروف مرضية ان شاء الله سوف نبدأ فى الاستمرار تباعا بامر الله

ان شاء الله جارى العمل على تحويل البرنامج ليعمل على نظام 64Bit ولكن ليس فى القريب العاجل