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

[Yasser Fathi Albanna]

وهذا الكود يوضع فى thisworkbook لحماية جميع الشيتات من التعديل

Private Sub Workbook_Open()
    Me.Worksheets("Sheet1").Protect UserInterfaceOnly:=True
    Me.Worksheets("Sheet2").Protect UserInterfaceOnly:=True
    Me.Worksheets("Sheet3").Protect UserInterfaceOnly:=True
End Sub

[Yasser Fathi Albanna]

معزرة أخى الفاضل ياسر

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

اعذرني أخي الحبيب ياسر البنا

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

تقبل اعتذاري .. وجزيت خيراً على كل ما تقدمه

يكفيني ولو كود واحد بس بشرط يكون مشرووووووووح

[Yasser Fathi Albanna]

إحنا إخوات يا أ / ياسر وهانحن نسعى لتعم الفائدة على الجميع

ولا داعى للإعتذار فأنت من الأخوة الأعزاء

أنا إللى بعتذر لأننى لم أوضح شرح للأكواد

وشكرا لمجهودك العظيم

[ابو تراب]

السلام عليكم

 

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

 

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

 

للتوضيح كتبت مثال لدالة جمع بأسم Sum .

 

لتحقيق ذلك تم استخدام المعرف ParamArray  لتعريف مصفوفة وسطاء الدالة من نوع Variant

 

في الاسفل تجد كود الدالة و اجراء اختبار لها

 

بالتوفيق

 

' دالة تقبل عدد غير محدود من الوسطاء
' المثال هنا هو دالة جمع
'تم تعريق مصفوفة خاصة من نو فيريانت
Function Sum(ParamArray Numbers() As Variant) As Double
Dim i As Integer
Dim Result As Double


Result = 0#
' هنا نتأكد انه يوجد على الاقل وسيط واحد قد تم تمريره للدالة
If Not UBound(Numbers) - LBound(Numbers) > -1 Then
' في حالة لم يمرر ولا وسيط ارسل خطأ و اوقف تنفيد الدالة
    Sum = CVErr(xlErrNull)
    Exit Function
Else
' هنا مر على جميع وسطاء الدالة
    For i = LBound(Numbers) To UBound(Numbers)
    ' اختبر اذا كان الوسيط يمثل رقما
        If IsNumeric(Numbers(i)) Then
            Result = Result + Numbers(i)
        Else
        ' في حالة اكتشاف وسيط ليس برقم ارسل خطأ تنفيد و اوقف تنفيد الدالة
             Sum = CVErr(xlErrNum)
             Exit Function
        End If
    Next i


End If
' في حالة نجاح تنفيدها حدث الدالة بقيمة الجمع
Sum = Result


End Function

Sub test()
    MsgBox Sum(5)
    MsgBox Sum(5, 10)
    MsgBox Sum(5, -10, -13.25)
End Sub

 

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

أخي أبو تراب ..الدالة غير منطقية .حيث توجد الدالة Sum أصلا بالإكسيل ولا أجد ميزة لهذه الدالة ..

لو أمكن مثال توضيحي لمعرفة مزايا الدالة .. التي تجعلها متميزة عن الدالة المدمجة بالإكسيل

قمت بعمل مقارنة بسيطة بين الدالتين

أولاً الدالة المدمجة في هذه المعادلة

=SUM(1,,,,,1)

تعطي ناتج أما عند استخدام نفس المعادلة مع الدالة المستحدثة فتعطي خطأ Value

=SumNew(1,,,,,1)

بالنسبة لعدد الوسائط الدالة المدمجة Sum تقبل 255 وسيط أما الدالة المستحدثة فتقبل 254 فقط ..إذاً ما المميز في الدالة؟

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

[ابو تراب]

اولا تقبل شكري على الاهتمام بهذا الكود

 

للتوضيح

 

الغرض من الدالة ليس الدالة نفسها (فالدالة SUM تكفي و زيادة) و لكن الغرض الاساسي هواعطاء مثال على عمل اي دالة قادرة على قبول و سيط او اكثر دون تحديد عددها.

 

 

على كلا اذا كان هناك ميزة للدالة فربما في ال VBA فالدالة WorksheetFunction.Sum تقبل الى حد 30 وسيط.

 

