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

الحمد لله رب العالمين و بفضل من الله ثم رضا الوالدين و بفضل هذا المنتدى و المنتديات العربية و العالمية الأخرى المتخصصة في مجال الإكسيل, حصلت على شهادة MVP Most Valuable Professional و لله الحمد أني كا أول عربي حصل عليها و أسأل الله العلي القدير أن تكون بداية توفيق جديد لنا و أنا نخدم الأمة و أن ننفع بها أهلنا و أمتنا لله الحمد من قبل و من بعد

ماشاء الله عليك استاذ ياسر والى الامام جميل جدا فكرتك استاذ سليم هذه محاولة بسيطة وللاثراء والافادة ! ومغازلة الكبار! Function ramhan(xinput As String) As Integer xinput = Replace(xinput, "أ", "ا") xinput = Replace(xinput, "إ", "ا") xinput = Replace(xinput, "ة", "ه") Dim xletters As String, i As Integer, xsum As Integer xletters = "ابتثجحخدذرزسشصضطظعغفقكلمنهوي" For i = 1 To Len(xinput) xsum = xsum + InStr(1, xletters, mid(xinput, i, 1)) Next i ramhan = xsum End Function تحياتي للجميع

السلام عليكم ورحمة الله وبركاته وبعد ,,, أقدم لكم اخوتى الأفاضل كودا يقوم بفحص نطاق من الخلايا ويحدد فقط الخلايا التى تحوى معادلات ذات القيم الخاطئة ويميزها بالتلوين أو التعديل أو التفريغ أو بعمل فلاش لتلك الخلايا لك الخيار فى اختيار شكل التمييز المناسب الكود وعليه شرح بعض السطور : Option Explicit Private Declare Function sndPlaySound32 Lib "winmm.dll" _ Alias "sndPlaySoundA" (ByVal lpszSoundName _ As String, ByVal uFlags As Long) As Long Sub CheckRangeForError() ' by mokhtat 2/10/2015 ' Error values include #DIV/0!, #N/A, #NAME?, #NULL!, #NUM!, #REF!, and #VALUE!. Dim C As Range Dim i As Integer Dim PlaySound As Boolean ' تحديد نطاق الفحص Sheets("Sheet1").Range("A2:F20").Select ' تحديد الخلايا التى تتضمن أخطاء Selection.SpecialCells(xlCellTypeFormulas, 16).Select ' استدعاء صوت من أصوات الويندوز للتنبيه على انتهاء الفحص PlaySound = True If PlaySound Then Call sndPlaySound32("C:\windows\media\notify.wav", 1) ' حدد الصوت المفضل لك طبقاً للمسار المقابل End If ' رسالة الى المستخدم بسؤال عن الرغبة فى التمييز أم لا If MsgBox(" تم انتهاء الفحص , هل تريد تمييز الخلايا ؟ ", vbYesNo + vbQuestion) = vbNo Then Exit Sub ' فى حالة اختيار لا يتم الخروج من الاجراء Else ' فى حالة اختيار تعم يتم عمل تمييز للخلايا بالتفريغ أو بالتعديل أو التلوين أو الفلاش ' ------------------------------------------------------------ ' تمييز الخلايا التى بها اخطاء بالتعديل ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "معادلة خاطئة" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتفريغ ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Value = "" ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالتلوين ' For Each C In Sheets("Sheet1").Range("A2:F20") ' If IsError(C.Value) Then ' C.Interior.ColorIndex = 3 ' End If ' Next C '------------------------------------------------------------- ' تمييز الخلايا التى بها اخطاء بالفلاش For Each C In Sheets("Sheet1").Range("A2:F20") If IsError(C.Value) Then C.Select With C For i = 1 To 2 ' عدد مرات الوميض Application.Wait (Now + TimeValue("0:00:01")) ' انتظار مؤقت لمدة ثانية .Interior.ColorIndex = 6 Application.Wait (Now + TimeValue("0:00:01")) .Interior.ColorIndex = 7 Next .Interior.ColorIndex = xlNone .Font.Color = -16777024 End With End If Next '------------------------------------------------------------ End If End Sub تفضلوا المرفق وتقبلوا تحياتى select all cells if contains Error value .rar

