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

اعرض الملف 🎁📅 :: المخطط السنوي للإجازات :: 🌼🌷 :: عرض جميع إجازات الموظفين على الجدول الزمني Gantt Cart دايناميكي 😊👌🏻 السلام عليكم ورحمة الله وبركاته 🙂 اليوم يسرني أن أقدم لكم هذه الهدية المتواضعة :: المخطط السنوي للإجازات :: وهو عبارة عن تقويم سنوي لإجازات الموظفين يتم رسمه دايناميكيا على مخطط رسم بياني يسمى Gantt Chart 👌 يمتاز التصميم بالسهولة والجمال والإبداعية وقد شرحت كيفية استخدامه في الفيديو التالي ✌ في التحديث الجديد 1.7 تم إضافة حقل لمجموع عدد الأيام سنويا ... مع دعم للإجازات عابرات القارات (الإجازات التي تمتد لعدة سنوات كالإجازات الدراسية الطويلة) ظهور عدد الأيام في جميع النوافذ من مميزات هذا المخطط: - عرض جميع الإجازات في صفحة واحدة يسهل من قرائتها ومراجعتها. - تصميم رائع وألوان جميلة . - سهل الاستخدام . - وكذلك هذا المخطط يمكن استخدامه للمشاريع بدل الإجازات أو عرض مدة الإيجارات أو .. أو .. أو ... حيث لا حدود للإبداع 🙂 :: وأخيرا وليس آخرا :: :: لا تنسونا ووالدينا من صالح دعواتكم الطيبة 🙂 🌹🌷 :: صاحب الملف Moosak تمت الاضافه 01 ينا, 2025 الاقسام قسم الأكسيس

السلام عليكم ورحمة الله وبركاته هذا تحديث بسيط ومهم في نفس الوقت على هذه الأداة الجميلة 🙂 ( عون المثابر في الحصول على أسماء العناصر (الإصدار 3.0)) كما علمتم هذه الأداة صممتها بفضل الله في أكسس تقوم بإحضار وسرد أسماء العناصر لك لكي تستطيع نسخها ولصقها في أي مكان تريد بكل سهولة ويسر 🙂 شخصيا أستفدت كثيرا منها وسهلت علي الكثير من الجهد وقلصت من وقت العمل بحمد الله وفضله. :: ما الجديد في النسخة 3.0 :: تم إضافة خانة في الأخير خاصة بالجداول فقط .. : وهي عند اختيار الجدول يتم كتابة جمل SQL أستعلامات أساسية للجدول المختار مع ذكر أسماء حقول الجدول مع مراعاة أنواع الحقول وكتابتها بشكل سليم في الكود .. طبعا الأداة ستعطيك الجمل الاستعلامية الأربعة SELECT, INSERT INTO, UPDATE ,DELETE والكود الناتج جاهز للصقه مباشرة في محرر الأكواد VBA .. عليك فقط أن تقوم ببعض التعديلات الطفيفة كإزالة الحقول الزائدة أو الغير مستهدفة وكذلك تحديد الشرط Where في حال التحديث أو الحذف مثلا . :: لقطة للنسخة 3.0 :: وهذا مثال على جمل ال SQL الناتجة : ' SELECT statement Dim sqlSelect As String sqlSelect = "SELECT [ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB]" sqlSelect = sqlSelect & vbCrLf & " FROM [SampleTable]" '============================================================ ' INSERT INTO statement Dim sqlInsert As String sqlInsert = "INSERT INTO [SampleTable] ([ID], [First Name], [Last Name], [Gender], [Age], [Email], [Phone], [Education], [Occupation], [Salary], [StaffNumber], [IsActive], [DOB])" sqlInsert = sqlInsert & vbCrLf & " VALUES (" & var_ID & ", '" & var_FirstName & "', '" & var_LastName & "', '" & var_Gender & "', " & var_Age & ", '" & var_Email & "', '" & var_Phone & "', '" & var_Education & "', '" & var_Occupation & "', " & var_Salary & ", " & var_StaffNumber & ", " & IIf(var_IsActive, -1, 0) & ", #" & var_DOB & "#)" '============================================================ ' UPDATE statement Dim sqlUpdate As String sqlUpdate = "UPDATE [SampleTable]" sqlUpdate = sqlUpdate & vbCrLf & " SET [ID] = " & var_ID & ", [First Name] = '" & var_FirstName & "', [Last Name] = '" & var_LastName & "', [Gender] = '" & var_Gender & "', [Age] = " & var_Age & ", [Email] = '" & var_Email & "', [Phone] = '" & var_Phone & "', [Education] = '" & var_Education & "', [Occupation] = '" & var_Occupation & "', [Salary] = " & var_Salary & ", [StaffNumber] = " & var_StaffNumber & ", [IsActive] = " & IIf(var_IsActive, -1, 0) & ", [DOB] = #" & var_DOB & "#" sqlUpdate = sqlUpdate & vbCrLf & " WHERE [SomeField] = SomeValue" '============================================================ ' DELETE statement Dim sqlDelete As String sqlDelete = "DELETE FROM [SampleTable]" sqlDelete = sqlDelete & vbCrLf & " WHERE [SomeField] = SomeValue" الشرح القديم للأداة على اليوتيوب 🙂 متابعة ممتعة 😊👌🏼 ولا أستغني عن آراءكم وملاحظاتكم .. 🙂 لتحميل الملف :

