تنسيق الرسالة الى واتساب

**حمدى الظابط** · يناير 12, 2023

السلام عليكم

الموضوع عند الضغط على زر الوتساب

اريد قراءة مربعات النص sub ومربع النص myname ومربع النص attach بنفس الترتيب الموجود فى الكود او بأى طريقة المهم يتم التعريف فى كود ارسال الوتساب ولكم جزيل الشكر

 rMSG = " || *" & Me.myname.Value & "*" & " ||" & vbcrlf & "|| *" & Me.msg.Value & "*" & " ||" & vbcrlf & "|| *" & Me.attach.Value & "* ||" & vbcrlf & "|| " & "المرسل : *" & Me.sub

تجرية.rarFetching info...

تم تعديل يناير 12, 2023 بواسطه حمدى الظابط

**kkhalifa1960** · يناير 12, 2023

استاذ حمدي جرب

strMSG = "*" & Me.myname.Value & "*" & "*" & Me.msg.Value & "*" & "*" & Me.attach1.Value & "*" & "المرسل":   Me.sub = "& Me.myname.Value & " & "" & vbCrLf & "*" & Me.msg.Value & "*" & "" & vbCrLf & "*" & Me.attach1.Value & "*" & vbCrLf & "" & "المرسل : *"

**حمدى الظابط** · يناير 13, 2023

في 12‏/1‏/2023 at 20:01, kkhalifa1960 said:

استاذ حمدي جرب

Option Compare Database
Dim piclink, piclink1, piclink2, piclink3, piclink4, piclink5, attach As String
Dim MsgGo As Integer

    Dim IEE As Object
    Dim SQL As String
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim Mytoname As String
    Dim stname1 As String

    Dim rs As DAO.Recordset
     Set rs = CurrentDb.OpenRecordset("email")
        rs.MoveLast: rs.MoveFirst
 Dim IE As Object

    DoCmd.RunCommand acCmdSaveRecord
    If Nz(DCount("SelectRow", "email", "SelectRow = 'R'"), 0) = 0 Then
    MsgBox "يجب اختيار المرسل اليه اولا", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
    End If
    Me.myname.SetFocus
     If IsNull(Me.msg) Then
    MsgBox "لايوجد نص للارسال", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
 If IsNull([subemail].Form![phone_number]) Then
    MsgBox "لايوجد رقم هاتف", vbCritical + vbMsgBoxRight, "تنبيه"
    Exit Sub
 End If
    If Not rs.BOF And Not rs.EOF Then
        rs.MoveFirst
        While (Not rs.EOF)
         If rs.Fields("SelectRow") = "R" Then
           Mytoname = rs.Fields(0)
           stname1 = rs.Fields("toname")

Dim strMSG As String
strMSG = "*" & Me.myname.Value & "*" & "*" & Me.msg.Value & "*" & "*" & Me.attach1.Value & "*" & "المرسل":   Me.sub = "& Me.myname.Value & " & "" & vbCrLf & "*" & Me.msg.Value & "*" & "" & vbCrLf & "*" & Me.attach1.Value & "*" & vbCrLf & "" & "المرسل : *"
Set IE = CreateObject("InternetExplorer.Application")
IE.Navigate "whatsapp://send?phone=" & rs!phone_number & "&text=""*" & strMSG & "*" & "&  app_sent =0"
Pause 3

Set IE = Nothing
Set IEE = Nothing

Dim objClipboard As Object
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText (MyFile)
objClipboard.PutInClipboard
Pause 5
SendKeys "+{TAB}"
Call SendKeys("{Enter}", True)
Pause 2
Call SendKeys("{Enter}", True)
Pause 5
Langauge ELanguage.en
Pause 5
Call SendKeys("^v", True)
Call SendKeys("{Enter}", True)
Pause 5
Set objClipboard = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objClipboard.SetText ReplaceLineBreaks(Me.msg)
objClipboard.PutInClipboard
Pause 1
Call SendKeys("^v", True)
Pause 5
Call SendKeys("{Enter}", True)
Pause 1

                DoCmd.SetWarnings False
                DoCmd.RunSQL "UPDATE email SET[SendStuts]='تم الارسال' , SelectRow ='T' WHERE [ID]=" & Mytoname
                DoCmd.SetWarnings True
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"
SendKeys "+{TAB}"

         End If
            rs.MoveNext
        Wend
    End If
    rs.Close
    Set rs = Nothing
    