مثال بسيط عن الماكرو فى الاكسيل المثال مشروح على برنامج PDF حمل من المرفقات الماكرو.rar

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

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

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

السّلام عليكم و رحمة الله و بركاته أستاذى الفاضل عادل حنفى بارك الله فيك ، سلمت من كل شر ، شرفنى مرورك أستاذى الكريم أخى العزيز زيزو البسكرى بارك الله فيك دائما تشرفنى بمرورك العزيز أخى وأستاذى الغالى ياسر خليل أشكرك بحرارة على هذا التشجيع الدائم والمستمر وهذا ما تعلمته من المنتدى ومنك تحديداً أستاذى الفاضل

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

الأستاد الفاضل جرب الكود التالي في ال ThisWorkbook Module: Private Sub Workbook_Open() If MsgBox("Do you want to add this workbook to the Windows startUp ?", vbYesNo + vbQuestion) = vbYes Then AddToWinStartUp Me.FullName, True End If End Sub Private Sub AddToWinStartUp(ByVal File As String, ByVal Add As Boolean) CreateObject("wscript.shell").RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Run\", IIf(Add, File, vbNullString), "REG_SZ" End Sub للتدكير فقط ممكن أن يختلف ال (Key Path ( Microsoft\Windows\CurrentVersion في اصدارات أخرى للويندوز .. كما أن المستخدم User ينبغي أن يتوفر على الحق Privileges في تغيير الريجيستار Registry لازالة الملف من قائمة البرامج عند بدء تشغيل الويندوز شغل الكود التالي : AddToWinStartUp Me.FullName, False

=ramhan(d2)

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

الأخ الكريم أبو عبد الرحمن يرجى تغيير اسم الظهور للغة العربية إليك الملف المرفق Book1.rar

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

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

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

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

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

جرب الدالة التالية Function YK(sInp As String) As Long Static bInit As Boolean Dim asMap() As String Dim asLtr() As String Dim I As Long Static aiVal(0 To 255) As Long If Not bInit Then asMap = Split("1 1 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 26 27 28") asLtr = Split("أ ا إ ب ت ث ج ح خ د ذ ر ز س ش ص ض ط ظ ع غ ف ق ك ل م ن ه ة و ي") For I = 0 To UBound(asMap) aiVal(Asc(asLtr(I))) = asMap(I) Next I bInit = True End If For I = 1 To Len(sInp) YK = YK + aiVal(Asc(Mid(sInp, I, 1))) Next I End Function Sum Letters YasserKhalil V3.rar

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

الأخ الكريم غرب الإكسيل (متخليك شرق عشان تكون معانا) جرب الدالة المعرفة التالية علها تفي بالغرض Function CalcString(S As String) Dim ArrLetters, ArrValues, X() As Byte, SpaceCounter As Long Dim I As Long, Counter As Long, Pos& ArrLetters = Join(Array("أ", "ا", "إ", "ب", "ت", "ث", "ج", "ح", "خ", "د", "ذ", "ر", "ز", "س", "ش", "ص", "ض", "ط", "ظ", "ع", "غ", "ف", "ق", "ك", "ل", "م", "ن", "ه", "ة", "و", "ي")) ArrValues = Array(1, 1, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 26, 27, 28) X = StrConv(S, vbFromUnicode) For I = 0 To UBound(X) Pos = InStr(ArrLetters, Chr(X(I))) If Pos > 0 Then Counter = Counter + ArrValues((Pos - 1) / 2) Next I SpaceCounter = SpaceCount(S) CalcString = Counter - SpaceCounter End Function Function SpaceCount(ByVal strLine As String) As String Dim Str As String Dim TempCount As Long Dim I As Long Str = Trim(strLine) TempCount = 0 For I = 1 To Len(Str) If Mid(Str, I, 1) = " " Then TempCount = TempCount + 1 Else If TempCount > 0 Then SpaceCount = SpaceCount & " " & TempCount TempCount = 0 End If End If Next I SpaceCount = Mid(SpaceCount, 2) End Function وإليك الملف المرفق Sum Letters.rar

