كود لارسال ايميل او رسالة وتس

محمد متولي · فبراير 16

السلام عليكم
برجاء المساعدة في كود vba حالة بلوغ عدد الأيام الخاصة بتاريخ انتهاء العقد 60 يوم يتم ارسال ايميل او وتس للشخص المحدد بالخلية ويكون نصها كما هو بالخلية الخاصة بالرسالة

تجديد العقود.xlsx

محمد متولي · فبراير 16

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

mahmoud nasr alhasany · فبراير 24

إليك كود VBA في Excel لتحقيق ذلك، مع شرح تفصيلي:

شرح الكود

المتغيرات:
- lastRow: لتحديد آخر صف يحتوي على بيانات في العمود A (يمكنك تغيير العمود حسب الحاجة).
- i: متغير يستخدم في حلقة التكرار للمرور على الصفوف.
- endDate: لتخزين تاريخ انتهاء العقد.
- daysRemaining: لحساب عدد الأيام المتبقية حتى انتهاء العقد.
- emailAddress: لتخزين عنوان البريد الإلكتروني للشخص المعني.
- messageBody: لتخزين نص الرسالة.
حلقة التكرار:
- تكرر الحلقة على جميع الصفوف التي تحتوي على بيانات.
- تفترض أن تاريخ انتهاء العقد موجود في العمود B، وأن عنوان البريد الإلكتروني موجود في العمود C، ونص الرسالة موجود في العمود D. يمكنك تغيير هذه الأعمدة حسب الحاجة.
- يتم حساب عدد الأيام المتبقية حتى انتهاء العقد باستخدام الدالة DateDiff.
- إذا كان عدد الأيام المتبقية 60 يومًا أو أقل، يتم تنفيذ الخطوات التالية:
  - جلب عنوان البريد الإلكتروني ونص الرسالة.
  - استخدام CreateObject("Outlook.Application") لإرسال البريد الإلكتروني.
  - تحديد عنوان المرسل إليه، الموضوع، ونص الرسالة.
  - عرض البريد الإلكتروني أو إرساله مباشرةً.
إرسال واتساب:
- تتطلب هذه الخطوة استخدام واجهة برمجة تطبيقات (API) خاصة بـ WhatsApp، حيث لا يوجد طريقة مباشرة لإرسال رسائل WhatsApp باستخدام VBA فقط.
- يمكنك استخدام خدمات مثل Twilio أو MessageBird أو غيرها لإرسال رسائل WhatsApp عبر API.
- يجب عليك التسجيل في إحدى هذه الخدمات والحصول على مفتاح API.
- يمكنك استخدام الدالة CreateObject("MSXML2.XMLHTTP") لإرسال طلب HTTP إلى API الخاص بـ WhatsApp.

الكود

ملاحظات:

تأكد من تغيير أسماء الأعمدة في الكود لتتوافق مع بياناتك.
لتفعيل إرسال الايميل يجب تفعيل المكتبة الخاصة ب outlook من قائمة tools ثم references ثم اختيار Microsoft outlook Object Library.
لإرسال رسائل WhatsApp، ستحتاج إلى إضافة كود إضافي باستخدام API.
يمكنك تخصيص نص الرسالة وموضوع البريد الإلكتروني حسب الحاجة.
يمكنك جدولة تشغيل هذا الكود تلقائيًا باستخدام وظيفة "جدولة المهام" في Windows.

إضافة كود لإرسال رسائل WhatsApp باستخدام API يتطلب بعض الخطوات الإضافية. إليك شرح لكيفية القيام بذلك باستخدام خدمة Twilio، وهي واحدة من الخدمات الشائعة التي توفر واجهة برمجة تطبيقات (API) لإرسال رسائل WhatsApp:

1. التسجيل في Twilio والحصول على مفتاح API:

