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

**مختار حسين محمود** · يناير 4, 2015

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

Public Sub HideExcelMakeExcelInvisible()

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

Application.Visible = False

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

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

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

Application.Visible = True

End Sub

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

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

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

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

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

**مختار حسين محمود** · يناير 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

**مختار حسين محمود** · يناير 4, 2015

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

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

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 · يناير 4, 2015

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

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

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

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

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

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

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

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

ياسر خليل أبو البراء · يناير 4, 2015

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

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

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

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

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

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

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

**مختار حسين محمود** · يناير 4, 2015

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

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

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

ياسر خليل أبو البراء · يناير 4, 2015

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

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

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

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

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

ياسر خليل أبو البراء · يناير 4, 2015

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

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

تغيير عنوان تطبيق الإكسيل
إخفاء وإظهار شريط الصيغ (المعادلات)
إظهار الشاشة (نافذة تطبيق الإكسيل) بالكامل
فتح الـ 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** · يناير 5, 2015

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

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

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

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

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

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

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

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

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

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

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

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

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

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

تحياتي :fff:

Codes.rar

سيف الدين حسام · يناير 5, 2015

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

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

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

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

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

السيد الفاضل

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

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

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** · يناير 5, 2015

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

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

 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

ياسر خليل أبو البراء · يناير 5, 2015

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

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

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

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

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

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

معزرة

**Yasser Fathi Albanna** · يناير 5, 2015

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

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** · يناير 5, 2015

كود لتصفح ملف 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** · يناير 5, 2015

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

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

ياسر خليل أبو البراء · يناير 5, 2015

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

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

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

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

**Yasser Fathi Albanna** · يناير 5, 2015

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

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

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

ياسر خليل أبو البراء · يناير 5, 2015

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

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

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

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

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

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

Codes Library v1.7.rar

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

محمد علي الطيب · يناير 5, 2015

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

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

ياسر خليل أبو البراء · يناير 5, 2015

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

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

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

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

تسجيل الدخول

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

الردود الموصى بها

رابط هذا التعليق

شارك

Top Posters In This Topic

Popular Days

Top Posters In This Topic

Popular Days

Popular Posts

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

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

الصـقر

Posted Images

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

رابط هذا التعليق

شارك

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

Important Information