MsgBox "تم الارسال"
End Sub

' =================================(وهذه دالة لجعل الواتسأب يقبل السطور الجديدة في النص المرسل)
Function ReplaceLineBreaks(text As String) As String
    ReplaceLineBreaks = Replace(text, vbCrLf, " %0a ")
    ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(10), " %0a ")
    ReplaceLineBreaks = Replace(ReplaceLineBreaks, Chr(13), " %0a ")
End Function

Expand

السلام عليكم

بعد التجربة

اولا / بيتم الارسال وهمى بمعنى يعطى اشارة تم الارسال ولكن لم تصل اى رسالة للراسل على الوتس برغم فتح برنامج الواتساب

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

ومرفق بالمشاركة كود الارسال كامل للمرجعة ومعرفة الخلل

ثالثا والاهم شكرا لك وجمعة مباركة

تم تعديل يناير 13, 2023 بواسطه حمدى الظابط

**حمدى الظابط** · يناير 14, 2023

up

**Moosak** · يناير 14, 2023

أستاذ حمدي .. غيرت لك كود الإرسال بشكل كاااااااااااامل 🙂

(الكود الآن يتجاهل المرفقات إن كان حقل المرفقات فارغا )

وهذه نتيجة الإرسال :

ملاحظة مهمة جدا جدا جدا : قمت بتعديلات أخرى على الملف غير كود الإرسال ، يجب عليك تعديلها ونقلها كلها في برنامجك وليس كود الإرسال فقط وذلك لكي تعمل لديك بشكل طبيعي .

ومن هذه التعديلات ما يلي :

أكواد ال API في الموديول FileOpen :

#If VBA7 Then
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#Else
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If

وفي الموديول 3 أيضا Module3 :

#If VBA7 Then
Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
#Else
Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
#End If

بالتوفيق 🙂

whatsapp-Moosak.rarFetching info...

تم تعديل يناير 14, 2023 بواسطه Moosak

**ابوخليل** · يناير 14, 2023

ايضا لدي توجيه للاستاذ حمدي _ وسبق ان نبهت عليه

ما دام الاستاذ موسى اجرى تعديلات جوهرية على الملف _ حاول ان تجعل هذا الملف هو الاساس عند طلبك لتعديلات اخرى حول واتساب

قم بتسميته اسما فريدا يخصه بحيث تصل اليه بسهوله

اعتقد انك تفهم قصدي .. لانك في كل استفسار ترفق مثالا يختلف عن ما سبقه .

يجب ان يكون العمل تراكمي على مثال واحد .. وتكتفي انت بالنسخ واللصق في برنامجك

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

**Moosak** · يناير 14, 2023

في 14‏/1‏/2023 at 09:01, ابوخليل said:

قم بتسميته اسما فريدا يخصه بحيث تصل اليه بسهوله

اعتقد انك تفهم قصدي .. لانك في كل استفسار ترفق مثالا يختلف عن ما سبقه .

يجب ان يكون العمل تراكمي على مثال واحد .. وتكتفي انت بالنسخ واللصق في برنامجك

Expand

شكرا لك أستاذنا العزيز @ابوخليل .. قلت كل اللي في نفسي أوصله للأستاذ حمدي 😄🌹

وإضافة إلى ذلك .. لديك الآن أكثر من موضوع في المنتدى تتكلم عن نفس القضية .. وهذا بدوره يسبب لنا ولك التشتت ..

وكذلك إجابة من هنا وإجابة من هناك سببت أن الكود به تكرارات وأسطر ليس لها داعي والنتيجة بيتزا أكواد ما تجيب أي نتيجة .. 😁

تم تعديل يناير 14, 2023 بواسطه Moosak

**حمدى الظابط** · يناير 14, 2023

في 14‏/1‏/2023 at 08:47, Moosak said:
أستاذ حمدي .. غيرت لك كود الإرسال بشكل كاااااااااااامل 🙂

(الكود الآن يتجاهل المرفقات إن كان حقل المرفقات فارغا )

وهذه نتيجة الإرسال :