قم بزيارة موقع Twilio وقم بإنشاء حساب.
بعد تسجيل الدخول، انتقل إلى وحدة تحكم Twilio واحصل على مفتاح API الخاص بك (Account SID وAuth Token).
قم بتمكين WhatsApp في حساب Twilio الخاص بك.
احصل على رقم هاتف Twilio يدعم WhatsApp.

2. إضافة مكتبة MSXML2:

في محرر VBA، انتقل إلى "Tools" ثم "References".
ابحث عن "Microsoft XML, v6.0" أو إصدار أحدث وقم بتحديده.

3. كود VBA لإرسال رسالة WhatsApp:

Sub SendEmailOrWhatsApp()

    Dim lastRow As Long
    Dim i As Long
    Dim endDate As Date
    Dim daysRemaining As Long
    Dim emailAddress As String
    Dim messageBody As String

    lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A

    For i = 2 To lastRow ' ابدأ من الصف الثاني (بافتراض أن الصف الأول هو رأس الجدول)
        endDate = Cells(i, "B").Value ' تاريخ انتهاء العقد في العمود B
        daysRemaining = DateDiff("d", Date, endDate) ' حساب الأيام المتبقية
        emailAddress = Cells(i, "C").Value ' عنوان البريد الإلكتروني في العمود C
        messageBody = Cells(i, "D").Value ' نص الرسالة في العمود D

        If daysRemaining <= 60 Then
            ' إرسال بريد إلكتروني
            Dim outlookApp As Object
            Dim outlookMail As Object

            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)

            With outlookMail
                .To = emailAddress
                .Subject = "تنبيه: انتهاء العقد"
                .Body = messageBody
                .Display ' أو .Send للإرسال مباشرةً
            End With

            Set outlookMail = Nothing
            Set outlookApp = Nothing

            ' إرسال واتساب (يتطلب استخدام API)
            ' يمكنك إضافة كود لإرسال واتساب هنا باستخدام API
        End If
    Next i

End Sub

Sub SendWhatsAppMessage(phoneNumber As String, messageBody As String)

    Dim xmlHttp As Object
    Dim accountSid As String
    Dim authToken As String
    Dim twilioNumber As String
    Dim url As String

    accountSid = "ACxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' استبدل بـ Account SID الخاص بك
    authToken = "your_auth_token" ' استبدل بـ Auth Token الخاص بك
    twilioNumber = "whatsapp:+1xxxxxxxxxx" ' استبدل برقم Twilio الخاص بك
    phoneNumber = "whatsapp:+xxxxxxxxxxx" ' استبدل برقم هاتف المستلم

    url = "https://api.twilio.com/2010-04-01/Accounts/" & accountSid & "/Messages.json"

    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    xmlHttp.Open "POST", url, False
    xmlHttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(accountSid & ":" & authToken)
    xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlHttp.send "To=" & phoneNumber & "&From=" & twilioNumber & "&Body=" & EncodeUrl(messageBody)

    If xmlHttp.Status = 201 Then
        MsgBox "تم إرسال رسالة WhatsApp بنجاح!"
    Else
        MsgBox "فشل إرسال رسالة WhatsApp. الحالة: " & xmlHttp.Status
    End If

    Set xmlHttp = Nothing

End Sub

Function EncodeBase64(text As String) As String

    Dim arrData() As Byte
    arrData = StrConv(text, vbFromUnicode)

    Dim objXML As Object
    Dim objNode As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

Function EncodeUrl(text As String) As String

    Dim objXML As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    EncodeUrl = objXML.createElement("url").appendChild(objXML.createTextNode(text)).ParentNode.innerHTML

    Set objXML = Nothing

End Function

**Foksh** · الجمعة at 21:09

في 24‏/2‏/2025 at 22:11, mahmoud nasr alhasany said:
إليك كود VBA في Excel لتحقيق ذلك، مع شرح تفصيلي:

شرح الكود

المتغيرات:

lastRow: لتحديد آخر صف يحتوي على بيانات في العمود A (يمكنك تغيير العمود حسب الحاجة).

