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

-تجهيز مجلدات وملف الصوت الخطوة الاولى قم بانشاء مجلد جديد فى مسار قاعدة البيانات الحالى باسم ( Resurce ) الخطوة الثانية قم بفتح المجلد السابق وقم بانشاء مجلد جديد بداخله باسم ( Audio Files ) الخطوة الثالثة قم بنسخ ملف صوت الى المجلد ( Audio Files ) اما بامتداد wav , .mp3. --------------------- -تجهيز قاعدة البيانات الخطوة الاولى قم بانشاء وحدة نمطية باسم ( modPlayAudio ) وقم بلصق الاكواد الاتية فى هذه الوحدة النمطية Option Compare Database Option Explicit #If VBA7 And Win64 Then Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare PtrSafe Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #Else Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long Private Declare Function playSound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long #End If Const SND_ALIAS_SYSTEMASTERISK As String = "SystemAsterisk" Const SND_ALIAS_SYSTEMDEFAULT As String = "SystemDefault" Const SND_ALIAS_SYSTEMEXCLAMATION As String = "SystemExclamation" Const SND_ALIAS_SYSTEMEXIT As String = "SystemExit" Const SND_ALIAS_SYSTEMHAND As String = "SystemHand" Const SND_ALIAS_SYSTEMQUESTION As String = "SystemQuestion" Const SND_ALIAS_SYSTEMSTART As String = "SystemStart" Const SND_ALIAS_SYSTEMWELCOME As String = "SystemWelcome" Const SND_ALIAS_YouGotMail As String = "MailBeep" ' playsound Params Const SND_LOOP = &H8 Const SND_ALIAS = &H10000 Const SND_NODEFAULT = &H2 ' silence if no sound associated with event Const SND_ASYNC = &H1 ' play async (don't freeze program while sound is playing) Private sMusicFile As String Public soundOn As Boolean Dim mp3Path As String Dim wavPath As String Dim Play As Variant Public Sub Sound_MP3(ByVal File$) sMusicFile = GetShortPath(File) Play = mciSendString("play " & sMusicFile, 0&, 0, 0) If Play <> 0 Then End If End Sub Public Sub Stop_MP3(Optional ByVal FullFile$) Play = mciSendString("close " & sMusicFile, 0&, 0, 0) End Sub Public Function GetShortPath(ByVal strFileName As String) As String Dim lngRes As Long, strPath As String strPath = String$(165, 0) lngRes = GetShortPathName(strFileName, strPath, 164) GetShortPath = Left$(strPath, lngRes) End Function Function IsFile(ByVal fName As String) As Boolean On Error Resume Next IsFile = ((GetAttr(fName) And vbDirectory) <> vbDirectory) End Function Public Function AudioFilePath() As String AudioFilePath = CurrentProject.Path & "\Resurce\Audio Files\" End Function Public Function PlayFile(ByVal FileName_ As String) Dim Msg As String Msg = ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1608) & ChrW(1580) & _ ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(40) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & _ ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) & _ ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & _ ChrW(1608) & ChrW(1580) & ChrW(1608) & ChrW(1583) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & _ ChrW(32) & ChrW(47) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & _ ChrW(1575) & ChrW(1604) & ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(1601) & ChrW(1609) & ChrW(32) & ChrW(1575) & _ ChrW(1604) & ChrW(1605) & ChrW(1587) & ChrW(1575) & ChrW(1585) & ChrW(32) & ChrW(1575) & ChrW(1604) & ChrW(1605) & _ ChrW(1581) & ChrW(1583) & ChrW(1583) & ChrW(32) & ChrW(46) & ChrW(13) & ChrW(10) & ChrW(1578) & ChrW(1571) & _ ChrW(1603) & ChrW(1583) & ChrW(32) & ChrW(1605) & ChrW(1606) & ChrW(32) & ChrW(1575) & ChrW(1587) & ChrW(1605) & _ ChrW(32) & ChrW(32) & ChrW(40) & ChrW(32) & ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(32) & ChrW(47) & ChrW(32) & _ ChrW(1605) & ChrW(1604) & ChrW(1601) & ChrW(1575) & ChrW(1578) & ChrW(41) & ChrW(32) & ChrW(1575) & ChrW(1604) & _ ChrW(1589) & ChrW(1608) & ChrW(1578) & ChrW(32) & ChrW(46) mp3Path = AudioFilePath & FileName_ & ".mp3" wavPath = AudioFilePath & FileName_ & ".wav" StopFile If IsFile(mp3Path) Then Sound_MP3 (mp3Path): Exit Function If IsFile(wavPath) Then playSound (wavPath), vbNull, SND_ALIAS Or SND_NODEFAULT Or SND_ASYNC: Exit Function If IsFile(mp3Path) = IsFile(wavPath) Then MsgBox (Msg), vbOKOnly + vbMsgBoxRtlReading + vbMsgBoxRight: Exit Function End Function Public Function StopFile() playSound vbNullString, ByVal 0&, SND_NODEFAULT Stop_MP3 (mp3Path) End Function الخطوة الثانية قم بانشاء نموذج باسم ( frmPlayAudio ) الخطوة الثالثة قم بانشاء مربع نص فى النموذج السابق باسم ( txtAudioFileName ) الخطوة الرابعة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdPlay ) وفى حدث عند النقر ضع الكود الاتى soundOn = True: PlayFile (Me.txtAudioFileName) الخطوة الخامسة قم بانشاء زر أمر فى النموذج السابق باسم ( cmdStop ) وفى حدث عند النقر ضع الكود الاتى StopFile الخطوة السادسة فى حدث عند إغلاق النموذج ضع الكود الاتى StopFile الخطوة السابعة بعد حفظ ما سبق افتح النموذج وادخل فى مربع النص ( txtAudioFileName ) اسم ملف الصوت الموجود فى المسار المحدد بدون الامتداد مثلا لو ملف الصوت باسم : MyAudio.mp3 Or MyAudio.wav اسم ملف الصوت فى مربع النص ( txtAudioFileName ) يكون فى الشكل الاتى فقط : MyAudio والان جرب الضغط على زر الامر الخاص بالتشغيل تارة وزر الامر الخاص بالايقاف تارة أخرى طيب ملاحظة مهمه : الطريقة ودوال API هنا تقوم بتشغيل ملفات صوت من النوعين MP3 . WAV <<---< والله دلع شغل فاخر من الأخر تم صياغة الكود بمرونه مطلقة للتعامل مع الملف بغض النظر عن امتداد الملف اه والله زيمبئولك كده مش مصدق ليه مش بئولك شغل فاخر اللى مش عاجبه المسار لملفات الصوت او عاوز يغير مكانها او اسمها طبعا فى الموديول يغير فى الروتين ده على مزاجه AudioFilePath() انا شرحت بالتفصيل الممل اياك حد يقول لى عاوز مرفق أو مش عارف يطبق الشرح

