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

[حمدى الظابط]

السلام عليكم 

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

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

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

 

 

تجرية.rar

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

[kkhalifa1960]

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

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

 

[حمدى الظابط]

5 ساعات مضت, 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

 

السلام عليكم

بعد التجربة

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

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

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

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

 

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

[حمدى الظابط]

up

[Moosak]

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

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

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

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

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

أكواد ال 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

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

[ابوخليل]

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

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

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

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

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

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

[Moosak]

19 دقائق مضت, ابوخليل said:

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

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

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

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

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

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

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

[حمدى الظابط]

6 ساعات مضت, 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

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

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

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

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

 

[حمدى الظابط]

7 ساعات مضت, ابوخليل said:

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

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

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

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

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

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

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

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

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

[Moosak]

2 ساعات مضت, حمدى الظابط said:

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

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

[حمدى الظابط]

11 ساعات مضت, Moosak said:

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

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

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

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

 

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

[Moosak]

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

[حمدى الظابط]

السلام عليكم

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

@ابو خليل 

[ابوخليل]

عليكم السلام

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

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

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

 

[حمدى الظابط]

18 ساعات مضت, ابوخليل said:

عليكم السلام

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

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

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