i: متغير يستخدم في حلقة التكرار للمرور على الصفوف.

endDate: لتخزين تاريخ انتهاء العقد.

daysRemaining: لحساب عدد الأيام المتبقية حتى انتهاء العقد.

emailAddress: لتخزين عنوان البريد الإلكتروني للشخص المعني.

messageBody: لتخزين نص الرسالة.

حلقة التكرار:

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

تفترض أن تاريخ انتهاء العقد موجود في العمود B، وأن عنوان البريد الإلكتروني موجود في العمود C، ونص الرسالة موجود في العمود D. يمكنك تغيير هذه الأعمدة حسب الحاجة.

يتم حساب عدد الأيام المتبقية حتى انتهاء العقد باستخدام الدالة DateDiff.

إذا كان عدد الأيام المتبقية 60 يومًا أو أقل، يتم تنفيذ الخطوات التالية:

جلب عنوان البريد الإلكتروني ونص الرسالة.

استخدام CreateObject("Outlook.Application") لإرسال البريد الإلكتروني.

تحديد عنوان المرسل إليه، الموضوع، ونص الرسالة.

عرض البريد الإلكتروني أو إرساله مباشرةً.

إرسال واتساب:

تتطلب هذه الخطوة استخدام واجهة برمجة تطبيقات (API) خاصة بـ WhatsApp، حيث لا يوجد طريقة مباشرة لإرسال رسائل WhatsApp باستخدام VBA فقط.

يمكنك استخدام خدمات مثل Twilio أو MessageBird أو غيرها لإرسال رسائل WhatsApp عبر API.

يجب عليك التسجيل في إحدى هذه الخدمات والحصول على مفتاح API.

يمكنك استخدام الدالة CreateObject("MSXML2.XMLHTTP") لإرسال طلب HTTP إلى API الخاص بـ WhatsApp.

الكود

ملاحظات:

تأكد من تغيير أسماء الأعمدة في الكود لتتوافق مع بياناتك.

لتفعيل إرسال الايميل يجب تفعيل المكتبة الخاصة ب outlook من قائمة tools ثم references ثم اختيار Microsoft outlook Object Library.

لإرسال رسائل WhatsApp، ستحتاج إلى إضافة كود إضافي باستخدام API.

يمكنك تخصيص نص الرسالة وموضوع البريد الإلكتروني حسب الحاجة.

يمكنك جدولة تشغيل هذا الكود تلقائيًا باستخدام وظيفة "جدولة المهام" في Windows.

إضافة كود لإرسال رسائل WhatsApp باستخدام API يتطلب بعض الخطوات الإضافية. إليك شرح لكيفية القيام بذلك باستخدام خدمة Twilio، وهي واحدة من الخدمات الشائعة التي توفر واجهة برمجة تطبيقات (API) لإرسال رسائل WhatsApp:

1. التسجيل في Twilio والحصول على مفتاح API:

قم بزيارة موقع Twilio وقم بإنشاء حساب.

بعد تسجيل الدخول، انتقل إلى وحدة تحكم Twilio واحصل على مفتاح API الخاص بك (Account SID وAuth Token).

قم بتمكين WhatsApp في حساب Twilio الخاص بك.

احصل على رقم هاتف Twilio يدعم WhatsApp.

2. إضافة مكتبة MSXML2:

في محرر VBA، انتقل إلى "Tools" ثم "References".

ابحث عن "Microsoft XML, v6.0" أو إصدار أحدث وقم بتحديده.

