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

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

حسب فهمنا للسؤال .... لأنك لم توضح لماذا تغيير الاسماء ؟؟؟؟؟ يمكن تعديل اسماء هذه الصفحات من خلال الجدول في المرفق اسماء الصفحات.rar

اليكم رابط برنامج عواصم العالم والدول كاملا اصدار رقم 1 https://top4top.io/downloadf-1654wznys1-rar.html ارجو ان ينال اعجابكم وهو يعتبر متكامل لجميع دول العالم وعواصمها واعلامها والقارة التى تقع فيها كل دولة ومستعد لتلقى اى ملاحظات للتعديل فى الاصدار الثانى واحب هنا ان اشكر مشرفين الموقع والاستاذ محمد طاهر للتشجيع المستمر وانا لم اتعلم شيئ الا من هذا الموقع الرائع وهذا رابط اخر علــى الميديا فاير اطلس العالم 1

جرب هذا الملف Ziad.xlsx

هل تم نسخ ملف الباركود في نفس المسار المذكور ؟؟؟ اقصد المسار السابق في الرد C:\Windows\SysWOW64

استعمل هذا الكود C:\Windows\SysWOW64\barcodex.ocx

هل طبقت كما اشرنا لك ممكن مثال مصغر للتطبيق عليه بارك الله فيك

بارك الله فيك الان فهمت ... بالتوفيق.

اخي الكريم انت تريد اظهار التقرير في حال كان النموذج منبثق . صحيح ....

وعليكم السلام ورحمة الله وبركاته نفذ الأتي : عند فتح التقرير في حدث عند نقر زر الأمر ضع هذا الكود DoCmd.OpenReport "اسم التقرير", acViewPreview Me.Visible = False وفي حدث عند الإغلاق في التقرير ضع هذا الكود Forms![اسم النموذج المنبثق].Visible = True

تفضل ...... 33333 (1).rar

هل الويندوز لديك 64 bit

السلام عليكم هذا البرنامج عملته من سنين ، حين كنت اعمل في مكتبة المدرسة برنامج مكتبة مدرسية شامل 1- تسجيل الكتب وتوصيفها 2- تسجيل الطلاب 3- شاشة احترافية لإعارة الكتب واسترجاعها باستخدام قارىء الباركود ، أو باستخدام ادخال رقم الكتاب ورقم الطالب 4 - تقارير متنوعة شاملة 5- محاولة لتفعيل جهاز البصمة للزوار لم تكتمل بعد وميزات اخرى تجدونها عند تجربة البرنامج ارجوا ممن يستفيد منه الا ينساني من دعوة في ظهر الغيب . mktbah.rar

غير الى هذا الكود Dim OutApp As Object Dim OutMail As Object Set OutApp = CreateObject("Outlook.Application") Set OutMail = OutApp.CreateItem(0) For i = 3 To Cells(Rows.Count, 1).End(xlUp).Row With OutMail .To = Range("A" & i).Value .CC = Range("B" & i).Value .Subject = Range("C" & i).Value .HTMLBody = Range("D" & i).Value .Send End With On Error GoTo 0 Set OutMail = Nothing Set OutApp = Nothing MsgBox Range("A" & i).Value Next i إيميللات.xlsm

مرفق ، وبالتوفيق لاحظ أن المعادلة هي: =INDIRECT(ADDRESS(3;COLUMN()-2;;;$D3)) والرقم -2 جاء من فرق مكان الخلايا في الشيتات عن مكانها في الشيت الرئيسي المبيعات.xlsx

السلام عليكم برنامج لإدارة حمامات السباحة والتدريبات والفترات الحرة .. شامل حسابات مرتبات العاملين مدربين إداريين محاسبين عمال .. وكثير من المزايا للتواصل 00201018156170 يدعم الواتساب او علي الايميل التالي soft.sample2014@gmail.com

في مثالك قيم مكررة في الكمبوبكس ... بالتوفيق اخي الكريم @ahmed_ali71470@yahoo.com

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

