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

:: إضـــــافـــة :: هذا هو الموديول الذي يمكنك نقله إلى برنامجك الخاص ومناداته باسم الدالة .. Option Compare Database Option Explicit Enum AttacmentsType Image = 1 Sticker = 2 Document = 3 End Enum #If VBA7 Or Win64 Then Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr Public Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #Else Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer #End If Private Const VK_NUMLOCK = &H90 Public Sub SendToWhatsApp(txtPhone As String, txtMSG As String, Optional txtAttchmentPath As String = "", Optional AttachmentType As AttacmentsType = Image) '---------------------------------------(التحقق من اكتمال البيانات) If Len(txtMSG & "") = 0 Then MsgBox "يرجى كتابة الرسالة": Exit Sub If txtAttchmentPath <> "" Then If Len(Dir(txtAttchmentPath, vbDirectory)) = 0 Then MsgBox "المرفق غير موجود .. تأكد من الرابط": Exit Sub End If txtMSG = Replace(txtMSG, vbCrLf, " %0a ") txtMSG = Replace(txtMSG, Chr(10), " %0a ") txtMSG = Replace(txtMSG, Chr(13), " %0a ") '---------------------------------------(بداية الإرسال) Dim Path As String Path = "whatsapp://send?phone=" & txtPhone & "&text=" & txtMSG CreateObject("Shell.Application").Namespace(0).ParseName(Path).InvokeVerb "Open" ' إرسال الرسالة Sleep 2000 SendKeys "~" Sleep 500 SendKeys "~" ' إرسال المرفق إن وجد If txtAttchmentPath <> "" Then SendKeys "+{TAB}" SendKeys "~" Sleep 1000 Select Case AttachmentType Case Is = 1 ' صورة SendKeys "{UP}" ' لإرسال الصور ' SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 2 ' ملصق SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات ' SendKeys "{UP}" ' لفتح الكاميرة ' SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال Case Is = 3 ' مستند SendKeys "{UP}" ' لإرسال الصور SendKeys "{UP}" ' لإرسال الملصقات SendKeys "{UP}" ' لفتح الكاميرة SendKeys "{UP}" ' لإرسال مستند ' SendKeys "{UP}" ' لإرسال جهة إتصال End Select SendKeys "~" Sleep 1000 SendKeys txtAttchmentPath, True SendKeys "~" Sleep 2000 SendKeys "~" Sleep 1000 SendKeys "~" End If 'If NumLock is off, turn it on If GetKeyState(VK_NUMLOCK) = 0 Then 'Send NumLock key press to turn it on SendKeys "{NUMLOCK}" End If '---------------------------------------( إعادة التركيز لبرنامج الأكسس) SetForegroundWindow Application.hWndAccessApp ' MsgBox " تم الإرســــــال ", vbMsgBoxRight, "" End Sub وهكذا تنادي الدالة : SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image

اعرض الملف 🎁 :: مرسال الواتسأب :: 📨 :: الإصدار الثاني 2.0 :: مطور :: 🧬🏹 السلام عليكم ورحمة الله وبركاته يسرني اليوم أن أقدم لكم هذه الهدية المتميزة والرائعة (مرسال الواتسأب) مع المرفقات مرسال الواتسأب مع المرفقات | سلسلة هدايا الأكسس | 03| 🎁 وهو عبارة عن برنامج صغير لإرسال الرسائل للواتسأب مع المرفقات .. :: من مميزات هذا الإصدار :: - إرسال رسائل فردية أو جماعية عن طريق برنامج الواتسأب . - لا يحتاج لبرنامج الإنترنت إكسبلورر لفتح الواتسأب. - لا يغلق مفتاح الـ NumLock بعد الإرسال. -تم اختصار الكود في موديول واحد ودالة واحدة تقوم بعملية الإرسال بعدة خيارات . - لو أردت تطبيق الكود في برنامجك الخاص ستحتاج لنقل الموديول إلى برنامجك + سطر برمجي واحد فقط لعملية الإرسال. :: شرح البرنامج :: :: لتحميل البرنامج :: صاحب الملف Moosak تمت الاضافه 30 مار, 2023 الاقسام قسم الأكسيس