أعجبنى هذا الموقع فاردت ان اشارك محتوياته معكم تحياتى للجميع http://csu.kau.edu.sa/Pages-تدريبات-مادة-مهارات.aspx

السلام عليكم ورحمة الله وبركاته اولا بشكر جميع القائمين بالمنتدى لاني تعلمت منه كثيرا ثانيا صممت 2 يوزر فورم لادخال البيانات و الثاني للبحث و منتظر الثالث للتعديل ولكني عندي عدة مشاكل وهي : يوزر فورم 1 الخاص بالادخال : 1- عند ادخال البيانات وتركت احد الخلايا فارغه فيقوم بترحيل قيمه الفراغ بمعنى ان مثلا سعر السيارة 150000 وسيقوم العميل بسداد 25% المفروض انه بيرحل قيمه المدفوع بالمبلغ 37500 جنيه و قيمه التمويل بالمبلغ 112500جنيه وهذا لا يحدث لاني عامل 2 خليه اخريين لقيمه المدفوع و قيمة التمويل بكتبهم اذا لم يحدد بالنسبة المئوية فبالتالي يقوم بمسح القيم المعلومه بالارقام مع العلم اني عامل معادلات في شيت الاكسيل اذا وضعت 25% يكتب قيمة المبلغ المدفوع و قيمة التمويل بالشيت . 2- عند ادخال قيمه مئويه % مثلا 25% لازم اكتب .25 يوزر فورم 2 الخاص بالبحث : فشلت كثيرا باستخدام اكثر من كود بحث واخرهم vlookup function لايقوم بترحيل البيانات نهائيا مرفق الملف و اتمنى المساعده Drive 07.rar

السلام عليكم ورحمة الله وبركاتة هذا المصنف أريد به أستدعاء التاريخ من الورقة5 على موجب أسم والبحث في عدة أعمدة عند كتابة اسم في الخلية B2 في الورقة2 يجلب التاريخ الذي يساويه على صفه من الورقة5 والمصنف يوضح أكثر . اعمدة الاسماء هي C;K;M;O في الورقة5 إستدعاء التاريخ.rar

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

وهذه زياده tab_riht_to_left.rar

جرب كدة orders3.rar

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

السلام عليكم أخي محمد للأسف لا يمكن عمل هذا بالاكسس والظاهر ان الاستاذ رمهان سبقني في الاجابة المختصرة واليك الاجابة المفصلة لعمل الحيلة: بس انا افضل النموذج frm_Option_Group والكود حقه: Private Sub Frame10_Click() If Me.Frame10.Value = 1 Then Me.Page1.SetFocus ElseIf Me.Frame10.Value = 2 Then Me.Page2.SetFocus ElseIf Me.Frame10.Value = 3 Then Me.Page3.SetFocus End If End Sub جعفر 228.RTL_Tabs.mdb.zip

واخيرا قدرت اسبقك ، بدقيقة ، حدث تاريخي مهم جعفر

قم بسحب المعادلات إلى الأسفل لإظهار بقية الطلاب تفضل جرب المرفق رصد درجات الطلاب2.rar

حتي و ان غاب الورد تظل رائحته تفوح زادك الله من فضله

اخي abo jana14 هل هذا هو المظلوب كيماس1.rar

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

بعد اذن الاساتذة الكرام نفس الشيء لكن بالمعادلات جلب بيانات من اكثر من شيت salim.zip

أخي الكريم ابو عبدالرحمن السلام عليكم ورحمة الله وبركاته تم الرد علي موضوعك علي هذا الرابط http://www.officena.net/ib/topic/63973-برنامج-تسجيل-بيانات-لروضة-أطفال/

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

هل هدا ما تقصده : (غير حروف الاسم ABDEL AZIZ الى العربية ) ... لاحظ أنني غيرت الكود TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter) Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="ABDEL AZIZ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As Long Dim hwndChild As Long Dim hwndParent As Long Dim hdc As Long Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hwndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message & " " & iCounter, Len(Message & " " & iCounter) ' TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hwndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

