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

* ملحوظة : انا خذت الكود في موقع اجنبي في البداية اريد اقول سنحتاج مكتبة Microsoft WMI Scripting v2.1 library الصق هذا الكود في وحدة نمطية Option Compare Database Option Explicit Const Arr = 2 Public Function GetPcSnCpuAndMotherboard() ' Microsoft WMI Scripting v2.1 library ستحتاج مكتبة DoCmd.Hourglass True Dim SWbemSet(Arr) As SWbemObjectSet Dim SWbemObj As SWbemObject Dim varObjectToId(Arr) As String Dim varSerial(Arr) As String Dim i, j As Integer Dim fld As String On Error Resume Next varObjectToId(1) = "Win32_BaseBoard,SerialNumber" varObjectToId(2) = "Win32_Processor,ProcessorId" For i = 1 To Arr Set SWbemSet(i) = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf(Split(varObjectToId(i), ",")(0)) varSerial(i) = "" For Each SWbemObj In SWbemSet(i) varSerial(i) = SWbemObj.Properties_(Split(varObjectToId(i), ",")(1)) 'Property value varSerial(i) = Trim(varSerial(i)) If Len(varSerial(i)) < 1 Then varSerial(i) = "Unknown value" Next fld = "Text" & i Forms("FORM2")(fld) = varSerial(i) ' غير اسم فورم 2 الى اسم الفورم عندك Next DoCmd.Hourglass False End Function وفي النموذج في اي حدث تريد مثلا عند تحميل او عند الضغط على كليك مثلا اكتب في محرر فيجوال هذا Call GetPcSnCpuAndMotherboard ويجب ان يكون عندك مربعين نصيين واسمهما بيكون text1 والاخر بيكون text2 على الرغم اننا نكدر نغيره الى مانريد في وحده‌ نمطية =============== واذا تريد ان توصل الى احد من سريالات وبدون استخدام وحدة النمطية اليك هذا Private Sub Form_Load() ' Microsoft WMI Scripting v2.1 library ستحتاج مكتبة Dim varObjectToId As String Dim varSerial As String On Error Resume Next varObjectToId = "Win32_BaseBoard,SerialNumber" ' اذا تريد ان تبحث عن معالج اكتب الصدر الادناه بدل السطر اعلاه 'varObjectToId = "Win32_Processor,ProcessorId" Set SWbemSet = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf(Split(varObjectToId, ",")(0)) varSerial = "" For Each SWbemObj In SWbemSet varSerial = SWbemObj.Properties_(Split(varObjectToId, ",")(1)) varSerial = Trim(varSerial) If Len(varSerial) < 1 Then varSerial = "Unknown value" Next Me.Text1 = varSerial End Sub واخيرا اتفضل مع قاعدة بيانات بها الطريقتين لمعرفة سريال نمبر المعالج واللوحة الأم.rar

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

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

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

ترقيم تلقائي يتجدد مع بداية كل سنة على النحو التالي 1300001 1300002 1300003 1400001 1400002 وهكذا ................. باعتبار الرقم 13 ، 14 هو السنة والترقيم لاشك سيكون تبعا للسنة الحالية Private Sub Form_BeforeInsert(Cancel As Integer) On Error Resume Next Dim xLast, xNext As Integer Dim prtyr, prtTxt As Integer prtyr = Right(DatePart("yyyy", Date), 2) prtTxt = Left(DMax("ID", "tbl1"), 2) xLast = DMax("ID", "tbl1", prtTxt = prtyr) If IsNull(xLast) Then xNext = 1 Else xNext = Val(Mid(xLast, 3, 5)) + 1 End If Me!ID = prtyr & Format(xNext, "00000") End Sub ترقيم تلقائي جديد كل سنة.rar