بارك الله في الاستاذين حجازي ومحمد هشام وجعله في ميزان اعمالكما وشفى نجل الاستاذ محمد هشام

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Tartib() Dim WS As Worksheet, lastRow As Long, OnRng As Range Dim i As Long, ColSort As String: ColSort = "Z" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set WS = ThisWorkbook.Sheets("Sheet1") lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row If lastRow < 2 Then GoTo ClearApp For i = 2 To lastRow WS.Cells(i, ColSort).Value = i Next i Set OnRng = WS.Range("A2:D" & lastRow).Resize(, WS.Range(ColSort & "2").Column - 1 + 1) OnRng.Sort Key1:=WS.Range(ColSort & "2"), Order1:=xlAscending, Header:=xlNo OnRng.Sort Key1:=WS.Range("C2"), Order1:=xlDescending, _ Key2:=WS.Range("D2"), Order2:=xlAscending, _ Key3:=WS.Range("B2"), Order3:=xlAscending, Header:=xlNo WS.Range(ColSort & "2:" & ColSort & lastRow).ClearContents ClearApp: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

وعليكم السلام ورحمة الله وبركاته ,, كمشاركة لي خارج قوقعتي في قسم الآكسيس ، استخدم الدالة LEFT ، في الخلية D1 حسب مثالك ، وسينتج عن ذلك رقم مكون من 6 خانات إن كان هذا طلبك , =LEFT(A1&"",2) & LEFT(B1&"",2) & LEFT(C1&"",2)

السلام عليكم اخوي موسى ، فكرة جملية وتنفيذ اجمل ، شكرا لك.

تفضل استاذ @ابو عبد الله العراقي محاولتي حسب مافهمت بالمرفق مع بعض التعديلات والاضافات مجرب ويعمل تمام . ووافني بالرد . Users-1.rar

الله الله الله اسم الموضوع بيفكرني بكتب العقيدة والدين 😂 سلمت ايديك على التحفه (وكل اعمالك رائعه ما شاء الله) بص انا عاوز منك تفتح موضوع يخص اختيار الالوان وكيف نختارهم وندمجهم معهم ^_^

هههههههههه ما هى دى بركات مولانا ههههههههههه والبخور العمانى والدى الحبيب واستاذى الجليل ومعلمى القدير الاستاذ @ابوخليل ابشر طالما معنا الله ثم مولانا ان شاء الله وأخيــــــرا الان جاء دورى من نفسي بقه يا مولانا : يضاف للمكتبة العامرة

إن شاء الله بس المطلوب في الملف غير المطلوب في الرسالة على العموم مرفق ملفين اختر ما يناسبك ترتيب الطلاب(2).xlsm ترتيب الطلاب(3).xlsm

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

ما شاء الله ، تحديث جميل للجزئية الهامة عند كتابة جمل SQL ، جزاكم الله كل خير مهندسنا الغالي

جزاكم الله خيـــــــــرا

مشاركةً مع استاذ @Foksh تفضل استاذ سامر محاولتي حسب ما فهمت بالمرفق . ووافني بالرد . Pepsi-1.rar

برنامج أرشفة 1- الملفات والمرفقات والمجلدات 2- البرامج المساعدة ومرفقاتها أرجو ابداء رأيكم به ArchiveMyFiles-Folders.rar

المشروع بحاجة الى اعادة بناء ، وخصوصاً موضوع الجداول والعلاقة فيما بينها ، ثم النقطة المتكررة دائماً وهي الإبتعاد عن الأسماء المحجوزة لآكسيس من أسماء الحقول والجداول والعناصر ... إلخ الآن النقطة الثانية انظر الصورة التالية لمصدر سجلات النموذج :- ما علاقة الجداول Data,Location_all,Location في النموذج . هذا أولاً .. ثانياً هل الجدول Data (وهو اسم محجوز لآكسيس) ، يتم تخزين قيم من النموذج الى هذا الجدول ؟؟؟؟؟ إن كان لا !! فلا حاجة لوجوده كمصدر سجلات ( من وجهة نظري ) لجلب البيانات منه . ومن هنا سكفيك وجود الجدول Fawri فقط كمصدر لتخزين القيم من النموذج مع ضبط الحدث بعد التحديث بحيث عند اختيار اسم الموظف يتم ادراج القيم الخاصة به الى مربعات النص في النموذج . هذه وجهة نظري ( الغير ملزمة طبعاً ودائماً ) .. مرفق لفكرة بدائية بسيطة لجلب القيم للموظف الذي تم اختياره من الكومبوبوكس جربه وأخبرني بالنتيجة .. Pepsi.zip

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