السلام عليكم تكملة و اثراء لهدا الموضوع لقد كتبت الكود التالي الدي يعرض رسالة على فترات زمنية متقطعة بدون اللجوء الى اليوزرفورم و بدون امكانية الغائها من طرف المستخدم كما هو مطلوب أعلاه Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) ال Routine اعلاه تعطي المستخدم مرونة اختيار موضوع الرسالة و عدد المرات التي سيتم فيها عرضها و مدة كل رسالة و ال Z order لنافدة الرسالة و لون الحروف و لون الخلفية طبعا لو نص الرسالة طويل فعلى مستعمل الكود أن يغير طول و عرض (WIDTH and HEIGHT Constantes) النافدة لاستعاب كل النص مرة أخرى نظرا لكتابة الكود على الويندوز 32 بت فانه لن يعمل على اويندوز و الأوفيس 64 بت لقطة من الشاشة: ملف للتحميل : https://app.box.com/s/vk5xn38vlqzik7lmts8m4q2svloix525 الكود في موديول عادي : Option Explicit Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long Private Const WS_CHILD = &H40000000 Private Const WS_CLIPCHILDREN = &H2000000 Private Const WS_CAPTION = &HC00000 Private Const WS_EX_TOPMOST = &H8& Private Const SW_NORMAL = 1 Private Const TRANSPARENT = 1 Private Const SM_CXSCREEN = 0 Private Const SM_CYSCREEN = 1 Private Const COLOR_BTNFACE = 15 Private bWindowExist As Boolean Public Sub Test() If Not bWindowExist Then Call ShowUpdatingMessage( _ Message:="Showing message number : ", _ Title:="Officena", _ HowManyTimes:=10, MessageDelay:=1, _ TOPMOST:=True, TextColor:=vbRed, BackColor:=vbYellow _ ) End If End Sub Private Sub ShowUpdatingMessage( _ ByVal Message As String, _ ByVal Title As String, _ ByVal HowManyTimes As Single, _ Optional ByVal MessageDelay As Single, _ Optional ByVal TOPMOST As Boolean, _ Optional ByVal TextColor As Long, _ Optional ByVal BackColor As Long) Const WIDTH = 250 Const HEIGHT = 120 Dim tRect As RECT Dim tLb As LOGBRUSH Dim t As Single Dim hBrush As Long Dim hwndChild As Long Dim hwndParent As Long Dim hdc As Long Dim iCounter As Integer On Error GoTo CleanUp ' Application.EnableCancelKey = xlErrorHandler hwndParent = CreateWindowEx(IIf(TOPMOST, WS_EX_TOPMOST, 0), "BUTTON", Title, WS_CAPTION + WS_CLIPCHILDREN, _ (GetSystemMetrics(SM_CXSCREEN) - WIDTH) / 2.2, (GetSystemMetrics(SM_CYSCREEN) - HEIGHT) / 2, WIDTH, HEIGHT, 0, ByVal 0&, 0, ByVal 0&) hwndChild = CreateWindowEx(0, "STATIC", vbNullString, WS_CHILD, 0, 0, WIDTH, HEIGHT, hwndParent, ByVal 0&, Application.hInstance, ByVal 0&) If hwndChild Then bWindowExist = True Application.OnKey "%{F4}", "" ShowWindow hwndParent, SW_NORMAL ShowWindow hwndChild, SW_NORMAL DoEvents hdc = GetDC(hwndChild) SetBkMode hdc, TRANSPARENT If TextColor <> 0 Then SetTextColor hdc, TextColor End If SetRect tRect, 0, 0, WIDTH, HEIGHT tLb.lbColor = IIf(BackColor = 0, GetSysColor(COLOR_BTNFACE), BackColor) hBrush = CreateBrushIndirect(tLb) For iCounter = 1 To HowManyTimes FillRect hdc, tRect, hBrush TextOut hdc, 30, 20, Message, Len(Message) TextOut hdc, 115, 50, CStr(iCounter), Len(CStr(iCounter)) t = Timer Do DoEvents Loop Until Timer - t >= IIf(MessageDelay = 0, 1, MessageDelay) Next End If CleanUp: ReleaseDC hwndChild, 0 DeleteObject hBrush DestroyWindow hwndChild DestroyWindow hwndParent bWindowExist = False Application.OnKey "%{F4}" End Sub