من ناحيت الخطأ فسبب ان الدالة سترجع خطأ اذا وجدت اي وسيط ليس برقم حتى لوكان NULL.

 

في رايي انه يمكن القياس على هذه الدالة لانشاء دوال اكثر ملائمة .. مثلا ;كتبت دالة مستفيدا من فكرة الكود بحيت تعمل على تعبئة الخلاياء باي نوع من البيانات 

 

الكود مع كود الاختبار

 

Sub Fill(R As Range, ParamArray Values() As Variant)
Dim i As Integer


For i = LBound(Values) To UBound(Values)
            R.Offset(0, i).Value = Values(i)
Next i
End Sub

Sub test()


Fill [A1], 100, "This", True, -25.5


End Sub

 

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

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

تقبل اعتذاري عن سوء فهمي لك

وجزيت خير الجزاء على المعلومات المفيدة جداً

[ابو تراب]

استاذ ياسر ليس هنا ما يدعو للاعتذار اطلاقا ...فالخطأ هو خطئي فقد كان من المفترض ان اختر مثال افضل من الدالة Sum

 

ان شاء الله في المرة القادمة ساضع ملاحظتك القيمة في الاعتبار

 

تقبل تحياتي و تقديري   

[محمد لطفى]

ماشاء الله

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

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

[اسامةمحمد]

 كود معرفة عدد CommandButton او Label او TextBox او اي اداة من الادوات الموجودة في الفورم
 ففط ضع اسم الاداة مكان TextBox

Private Sub CommandButton1_Click()
Dim NC As Integer
For Each Control In Me.Controls
If TypeName(Control) = "TextBox" Then NC = NC + 1
Next
MsgBox NC
End Sub

[اسامةمحمد]

فتح حاسبة الكومبيوتر

Sub فتح_الحاسبة()
Shell ("calc")
End Sub

كود فتح Notepad

Sub نوت_باد()
Shell ("notepad")
End Sub

[ابو تراب]

كود لفتح مجلد

 

مثال:

 

اذا افترضنا ان المدى من A1 الى A5 يحتوي على اسماء المجلدات في المسار في المسار C:\test

 

فلفتح المجلد المعني بمجرد اختيار خلية من خلاياء المدى اعلاه .. نكتب الكود التالي في حدث الصفحة:

 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
' تأكد ان  الخلية تقع على المدى المطلوب و ان الخلية لديها قيمة
    If Not Intersect(Target, Range("A1:A5")) Is Nothing And Target.Count() = 1 Then
        If Target.Value <> "" Then Shell "cmd /c start C:\Test\" & Target.Value, vbHide
    End If


End Sub

[Yasser Fathi Albanna]

كود تحويل صفحة الإكسيل إلى Pdf

مرفق تطبيق للكود

Sub ExcelToPDF()
 
  Dim iPtr As Long
  Dim sFileName As String
  
  iPtr = InStrRev(ActiveWorkbook.FullName, ".")

  If iPtr = 0 Then
    sFileName = ActiveWorkbook.FullName & ".pdf"
  Else
    sFileName = Left(ActiveWorkbook.FullName, iPtr - 1) & ".pdf"
  End If

  sFileName = Application.GetSaveAsFilename(InitialFileName:=sFileName, FileFilter:="PDF Files (*.pdf), *.pdf")

  If sFileName = "False" Then Exit Sub
 
  ThisWorkbook.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sFileName, Quality:=xlQualityStandard, openAfterPublish:=True
 
End Sub

Excel To Pdf.rar

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

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

تسلم أياديكم

[احمدزمان]

السلام عليكم و رحمة الله وبركاته

 

استاذ ياسر

موضوع رائع جزاك الله خيرا

 

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

 

منشان هيك ياحبيب البي

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

 

كود كل الخيارات المطلوبة للطباعة

طباعة ورقة اكسل

    With ActiveSheet.PageSetup
' الصفوف المكررة الى الأعلى 
        .PrintTitleRows = "$3:$3"
        .PrintTitleColumns = "$A:$A"
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = "رأس يسار Up Lift"
        .CenterHeader = "UpMidel رأس وسط"
        .RightHeader = "رأس - يمين up Right"
        .LeftFooter = "DownLift اسفل يمين"
        .CenterFooter = "اسفل وسط DownMidel"
        .RightFooter = "DownRight اسفل يمين"
