المشروع الكبير (مكتبة الصرح .. زاخرة بالشرح) وهي عبارة عن تجميع لمكتبة الأكواد

[مختار حسين محمود]

كود  ترفيهى مع الاكسل  ( اختفاء الملف ثم الظهور بعد مدة زمنية محددة )

Public Sub HideExcelMakeExcelInvisible()

'   اخفاء ملف الاكسل من أمامك

Application.Visible = False

'  المدة الزمنية التى يظهر بعدها ملف الاكسل

Application.Wait Now + TimeValue("00:00:10")

'  أمر ظهور الملف

Application.Visible = True

End Sub

                       

 

 

==================================================           

 

 

 

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

 

 

******************************************************************

 

 

كل سنة وأنتم أقرب الى الله

                                  

                                        

تم تعديل يناير 4, 2015 بواسطه مختار حسين محمود

[مختار حسين محمود]

كود انتهاء صلاحية ملف فى تاريخ محدد مع فتح الملف بكلمة سر     الحمد لله     ( يوضع فى حدث الـــ workbook  )    

Private Sub Workbook_Open()

'تحديد انتهاء صلاحية ملف اعتبارا من تاريخ محدد والفتح بكلمة الحمد لله 
If Date > DateValue("1/1/2015") Then
    If InputBox ("من فضلك أدخل كلمة السر ")   <> "الحمد لله"  Then
' رسالة لو كلمة المرور خاطئة
        MsgBox "كلمة مرور خاطئة "
' وغلق الملف لو كلمة المرور خاطئة
        ThisWorkbook.Close
        Else
' اذا كانت كلمة المرور  صحيحة ترى الرسالة التالية
        MsgBox "تفضل بالدخول كلمة مرورك صحيحة  "
    End If
End If
End Sub

[مختار حسين محمود]

أستاذى ياسر أنا متوصى بيك النهردة أهــــه

كود بحث عن طالب باستخدام رقمه السرى   ( يوضع فى حدث الـــورقة  ) 

Private Sub Worksheet_Change(ByVal Target As Range)

    Application.ScreenUpdating = False
     
    ' هنا نحدد رقم الصف الرقم السرى   

    If Target.Column <> 6 Then Exit Sub

     ' هنا نحدد عنوان الخلية التى سنضع بها الرقم السرى للطالب الذى سنبحث عنه

    If Not Range("f6") = "" Then
     
    
    Range("f6").Select

    Range(Selection, Selection.End(xlDown)).Select

    ' عند الكتابة فى الخلية تحدث عملية فلترة وظهور الاسم الذى تبحث عنه فقط فى شيتك
    Selection.AutoFilter Field:=1, Criteria1:=[f6], Operator:=xlOr

    Application.ScreenUpdating = True
    ' رسالة حمد بعد ظهور الاسم 
    MsgBox "بحمد الله تعالى تم اظهار الاسم ", vbInformation + vbMsgBoxLEFT, " مع تحيات / مختار حسين محمود "
    
    End If
    
        
    Application.ScreenUpdating = True

   ' ملحوظه : لإعادة اظهار جميع الأسماء امسح الرقم السرى من الخلية عندها ستظهر كل الاسماء

   
   End Sub

[numanawwad]

 

الأخ الفاضل نعمان عوض ..

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

الآن بعون الله وتوفيقه بدأت فكرة المشروع تظهر بوادرها وإن شاء الله قريباً سيكتمل المشروع ويكون نبراسا للجميع ، ويسهل عملية البحث والتطبيق والتنفيذ

الأخ الحبيب مختار ..

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

وننتظر منك المزيد المزيد (رحم الله والديك وغفر لهما وجعل الجنة مثواهما)

أريدك سنداً لي في المشروع فلا تخذلني

 

 

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

[ياسر خليل أبو البراء]

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

فلقد أشعلتم الأمل في من جديد بعدما ظننت لوهلة أن الموضوع غير ذو أهمية بالنسبة للكثيرين ...

ومشكور على الأكواد الرائعة ..

أخي مختار كود إختفاء تطبيق الإكسيل لفترة محدودة ..هل بحثت عنه بالمكتبة؟

اكتب كلمة تطبيق في مربع البحث ثم اضغط على زر البحث ستجد أن الكود موجود
هذا لإشعار الجميع بأهمية البحث في المكتبة أولاً فقد تجد مبتغاك بدون معاناة البحث ، وعندما تجد مبتغاك ستجد الشرح مرفق بكيفية التطبيق للكود

أسعد الله أوقاتكم إخواني

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

[مختار حسين محمود]

 صراحةً أستاذى الفاضل لم أبحث

 

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

 

و سوف أراعى  هذا فى المستقبل ان شاء المولى عزوجل .                                      تحياتى وبالتوفيق

[ياسر خليل أبو البراء]