السلام عليكم اهداني اخي العزيز @حسونة حسين ملف اكسل يحتوي على جميع مواضيع منتدى اكسس وبروابط مباشرة اضعه بين ايديكم لا تنسونا من دعوات صالحات *********************** ( إضافات للموضوع - Moosak ) قمت بعمل تصميم بسيط لنموذج البحث وأضفته إلى الموضوع الرئيسي بعد أذن أستاذنا أبو خليل 🙂 بمجرد الكتابة تظهر النتائج .. لاستعراض الموضوع يتم الضغط على العنوان مباشرة النقر المزدوج على مربع البحث يعيد إظهار جميع النتائج 🙂 يمكن البحث بكلمات متفرقة في الجملة .. Search_Officena_Access.rar ********************************************** Access.rar

كيف يمكن معرف الارقام التى تم ارسال الرسالة لها و الارقام التى لم ترسل لها رسائل بحيث أنه فى حالة الارسال يكتب تم ارسال الرسالة وفى حاله انه لم يتم الارسال و السبب أن الرقم ليس مسجل فى الواتس يكتب لم يتم ارسال الرسالة وجزاكم الله خيراً WhatsappMessageSender.rar

بارك الله فيك استاذنا موسي روووعه زادك الله علما ما شاء الله عليك هل من الممكن استاذي تطويره بحيث أن يكون يشتغل بدون تنصيب تطبيق الواتساب تحياتي يالغالي

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

بارك الله بك اخ @lionheart في ميزان حستاتك

أتفق معك تماما عمي المهندس خالد @متقاعد 🙂 وكان جوابي السابق لأخي @ابو هاله النبلسي عن طريقة استخدام الأداة وعن الصياغة .. ولم يكن عن المنطق .. أما لو تطرقنا للمنطق وطبقنا فكرتك عمي خالد فهنا الأمر يتطلب إضافة معيار جديد للقيمة الفريدة كالـ ID مثلا .. وتطبيقه بالأداة سيكون هكذا : والدالة الناتجة هكذا : DLookUp("[First Name]","[SampleTable]","[BirthDate] >=#"& [Forms]![SampleForm]![TxtBox1] &"# And [BirthDate] <=#"& [Forms]![SampleForm]![TxtBox2] &"# And [ID] =90 ") وهذا ينطبق على المعامل Like .. الحل يكمن في إضافة المعيار الفريد .. 🙂

ستعمل الدالة ولكن قد تعود بنتيجة غير المطلوبه إذا كان هناك أكثر من حقل يلبي المعايير،ترجع الدالة DLookup بالتكرار الأول مثلا لو كان لدينا 10 موظفين تم تعينهم في الفترة من 1/9 الى 3/9 ووضعنا معيار الدالة من الى او بين ستعود الدالة باول سجل وستهمل باقي السجلات التي تتوافق مع المعيار لذا فكما اشرت في مشاركة سابقة ان هذا الاستخدام غير مالوف سواء باستخدام بين او مثل ولتلافي ذلك نحتاج الى معيار فريد للحصول على النتيجة الصحيحة

جرب الملف المدرسة.xlsm

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