'حجم الهوامش
        .LeftMargin = Application.InchesToPoints(0.748031496062992)
        .RightMargin = Application.InchesToPoints(0.748031496062992)
        .TopMargin = Application.InchesToPoints(0.78740157480315)
        .BottomMargin = Application.InchesToPoints(0.984251968503937)
        .HeaderMargin = Application.InchesToPoints(0.511811023622047)
        .FooterMargin = Application.InchesToPoints(0.511811023622047)
' طباعة رئوس الصفوف و الأعمدة 
        .PrintHeadings = True
        .PrintGridlines = True
        .PrintComments = xlPrintNoComments
' توسيط الى عرض الصفحة 
        .CenterHorizontally = False
' توسيط الى ارتفاع الصفحة 
        .CenterVertically = False
' طباعة طولية
        .Orientation = xlPortrait
' طباعة عرضية
        .Orientation = xlLandscape
' حجم الورق 
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
' طباعة اسود و ابيض
        .BlackAndWhite = True
        .Zoom = 100
' ملائمة الى عرض الصفحة 
        .FitToPagesWide = 1
        .FitToPagesTall = False
    End With

آمل ان يكون به الفائدة للجميع

 

[عبدالله المجرب]

السلام عليكم 

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

وللأمانه هي من اعدادا الإستاذ محمد صالح (ماس)

CreateObject("Wscript.shell").Popup "إنتظر قليلاً ستختفي هذه الرسالة خلال ثانية ", 1, "إنتظار !!!!", vbExclamation

طبعاً  الرقم 1 هو الزمن المختار لإختفاء الرسالة بعد عرضها

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

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

لكم يسعدني مروركما الثري على الموضوع الكبير والمشروع المرتقب الذي من شأنه أن يغير من مسار المنتدى بإذن الله إلى الأفضل والأيسر والأنفع

بارك الله فيكما وجمع بيني وبينكما في جنته في مستقر رحمته نحن وجميع الأخوة الذين نحبهم في الله ..اللهم تقبل اللهم آمين

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

[Yasser Fathi Albanna]

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

Private Sub Workbook_Open()
Dim Edate As Date
Edate = Format("31/12/2012", "DD/MM/YYYY") ' Replace this with the date you want
If Date > Edate + 2 Then
MsgBox "This workbook is Expired and will now close !!!"
ActiveWorkbook.Close
End If
End Sub

[احمد_محمود]

السلام عليكم
بارك الله بكم على هذا الموضوع الرائع 
حاولت فتح الملف و لكن اعطاني هذا التنبيه

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

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

لا حرمنا الله من إضافاتك ..

قم بالبحث عن كلمة [صلاحية] في مكتبة الصرح ، ستجد كود مشابه

عموماً تمت إضافة هذا الكود أيضاً لتنوع الأفكار بعض الشيء

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

السلام عليكم

بارك الله بكم على هذا الموضوع الرائع 

حاولت فتح الملف و لكن اعطاني هذا التنبيه

أعتقد بسبب عملك على نسخة 64 بت ، ولا أدري كيفية التعامل مع نظام الـ 64 بت .. ربما تجد من يساعدك بالأمر

تقبل تحياتي

[ibn_egypt]

السلام عليكم

بارك الله بكم على هذا الموضوع الرائع 

حاولت فتح الملف و لكن اعطاني هذا التنبيه

 

اخى الفاضل

 

هذا لعملك على نظام تشغيل 64-bit .. قم باستبدال الاربع اسطر المظللة بالأحمر ... بالأسطر التالية بإذن الله ستزبط معك

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" ( _
    ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" ( _
    ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long

تحياتي  

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

جزيت خيراً يا ابن مصر

بينما كتبت مشاركتك بحثت ووجدت الحل يمكن أن يكون بهذا الشكل ليعمل على32 بت أو 64 بت

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" ( ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
#End If

[احمد_محمود]

حاولت بكلا الطريقتين و اعطاني 
FindWindow Missmatch error