ملاحظة مهمة جدا جدا جدا : قمت بتعديلات أخرى على الملف غير كود الإرسال ، يجب عليك تعديلها ونقلها كلها في برنامجك وليس كود الإرسال فقط وذلك لكي تعمل لديك بشكل طبيعي .

ومن هذه التعديلات ما يلي :

أكواد ال API في الموديول FileOpen :
#If VBA7 Then
Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#Else
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
  "GetOpenFileNameA" (ofn As OPENFILENAME) As Boolean

Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _
  "GetSaveFileNameA" (ofn As OPENFILENAME) As Boolean
#End If

#If VBA7 Then
    Public Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
#Else
    Public Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
#End If
وفي الموديول 3 أيضا Module3 :
#If VBA7 Then
Private Declare PtrSafe Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
#Else
Private Declare Function LoadKeyboardLayout Lib "user32" Alias "LoadKeyboardLayoutA" (ByVal pwszKLID As String, ByVal flags As Long) As Long
#End If
بالتوفيق 🙂

whatsapp-Moosak.rar 97.12 kB · 5 downloads
Expand

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

استاذ موسى لك من الشكر والاحترام الجزيل ولن اجد تعبير عن مدى سرورى بمشاركتك الراقية والتى اسعدتنى كثيرا

بعد التجربة على المرفق الموجود بالموضوع وجد الكود يعمل بكفاءة عالية ولكن لاحظة ملحوظة هامة

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

**حمدى الظابط** · يناير 14, 2023

في 14‏/1‏/2023 at 09:01, ابوخليل said:

ايضا لدي توجيه للاستاذ حمدي _ وسبق ان نبهت عليه

ما دام الاستاذ موسى اجرى تعديلات جوهرية على الملف _ حاول ان تجعل هذا الملف هو الاساس عند طلبك لتعديلات اخرى حول واتساب

قم بتسميته اسما فريدا يخصه بحيث تصل اليه بسهوله

اعتقد انك تفهم قصدي .. لانك في كل استفسار ترفق مثالا يختلف عن ما سبقه .

يجب ان يكون العمل تراكمي على مثال واحد .. وتكتفي انت بالنسخ واللصق في برنامجك

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

Expand

الصديق الصدوق ابو خليل

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

تم تعديل يناير 14, 2023 بواسطه حمدى الظابط

**Moosak** · يناير 14, 2023

في 14‏/1‏/2023 at 15:24, حمدى الظابط said:

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

Expand

بعد مراجعة الكود وجدت أن rs.MoveNext متكررة مرتين .. أحذف الأولى حسب الصورة التالية :

**حمدى الظابط** · يناير 15, 2023

في 14‏/1‏/2023 at 18:20, Moosak said:

بعد مراجعة الكود وجدت أن rs.MoveNext متكررة مرتين .. أحذف الأولى حسب الصورة التالية :

Expand

صباح الرزق والسعادة

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

ولا يسعنى من الكلمات غير الشكر والامتنان واعلم انى غلبتك معايا ولكنك ذو صدرا رحبم

تم تعديل يناير 15, 2023 بواسطه حمدى الظابط

**Moosak** · يناير 15, 2023

العفو أخي حمدي .. تحياتي لك 🙂🌹

**حمدى الظابط** · يناير 15, 2023

السلام عليكم

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

@ابو خليل

**ابوخليل** · يناير 16, 2023

عليكم السلام

شكرا استاذ حمدي على حرصك واهتمامك بما يخدم المصلحة العامة

طبعا في موضوع وعنوان جديد افضل .

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

**حمدى الظابط** · يناير 16, 2023

في 16‏/1‏/2023 at 00:15, ابوخليل said:

عليكم السلام

شكرا استاذ حمدي على حرصك واهتمامك بما يخدم المصلحة العامة

طبعا في موضوع وعنوان جديد افضل .

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

Expand

تسجيل الدخول

تنسيق الرسالة الى واتساب

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

حمدى الظابط

kkhalifa1960

حمدى الظابط

حمدى الظابط

Moosak

ابوخليل

Moosak

حمدى الظابط

حمدى الظابط

Moosak

حمدى الظابط

Moosak

حمدى الظابط

ابوخليل

حمدى الظابط

Join the conversation

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

تصفح الموقع

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

Support

Important Information