لم اجد تفاعل أو اى رد يدل على نجاح فاعلية التطبيق والتجربة وهذه القواعد للتجربة تم مراعاة عند كتابة الأكواد العمل على كل من النواتان 32x , 64x استاذى الجليل الاستاذ @Moosak اردت فقط الاطمئنان على المكتبة العامرة Moh3sam.zip

اذا كنت تقصد اظهار التقويم لاختيار التاريخ عندها يمكن استخدام اداتين date picker او calendar . هذه محاولة بعد القيام بإضافة فورم التقويم والقيام ببعض التعديلات . قم بالنقر مرتين علي خلية التاريخ وسيظهر التقويم . ولكن هذا يتوقف على اصدار الاوفيس اشك انها تعمل مع الإصدارات قبل 2016 واذا واجهتك مشكلة بإظهار رسالة بعدم وجود كائن عنده يجب تنصيبه حتى يظهر لك . حاليا يعمل معي باستخدام بإصدار 2019 تحياتي مطلوب تعديل.xlsm

اذن انت تحتاج - جدول واحد فقط لادخال القوانين فيه حقلان ( رقم المادة - نص المادة ) - نموذج لادخال القوانين للجدول المذكور - نموذج للبحث والطباعة - تقرير لطباعة القانون بعد البحث هذا في رأيي حسب ما ذكرت انت من طلبات ..

قم باضافة التالى Me.Frame1.Height = Me.Frame1.Height + 14 If Me.Frame1.Height > 365 Then Me.Frame1.Height = 365 Me.ListBox2.Height = 280 End If

وعليكم السلام يكفي COUNT بدون شرط إلا إذا كنت تريد عد أرقام محددة فقط =COUNT(B2:B10)

وعليكم السلام ورحمة الله وبركاته ضع هذا قبل اخر End If Me.Frame1.Height = Me.Frame1.Height + 14 Me.ListBox2.Height = ListBox2.Height + 14 Me.Label8.Top = Me.Frame1.Top + Me.Frame1.Height + 10: Me.Label9.Top = Me.Label8.Top + Me.Label8.Height: Me.Label10.Top = Me.Label9.Top + Me.Label9.Height Me.TextBox1.Top = Me.Label8.Top: Me.TextBox2.Top = Me.TextBox1.Top + Me.TextBox1.Height: Me.TextBox3.Top = Me.TextBox2.Top + Me.TextBox2.Height Me.CommandButton1.Top = Me.Label8.Top