السلام عليكم ورحمة الله أساتذتنا وأصدقائنا الكرام في هذ الصرح العملاق والمتميز دائماً في فعل ونشر المعرفة والخير للجميع اليوم أتيت لكم ببرنامجي البسيط والمتواضع الذي ولله الحمد قد قمت ببرمجته في عام 2015 وأستخدمته أحدى شركات المقاولات التي تحتوي مايقارب عن 500 موظف في الأونة الأخيرة تم نشر برامج كثيرة حول مجال شؤون الموظفين والمرتبات ولكن كانت تقتصر فقط على مبدأ أرشفة بيانات الموظفين ولكن الآن تستطيع أخي المستخدم غير ذلك بكثير ، وهي إضافة المرتب لكل موظف في حسابه حسب اختيار المستخدم لفترة استحقاق المرتب له وعند دخول وقت الاستحقاق يقوم البرنامج بالتنبيه وتذكيرك بسحب المرتبات وأيضاً تستطيع إضافة حركات مالية أخرى كنظام السلف والدفعات والمسحوبات على المرتب وميزات كثيرة سوف تكتشفها بنفسك عند الاستخدام . قمت بإضافة نظام الحماية المتميز وهو تفعيل النسخة بالرقم التسلسي للوحة الأم بحيث تعمل النسخة على جهاز واحد فقط وعند النقل يتم قفل البرنامج عن العمل صور من البرنامج صورة تفعيل البرنامج روابط التحميل Office Soft.Employ & Salary أو Office Soft.Employ & Salary فيديو شرح التنصيب والتثبيت من هنا فيديو طريقة ألية عمل واستخدام البرنامج من هنا الشرح التفصيلي للبرنامج موجود في مجلد البرنامج بعد تثبيته على جهاز الكمبيوتر ملاحظة مهمة :يرجى عدم تغيير مسار تنصيب البرنامج لكي يعمل معكم بشكل كامل أو تنصيبه في مسار أخر غير القرص الصلب (C) البرنامج تم تجربته على أوفيس 2010 و 2007 ويعمل بشكل كامل ومتميز أتمنى أن ينال أعجابكم والحمد لله

السلام عليكم تفضل أخي التعديل البحث.rar

جزيت خيرا استاذنا .. فقد كفيتنا المؤونة وأجدت

استأذن من استاذنا ابو خليل على المداخلة اتفضل ما طلبت للعلم انا غيرت اسماء الحقول من number الى number1 ومن code الى code1 لان تلك الاسماء محجوزة لكي يتجنب من الاخطاء واتفضل استخدمت هذا الكود Private Sub f_date_AfterUpdate() On Error Resume Next If Me.number1 <> 0 Then Me.Undo Exit Sub End If If DCount("number1", "tp1") < 1 Or IsNull(DMax("number1", "tp1", "[f_date]=#" & Format(Me.f_date.Value, "dd/mm/yyyy") & "#")) = True Then Me.number1 = 1 Me.code1 = Left(Right(Me.f_date, 2), 4) & "\" & Format(Me.f_date, "mm") & "\" & Format(Me.f_date, "dd") & "-000" & Me.number1 Else Me.number1 = DMax("number1", "tp1", "[f_date] =#" & Format(Me.f_date.Value, "dd/mm/yyyy") & "#") + 1 Me.code1 = Left(Right(Me.f_date, 2), 4) & "\" & Format(Me.f_date, "mm") & "\" & Format(Me.f_date, "dd") & "-000" & Me.number1 End If End Sub واليك ملفك بعد تعديل واذا ما فهمت من الكود راح نشرح لك باذن الله تقبل تحياتي db9790.rar

السلام عليكم يمكن الحل في الملف المرفق... بن علية معادلة مساعدة لاستثناء بعض الارقام من الجمع.rar

جرب هذا الماكرو الارقام الملونة هي الارقام الخاصة salim الجمع.rar

الاح ناصر انا منزلة على الرابط التالى وعموما اسم البرنامج Button Shop 4

استاذ حمادة تسليم ايدك جزاك الله كل خيراً

وعليكم السلام لا تطبع النموذج الفرعي اطبع تقرير (صورة من النموذج الفرعي ) اي : اجعل مصدر بيانات التقرير هو مصدر النموذج

تحميل الملف Time.rar

السلام عليكم ورحمة الله اخى الكريم ربما طلبك فى هذا الملف قصول و لجان.rar