اعرض الملف كود لقلب وضعية بلوكات كاملة طلب مني زميل حل لعكس ترتيب مجموعة من بلوكات البيانات من الوضعية الافقية الي الوضع الرأسي و ذلك دون تغيير وضعية البيانات داخل البلوك الواحد ، كما هو مبين فى الضورة يمتاز الكود بعدم مجدودية عدد البلوكات (يتم الاختيار طبقا للتظليل) و يمكن تعديله بسهولة ليناسب اعداد الاعمدة المختلفة داخل البلوك و ذلك يتعديل قيمة متغير واحد فى الكود. و لكي تستخدم هذا الكود قم اولا بتحديد عدد الأعمدة داخل كل بلوك عن طريق المتغير CC فى الكود و فى المثال هنا عدد أعمدة كل بلوك هو 3 ـ و يمكنك تغييره كما تشاء ثم قم بتظليل كافة البيانات المراد تغيير وضعها على أن تكون عدد الاعمدة المختارة من مضاعفات الرقم المختار لأعمدة كل بلوك ثم شغل الكود Sub PivotBlocks_arafa() Dim r, c, b As Integer Dim g As String cc = 3 ' قم بتعديل هذا الرقم لتغيير عدد الاعمدة الافتراضي فى البلوك الوحد r = Selection.Rows.Count c = Selection.Columns.Count b = c / cc g = ActiveCell.Address For x = 1 To b - 1 Range(ActiveCell.Offset(0, cc * x), ActiveCell.Offset(r - 1, cc * x + cc - 1)).Cut ActiveCell.Offset(r * x - 1 + 1, 0).Activate ActiveSheet.Paste Range(g).Activate Next x End Sub صاحب الملف محمد طاهر تمت الاضافه 07 يول, 2020 الاقسام قسم الإكسيل  

برجاء الاطلاع ع هذا الموضوع بالتوفيق

بالرغم من انك لم ترفع بيانات في ملف (امر مخالف لقوانين المنتدى) اليك هذا النموذج Abou_yousef.xlsm

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

احسنت عمل ممتاز جزاك الله خير الثواب

وعليكم السلام -تفضل ملف قيم لما تريد List All files from Folder and Sub-folders in Excel Workbook File_Manager.xlsm وهذا ملف اخر Open Excel files in a folder [VBA] List-all-files-in-a-folder.xlsm وهذا الرابط من داخل المنتدى أيضاً سيفيدك للأستاذ محمد صالح شرح عرض جميع الملفات والمجلدات في مسار list all files and folders in path في vba

السلام عليكم ورحمة الله بورك فيك اخى الكريم محمد جعل الله لك من دعاءك لى نصيبا و زيادة ان شاء الله

OmHamza فين انتى من كل هذه الإجابة الممتازة ؟!!! أين الضغط على الإعجاب ؟!!!💙

المطلوب ليس له حل مثالي، لأن التوزيع مبنى على قيم غير متوافقة (اللغات/ المبالغ) لكن من حسن الحظ أن عدد العملاء كبير في مقابل عدد الموظفين قليل، والتفاوت في المبالغ محدود وليس كبير وهذا جعل عملية التوزيع العشوائي تعمل بشكل جيد ولتأكيد ذلك: قمنا بتوزيع العملاء بالترتيب على الموظفين بالتناوب فظهرت المبالغ التالية: وهذه نسب متقاربة جدا جدا فأول نقطة تجاوزناها: الموظفين يوزعون بالتسلسل وهذا سيحقق الغرض بقي نقطة توزيع العملاء على شيتات الموظفين، تم عمل شيت لكل موظف، ويمكن التحديث بزر التحديث في أعلى يمين الصفحة توزيع العملاء -3.xlsm وبالتوفيق

ما شاء الله عمل رائع اخي الفاضل مهندس الاكسيل تسلم ايدك وبارك الله فيك ويزيدك من علمه