عليكم السلام جرب استخدام هذا الكود بعد تحديد الخلايا التي يراد وضع ارتباط تشعبي لها Sub AddHypaerlinks() Dim cl As Range Dim myPath As String, fileName As String myPath = "C:\Users\civat\Desktop\New folder\" 'SET TO WHERE THE FILES ARE LOCATED For Each cl In Selection If Len(cl) > 0 Then fileName = myPath & cl.Value & "*.docx" 'IF THE FILE EXISTS THEN If Len(Dir(fileName)) <> 0 Then ActiveSheet.Hyperlinks.Add cl, myPath & Dir(fileName) End If Next End Sub بالتوفيق

تفضل مثال ارسال البيانات.zip

افضل طيقة بأن تقوم بتصميم التقارير على ملف وورد مرفق مثال لإرسال البيانات من الاكسس الى الوورد سيتم حفظ ملف الوورد بصيغتين Word و PDF RepToWord.zip

عملية البحث طبيعية ولا مشكلة في الكود ويرجع سبب الحصول على أرقام أخرى أن عملية البحث غير مطابقة وإنما باللواصق (ما قبلها وما بعدها) "*" & Me.TextBox1 & "*" فلو بحثنا عن الرقم 2 يجلب لنا 2 و 12 و 22 و 25 و 32 وهكذا وإذا أردنا أن يكون البحث عن الأرقام مطابقا يجب إضافة شرط لمعيار البحث باستبدال السطر الثاني إلى هذا السطر clé = IIf(Me.combobox1.Value = "الرقم" Or Me.combobox1.Value = "عدد الحروف" Or Me.combobox1.Value = "عدد الكلمات", Me.TextBox1, "*" & Me.TextBox1 & "*"): n = 0 بالتوفيق

عليكم السلام يمكنك وضع هذه المعادلة في الخلية F3 =(SUM(B3,E3)-SUM(A3,D3))*24 بالتوفيق

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

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

🤔

تفضل هذا الملف .على الرغم ان كان عليك من البداية رفع ملف بالمشاركة فلا تعنى أى مشاركة شيء بدون ملف يدعمها Colored.xlsb

تفضل <><><><><><> 01.accdb

اتفضل اداة تساعدك مستقبلا من تصميم الاستاذ القدير @Moosak اتفضل شوف الدرس ده ان اردت الشرح والايضاح

وعليكم السلام ورحمة الله تعالى وبركاته اليك الملف بعد التعديل على كود الاستاد @حسونة حسين واظافة جميع الاكواد الازمة محمد 4.xlsm

وعليكم السلام ورحمة الله وبركاته حبا وتقديرا للاستاذ الفاضل @ياسر خليل أبو البراء تفضل مواقيت الصلاة.xlsb