Insert module and paste the following code Sub Highlight_Names_In_Similar_Groups() Dim groupColors(), ws As Worksheet, sh As Worksheet, colRange As Range, cell As Range, sName As String, lr As Long, i As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets(2) Set sh = ThisWorkbook.Worksheets(3) Set colRange = ws.Range("E12:N20") lr = sh.Cells(sh.Rows.Count, 3).End(xlUp).Row groupColors = RandomColors(colRange.Columns.Count, True) sh.Columns("C:F").Interior.Color = xlNone For Each cell In colRange.Cells sName = Trim(cell.Value) If sName <> Empty Then For i = 3 To lr If Trim(sh.Cells(i, 3).Value) = sName And sh.Cells(i, 3).Interior.Color <> xlNone Then sh.Cells(i, 4).Resize(, 3).Interior.Color = groupColors(cell.Column - 4) End If Next i End If Next cell Application.ScreenUpdating = True End Sub Function RandomColors(ByVal numColors As Long, Optional ByVal lightColorsOnly As Boolean = False) Dim isUnique As Boolean, i As Long, j As Long ReDim colors(1 To numColors) For i = 1 To numColors Do If lightColorsOnly Then colors(i) = RGB(Int(Rnd() * 128) + 128, Int(Rnd() * 128) + 128, Int(Rnd() * 128) + 128) Else colors(i) = RGB(Int(Rnd() * 256), Int(Rnd() * 256), Int(Rnd() * 256)) End If isUnique = True For j = 1 To i - 1 If colors(i) = colors(j) Then isUnique = False: Exit For Next j Loop Until isUnique Next i RandomColors = colors End Function Then in worksheet module of the first worksheet add this part at the end of the existing code Next c End If If Target.Address = "$C$2" Then Call Highlight_Names_In_Similar_Groups End Sub

تفضل اخي Private Sub Select_and_Copy_File1_Click() Dim file As Variant Dim copyToFolder As String Dim p As Long Dim filePath As String filePath = Application.ActiveWorkbook.path file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه") If file = False Then Exit Sub On Error Resume Next MkDir filePath & "\" & "اوفيسنا" ' إنشاء نسخة في مجلد آخر copyToFolder = filePath & "\" & "اوفيسنا" ' If copyToFolder <> Left(file, InStrRev(file, "\")) Then p = InStrRev(file, "\") If Right(copyToFolder, 1) = "\" Then p = p + 1 FileCopy file, copyToFolder & Mid(file, p) Else 'إنشاء نسخة في نفس المجلد - اظافة "نسخة من " الى اسم الملف p = InStrRev(file, ".") FileCopy file, Left(file, p - 1) & "نسخة من" & Mid(file, p) End If MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & copyToFolder & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" End Sub او بهدا الشكل Private Sub Select_and_Copy_File_Click() Dim MH As String, folder As String, p As String, NwPath As String Dim file As Variant Dim copyToFolder As String Set wb = ThisWorkbook p = wb.Path & "\" 'هنا قم باختيار اسم المجلد الدي سيتم انشاءه MH = "اوفيسنا" NwPath = p & MH folder = Dir(NwPath, vbDirectory) If folder = vbNullString Then VBA.FileSystem.MkDir (NwPath) End If file = Application.GetOpenFilename(FileFilter:="جميع الملفات (*.*), *.*", MultiSelect:=False, Title:="حدد الملف المراد نسخه") If file = False Then Exit Sub copyToFolder = filePath If copyToFolder <> Left(file, InStrRev(file, "\")) Then p = InStrRev(file, "\") If Right(NwPath, 1) = "\" Then p = p + 1 FileCopy file, NwPath & Mid(file, p) End If MsgBox " :تم نسخ الملف بنجاح في مجلد" & vbLf & vbLf & SvAs & "" & NwPath & vbLf & "" & vbLf & ":الفارس محمد رجب" & vbCrLf, vbInformation + vbOKOnly, " ! تعليمات" End Sub الارشيف الاكترونى_v2.xlsb

هكذا؟ Sub test() Dim r As Range Dim a Dim k&, c&, z& k = 7 Application.ScreenUpdating = False With Sheets("تقرير الوردية اليومي") a = .Cells(4, 2).Resize(, 13) For Each r In .Range("B5:B" & Cells(Rows.Count, 2).Row).SpecialCells(2, 23).Areas .Cells(r(1).Row, 2).Offset(1).Resize(r.Rows.Count, .Cells(r(1).Row, Columns.Count).End(xlToLeft).Column - 1).Copy z = Sheets("شيت مجمع").Cells(Rows.Count, 1).End(xlUp).Row + 1 Sheets("شيت مجمع").Cells(z, k).PasteSpecial Paste:=xlPasteValues k = k + 12 c = r.Rows.Count - 1 Next Sheets("شيت مجمع").Cells(z, 1).Resize(c, 6) = Application.Index(a, 1, Array(2, 4, 6, 8, 10, 13)) End With Application.ScreenUpdating = True End Sub