3. كود VBA لإرسال رسالة WhatsApp:
Sub SendEmailOrWhatsApp()

    Dim lastRow As Long
    Dim i As Long
    Dim endDate As Date
    Dim daysRemaining As Long
    Dim emailAddress As String
    Dim messageBody As String

    lastRow = Cells(Rows.Count, "A").End(xlUp).Row ' تحديد آخر صف في العمود A

    For i = 2 To lastRow ' ابدأ من الصف الثاني (بافتراض أن الصف الأول هو رأس الجدول)
        endDate = Cells(i, "B").Value ' تاريخ انتهاء العقد في العمود B
        daysRemaining = DateDiff("d", Date, endDate) ' حساب الأيام المتبقية
        emailAddress = Cells(i, "C").Value ' عنوان البريد الإلكتروني في العمود C
        messageBody = Cells(i, "D").Value ' نص الرسالة في العمود D

        If daysRemaining <= 60 Then
            ' إرسال بريد إلكتروني
            Dim outlookApp As Object
            Dim outlookMail As Object

            Set outlookApp = CreateObject("Outlook.Application")
            Set outlookMail = outlookApp.CreateItem(0)

            With outlookMail
                .To = emailAddress
                .Subject = "تنبيه: انتهاء العقد"
                .Body = messageBody
                .Display ' أو .Send للإرسال مباشرةً
            End With

            Set outlookMail = Nothing
            Set outlookApp = Nothing

            ' إرسال واتساب (يتطلب استخدام API)
            ' يمكنك إضافة كود لإرسال واتساب هنا باستخدام API
        End If
    Next i

End Sub

Sub SendWhatsAppMessage(phoneNumber As String, messageBody As String)

    Dim xmlHttp As Object
    Dim accountSid As String
    Dim authToken As String
    Dim twilioNumber As String
    Dim url As String

    accountSid = "ACxxxxxxxxxxxxxxxxxxxxxxxxxxxxx" ' استبدل بـ Account SID الخاص بك
    authToken = "your_auth_token" ' استبدل بـ Auth Token الخاص بك
    twilioNumber = "whatsapp:+1xxxxxxxxxx" ' استبدل برقم Twilio الخاص بك
    phoneNumber = "whatsapp:+xxxxxxxxxxx" ' استبدل برقم هاتف المستلم

    url = "https://api.twilio.com/2010-04-01/Accounts/" & accountSid & "/Messages.json"

    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    xmlHttp.Open "POST", url, False
    xmlHttp.setRequestHeader "Authorization", "Basic " & EncodeBase64(accountSid & ":" & authToken)
    xmlHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xmlHttp.send "To=" & phoneNumber & "&From=" & twilioNumber & "&Body=" & EncodeUrl(messageBody)

    If xmlHttp.Status = 201 Then
        MsgBox "تم إرسال رسالة WhatsApp بنجاح!"
    Else
        MsgBox "فشل إرسال رسالة WhatsApp. الحالة: " & xmlHttp.Status
    End If

    Set xmlHttp = Nothing

End Sub

Function EncodeBase64(text As String) As String

    Dim arrData() As Byte
    arrData = StrConv(text, vbFromUnicode)

    Dim objXML As Object
    Dim objNode As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    Set objNode = objXML.createElement("b64")
    objNode.DataType = "bin.base64"
    objNode.nodeTypedValue = arrData
    EncodeBase64 = objNode.text

    Set objNode = Nothing
    Set objXML = Nothing

End Function

Function EncodeUrl(text As String) As String

    Dim objXML As Object

    Set objXML = CreateObject("MSXML2.DOMDocument")
    EncodeUrl = objXML.createElement("url").appendChild(objXML.createTextNode(text)).ParentNode.innerHTML

    Set objXML = Nothing

End Function

جهود جميلة منكم أخي الكريم ، واسمحلي بسؤال يدور في ذهني !!

هل تمت التجربة على هذا الكود ؟؟؟؟؟؟؟؟؟؟؟؟؟

محمد متولي · منذ 23 ساعات

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

بس للاسف الشيت ما ظبط بالكود يعني اذا ممكن نخلية يرسل رسالة ايميل فقط

تسجيل الدخول

كود لارسال ايميل او رسالة وتس

الردود الموصى بها

محمد متولي

محمد متولي

mahmoud nasr alhasany

Foksh

محمد متولي

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information