السلام عليكم خير الكلام ما قل ودل . اللهم صل على محمد وآله وصحبه . بسبب ملاحظتي لحرص البعض _خاصة المستجدين _ على مسألة الحماية واستخدام طرق معقدة والبحث عن الجديد والأقوى احببت ان انشر تجربتي وخبرتي في هذه المسألة كأيسر وكذلك اقوى طريقة . الحماية من جهتين : 1- حماية البيانات وهي الجداول .. وهذه تهم المستخدم ( العميل) 2- حماية البناء ..( التصميم بما يشتمل من اكواد وغيرها ) وهذه تهم المبرمج ----------------------------------- الجهة الأولى : 1- اكسس ضعيف جدا في حماية جداوله .. لأن اي مستخدم مهما ضعفت صلاحياته يمكنه التمكن من الجداول ( نسخ / تغيير / حذف) 2- اي شخص يملك قاعدة بيانات اكسس يمكنه الوصول الى الجداول ما لم يتم حمايتها بكلمة مرور اكسس 3- ينطبق هذا على القواعد المقسمة حيث يجب تفعيل كلمة مرور اكسس على الواجهات الأمامية قبل عرض كلمة مرور المستخدم ، والا ستكون الجداول في متناول اليد . نأتي للجهة الثانية وهي ما يخص المبرمج : من خلال تجارب وخبرة سنوات افضل طريقة تريح المبرمج وكذلك العميل وبعيدا عن غرس الملفات والريجستري والفلاش : الاعتماد على رقم سيريال واحد من عتاد الجهاز ( قرص صلب / معالج / اللوحة الأم ) بشرط ان يكون الرقم اساسي خاصة القرص الصلب لا يتغير عند عمل التهيئة . فكون الرقم اساسي لا يتغير يفيد العميل عندما يقوم بتهيئة القرص ، وهو مريح ايضا للمبرمج ( يوجد كثير من المواضيع هنا في هذا المنتدى تشرح عملية استخلاص ارقام القطع الداخلية لجهاز الحاسب .. ابحث ) الخطوات : --------------------------------- - استخراج واستخلاص الارقام من السيريل ( غالبا يأتي مختلط بارقام وحروف) سيظهر هذا الرقم للعميل في فورم التسجيل واسفله حقل لادخال رقم النسخة ------------------------------- - نعمل دالة1 = استقطاع جزء محدد من النتيجة .. مثلا خمسة ارقام او اربعة ارقام من اليمين او من اليسار ( استقطاع ثابت) - نعمل دالة2 = اجراء معادلة على دالة1 ، مثلا ( دالة1 (x) 1234567 + 53954 ) ------------------------------- - عندما يرسل العميل رقم السيريل ويطلب رقم النسخة نقوم بعمل المعادلة ومن ثم نرسلها للعميل نتيجة هذه المعادلة ستبقى ملك دائم لجهاز حاسب واحد ما دام على قيد الحياة -------------------------------------------------------------------------------------------------------------- ما ذكرته اعلاه هو للنسخة الدائمة .. أما النسخة المؤقته فأقوم بعملها كالتالي : يجب ان يكون العمل مقسم الى واجهات وجداول . يجب ان اتعامل مع العميل على اساس نسختين من الواجهات : مؤقتة / دائمة الفرق بين الواجهة المؤقتة والواجهة الدائمة .. هي زيادة سطرين بشرطين في المؤقتة 1- الشرط 1: لن تفتح المؤقتة الا مع وجود الأنترنت شغال 2- نضع سطرا نحدد تاريخ توقف البرنامج ( يتم جلب التاريخ من الانترنت ) لنفرض انتهت مدة التجربة بعد شهر او شهرين .. وتم الشراء .. هنا نرسل الواجهة الدائمة للصق والاستبدال . هنا نكون حافظنا على بيانات العميل المدخلة وعلى حقوقنا البرمجية ----------------------------------------------------- نقطة اخيرة : سيتبادر الى الذهن ! اين يحفظ رقم النسخة ؟ لأن البرنامج سيطلبه عند كل اقلاع ؟ الجواب : ما دام رقم النسخة ملكا للجهاز فيمكن حفظه في اي مكان ، مثلا في حقل في جدول بشرط ان يحتوي الجدول على سجل واحد فقط او يمكن حفظه في ملف نصي بجانب قاعدة البيانات وهذه الطريقة الاخيرة هي الافضل بل تجب اذا تم توزيع الواجهات على اكثر من جهاز .. والسبب ان كل جهاز سيكون له رقمه الخاص هذا ما لدي آمل تجدوا فائدة

تفضل اخى الفاضل ياسر جرب الملف Example (1).xlsm

وعليكم السلام ورحمة الله وبركاته استخدم هذه المعادلة لعلها المطلوبة =COUNTIF(B1:B10;">0")

حسب فهمي للمطلوب طبعا بعد جعل جميع خلايا الشيت مؤمنة ومخفية locked & hidden ما عدا الخلايا المسموح بالكتابة فيها (بحذف علامة الصح بجوار locked & hidden ) من التبويب الأخير لنافذة تنسيق الخلايا (protection حماية ) ثم اثناء حماية الشيت من تبويب مراجعة review قم بإلغاء تحديد الخلايا المؤمنة (الملونة باللون الأصفر في الصورة التالية) بالتوفيق

إن شاء الله يفيدك هذا الملف نموذج بسيط لاختيار الوقت مثل اختيار التاريخ بالتوفيق time picker.xlsb

لا , لا يمكن لانه لا يعرف ماذا حفظت في ريجيستري بالتفصيل , واذا عرف ذلك نعم يمكن ... بهذه الطريقة حسب المثال الاعلى DeleteSetting "aa", "bb", "trial"

السلام عليكم جرب الكود التالي Sub Test() Dim sRow As Long, eRow As Long sRow = 8: eRow = 19 With ActiveSheet .Range("D" & sRow & ":D" & eRow).Value = .Range("F" & sRow & ":F" & eRow).Value .Range("E" & sRow & ":E" & eRow).Value = 0 End With End Sub

السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مكتبة الأكواد الخاصة) :: الإصدار الثالث :: مكتبة عامرة بمئات الأكواد VBA داعمة للمبرمجين وجزء لا يتجزأ من عملهم. تختصر الوقت وتسهل العمل على مصممي البرامج. وهي مكتبة عامة يمكن استخدامها لأي لغات برمجية أخرى . من مميزات المكتبة : - أكثر من 360 كود ودالة في مختلف الفنون والمجالات . - قابلة لحفظ مرفقات مع الكود لدعم التطبيق. - يمكنك إضافة أكوادك الخاصة لتكون مكتبة داعمة لكل مبرمج. - سهلة الاستخدام . تحميل المكتبة : مكتبة الأكواد الخاصة zip.zip ولا تنسوني من صالح دعواتكم 🙂🌹

تفضل اخى الفاضل @محمد متولي اتمنى ان يكون هذا كا تريده بناءا على توضيح مطلبك ولكن يجب ان يكون ترتيب البيانات كما هو بالظبط ايضا تاكد من النتيجة لكل موظف قبل اعتماد المعادلة تقبل تحياتى سلف العاملين 2023.xlsx

في حدث بعد التحديث (يعني بعد كتابة الاسم كاملا) تكتب هذا Replace ( [NameText], "عبد " , "عبد") ' للتأكد من عدم وجود مسافتين Replace ( [NameText], " عبد " , "عبد")

تفضل اخى الفاضل @عمر الجزاوى قمت باضافة بعد التعديلات كالتالى هذا بخصوص ListBox1 اذا كان رصيد الصنف اقل من او يساوى صفر عدم اضافة الصنف واظهار رسالة بان الرصيد لهذا الصنف قد انتهى عند اختيار الصنف لاكثر من مرة ووصول الكمية لاكبر من رصيد المخزن عدم اضافة الصنف واظهار رسالة بان الرصيد لا يسمح حيث انه لا يصح الصرف اذا كان الرصيد صفر او تعدت الكمية المباعة الرصيد الفعلى للصنف اما بخصوص ListBox2 يمكن ان تقوم بازالة منتج من الفاتورة فقط قم بالنقر على الصنف المراد حذفه من الفاتورة مرتيين تقبل تحياتى المصنف1.xlsm

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

ما شاء الله تبارك الله ممتاز اخي الكريم والتصميم هادئ ومختصر .... استمر ....

Range("AB8") = t t = "" Set fnd = .Find("Û", , , 1) v = fnd.Address If Not fnd Is Nothing Then Do t = IIf(t = "", Cells(2, fnd.Column).Text, t & "+" & Cells(2, fnd.Column).Text) Set fnd = .FindNext(fnd) Loop Until v = fnd.Address End If Range("AB10") = t End With

والله أعلى وأعلم على قدر معلوماتى للاسف PlaySound API الخاصة بتشغيل ملفات صوت ذات الامتداد WAV لا تدعم الإيقاف المؤقت/الاستئناف وننتظر من اساتذتنا أهل الخبرة مراجعتنا فى هذه النقطة إن أمكن وهذا تعديل بسيط علشان خاطر عيونك تدلل PlayAudio V0.2.zip

يجدر القيام بحلقة تكرارية في هذه الحالة Sub delete_tools() Dim ws As Worksheet For Each ws In Worksheets ws.DrawingObjects.Delete Next ws End Sub

السلام عليكم و رحمة الله و بركاتة ياسر خليل أبو البراء احمد عبدالحليم أسأل الله العلي القدير إنه يجعل ماتقدمونه من خدمة ومساعدة للناس في فعل الخير يجعله في ميزان حسناتكم وان لايحرمكم الأجر

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

بعد اذن استاذنا الغالي @ابو جودي اتفضل المرفق اتمنى يكون مطلوبك https://wayprograms.blogspot.com/ محاسب العمال.rar

وعليكم السلام ورحمة الله وبركاته في البداية خلينا نشوف مصدر هذه القوانين .... اعني هل تكتب أم تستورد من ملف اكسل مثلأ ... وهل ممكن عينة لمثل هذا الملف حتى ننظر فيما يمكن صنعه ؟؟