بارك الله فيك وجعله بميزان حسناتك

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

ما شاء الله ابداع والموضوع فوق الرائع شئ ممتع ان اجد مثل هذه المواضيع الثمينه بكل ما فيها جذاكم الله عنا كل خير استاذي @ابو جودي انا شايف ان فى نقطه فى الجدل هل هذا يعني ان هناك كود للربط تلقائى بناءا على حالة حقل ActiveAutoLink اين هذا الكود 😁

السلام عليكم ورحمة الله وبركاته الحمد لله والشكر لله الأخوة الكرام / حفظكم الله أقدم لكم أكواد للتعامل مع الحافظة (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 بالتوفيق

السلام عليكم بمراجعة ملف الاكسيل المشار اليه، وجدت به دالة جاهزة اسمها StrReverse تقوم بعكس النص باستخدام VBA ، وهي كافية لاداء المطلوب و تعمل ايضا فى الوورد الدالة من موقع ميكروسوفت و عليه قمت بتطبيقها فى الوورد ، و عملت معي جداً فقط قبل تشغيل الكود قم باختيار النص المطلوب عكسه، حيث يعمل الكود الذى أعددته على النص المختار فقط Sub reversit() Selection.Text = StrReverse(Selection.Text) End Sub مرفق الملف Word-Reverse.docm

السلام عليكم احتجت لكود لعكس الكلمات بالوورد، و جربت كود الاخ عبد الله فتحي المنشور اعلاه و يعمل بامتياز مرفق الملف للاستفادة Wor-Reverse.docm

السلام عليكم ورحمة الله وبركاته جمعة مباركة للجميع التعديلات الجديدة : 1ـ عندما تريد تعديل حساب اثناء اختيارك لرقم الحساب تاتيك معطيات هذا الحساب في الفورم لتختار منها ما تريد تعديله 2ـ حساب المتاجرة وارباح وخسائر والميزانية الختامية تم ضمهم في ورقة واحدة وسميت الاغلاق اذا اردت اقفال حساباتك تذهب الى ميزان المراجعة الذي يوجد فيه زر الانتقال اليها ثم ....... في النظر كفاية عن الشرح 3ـ زر جديد في القيود للصق قيمة العملة بمعطيات قيمته بالعملة الرئيسية 4ـ زر لصق فارق الميزان يقوم باحتساب الفرق للعملتين الرئيسية والفرعية 5ـ فورم اضافة التاريخ ( هدية الاخ نزار) للتذكيراسم المستخدم : خبور كلمة المرور : بسم الله كلمة مرور التعديلات : بسم الله وترقبوا قريبا ان شاء الله برنامج خبور بالتاريخ الهجري ودمتم في حفظ الله وسلامته تحياتي وسلامي اخوكم / خبور __________________________.rar

ضع هدا الكود في الفورم Const FTP_TRANSFER_TYPE_UNKNOWN = &H0 Const FTP_TRANSFER_TYPE_ASCII = &H1 Const FTP_TRANSFER_TYPE_BINARY = &H2 Const INTERNET_DEFAULT_FTP_PORT = 21 ' default 'for FTP servers Const INTERNET_SERVICE_FTP = 1 Const INTERNET_FLAG_PASSIVE = &H8000000 ' used 'for FTP connections Const INTERNET_OPEN_TYPE_PRECONFIG = 0 ' 'use registry configuration Const INTERNET_OPEN_TYPE_DIRECT = 1 ' 'direct to net Const INTERNET_OPEN_TYPE_PROXY = 3 ' 'via named proxy Const INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4 ' prevent using java//INS Const MAX_PATH = 260 Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Type WIN32_FIND_DATA dwFileAttributes As Long ftCreationTime As FILETIME ftLastAccessTime As FILETIME ftLastWriteTime As FILETIME nFileSizeHigh As Long nFileSizeLow As Long dwReserved0 As Long dwReserved1 As Long cFileName As String * MAX_PATH cAlternate As String * 14 End Type Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) As Integer Private Declare Function InternetConnect Lib "wininet.dll" Alias "InternetConnectA" (ByVal hInternetSession As Long, ByVal sServerName As String, ByVal nServerPort As Integer, ByVal sUserName As String, ByVal sPassword As String, ByVal lService As Long, ByVal lFlags As Long, ByVal lCon As Long) As Long Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" (ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long Private Declare Function FtpSetCurrentDirectory Lib "wininet.dll" Alias "FtpSetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean Private Declare Function FtpGetCurrentDirectory Lib "wininet.dll" Alias "FtpGetCurrentDirectoryA" (ByVal hFtpSession As Long, ByVal lpszCurrentDirectory As String, lpdwCurrentDirectory As Long) As Long Private Declare Function FtpCreateDirectory Lib "wininet.dll" Alias "FtpCreateDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean Private Declare Function FtpRemoveDirectory Lib "wininet.dll" Alias "FtpRemoveDirectoryA" (ByVal hFtpSession As Long, ByVal lpszDirectory As String) As Boolean Private Declare Function FtpDeleteFile Lib "wininet.dll" Alias "FtpDeleteFileA" (ByVal hFtpSession As Long, ByVal lpszFileName As String) As Boolean Private Declare Function FtpRenameFile Lib "wininet.dll" Alias "FtpRenameFileA" (ByVal hFtpSession As Long, ByVal lpszExisting As String, ByVal lpszNew As String) As Boolean Private Declare Function FtpGetFile Lib "wininet.dll" Alias "FtpGetFileA" (ByVal hConnect As Long, ByVal lpszRemoteFile As String, ByVal lpszNewFile As String, ByVal fFailIfExists As Long, ByVal dwFlagsAndAttributes As Long, ByVal dwFlags As Long, ByRef dwCon As Long) As Boolean Private Declare Function FtpPutFile Lib "wininet.dll" Alias "FtpPutFileA" (ByVal hConnect As Long, ByVal lpszLocalFile As String, ByVal lpszNewRemoteFile As String, ByVal dwFlags As Long, ByVal dwCon As Long) As Boolean Private Declare Function InternetGetLastResponseInfo Lib "wininet.dll" Alias "InternetGetLastResponseInfoA" (lpdwError As Long, ByVal lpszBuffer As String, lpdwBufferLength As Long) As Boolean Private Declare Function FtpFindFirstFile Lib "wininet.dll" Alias "FtpFindFirstFileA" (ByVal hFtpSession As Long, ByVal lpszSearchFile As String, lpFindFileData As WIN32_FIND_DATA, ByVal dwFlags As Long, ByVal dw As Long) As Long Private Declare Function InternetFindNextFile Lib "wininet.dll" Alias "InternetFindNextFileA" (ByVal hFind As Long, lpvFindData As WIN32_FIND_DATA) As Long Const PassiveConnection As Boolean = True Private Sub Form_Load() Dim hConnection As Long, hOpen As Long, sOrgPath As String 'open an internet connection hOpen = InternetOpen("API-Guide sample program", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0) 'connect to the FTP server hConnection = InternetConnect(hOpen, "your ftp server", INTERNET_DEFAULT_FTP_PORT, "your login", "your password", INTERNET_SERVICE_FTP, IIf(PassiveConnection, INTERNET_FLAG_PASSIVE, 0), 0) 'create a buffer to store the original directory sOrgPath = String(MAX_PATH, 0) 'get the directory FtpGetCurrentDirectory hConnection, sOrgPath, Len(sOrgPath) 'create a new directory 'testing' FtpCreateDirectory hConnection, "testing" 'set the current directory to 'root/testing' FtpSetCurrentDirectory hConnection, "testing" 'upload the file 'test.htm' FtpPutFile hConnection, "C:\test.htm", "test.htm", FTP_TRANSFER_TYPE_UNKNOWN, 0 'rename 'test.htm' to 'apiguide.htm' FtpRenameFile hConnection, "test.htm", "apiguide.htm" 'enumerate the file list from the current directory ('root/testing') EnumFiles hConnection 'retrieve the file from the FTP server FtpGetFile hConnection, "apiguide.htm", "c:\apiguide.htm", False, 0, FTP_TRANSFER_TYPE_UNKNOWN, 0 'delete the file from the FTP server FtpDeleteFile hConnection, "apiguide.htm" 'set the current directory back to the root FtpSetCurrentDirectory hConnection, sOrgPath 'remove the direcrtory 'testing' FtpRemoveDirectory hConnection, "testing" 'close the FTP connection InternetCloseHandle hConnection 'close the internet connection InternetCloseHandle hOpen End Sub Public Sub EnumFiles(hConnection As Long) Dim pData As WIN32_FIND_DATA, hFind As Long, lRet As Long 'set the graphics mode to persistent Me.AutoRedraw = True 'create a buffer pData.cFileName = String(MAX_PATH, 0) 'find the first file hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0) 'if there's no file, then exit sub If hFind = 0 Then Exit Sub 'show the filename Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1) Do 'create a buffer pData.cFileName = String(MAX_PATH, 0) 'find the next file lRet = InternetFindNextFile(hFind, pData) 'if there's no next file, exit do If lRet = 0 Then Exit Do 'show the filename Me.Print Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1) Loop 'close the search handle InternetCloseHandle hFind End Sub Sub ShowError() Dim lErr As Long, sErr As String, lenBuf As Long 'get the required buffer size InternetGetLastResponseInfo lErr, sErr, lenBuf 'create a buffer sErr = String(lenBuf, 0) 'retrieve the last respons info InternetGetLastResponseInfo lErr, sErr, lenBuf 'show the last response info MsgBox "Error " + CStr(lErr) + ": " + sErr, vbOKOnly + vbCritical End Sub فتح صفحة انترنت ضع هدا الكود في الفورم Private Sub Command1_Click() l "RUNDLL32.EXE URL.DLL,FileProtocolHandler http://www.al-ebda3.info/ib/", vbNormalFocus End Sub Private Sub Command2_Click() Dim X As Object Set X = CreateObject("InternetExplorer.Application") X.Navigate "www.noisrael.com" X.Visible = True End Sub حالة الاتصال بالانترنت ضع هدا الكود في الموديول Public Declare Function RasEnumConnections Lib "RasApi32.dll" Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As Long, lpcConnections As Long) As Long Public Declare Function RasGetConnectStatus Lib "RasApi32.dll" Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, lpStatus As Any) As Long Public Const RAS95_MaxEntryName = 256 Public Const RAS95_MaxDeviceType = 16 Public Const RAS95_MaxDeviceName = 32 Public Type RASCONN95 dwSize As Long hRasCon As Long szEntryName(RAS95_MaxEntryName) As Byte szDeviceType(RAS95_MaxDeviceType) As Byte szDeviceName(RAS95_MaxDeviceName) As Byte End Type Public Type RASCONNSTATUS95 dwSize As Long RasConnState As Long dwError As Long szDeviceType(RAS95_MaxDeviceType) As Byte szDeviceName(RAS95_MaxDeviceName) As Byte End Type ضع هدا الكود في الفورم Public Function IsConnected() As Boolean Dim TRasCon(255) As RASCONN95 Dim lg As Long Dim lpcon As Long Dim RetVal As Long Dim Tstatus As RASCONNSTATUS95 TRasCon(0).dwSize = 412 lg = 256 * TRasCon(0).dwSize RetVal = RasEnumConnections(TRasCon(0), lg, lpcon) If RetVal <> 0 Then MsgBox "ERROR" Exit Function End If Tstatus.dwSize = 160 RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus) If Tstatus.RasConnState = &H2000 Then IsConnected = True Else IsConnected = False End If End Function Private Sub Command1_Click() If IsConnected() = True Then MsgBox ("الجهاز متصل بالانترنت") Else MsgBox ("الجهاز غير متصل بالانترنت") End If End Sub فيديو تشغيل ملف فيديو في picture ضع هدا الكود في الفورم Private Sub Form_Load() MMControl1.FileName = ("c:\FileName.dat") MMControl1.Command = "open" MMControl1.hWndDisplay = Picture1.hWnd End Sub تشغيل ملف من نوع avi بدون أوات ضع هدا الكود في الفورم Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Sub Form_Click() Dim Ret As Long, A$, x As Integer, y As Integer x = 10 y = 10 A$ = "c:\Filename.avi" Ret = mciSendString("stop movie", 0&, 128, 0) Ret = mciSendString("close movie", 0&, 128, 0) Ret = mciSendString("open AVIvideo!" & A$ & " alias movie parent " & Form1.hWnd & " style child", 0&, 128, 0) Ret = mciSendString("put movie window client at " & x & " " & y & " 0 0", 0&, 128, 0) Ret = mciSendString("play movie", 0&, 128, 0) End Sub Private Sub Form_DblClick() End End Sub Private Sub Form_Terminate() Dim Ret As Long Ret = mciSendString("close all", 0&, 128, 0) End Sub صورة التقاط صورة للشاشة ضع هدا الكود في الفورم Const RC_PALETTE As Long = &H100 Const SIZEPALETTE As Long = 104 Const RASTERCAPS As Long = 38 Private Type PALETTEENTRY peRed As Byte peGreen As Byte peBlue As Byte peFlags As Byte End Type Private Type LOGPALETTE palVersion As Integer palNumEntries As Integer palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors End Type Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PicBmp Size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID 'Fill GUID info With IID_IDispatch .Data1 = &H20400 .Data4(0) = &HC0 .Data4(7) = &H46 End With 'Fill picture info With Pic .Size = Len(Pic) ' Length of structure .Type = vbPicTypeBitmap ' Type of Picture (bitmap) .hBmp = hBmp ' Handle to bitmap .hPal = hPal ' Handle to palette (may be null) End With 'Create the picture R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic) 'Return the new picture Set CreateBitmapPicture = IPic End Function Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE 'Create a compatible device con hDCMemory = CreateCompatibleDC(hDCSrc) 'Create a compatible bitmap hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc) 'Select the compatible bitmap into our compatible device con hBmpPrev = SelectObject(hDCMemory, hBmp) 'Raster capabilities? RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster 'Does our picture use a palette? HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette 'What's the size of that palette? PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of If HasPaletteScrn And (PaletteSizeScrn = 256) Then 'Set the palette version LogPal.palVersion = &H300 'Number of palette entries LogPal.palNumEntries = 256 'Retrieve the system palette entries R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0)) 'Create the palette hPal = CreatePalette(LogPal) 'Select the palette hPalPrev = SelectPalette(hDCMemory, hPal, 0) 'Realize the palette R = RealizePalette(hDCMemory) End If 'Copy the source image to our compatible device con R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy) 'Restore the old bitmap hBmp = SelectObject(hDCMemory, hBmpPrev) If HasPaletteScrn And (PaletteSizeScrn = 256) Then 'Select the palette hPal = SelectPalette(hDCMemory, hPalPrev, 0) End If 'Delete our memory DC R = DeleteDC(hDCMemory) Set hDCToPicture = CreateBitmapPicture(hBmp, hPal) End Function Private Sub Form_Load() 'Create a picture object from the screen Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY) End Sub كود بسيط لالتقاط صورة للشاشة في الحافظة ضع هدا الكود في الفورم Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long) Private Sub Command1_Click() keybd_event vbKeySnapshot, 0, 0, 0 DoEvents End Sub صوت تشغيل ملف صوتي من نوع ram ضع هدا الكود في الفورم ولاحظ أنه يحتاج إلى الأداة الموجودة مع الريل بلاير Private Sub Command1_Click() RealAudio1.Source = "c:\AFR.ram" RealAudio1.DoPlay End Sub تشغيل ملف صوتي من نوع midi ضع هدا الكود في الفورم Private Sub Form_Load() MMControl1.Visible = False MMControl1.DeviceType = "sequencer" MMControl1.FileName = ("c:\FileName.mid") MMControl1.Command = "open" MMControl1.Command = "play" End Sub التحكم في رفع وخفض الصوت ضع هدا الكود في الفورم Private Declare Function waveOutSetVolume Lib "Winmm.dll" (ByVal DevID As Integer, ByVal Vol As Long) As Long Sub SetVol(Volume As Long) Dim Vol& Vol = CLng("&H" & Hex(Volume + 65536)) waveOutSetVolume 0, Vol End Sub Private Sub Command1_Click() SetVol 1. End Sub Private Sub Form_Load() 1. = "ضع قيمة عددية تنحصر ما بين 0 و65536" End Sub الوقت والتاريخ معرفة اليوم الحالي ضع هدا الكود في الفورم Private Sub Command1_Click() Dim Dday As Integer Dday = Weekday(Date) If Dday = 1 Then Print "الأحد" If Dday = 2 Then Print "الاثنين" If Dday = 3 Then Print "الثلاثاء" If Dday = 4 Then Print "الأربعاء" If Dday = 5 Then Print "الخميس" If Dday = 6 Then Print "الجمعة" If Dday = 7 Then Print "السبت" End Sub معرفة الشهر الحالي ضع هدا الكود في الفورم Private Sub Command1_Click() Mmonth = Mid(Date, 4, 2) Print MonthName(Mmonth) End Sub الفرق بين تاريخين باليوم ضع هدا الكود في الفورم Private Sub Command1_Click() On Error GoTo 1 Dim Form1Date As Date Dim Form2Date As Date Form1Date = 1. Form2Date = 2. 3. = DateDiff("d", 1., 2.) & " اليوم" Exit Sub MsgBox ("من فضلك أدخل التاريخ بشكل صحيح") End Sub عرض الزمن والتاريخ ضع هدا الكود في الفورم Private Sub Form_Load() Timer1.Interval = 1000 End Sub Private Sub Timer1_Timer() Label1 = Time & Date End Sub الحماية نسخة مشتركة من البرنامج (تشتغل لعدد معين) ضع هدا الكود في الفورم Private Sub Form_Load() retvalue = GetSetting("A", "0", "Runcount") GD$ = Val(retvalue) + 1 SaveSetting "A", "0", "RunCount", GD$ If GD$ > 3 Then ' الرقم (3) يحدد عدد مرات التشغيل MsgBox ("انتهت مدة تشغيل البرنامج,قم بشراء النسخة الكاملة من المنتج") Unload Me End If End Sub منع النسخ أو اللصق ضع هدا الكود في الفورم Private Sub Form_Load() Timer1.Interval = 1 End Sub Private Sub Timer1_Timer() R = Clipboard.Get If Len® = 0 Then Clipboard.Clear End If End Sub منع تشغيل أكثر من نسخة من البرنامج ضع هدا الكود في الفورم Private Sub Form_Load() If App.PrevInstance = True Then MsgBox "لا يمكن تشغيل أكثر من نسخة من البرنامج" Unload Me Exit Sub End If End Sub التأكد من عمل البرنامج من على ال CD-ROM ضع هدا الكود في الفورم Private Declare Function GetDriveType Lib "kernel32.dll" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long Private Sub Form_Load() Dim driveType As Long driveType = GetDriveType(Mid(App.Path, 1, 3)) If driveType <> 5 Then 'إنهاء البرنامج ادا كان لا يشتغل من القرص المدمج End End If End Sub التعامل مع النماذج جعل الفورم في المقدمة ضع هدا الكود في الفورم Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal CX As Long, ByVal CY As Long, ByVal wFlags As Long) As Long Private Const SWP_NOMOVE = 2 Private Const SWP_NOSIZE = 1 Private Const HWND_TOPMOST = -1 Private Const HWND_NOTOPMOST = -2 Public Sub SetOnTop(ByVal hwnd As Long, ByVal bSetOnTop As Boolean) Dim lR As Long If bSetOnTop Then lR = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) Else lR = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE) End If End Sub Private Sub Form_Load() SetOnTop Form1.hwnd, True End Sub إبطال مفعول زر × في النافدة ضع هدا الكود في الفورم Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Cancel = True End Sub إلغاء تفعيل زر الإغلاق في أعلى النافدة ضع هدا الكود في الموديول Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long Public Const MF_BYPOSITION = &H400& ضع هدا الكود في الفورم Public Sub DisableCloseWindowButton(frm As Form) Dim hSysMenu As Long 'Get the handle to this windows system menu hSysMenu = GetSystemMenu(frm.hwnd, 0) 'Remove the Close menu item This will also disable the close button RemoveMenu hSysMenu, 6, MF_BYPOSITION 'Lastly, we remove the seperator bar RemoveMenu hSysMenu, 5, MF_BYPOSITION End Sub Private Sub Form_Load() DisableCloseWindowButton Me End Sub إلغاء تفعيل زر التكبير في أعلى النافدة ضع هدا الكود في الفورم Option Explicit Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Private Sub Form_Load() Const WS_MAXIMIZEBOX = &H10000 Const GWL_STYLE = (-16) Const SWP_FRAMECHANGED = &H20 Const SWP_NOMOVE = &H2 Const SWP_NOSIZE = &H1 Dim nStyle As Long nStyle = GetWindowLong(Me.hWnd, GWL_STYLE) Call SetWindowLong(Me.hWnd, GWL_STYLE, nStyle And Not WS_MAXIMIZEBOX) SetWindowPos Me.hWnd, 0, 0, 0, 0, 0, SWP_FRAMECHANGED Or SWP_NOMOVE Or SWP_NOSIZE End Sub كود بسيط لجعل الفورم في المقدمة ضع هدا الكود في الفورم Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) Private Sub Form_Load() Timer1.Interval = 1 End Sub Private Sub Timer1_Timer() SetWindowPos Form1.hwnd, -1, 0, 0, 0, 0, 3 End Sub التعامل المجلدات إنشاء مجلد جديد ضع هدا الكود في الفورم Private Type SECURITY_ATTRIBUTES nLength As Long lpSecurityDeor As Long bInheritHandle As Boolean End Type Private Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long Private Sub Command1_Click() Dim attr As SECURITY_ATTRIBUTES ' security attributes structure Dim rval As Long ' Set security attributes attr.nLength = Len(attr) 'size of the structure attr.lpSecurityDeor = 0 'normal level of security attr.bInheritHandle = 1 'default setting ' Create directory. rval = CreateDirectory(1., attr) End Sub Private Sub Form_Load() 1. = "c:\Abdu" Command1.Caption = "New Directory" End Sub البيانات نقل الملفات ضع هدا الكود في الفورم Private Sub Command1_Click() Name "c:\Autoexec.bat" As "D:\Autoexec.bat" End Sub حساب عدد سطور ملف نصي ضع هدا الكود في الفورم Private Sub Command1_Click() Open "c:\autoexec.bat" For Input As #1 Count: SS = SS + 1 Line Input #1, x If EOF(1) Then Label1.Caption = SS Exit Sub Else GoTo Count: End If Close End Sub تغيير خصائص ملف ضع هدا الكود في الفورم Private Sub COMMAND1_CLICK() SetAttr "C:\data.txt", vbHidden SetAttr "C:\data.txt", vbReadOnly SetAttr "C:\data.txt", vbArchive End Sub التأكد من وجود ملف ضع هدا الكود في الفورم Private Sub Command1_Click() On Error GoTo Error: Open "ضع مسار الملف الذي تريد التأكد من وجوده هنا" For Input As #1 Close MsgBox ("الملف موجود") Exit Sub Error: MsgBox ("الملف غير موجود") End Sub حجم الملف بالبايت ضع هدا الكود في الفورم Private Sub Command1_Click() Print FileLen("c:\Autoexec.bat") End Sub حذف ملف ضع هدا الكود في الفورم Private Sub Command1_Click() Kill ("C:\FileName.fnm") End Sub إنشاء ملف جديد ضع هدا الكود في الفورم Private Sub Command1_Click() open "c:\FileName.txt" for append as #1 Print #1,"Willkommen auf die Erde" Close #1 End Sub نسخ ملف ضع هدا الكود في الفورم Private Sub Command1_Click() FileCopy "c:\Autoexec.bat", "d:\Autoexec.bat" End Sub أكواد عامة فتح برنامج المفكرة و الإضافة عليه ضع هدا الكود في الفورم Private Sub Command1_Click() l "notepad.exe", vbNormalNoFocus AppActivate ("المفكرة") SendKeys ("أهلا بك ") End Sub عرض الخطوط في قائمة منسدلة ضع هدا الكود في الفورم Private Sub Form_Load() Dim i As Integer For i = 0 To Screen.FontCount - 1 Combo1.AddItem Screen.Fonts(i) Next i Combo1. = Combo1.List(0) End Sub أيقونة للبرنامج بجوار الساعة ضع هدا الكود في الموديول Public Type NOTIFYICONDATA cbSize As Long hWnd As Long uId As Long uFlags As Long uCallBackMessage As Long hIcon As Long szTip As String * 64 End Type Public Const NIM_ADD = &H0 Public Const NIM_MODIFY = &H1 Public Const NIM_DELETE = &H2 Public Const NIF_MESSAGE = &H1 Public Const NIF_ICON = &H2 Public Const NIF_TIP = &H4 Public Const WM_MOUSEMOVE = &H200 Public Const WM_LBUTTONDOWN = &H201 'Button down Public Const WM_LBUTTONUP = &H202 'Button up Public Const WM_LBUTTONDBLCLK = &H203 'Double-click Public Const WM_RBUTTONDOWN = &H204 'Button down Public Const WM_RBUTTONUP = &H205 'Button up Public Const WM_RBUTTONDBLCLK = &H206 'Double-click Public Declare Function SetForegroundWindow Lib "user32" _ (ByVal hWnd As Long) As Long Public Declare Function l_NotifyIcon Lib "l32" _ Alias "l_NotifyIconA" _ (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean Public nid As NOTIFYICONDATA ضع هدا الكود في الفورم Private Sub Form_Load() Me.Show Me.Refresh With nid .cbSize = Len(nid) .hWnd = Me.hWnd .uId = vbNull .uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE .uCallBackMessage = WM_MOUSEMOVE .hIcon = Me.Icon .szTip = "Your ToolTip" & vbNullChar End With l_NotifyIcon NIM_ADD, nid End Sub Private Sub Form_Resize() If Me.WindowState = vbMinimized Then Me.Hide End Sub Private Sub Form_Unload(Cancel As Integer) l_NotifyIcon NIM_DELETE, nid End Sub تأجيل تنفيذ الكود لفترة معينة ضع هدا الكود في الفورم Public Sub Delay(HowLong As Date) TempTime = DateAdd("s", HowLong, Now) While TempTime > Now DoEvents Wend End Sub Private Sub Command1_Click() Delay 5 MsgBox "Test" End Sub

السلام عليكم ورحمة الله وبركاته اليك طريقة وضع رقم سري لملف اكسل ( وجدتها من موقع اجنبي ) في اعلى صفحة الاكسل اذهب الى ايقونة ادوات ==> خيارات ==> امان ==> ضعي الرقم السري في الخانتين ( واحد لعدم الاطلاع والاخر لعدم تغييير محتى الصفحة )==> ثم اضغط على خيارات متقدمة ==> اختاري RC4, Microsoft Enhanced Cryptographic Provider v1.0. من غير ان تغيري القيمة التي تظهر والتي هي 128===> اضغط على اوكي ===> اكد الرقم السري على مرتين ====> ثم احفظ عملك في مكان تعرفه جيدا مثل حقيبة الملفات او سطح المكتب للتاكد اعيد فتحه من جديد سيطالبك بالرقمين السريين ( يجب ان تحفظهما وسينبهك اكسل على ذلك ) والله اعلم شكرا لكل من أطلع على الموضوع

المقصود عمل نموذج لتجميع البيانات بجدول واحد