اتفضل هذا الكود بيعطيك سريال نمبر لمزربورد Const Arr = 1 Public Function GetPCInfo() 'You need to have Microsoft WMI Scripting v2.1 library Registered in your references DoCmd.Hourglass True Dim SWbemSet(Arr) As SWbemObjectSet Dim SWbemObj As SWbemObject Dim varObjectToId(Arr) As String Dim varSerial(Arr) As String Dim i, j As Integer Dim fld As String On Error Resume Next varObjectToId(1) = "Win32_BaseBoard,SerialNumber" For i = 0 To Arr Set SWbemSet(i) = GetObject("winmgmts:{impersonationLevel=impersonate}").InstancesOf(Split(varObjectToId(i), ",")(0)) varSerial(i) = "" For Each SWbemObj In SWbemSet(i) varSerial(i) = SWbemObj.Properties_(Split(varObjectToId(i), ",")(1)) 'Property value varSerial(i) = Trim(varSerial(i)) If Len(varSerial(i)) < 1 Then varSerial(i) = "Unknown value" Next fld = "Text" & i Forms("form2")(fld) = varSerial(i) Next DoCmd.Hourglass False End Function خذت من موقع اجنبي وغدا ان شاء الله راح ارفع لك نموذج على ذلك تحياتي

الى هنا اقول وباعلى صوت حق لك ان تصبح خبير واكثر استاذ شيفان

ربما هذا الكود يقوم بالمهمة Private Sub Worksheet_Change(ByVal Target As Range) Application.EnableEvents = False If Target.Column = 1 And Target.Count = 1 And Target.Address <> "$A$1" Then If Target.Offset(, 3) = "" Then Target.Offset(, 3) = Time End If Application.EnableEvents = True End Sub

جرب هذا الكود يجب تغيير اسم الصفحة الى "jan" ,وذلك لحسن التعامل مع اللغة الاجنبية (و لا اعلم لماذا حملت الملف كله كان يكفي حوالي 100 صف -كنموذج) Sub find_for_me() With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With If ActiveSheet.Name <> "jan" Then GoTo 1 Set my_sh = Sheets("jan") Dim FoundCell As Range Dim LastCell As Range Dim FirstAddr, My_string As String My_string = "المبيعات" my_sh.Range("H2:H50000").Clear Set FoundCell = my_sh.Range("d:d").Find(what:=My_string, after:=my_sh.Cells(1, 4), lookat:=xlPart) If Not FoundCell Is Nothing Then FirstAddr = FoundCell.Address t = 1 Do Until FoundCell Is Nothing Cells(m + 2, 8) = FoundCell.Row - 1 Cells(FoundCell.Row - 1, 4) = t m = m + 1 t = t + 1 Set FoundCell = Range("D:D").FindNext(after:=FoundCell) If FoundCell.Address = FirstAddr Then Exit Do Loop '============================== k = 2 Do Until Cells(k, "h") Is Nothing ActiveSheet.Hyperlinks.Add Anchor:=Cells(k, "h"), Address:="", SubAddress:= _ "jan!E" & Cells(k, "h").Value, ScreenTip:="GOTO E" & Cells(k, "h").Value k = k + 1 Loop '===================== 1: With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With End Sub مرفق الملف مع الكود Hyper_Salim.rar

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

بسم الله الرحمن الرحيم وبه نستعين أخى وأستاذى القدير / محمد طاهر السلام عليكم ورحمته الله وبركاته بداية جزاكم الله خيرا وبارك فيكم ورزقنا واياكم من حيث لانحتسب عليك أن تأمر وعلينا التنفيذ فكما تعلم سيادتكم أن صدقة العلم نشرة ارجو الافادة حال عدم حل المشكلة تمهيدا لاعادة رفع الموضوع واليك رابط الموضوع تقبل وافر تقديرى واحترامى وجزاكم الله خيرا https://www.officena.net/ib/topic/76449-منع-وإخفاء-وطباعة-أوراق-محددة-فى-مصنف-سعيد-بيرم/

فورم بحث واضافة وحذف صف وتعديل بيانات وشرح طريقة عمل الازرارا نتمنى ان يكون المطلوب فيديو الشرح فورم بازرار.rar

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