السلام عليكم ورحمة ورحمة الله كان هذا طلبك وتم الاجابة عليه باكثر من طريقة من الاخوة الافاضل انتهى من التصميم ثم فكر فى الحل قم بتغيير التالى x = Columns(1).Cells.Find(Range("N6"), , , 1).Row هنا هتغير حاجتين رقم العمود حيث كان العمود a وهو رقم 1 بالعمود الذى يحتوى على اكواد الموظفين وكمان هتغيير الخلية n6 وهى التى تحتوى على رقم كود الموظف بالخلية الجديدة التى تحتوى على كود الموظف Range("N8") = Cells(x, 2) هنا هتغير حاجتين Range("N8") بالخلية الجديدة التى اصبحت تحتوى على اسم الموظف وكمان هتغير Cells(x, 2) رقم 2 برقم العمود الذى اصبح يحتوى على اسماء الموظفين حسث كان سابقا هو العمود b اى رقم 2 Set r = Cells(x, 1 + Split(Range("N4").Text, "-")(0) * 1).Resize(, 1 + Split(Range("P4").Text, "-")(0) * 1) هنا هتغير Range("N4") باسم الخلية التى تحتوى على تاريخ البداية باسم الخلية الجديدة وكمان هتغيير Range("P4") تاريخ النهاية باسم الخلية الجديدة لتاريخ النهاية واكمل باقى باقى التغييرات بنفس النمط او قم برفع ملف لعمل التعديلات المطلوبة مفيش حد هيكتب توقعات على اساس التعديل الذى قمت به تقبل تحياتى

السلام عليكم وبها نبدأ تفضل كود التعديل Private Sub CommandButton4_Click() Dim SH As Worksheet, X, I As Long Set SH = ThisWorkbook.Worksheets("كي جي1") If TextBox1.Value = "" Then MsgBox "من فضلك ادخل الاسم الذي تريد البحث عنه يا عم سعد", vbCritical, "تنبيه يا عم سعد": Exit Sub X = Application.Match(Val(TextBox1.Value), SH.Columns("C"), 0) If Not IsError(X) Then For I = 1 To 10 SH.Cells(X, I + 2).Value = Controls("TextBox" & I).Value Next I SH.Range("M" & X).Value = openpic Else MsgBox "الاسم غير موجود" End If End Sub

من الواضح أن إجراء التمكين غير موجود والذي يسمى enableply لذلك يمكنك استعمال هذين الاجرائين للتعطيل Private Sub Workbook_Open() Application.CommandBars("Ply").Enabled = False End Sub للتمكين Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.CommandBars("Ply").Enabled = True End Sub بالتوفيق

يمكنك استعمال هذه المعادلة في B3 =WORKDAY.INTL(A3-1,D3,16) بالتوفيق

وعليكم السلام إليك هذه المحاولة New Microsoft Excel Worksheet.xlsx