أخي الحبيب مختار

لا تأخذ الكلام بمحمل آخر (مش عايزك تزعل مني إنت حبيبي في الله)

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

ومشكور والله أخي مختار على تعاونك المثمر معي

وفي انتظار المزيد ... ولا تنسى كما تفعل أن تدعم الأكواد بشروحات

[ياسر خليل أبو البراء]

إخواني الكرام تفضلوا الإصدار الأخير من مكتبة الصرح

وإليكم فهرس المكتبة إلى الآن

تغيير عنوان تطبيق الإكسيل
إخفاء وإظهار شريط الصيغ (المعادلات)
إظهار الشاشة (نافذة تطبيق الإكسيل) بالكامل
فتح الـ CD-ROM وإغلاقه
دالة فصل الحروف عن الأرقام
تغيير عنوان الفورم
الحفظ والخروج التلقائي من الإكسيل
حفظ المصنف وإغلاقه
تصدير البيانات من الإكسيل إلي الأكسيس
إنشاء فهرس بأوراق العمل
إظهار رسالة عند فتح المصنف
إخفاء وإظهار عناوين الصفوف والأعمدة
إظهار وإخفاء أوراق العمل عن طريق مربع اختيار
توليد أرقام عشوائية
ربط Label في فورم بقيمة في خلية
منع إضافة أوراق عمل جديدة
منع عملية الطباعة في المصنف وأوراق العمل
التبديل بين حماية ورقة عمل وإلغاء الحماية
رسالة تحذير عند فتح الملف
قبول TextBox لحروف فقط أو أرقام فقط
فورم رزنامة تقويم Calendar لإدراج التواريخ
عمل عداد Counter
صندوق إدخال لمضاعفة العدد
إخفاء وإظهار شريط الحالة
كتابة جملة في شريط الحالة
معاينة ما قبل الطباعة
تحديد عدد مرات استخدام البرنامج
إخفاء ورقة عمل وإظهارها بكلمة سر
تقسيم الخلية إلى عدة أسطر (إلتفاف النص)
استعادة أشرطة الأدوات CommandBars
الفرز Sort حسب العمود المختار
حذف الملف لنفسه بعد استخدامه 3 مرات
مسح محتويات نطاق بعد وقت محدد
إغلاق ملف الإكسيل بعد وقت محدد
تشغيل الماكرو أوتوماتيكياً بعد مرور 10 ثواني
تشغيل الماكرو في وقت محدد
فرز البيانات أوتوماتيكياً بمجرد النقر المزودج
دالة جمع الخلايا الملونة وعدها
ملائمة عرض العمود لمحتوى النص
دالة إرجاع اسم اليوم لتاريخ معين
تغيير لون الخلايا عشوائياً
إخفاء تطبيق الإكسيل لفترة من الزمن
تنسيق أجزاء النص داخل الخلية الواحدة
تلوين الخلية النشطة
تلوين صف وعمود الخلية النشطة
دالة معرفة عدد أيام الشهر لأي تاريخ
حماية فورم بكلمة مرور متغيرة
إخفاء الصفوف إذا كانت قيمة الخلية صفر أو فراغ
إظهار جميع الصفوف والأعمدة في ورقة العمل
حذف القيم المكررة داخل نطاق
طباعة محتوى مربع القائمة ListBox من الفورم
إخفاء وإظهار شريط الإكسيل Ribbon
إخفاء وإظهار تبويبات أوراق العمل Sheet Tabs
استرجاع البيانات عن طريق فتح المصنف
الانتقال إلى أي كلمة داخل المصنف (البحث Find)
ربط المصنف بوجود برنامج منصب على جهازك
التحكم المطلق بمربع النص TextBox
عمل شاشة توقف Screen Saver (محمية )
الترقيم التلقائي لنطاق معين
انتهاء صلاحية مصنف في تاريخ محدد
بحث عن طالب برقمه السرى (البحث بالفلترة)
ترقيم أي خلية في العمود C تبعاً لرقم الصف
توليد كود عشوائي (سيريال نمبر عشوائي)
حماية فورم بكلمة مرور متغيرة حسب الوقت والتاريخ
دالة تقوم بإرجاع اسم أول يوم وآخر يوم في الشهر
عمل شاشة توقف Screen Saver (كود سهل)
منع تغيير اسم ورقة العمل

Codes Library v1.7.rar

تم تعديل يناير 4, 2015 بواسطه YasserKhalil

[ibn_egypt]

أخى الفاضل وأستاذي الكريم

 

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

 

كود تحديد القيم 0 وتلوينها

 

كود تلوين الصفوف الفارغة في نطاق محدد

 

كود منع ال Right-Click او ال Double-Click داخل الشيت

 

كود تلوين الخلية بالأحمر عند الضغط عليها Double-Click

 