ترحيل السلة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته تفضل اخي احمد أغذية =SI(E11="";"";SI([@[Finnish Prodect ]]="FP";SOMME.SI.ENS(Q11:Q100;H11:H100;$H11;I11:I100;$I11;X11:X100;"*أغذية*"))) جينرال =SI(E11="";"";SI([@[Finnish Prodect ]]="FP";SOMME.SI.ENS(Q11:Q100;H11:H100;$H11;I11:I100;$I11;X11:X100;"جينرال"))) معادلة Sumifs_01.xlsx

وعليكم السلام استاذي ومعلمي القدير @محمد حسن المحمد اسمح لي بالمشاركه من باب التنوع وزياده السائل بالمعرفه استاذ @مصطفى العراقي1988 يمكن استخدام المعادله =COUNTIF(A3:F3,"*ع") مسودة.xlsx

وعليكم السلام يمكنك استخدام هذه المعادلة =COUNTA(A2:F2)-COUNTBLANK(A2:F2) واسحب نزولاً تقبل تحياتي

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

السلام عليكم ورحمة الله وبركاته اولا الشكر الجزيل لكل من سال عني او خطرت بباله وهناك ظروف شخصية منعتني من التواصل منكم لما سببته لي من اثر نفسي والحمد لله على ذلك ======================================================== واقدم اليكم اليوم برنامج التقويم و هو عبارة عن فورم صغير بامكانيات هائلة للتعامل مع التقويمين الميلادي والهجري بسهولة ولاضافة التواريخ في اوراق العمل في جميع مصنفات الاكسل المفتوحه بالتقويم الذي يناسب احتياجاتك والتبديل بين التاريخ باي تقويم الى التقويم الآخر , يمكنك من خلاله ايضا حساب عمرك وامكانيات اخرى ستكتشفها اثناء التعامل مع البرنامج و ان شاء الله تكون بشرى سارة لمستخدمي التقويم الهجري واليكم نبذه من تعليمات البرنامج التقويم الافتراضي : ========== التقويم الافتراضي هو التقويم الذي يكون محفزاً و يتم العمل عليه عند دخولك الفورم. ولديك إمكانية تغيير التقويم (الذي يناسب احتياجاتك للتعامل معه في ادخال التواريخ في اوراق العمل) لجعله التقويم الافتراضي للبرنامج بشكل دائم. التاريخ الافتراضي : ========== عند فتحك الفورم ستجد تاريخ اليوم هو الافتراضي وبإمكانك التشييك على اي تاريخ تريده و بأي تقويم تريده والتنقل بين التواريخ بكل سهولة . و إذا أردت العودة الى تاريخ اليوم إضغط زر اليوم . اضافة التاريخ : ======== اضافة التاريخ الى خلية معينة بكل سهولة و بإي تقويم تريده حسب إختيارك , ثم إضغط الزر ذو اللون الأصفر لوضع التاريخ في الورقة . ملاحظة : يمكنك ايضاً إدخال اكثر من تاريخ في الورقة و التنقل بين خلايا الورقة والفورم مفتوح . الانتقال الى تاريخ معين : ============= الانتقال الى تاريخ معين بالتقويم الهجري أو الميلادي بدلالة التاريخ بالتقويم المعاكس له . مثال : ==== لواردت معرفة تاريخ ميلادك بالهجري بدلالة التاريخ بالميلادي اختار التاريخ ثم شيك على التاريخ الهجري , والعكس صحيح . حساب العمر : ======== إذا اردت حساب عمرك باي تقويم شيك على تاريخ ميلادك ثم اضغط زر عمري ملاحظة : هناك اختلاف في حساب العمر بين التقويم الميلادي (اصغر) والتقويم الهجري (اكبر) . ______________.rar