السلام عليكم نظرا لبعض طلبات الاعضاء الكرام . خاصة ممن يقومون بعمل برامج من أجل كسب العيش أعانهم الله فيما يخص حماية الاكواد التي بملفاتهم لانه عادة ما تحصل سرقة لبرامجهم و هذا بسبب ان أكسل لا يوفر الخماية الكاملة اضافة الى أن هناك برامج تقوم بكشف كلمات سر الملف ببساطة. لذلك اردت أن أقدم فكرة و هي تحويل الكود البرمجي الى ملف DLL مما يوفر حماية قوية للملف عن طريق برنامج vbacompiler for excel و لكن للاسف غير مجاني و هو برنامج يقوم بتحويل الاكواد بالملف الى ملف DLL و تغيير الاكواد بالملف لتستدعى ملف DLL الذي تم انشاؤه و يعمل الملف بكفاءءة عالية لقد قمت بالتجريب و فعلا نتيجة رائعة. يمكنك تحميل البرنامج كنسخة تجريبية . و بالنسبة للذين يعملون البرامج و يبيعونها و يكسبون العيش مننها يمكنهم شراء النسخة الكاملة كيف تحمي ملفك ؟ يمكنك وضع كود خاص بكلمة السر و السريال نمبر للهارد ديسك و ييمكنك وضع الكود التالي عند فتح الملف WORK BOOK OPEN يعني اذاكان رقم السريال نمبر هو مثلا : FFFFF-FFFFF-FFFFF ادخل الرقم السري 222222 و اذا كان خطأا اغلق الملف Private Sub Workbook_Open() Dim RAD As String If CreateObject("Scripting.FileSystemObject").GetDrive("C:\").SerialNumber = "FFFFF-FFFFF-FFFFF" Then RAD = InputBox("Enter password:") If LCaseRAD <> "222222" Then ActiveWorkbook.Close False End If End Sub و بعد الانتهاء من عمل ملف افتح برنامج vbacompiler for excel و جول ملفك الى ملف جديد معه ملف DLL يمكنك التجريب على أي ملف لقد قمت بتجريب البرنامج على ملف أحد الاعضاء و النتيجة بالمرفقات الملف عبارة عن كود بسيط يبحث عن تكرار في عمودين و نقل المكرر الى عمود ثالث هدا الكود مثلا قبل استعمال برنامج vbacompiler for excel Sub brg() ScreenUpdating = False Dim lr As Integer Dim lr1 As Integer Dim c As Range lr1 = ActiveSheet.Range("g" & Rows.Count).End(xlUp).Row For Each c In ActiveSheet.Range("c2:c1000") lr = ActiveSheet.Range("i" & Rows.Count).End(xlUp).Row If WorksheetFunction.CountIf(ActiveSheet.Range("g2:g" & lr1), c.Value) >= 1 Then Cells(lr + 1, 9) = c.Value On Error Resume Next End If Next ScreenUpdating = True End Sub و هذا بعد استعمال البرنامج #If Win64 Then Private Declare PtrSafe Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq" () #Else Private Declare Sub p0iflwmc269 Lib "EXEMPLE_xlsm_64.dll" Alias "r8rfyae98n05rlq@0" () #End If Sub brg() p0iflwmc269 End Sub Option Private Module #If Win64 Then Private Declare PtrSafe Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook" (ByVal twbk As Object) As Long Private Declare PtrSafe Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal obj As Object) As Long Private Declare PtrSafe Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" (ByVal i As Long, ByVal mp As LongPtr) As Long Private Declare PtrSafe Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" () As Variant Private Declare PtrSafe Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" (ByVal dst As Any, ByVal src As LongPtr, ByVal sz As Long) Private Declare PtrSafe Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" (ByRef p() As Any) As LongPtr Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As LongPtr Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As LongLong Private Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As LongPtr #Else Private Declare Function SetThisWbk Lib "EXEMPLE_xlsm_64.dll" Alias "SetThisWorkbook@4" (ByVal twbk As Object) As Long Private Declare Function u6hpyov9dx5 Lib "EXEMPLE_xlsm_64.dll" Alias "u6hpyov9dx5@8" (ByVal i As Long,ByVal obj As Object) As Long Private Declare Function c1smc91ey1mls Lib "EXEMPLE_xlsm_64.dll" Alias "c1smc91ey1mls@8" (ByVal i As Long,ByVal mp As Long) As Long Private Declare Function s1a3nzo1yqora3l Lib "EXEMPLE_xlsm_64.dll" Alias "s1a3nzo1yqora3l@0" () As Variant Private Declare Sub d0np2x0oglsn Lib "EXEMPLE_xlsm_64.dll" Alias "d0np2x0oglsn@12" (ByVal dst As Any,ByVal src As Long,ByVal sz As Long) Private Declare Function p8t9c8qi9tgx Lib "EXEMPLE_xlsm_64.dll" Alias "p8t9c8qi9tgx@4" (ByRef p() As Any) As Long Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal libFileName As String) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long #End If Private Function k7wgf46mba0cj8() As String On Error Resume Next k7wgf46mba0cj8 = ThisWorkbook.Path + "\EXEMPLE_xlsm_64.dll" End Function Public Sub p8oi75y3jrid8() #If Win64 Then Dim hModule As LongPtr Dim dllPath As String Dim msg As String On Error Resume Next dllPath = k7wgf46mba0cj8() hModule = LoadLibrary(dllPath) If hModule = 0 Then MsgBox "Cannot load '" & dllPath & "'" ThisWorkbook.Close False Else c1smc91ey1mls 1&, AddressOf u4fw2npwzdn25f4 If SetThisWbk(ThisWorkbook) Then u6hpyov9dx5 3&, Sheet1 u6hpyov9dx5 4&, Sheet2 u6hpyov9dx5 2&, ThisWorkbook ThisWorkbook.Saved = True Else GoTo qpnt End If End If #Else MsgBox "This workbook can work with 64 bit Excel only" ThisWorkbook.Close False #End If Exit Sub qpnt: ThisWorkbook.Close False End Sub Public Sub x1u5slqd9g() On Error GoTo errh SetThisWbk (ThisWorkbook) Exit Sub errh: p8oi75y3jrid8 End Sub Public Function q7uobay8mw() As Boolean On Error Resume Next q7uobay8mw = GetModuleHandle("EXEMPLE_xlsm_64.dll") <> 0& End Function #If Win64 Then Public Function FreeCompiledDll() As LongLong Dim i As Long Do FreeCompiledDll = FreeLibrary(GetModuleHandle("EXEMPLE_xlsm_64.dll")) i = i + 1 Loop While FreeCompiledDll <> 0 And i < 100 End Function #End If Private Sub auto_open() x1u5slqd9g End Sub Private Sub auto_close() #If Win64 Then On Error Resume Next Dim p As Variant ThisWorkbook.Saved = True SetThisWbk Nothing p = s1a3nzo1yqora3l FreeCompiledDll If p <> "" Then Kill p & "cbinrtl.dll" RmDir p End If #End If End Sub Function u4fw2npwzdn25f4(ByVal v7liriqd8 As Variant, ByVal m8g6onrhcrw As Variant, ByVal m7jy4oel As Variant, ByRef j8yhrsbf2() As Variant) As Variant On Error Resume Next Dim sz As Long sz = UBound(j8yhrsbf2) - LBound(j8yhrsbf2) + 1 Select Case sz Case 0 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel) Case 1 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0)) Case 2 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1)) Case 3 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2)) Case 4 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3)) Case 5 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4)) Case 6 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5)) Case 7 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6)) Case 8 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7)) Case 9 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8)) Case 10 u4fw2npwzdn25f4 = CallByName(v7liriqd8, m8g6onrhcrw, m7jy4oel, j8yhrsbf2(0), j8yhrsbf2(1), j8yhrsbf2(2), j8yhrsbf2(3), j8yhrsbf2(4), j8yhrsbf2(5), j8yhrsbf2(6), j8yhrsbf2(7), j8yhrsbf2(8), j8yhrsbf2(9)) End Select End Function و الملف يعمل بكفاءة جيدة يمكنكم التجربة من المرفقات ملف خاص بعد التشفير ب اوفيس 64 و ملف خاص بعد التشفير ب اوفيس 32 و السلام عليكم و تقبل الله منا و منكم الملف بدون تشفير.rar الملف مشفر مع ملف DLL لنسخة اوفيس 32.rar الملف مشفر مع ملف DLL لنسخة اوفيس 64.rar

لتكبير حجم الفورم بطريقة احترافية توصلت و اخيرا لهذا الكود بدون مشاكل ان كان السيستم 32 او 64 😉 #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long) #End If Option Explicit 'http://www.mrexcel.com/archive/VBA/24009.html Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long Private Const GWL_STYLE As Long = (-16) 'Sets a new window style Private Const WS_SYSMENU As Long = &H80000 'Windows style Private Const WS_MINIMIZEBOX As Long = &H20000 Private Const WS_MAXIMIZEBOX As Long = &H10000 Private Const SW_SHOWMAXIMIZED = 3 Private Sub UserForm_Activate() Dim lFormHandle As Long, lStyle As Long '=========================================== '= Originally from Dax = '= Modified with comments by Ivan F Moala = '= 22/07/01 = '=========================================== 'Lets find the UserForm Handle the function below retrieves the handle 'to the top-level window whose class name ("ThunderDFrame" for Excel) 'and window name (me.caption or UserformName caption) match the specified strings. lFormHandle = FindWindow("ThunderDFrame", Me.Caption) 'The GetWindowLong function retrieves information about the specified window. 'The function also retrieves the 32-bit (long) value at the specified offset 'into the extra window memory of a window. lStyle = GetWindowLong(lFormHandle, GWL_STYLE) 'lStyle is the New window style so lets set it up with the following lStyle = lStyle Or WS_SYSMENU 'SystemMenu lStyle = lStyle Or WS_MINIMIZEBOX 'With MinimizeBox lStyle = lStyle Or WS_MAXIMIZEBOX 'and MaximizeBox 'Now lets set up our New window the SetWindowLong function changes 'the attributes of the specified window , given as lFormHandle, 'GWL_STYLE = New windows style, and our Newly defined style = lStyle SetWindowLong lFormHandle, GWL_STYLE, (lStyle) 'Remove >'< if you want to show form Maximised 'ShowWindow lFormHandle, SW_SHOWMAXIMIZED 'Shows Form Maximized 'The DrawMenuBar function redraws the menu bar of the specified window. 'We need this as we have changed the menu bar after Windows has created it. 'All we need is the Handle. DrawMenuBar lFormHandle End Sub

اهلا بك فى المنتدى , يمكنك هذا بالدالة المعرفة ConvertDate ... بوضع هذه المعادلة بالخلية D5 سحباً للأسفل وهذا هو كود الدالة Option Explicit Function ConvertDate(ByRef StringIn As String) As String Dim savedCal As Integer Dim d As Date Dim s As String savedCal = Calendar Calendar = 1 d = CDate(StringIn) Calendar = 0 s = CStr(d) ConvertDate = Format(s, "dd/mm/yyyy") Calendar = savedCal End Function المصنف1.xlsm

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

xlsاوفسينا.xls