كود تلوين القيم الفريدة والقيم المكررة داخل نطاق محدد

 

كود تلوين الخلايا الفارغة في نطاق محدد

 

كود تلوين الخلايا التى بها قيم وتجاهل الفارغة

 

كود تلوين الخلايا التى بها أخطاء

 

كود ازالة التنسيق الشرطي السابق من النطاق

 

كود جعل علامة X (الاغلاق ) بالفورم غير نشطة

 

كود تقسيم الاوراق الى ملفات منفصلة

 

 

حاجات خفيف خفيف كده، وأول الغيث قطرة، وعذرا للتأخير، مرفق الملف زبط بقي على كيفك وضيف ما تريده للمكتبة

 

تحياتي  

Codes.rar

[سيف الدين حسام]

تحياتى للجميع لا اجد قولا افضل ولا أحق من ذلك الذى قاله

رسولنا الكريم صلى الله عليه وسلم

خيركم من تعلم العلم وعلمه

[Yasser Fathi Albanna]

وهذا كود الفرق بين تاريخين

مشاركة منى ومش عارف هذا الكود موجود من قبل أم لا

أعتزر إن كان موجود من قبل

Sub DateExample2()
    Dim dtmStartDate As Date
    dtmStartDate = #5/2/2010#
    MsgBox DateDiff("m", dtmStartDate, Date) & " Months"
End Sub

[Yasser Fathi Albanna]

وهذا الكود وجدته ولكن لا أعرف فائدته

Sub RandomNumber()
    Dim intNumber As Integer
    intNumber = Int((100 * Rnd) + 1)
    MsgBox intNumber
End Sub

[Yasser Fathi Albanna]

السيد الفاضل

وجدت هذه الأكواد من فترة ولكن أريد شرح لها

وهل يمكن الإستفادة منها

Sub WhichLibrary()
    'Excel's Round function
    MsgBox Application.WorksheetFunction.Round(10.2356, 2)
    'VBA's Round function
    MsgBox Round(10.2356, 2)
End Sub

Sub StringExample1()
    Dim strString As String
    strString = "Microsoft Excel VBA"
    'Returns 17 (17th character starting from first character)
    MsgBox InStr(1, strString, "V", vbTextCompare)
    'Returns 7 (7th character from left starting ‘at the sixth position)
    MsgBox InStr(6, strString, "o", vbTextCompare)
End Sub

Sub StrngExample2()
    MsgBox Format(12.5 * 1.175, "£0.00")
End Sub

[Yasser Fathi Albanna]

وهذ كود رسالة ترحيب

Sub ConcatenateExample()
    Dim FName As String, SName As String
    FName = "Engineer"
    SName = "Yasser"
    MsgBox "Welcome " & FName & " " & SName
End Sub

[Yasser Fathi Albanna]

وهذا كود حماية ورقة العمل عن طريق نوع القيمة

 Sub SetProtection()
    On Error GoTo errorHandler

    Dim myDoc As Worksheet
    Dim cel As Range
    Set myDoc = ActiveSheet
    myDoc.Unprotect
    For Each cel In myDoc.UsedRange
        If Not cel.HasFormula And _
                           Not TypeName(cel.Value) = "Date" And _
                                          Application.IsNumber(cel) Then
            cel.Locked = False
            cel.Font.ColorIndex = 5
       Else
            cel.Locked = True
            cel.Font.ColorIndex = xlColorIndexAutomatic
       End If
    Next
    myDoc.Protect
    Exit Sub

errorHandler:
     MsgBox "Error"
End Sub 

[ياسر خليل أبو البراء]

أخي ياسر البنا

أريد منك التهمل بين كل مشاركة وأخرى ، حتى نستطيع أن نجيب على كل تساؤلاتك .. وإن كان الموضوع ليس موضوع للتساؤل.. إنما هو تجميع للأكواد التي يمكن الاستفادة منها..

سأجيبك على كود واحد الآن حيث أني مشغول كثيراً..
 

Sub RandomNumber()
    Dim intNumber As Integer
    intNumber = Int((100 * Rnd) + 1)
    MsgBox intNumber
End Sub

وهو كود توليد رقم عشوائي من 1 إلى 100 (راجع مكتبة الصرح بالبحث عن [توليد])

[Yasser Fathi Albanna]

كان الله فى عونك أخى ياسر

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

معزرة

[Yasser Fathi Albanna]

كود لتصفح ملف مضغوط وفك ضغطه

Sub Unzip1()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use DefPath = "C:\Users\Ron\test\"
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        'If you want to extract only one file you can use this:
        'oApp.Namespace(FileNameFolder).CopyHere _
         'oApp.Namespace(Fname).items.Item("test.txt")

        MsgBox "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

[Yasser Fathi Albanna]

كود لتصفح ملف TXT من ملف مضغوط

