ارسال رسائل الواتس اب عبر الاكسس وعلاقه انترنت اكسبلور

[رياض البرعي]

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

ارسال واتس اب.accdb

تم تعديل يونيو 6, 2023 بواسطه رياض البرعي
الصوره لم ترفق من قبل

[رياض البرعي]

وين الردود 
50 قراءه للموضوع 
مافي حتى رد 
😢

[Moosak]

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

استغن عن الأكسبلورر بهذا الكود ( ضعه في وحدة نمطية ) واستخمه كالتالي : 

Option Compare Database
Option Explicit

Enum AttacmentsType
Image = 1
Sticker = 2
Document = 3
End Enum

#If VBA7 Or Win64 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer

#Else
    Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private 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

Sub test()
' لا تنس إضافة كود الدولة
SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image

End Sub

طريقة الاستخدام : 

SendToWhatsApp "96899445566", "السلام عليكم", "C:\Users\User\Desktop\123.jpg", Image

 

راجع : 

 

 

[دروب مبرمج]

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

استغن عن الأكسبلورر بهذا الكود ( ضعه في وحدة نمطية ) واستخمه كالتالي : 

كلمة فنان او معلم او محترف قليلة في انسان عظيم مثلك 

يشرفني بأن احتفظ بهذه الشفرة في مكتبتي 

[Moosak]

تشريف أخي العزيز @دروب مبرمج ☺️

[رياض البرعي]

@Moosak
هذا هو المطلوب اخي
الف الف شكر 

جريت الكود و شغال 100%
و افضل من الانترنت اكسبلور حيث كان الاكسبلور بطئ نوعا ما 
 

@Moosak

سوال اخير ياغالي 
هل هناك كود لجعل الاكسس يحفظ التقرير كصوره jpeg  او png 
 

[ابوخليل]

36 دقائق مضت, رياض البرعي said:

سوال اخير ياغالي 
هل هناك كود لجعل الاكسس يحفظ التقرير كصوره jpeg  او png 
 

نرجوا مراعاة قواعد المشاركات

افراد كل موضوع بعنوان مستقل