السلام عليكم ورحمة الله اجعل الكود هكذا Private Sub CommandButton1_Click() UserForm1.TextBox1 = "" Dim ChekCapn As String, Data As String Dim ChekBx As Control, FData As String For Each ChekBx In Me.Controls If TypeName(ChekBx) = "CheckBox" Then ChekCapn = ChekBx.Caption If ChekBx.Value = True Then Data = Data & "," & ChekCapn FData = Mid(Data, 2, Len(Data) - 1) End If End If Next UserForm1.TextBox1.Value = FData Unload Me End Sub

لا أعلم لماذا الحاجة للكود الملف بالمعادلة يعمل وبدون الحاجة لتغيير الأعمدة!!vlookUP.xlsx

تفضل .... 33333 (1).rar

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

السلام عليكم عذرا للتاخير انقطاع الكهرباء وصل لارقام قياسية جرب الملف وبه كود للعلامة عبدالله باقشير طبقته على ملفك ينقص الكود تكملة اسماء الاعمدة المراد ترحيلها فقد قمت بكتابة مادتين فقط وعليك اكمال الباقي ''' أسماء الأعمدة المطلوب نسخها Range("A" & R).Range("b1:c1,g1,i1:k1,s1:u1").Copy طبعا القائمة المنسدلة لم تعد ضرورية تحياتي الترحيل بشرط القسم (1).xlsb

السلام عليكم اخي العزيز هل تقصد تشغيل اصوات النظام الموجودة في C:\WINDOWS\Media المهم انظر للملف يمكنك تغيير الصوت الذي تريده من خلال استبدال اسمه (tada.wav) بالنموذج عند التحميل فقط من خلال الكود التالي: Playsound ("C:\WINDOWS\Media\tada.wav") تحياتي 77.rar

عمل رائع شكرا لك

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

الله يرحمها ويغفر لها ويدخلها فسيح جناته

انا لله وانا اليه راجعون غفر الله لها ورزقكم الله الصبر لفراقها

لله مااعطى ولله ما اخذ انا لله وإنا اليه راجعون خالص العزاء

البقاء لله وربنا يغفر له ويسكنها فسيح جناته

البقاء لله نسأل الله أن يسكنها الفردوس الاعلى وان يبارك في عقبها.

طبعا هناك معادلات يمكن دمجها، ولكن أحببت أن تكون الأمور لك أكثر وضوح لتسهيل تكرار العملية في ملفك ولاتنس أن بعض المعادلات تحتاج الضغط على ctrl+shift+enter أتمنى أن الصورة وضحت

بنفس طريقة التنسيق الشرطي يمكن تنفيذ الامر انظر نموذج Tb-Empl3 ستجد اللون الازرق لمن قارب على تاريخ اليوم بـ 10 ايام Database1011_2.rar تحياتي

الرسالة تفيد بنجاح العملية .... ربما المشكلة في ملف الاكسس

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

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

أضم صوتي إلى صوت الأخ هل يمكن إرسال رسالة مخصصة لكل شخص (ربما فيها اسمه ونتيجته) وهل يمكن إرسال صورة

وهذه هي الصيغة النهائية للعمل : Dim objWShell, objReead ' On Error Resume Next Set objWShell = CreateObject("WScript.Shell") objReead = objWShell.RegRead("HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA") If objReead = "0" And Me.tmp = "0" Then Call tsjeelMktbat Set objWShell = Nothing MsgBox "تم التنصيب واضافة ملفات النظام بنجاح" Exit Sub ElseIf objReead = "1" And Me.tmp = "0" Then objWShell.RegWrite "HKLM\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", 0, "REG_DWORD" Me.tmp = "1" objWShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce\tsj", "D:\tsjeel.mdb", "REG_SZ" objWShell.Run "shutdown /r /t 10 /f /d P:4:2" 'visit: http://pcsupport.about.com/od/commandlinereference/p/shutdown-command.htm Set objWShell = Nothing Exit Sub Else Call tsjeelMktbat objWShell.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Policies\System\EnableLUA", "1", "REG_DWORD" MsgBox "تم التنصيب واضافة ملفات النظام بنجاح" 'If MsgBox("سيتم إعادة تشغيل النظام" & vbCrLf & _ ' " هل تريد المتابعة؟", _ ' vbQuestion + vbYesNo, _ ' "اعادة تشغيل النظام") = vbNo Then ' Exit Sub 'Else 'objWShell.Run "shutdown /r /t 10 /f /d P:4:2" Set objWShell = Nothing 'End If End If وهذا هو التطبيق tsjeel.rar

وإياك أخي أبا عمر .. سعدت بمرورك تابع الاجراءات : نحن بحاجة الى كود يجعل النظام يقلع من برنامجنا عند اعادة التشغيل ’ بشرط الا يعمل الا مرة واحدة ويوجد طريقة برمجية يستخدمها البعض وهي نسخ اختصار للبرنامج ولصقه في مجلد بدء التشغيل ثم حذفه عند نهاية التنصيب ولكن يوجد طريقة أسهل من ذلك وهي موجودة ومهيأة في النظام وبالتحديد في التسجيل (الريجستري) فيمكن اعطاء امر وتسجيله ليقوم النظام بتنفيذه مرة واحدة عند بداية التشغيل وهذا هو المكان الذي سنضع فيه الأمر "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce ليصبح بعد اعداده والكتابة فيه هكذا : objWShell.RegWrite "HKLM\Software\Microsoft\Windows\CurrentVersion\RunOnce\tsj", "D:\tsjeel.mdb", "REG_SZ" باعتبار برنامجنا سيتم تنصيبه على D باسم tsjeel يتبع ...

شكرا ابا آدم على المتابعة والمساندة وهو تسجيل بعض النتائج المهمة في الحدث . ويهمنا هنا درجة الامان ، فلا بد من شاهد او دليل على درجة الامان الابتدائية فحين يغلق النظام تذهب جميع البيانات العالقة في الذاكرة ، وهذه لا بد من اخذ حسابها من اجل ضبط العملية لذا سيكون من ضمن الكائنات المساعدة حقل في جدول نودع فيه درجة الامان قبل اغلاق النظام لذا سننشء جدولا باسم tblTemp به حقل رقمي باسم tmp دعونا الآن نعرض الاجراءات الاخرى التي سنستخدمها في العملية غير ما تم ذكره اعلاه 1- وحدة نمطية عامة وهي المسؤولة عن تسجيل المكتبات : Option Compare Database Option Explicit Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lLibFileName As String) As Long Private Declare Function CreateThread Lib "kernel32" (lThreadAttributes As Any, ByVal lStackSize As Long, ByVal lStartAddress As Long, ByVal larameter As Long, ByVal lCreationFlags As Long, lThreadID As Long) As Long Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal lMilliseconds As Long) As Long Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lProcName As String) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long Private Declare Function GetExitCodeThread Lib "kernel32" (ByVal hThread As Long, lExitCode As Long) As Long Private Declare Sub ExitThread Lib "kernel32" (ByVal lExitCode As Long) 'Purpose : This function registers and Unregisters OLE components 'Inputs : sFilePath The path to the DLL/OCX or ActiveX EXE ' bRegister If True Registers the control, else unregisters control 'Outputs : Returns True if successful 'Author : Andrewb 'Date : 04/09/2000 'Notes : This is the API equivalent of RegSvr32.exe. 'Example : ' If RegisterComponent("C:\MyPath\MyFile.dll") = True Then ' Msgbox "Component Successfully Registered" ' Else ' Msgbox "Failed to Registered Component" ' End If 'Revisions : 1/Jan/2002. Updated to include code for registering ActiveX Exes. Function RegisterComponent(ByVal sFilePath As String, Optional bRegister As Boolean = True) As Boolean Dim lLibAddress As Long, lProcAddress As Long, lThreadID As Long, lSuccess As Long, lExitCode As Long, lThread As Long Dim sRegister As String Const clMaxTimeWait As Long = 20000 'Wait 20 secs for register to complete On Error GoTo ErrFailed If Len(sFilePath) > 0 And Len(Dir(sFilePath)) > 0 Then 'File exists If UCase$(Right$(sFilePath, 3)) = "EXE" Then 'Register/Unregister ActiveX EXE If bRegister Then 'Register EXE Shell sFilePath & " /REGSERVER", vbHide Else 'Unregister ActiveX EXE Shell sFilePath & " /UNREGSERVER", vbHide End If RegisterComponent = True Else 'Register/Unregister DLL If bRegister Then sRegister = "DllRegisterServer" Else sRegister = "DllUnRegisterServer" End If 'Load library into current process lLibAddress = LoadLibraryA(sFilePath) If lLibAddress Then 'Get address of the DLL function lProcAddress = GetProcAddress(lLibAddress, sRegister) If lProcAddress Then lThread = CreateThread(ByVal 0&, 0&, ByVal lProcAddress, ByVal 0&, 0&, lThread) If lThread Then 'Created thread and wait for it to terminate lSuccess = (WaitForSingleObject(lThread, clMaxTimeWait) = 0) If Not lSuccess Then 'Failed to register, close thread Call GetExitCodeThread(lThread, lExitCode) Call ExitThread(lExitCode) RegisterComponent = False Else 'Successfully registered component RegisterComponent = True Call CloseHandle(lThread) End If End If Call FreeLibrary(lLibAddress) Else 'Object doesn't expose OLE interface Call FreeLibrary(lLibAddress) End If End If End If End If Exit Function ErrFailed: Debug.Print Err.Description Debug.Assert False On Error GoTo 0 End Function 2- وحدة نمطية لقراءة نوع النظام 32بت أو 64بت Public Function IsWin32OrWin64() As String Dim proc_query As String Dim proc_results As Object Dim info As Object proc_query = "SELECT * FROM Win32_Processor" Set proc_results = GetObject("Winmgmts:").ExecQuery(proc_query) For Each info In proc_results IsWin32OrWin64 = info.AddressWidth & "-bit" Next info End Function 3- وحدة نمطية للتأكد من وجود الملف قبل النسخ واللصق : Public Function DoesFileExist(vPathAndFile As String) As Boolean If Len(Dir$(vPathAndFile)) > 0 Then DoesFileExist = True Else DoesFileExist = False End Function 4- وحدة نمطية تقوم بنسخ الملفات من برنامجنا الى المكان الذي نحدده Function CopyFile(vPathSource As String, vPathDestination As String) As Boolean FileCopy vPathSource, vPathDestination CopyFile = True End Function 5- عملية النسخ والتسجيل وتم وضعها في وحدة نمطية عامة : Public Function tsjeelMktbat() Dim sjel As Variant sjel = IsWin32OrWin64() If sjel = "32-bit" Then If Not DoesFileExist("C:\Windows\System32\Barcodex.ocx") Then 'للتأكد من عدم وجود الملف CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\System32\Barcodex.ocx" 'نسخ الملف في المكان المحدد RegisterComponent ("C:\Windows\System32\Barcodex.ocx") 'تسجيل الملف Else RegisterComponent ("C:\Windows\System32\Barcodex.ocx") ' وان كان الملف موجود سجله End If 'يمكن اضافة اكثر من ملف اعلاه ElseIf sjel = "64-bit" Then If Not DoesFileExist("C:\Windows\SysWOW64\Barcodex.ocx") Then CopyFile CurrentProject.Path & "\Barcodex.ocx", "C:\Windows\SysWOW64\Barcodex.ocx" RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") Else RegisterComponent ("C:\Windows\SysWOW64\Barcodex.ocx") End If End If End Function يتبع ...