وعليكم السلام ورحمة الله وبركاته مرحبا اخي الكريم ديو05 للاسف المرفق بصيغة accdb والاوفيس عندي 2003 يعمل بصيغة mdb جهزت لك ملف ارجو ان تجد ما تبحث عنه تحياتي db03.rar ============= نفس الملف مع اضافة زر امر تحياتي db03.rar

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

اليك هذا الرابط لعل تستفيد منه

عندك كم الوان .. هل عدد الالوان اللي عندك بيكون يساوي مع عدد الارقام ؟

سؤال : وهل من المحتمل ان يكون كله سوى او اثنين معا اي يعني مبلغ من الرياض الى مكة + مبلغ من مكة الى المدينة او تختار واحد منه فقط

بارك الله فيك و جزاك الله خير الجزاء

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

تم المطلوب تم إرجاع نطاق البحث من النطاق A2 إلى أخر النطاق الذي به البيانات لانه لو تم تحديد بيانات البحث البيانات الي قبل النطاق 7 وبعد 27 لن تظهر لك في عملية البحث وبذلك لن تستطيع التعديل او حذفها تم التعديل على زر التعديل والحذف ليتماشى مع ما طلبته مواضيع معدل.rar بقي زر الإضافة راح أحاول في الكود

بالسبة لتحديد نطاق البحث في حدث تكست البحث قم بتعديل السطر 8 بهذا الكود For Each c In Range("B7:B26") ليصبح على النحو التالي Private Sub TextBox4_Change() TextBox1.Value = "" TextBox2.Value = "" TextBox3.Value = "" ListBox1.Clear Sheets(1).Activate ListBox1.Clear k = 0 For Each c In Range("B7:B26") B = InStr(c, TextBox4) If B > 0 Then ListBox1.AddItem ListBox1.List(k, 0) = Cells(c.Row, 2).Value ListBox1.List(k, 1) = Cells(c.Row, 1).Value ListBox1.List(k, 2) = Cells(c.Row, 3).Value k = k + 1 End If Next c End Sub اما بخصوص اضافة اسم لم افهم جيدا هل تريد الاضافة قبل السطر 26

السلام عليكم الاخ الكريم / ٍآلـ طاهر بارك الله فيك عذرا للتأخير في الرد ... وذلك نظرا لضيق الوقت شاهد اخي المرفق والطريقة الموجودة به يفتح الملف الاساسي ( main ) معك وتفتح الفورم الخاصة بك قم باختيار الملف الذي تريد التسجيل به من الكومبوبكس وان كنت تريد التسجيل في الملف الاساسي نفسه تجاهل الكومبوبكس الاول ثم اكمل البيانات وقم بالترحيل وشاهد النتيجة وان كانت النتيجة كما تريد نكمل العمل سويا وعذرا تم تغيير اسماء الملفات للانجليزية لعطل فني لدي بالنسخة ملحوظة : يجب ان تكون كل الملفات في فولدر واحد شاهد المرفق واخبرنا بالنتائج تقبل خالص تحياتي واعتذاري نهائي.rar

للرفع

'تحويل الى اكسل DoCmd.OutputTo acOutputReport, "myreport", "excelworkbook(*.xlsx)" ' تحويل الى وورد DoCmd.OutputTo acOutputReport, "myreport", "richtextformat(*.rtf)" اتفضل اخي بدل كلمة myreport الى اسم تقريرك مع تقدير

السلام عليكم تعليم برنامج الاكسس 2010 الجزء الاول http://www.mediafire.com/?07u7um8n2ptwg77 الجزء الثاني http://www.mediafire.com/?tt7k8dz8j2h3tkh

قم بانشاء جدول بحقل واحد اسم الجدول tblCheck اسم الحقل strCheck نوع الحقل Number في النموذح وعند حدث عند الضغط لزر الأمر انسخ Private Sub Command0_Click() lntCount = DCount("*", "tblcheck") If lntCount > 0 Then MsgBox " mohamed" MsgBox " salah" Exit Sub End If MsgBox " waleed" strSQL = "INSERT INTO tblcheck (strCheck) VALUES (1 );" DoCmd.SetWarnings False DoCmd.RunSQL strSQL DoCmd.SetWarnings True MsgBox " mohamed" MsgBox " salah" End Sub

بارك الله فيك و إن كان قليلا على 9 سنوات

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