بعد اذن اخي ياسر A لو كانت الكلمات في العامود اكتب هذه المعادلة واسحب نزولا ( معادلة صفيف) =IF(A1<>"",SUM(MATCH(MID(A1,ROW(INDIRECT("1:"&LEN(A1))),1),{"ا";"ب";"ت";"ث";"ج";"ح";"ح";"د";"ذ";"ر";"ز";"س";"ش";"ص";"ض";"ط";"ظ";"ع";"غ";"ف";"ق";"ك";"ل";"م";"ن";"ه";"و";"ي"},0)),"")

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

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

شكرا على الكود الجميل فقط عندي اقتراح أن يتم تفريغ الفورم من الداكرة ال memory عوض اخفائه .. ايضا لا داعي لتكرار المصفوفة داخل ال UnloadUF Option Explicit Dim X As Integer Dim iuserform As Variant Sub showUF() ' by mokhtatr 19/9/2015 iuserform = Array(UserForm1, UserForm2, UserForm3, UserForm4) For X = LBound(iuserform) To UBound(iuserform) Application.OnTime Now + TimeValue("00:00:01"), "UnloadUF" iuserform(X).Show Next X End Sub Sub UnloadUF() Unload iuserform(X) Application.Wait Now + TimeValue("00:00:01") End Sub كدالك لا ينبغي نسيان أن المستخدم يمكن له أن يغلق الفورم بالضغط على الزر x و لهدا يجب اضافة كود داخل اليوزرفورم موديول كالتالي Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Cancel = Not CloseMode End Sub بالمناسبة يمكن كتابة كود لا يستوجب استخدام عدد معين من اليوزرفورم و انما يستخدم فقط ال Standard MsgBox الكود أكثر تعقيدا لكنه ممكن

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

السلام عليكم ورحمة الله وبركاته الى جميع من استفدت منهم فى هذا المنتدى (الصرح العلمى العظيم اوفيسنا ) اقدم هذا العمل وهو ابجدة الاسماء بالمعادلات العاديه والبيفوت تيبل وهذا بعد الكود الرائع من استاذى الحبيب (ملك المعادلات)جمال عبدالسميع وانا اقدم هذه المعادله من بعده واسال الله العلى العظيم ان يتقبل منا ومنكم جميع الاعمال الصالحه تقبلوا خالص تحياتى تلميذ فى اوفيسنا /محمد الريفى ابجدة الاسماء.rar

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

الســـــــــــــــــــــادة الأعضاء : الموضوع لايخص الأساتذة والخبراء ( لانه دون مستواهم بكثير) في المرفقات ملف اكسل لاحتساب ضريبة الدخل على الرواتب والأجور المعمول به في الجمهورية العربية السورية والمطبق اعتبارا من 1/4/2011 ويمكن تعديل النسب حتى يتم الاستفادة منه بشكل عام أتمنى أن ينال الرضى ولو قليلا مع ملاحظة انه ليس برنامج بمعنى الكلمة ولكنه ملف لاحتساب الضريبة وفق شرائح الدخل وأتمنى من الأخ العزيز HaNcOcK : إبداء رأيه في Forms المرفقة بالصفحات : " ادخال " + " صافي " لان هذه الـ Forms أصلا هو من علمني كيف يتم إعدادها وعملها وله ألف ألف شكر وفقكــــــــــــــــــــــــــــــــم الله والسلام ياسر الحافظ Net Tax & Salary.rar

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

مشكورررررررر اخي الله يوفقك جربته ممتاز البرنامج ولاكن سجلت فيه بيانات جديده ولا يقبلها مايظهر غير الموجود سابقاً وياليت تشرحلي كيف علمته لني عندي اكثر من 6 حقول ابي اربطها في الورد

الاخ العزيز rudwan و كل الاخوة الاعضاء السلام عليكم و رحمة الله و بركاته يمكنكم استخدام كود المرور (0) (صفر) و كلمة السر (..........) ( العلامة العشرية 10 مرات ) مع خالص تحياتى و افيدونى بنجاح الدخول اخوكم علاء النكلاوى