Sub Unzip2()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String
    Dim fileNameInZip As Variant

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use DefPath = "C:\Users\Ron\test\"
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        'Change this "*.txt" to extract the files you want
        For Each fileNameInZip In oApp.Namespace(Fname).items
            If LCase(fileNameInZip) Like LCase("*.txt") Then
                oApp.Namespace(FileNameFolder).CopyHere _
                        oApp.Namespace(Fname).items.Item(CStr(fileNameInZip))
            End If
        Next

        MsgBox "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

[Yasser Fathi Albanna]

كود إنشاء مجلد جديد  لنسخ الملفات فيه ولكن هذا الماكرو يفك ملف مضغوط في مجلد ثابت

Sub Unzip3()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=False)
    If Fname = False Then
        'Do nothing
    Else
        'Destination folder
        DefPath = "C:\Users\Ron\test\"    '<<< Change path
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        FileNameFolder = DefPath

        '        'Delete all the files in the folder DefPath first if you want
        '        On Error Resume Next
        '        Kill DefPath & "*.*"
        '        On Error GoTo 0

        'Extract the files into the Destination folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        MsgBox "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

Sub Unzip4()
    Dim FSO As Object
    Dim oApp As Object
    Dim Fname As Variant
    Dim FileNameFolder As Variant
    Dim DefPath As String
    Dim strDate As String
    Dim I As Long
    Dim num As Long

    Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", _
                                        MultiSelect:=True)
    If IsArray(Fname) = False Then
        'Do nothing
    Else
        'Root folder for the new folder.
        'You can also use DefPath = "C:\Users\Ron\test\"
        DefPath = Application.DefaultFilePath
        If Right(DefPath, 1) <> "\" Then
            DefPath = DefPath & "\"
        End If

        'Create the folder name
        strDate = Format(Now, " dd-mm-yy h-mm-ss")
        FileNameFolder = DefPath & "MyUnzipFolder " & strDate & "\"

        'Make the normal folder in DefPath
        MkDir FileNameFolder

        'Extract the files into the newly created folder
        Set oApp = CreateObject("Shell.Application")

        For I = LBound(Fname) To UBound(Fname)
            num = oApp.Namespace(FileNameFolder).items.Count

            oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname(I)).items

        Next I

        MsgBox "You find the files here: " & FileNameFolder

        On Error Resume Next
        Set FSO = CreateObject("scripting.filesystemobject")
        FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
    End If
End Sub

[ياسر خليل أبو البراء]

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

متنساش إني مش بلصق أكواد وخلاص داخل المكتبة

لازم الكود أجربه بنفسي وأعمله شرح بقدر المستطاع حتى يستفيد منه الأعضاء ..

فرامل فرامل ..عشان متوهش !! خليني أجمع شوية الأكواد دول الأول..

[Yasser Fathi Albanna]

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

أنا قلت أشارك بإيد مليانه مش فاضية لأن بجد الموضوع هايل ومجهودك رائع جدا جدا تسلم إيدك

وأنا بعتذر لكثرة الأكواد

[ياسر خليل أبو البراء]

إخواني الكرام

إليكم الإصدار الأخير من مكتبة الصرح

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

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

جزاكم الله خيراً إخواني الكرام على كل ما تقدمونه لبناء هذه المكتبة

إليكم الإصدار 1.7 من مكتبة الصرح

Codes Library v1.7.rar

تم تعديل يناير 5, 2015 بواسطه YasserKhalil

[محمد علي الطيب]

كود لاخفاء الاطار الخارجي للفروم (الصق الكود في بداية أكواد الفورم)

 

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Declare Function SetWindowPos Lib "user32.dll" (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 Declare Function GetActiveWindow Lib "user32.dll" () As Long

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 BringWindowToTop Lib "user32.dll" (ByVal hWnd As Long) As Long

Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Const GWL_STYLE = -16

Const WS_CAPTION = &HC00000

Const WS_SYSMENU = &H80000

Private Const GWL_EXSTYLE = (-20)

Private Const WS_EX_LAYERED = &H80000

Private Const LWA_ALPHA = &H2

Dim hWnd As Long

'===================================================

Private Sub UserForm_Initialize()

On Error Resume Next

Dim lngWindow As Long, lFrmHdl As Long

lFrmHdl = FindWindow(vbNullString, Me.Caption)

lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)

lngWindow = lngWindow And (Not WS_CAPTION)

Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)

Call DrawMenuBar(lFrmHdl)

End Sub

[ياسر خليل أبو البراء]

بارك الله فيك أخي الفاضل محمد علي الطيب على هذا الكود الجميل

يرجى عند إضافة كود وضعه بين علامة الكود من المحرر الكامل التي يكون شكلها هكذا
<>

ليظهر الكود بشكل واضح

مثل هذا الشكل .. يظهر الكود في هذا الشكل