WhatsApp ile otomatik olarak dinamik mesaj gönderme

[Tevfik_Kursun]

Merhaba Arkadaşlar,
Sitede yaptığım aramalarda ;
https://www.excel.web.tr/threads/excel-ile-web-whatsappa-mesaj-goenderme.176607/#post-974774
Bu adresteki dosya ile tek kişiye, kişiyi oluşturup manuel olarak yazıp gönderebiliyorsunuz

https://excel.web.tr/threads/whatsapp-da-otomatik-veri-goenderimi.166843/
Bu adresteki dosya telefonu listede olan herkese aynı mesajı otomatik olarak gönderiyor.

Acaba gönderilecek her kişide bilgi değişikliği varsa WhatsApp'ta bu nasıl gönderilir? Daha da doğrusu, örnekteki ilk sayfada C3:H12 arasını birleştirmişler. Ama nasıl yapılmış anlamadım. O bölüm değişken kabul etmiyor. Bunu anlayabilirsen sorunu çözerim. (Bu çalışma Mozilla'da güzel çalışıyor)
Saygılarımla

 

[Asri]

Hocam, bu şekilde deneyiniz.
Mesaj sayfasında gönderilecek mesajı istediğiniz şekilde değiştirebilirsiniz.

Sub Gonder()
' işlem sırasında mouse'un odağını tıklatamaz veya değiştiremez veya tuşlara basamazsın
Dim text As String
Dim Contato As String

mesajorg = Sheets("Mesaj").Range("A1").Value

If mesajorg = "" Then
   MsgBox "Gönderilecek mesajı gir!", 64, "Prosedür Hatası"
   Exit Sub
End If

Shell "C:\Program Files (x86)\Mozilla Firefox\firefox.exe" & " https://web.whatsapp.com/"
'Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/"

Fazer (15000)
linha = 2

Do Until Sheets(1).Cells(linha, 1) = ""
    Fazer (2000)
    Contato = Cells(linha, 1)
    adi = Cells(linha, "B").Value
    link = Cells(linha, "C").Value
    mesaj = Replace(mesajorg, "{ADI}", adi)
    mesaj = Replace(mesaj, "{LINK}", link)
   
    If Contato = "" Then
        MsgBox "İrtibat adresini doldurun!", 64, "Lütfen en az birkişi girin"
        Exit Sub
    End If

    Fazer (3000)
    Call SendKeys("{TAB}", True)
    Call SendKeys(Contato, True)
    Call SendKeys("~", True)

    Fazer (8000)
    Call SendKeys(mesaj, True)
    Call SendKeys("~", True)
    Cells(linha, "D").Value = "Gönderildi"
    linha = linha + 1
Loop
End Sub

Function Fazer(ByVal Acao As Double)
    Application.Wait (Now() + Acao / 24 / 60 / 60 / 1000)
End Function

Sub teste()
    Fazer (5000)
    MsgBox "suel"
End Sub

 

[hgenc545]

merhaba b

Hocam, bu şekilde deneyiniz.
Mesaj sayfasında gönderilecek mesajı istediğiniz şekilde değiştirebilirsiniz.

Sub Gonder()
' işlem sırasında mouse'un odağını tıklatamaz veya değiştiremez veya tuşlara basamazsın
Dim text As String
Dim Contato As String

mesajorg = Sheets("Mesaj").Range("A1").Value

If mesajorg = "" Then
   MsgBox "Gönderilecek mesajı gir!", 64, "Prosedür Hatası"
   Exit Sub
End If

Shell "C:\Program Files (x86)\Mozilla Firefox\firefox.exe" & " https://web.whatsapp.com/"
'Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/"

Fazer (15000)
linha = 2

Do Until Sheets(1).Cells(linha, 1) = ""
    Fazer (2000)
    Contato = Cells(linha, 1)
    adi = Cells(linha, "B").Value
    link = Cells(linha, "C").Value
    mesaj = Replace(mesajorg, "{ADI}", adi)
    mesaj = Replace(mesaj, "{LINK}", link)
  
    If Contato = "" Then
        MsgBox "İrtibat adresini doldurun!", 64, "Lütfen en az birkişi girin"
        Exit Sub
    End If

    Fazer (3000)
    Call SendKeys("{TAB}", True)
    Call SendKeys(Contato, True)
    Call SendKeys("~", True)

    Fazer (8000)
    Call SendKeys(mesaj, True)
    Call SendKeys("~", True)
    Cells(linha, "D").Value = "Gönderildi"
    linha = linha + 1
Loop
End Sub

Function Fazer(ByVal Acao As Double)
    Application.Wait (Now() + Acao / 24 / 60 / 60 / 1000)
End Function

Sub teste()
    Fazer (5000)
    MsgBox "suel"
End Sub

Merhaba sayın @asri

Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/

bende macro burada takılıyor, syntax error veriyor. sorun ne olabilir..

 

[Tevfik_Kursun]

Sayın Asri Hocam,
Her zamanki gibi süpersiniz. Çok teşekkür ederim.
Saygılarımla

 

[Asri]

merhaba b



Merhaba sayın @asri

Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/

bende macro burada takılıyor, syntax error veriyor. sorun ne olabilir..

Google chrome un yolunda sorun vardır.
Bir de Program Files dan bakın x86 sız olanı.

 

[enboy81]

Hocam, bu şekilde deneyiniz.
Mesaj sayfasında gönderilecek mesajı istediğiniz şekilde değiştirebilirsiniz.

Sub Gonder()
' işlem sırasında mouse'un odağını tıklatamaz veya değiştiremez veya tuşlara basamazsın
Dim text As String
Dim Contato As String

mesajorg = Sheets("Mesaj").Range("A1").Value

If mesajorg = "" Then
   MsgBox "Gönderilecek mesajı gir!", 64, "Prosedür Hatası"
   Exit Sub
End If

Shell "C:\Program Files (x86)\Mozilla Firefox\firefox.exe" & " https://web.whatsapp.com/"
'Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/"

Fazer (15000)
linha = 2

Do Until Sheets(1).Cells(linha, 1) = ""
    Fazer (2000)
    Contato = Cells(linha, 1)
    adi = Cells(linha, "B").Value
    link = Cells(linha, "C").Value
    mesaj = Replace(mesajorg, "{ADI}", adi)
    mesaj = Replace(mesaj, "{LINK}", link)
  
    If Contato = "" Then
        MsgBox "İrtibat adresini doldurun!", 64, "Lütfen en az birkişi girin"
        Exit Sub
    End If

    Fazer (3000)
    Call SendKeys("{TAB}", True)
    Call SendKeys(Contato, True)
    Call SendKeys("~", True)

    Fazer (8000)
    Call SendKeys(mesaj, True)
    Call SendKeys("~", True)
    Cells(linha, "D").Value = "Gönderildi"
    linha = linha + 1
Loop
End Sub

Function Fazer(ByVal Acao As Double)
    Application.Wait (Now() + Acao / 24 / 60 / 60 / 1000)
End Function

Sub teste()
    Fazer (5000)
    MsgBox "suel"
End Sub

Eklenen dosyayı indiremiyoruz "dosyayukle" sitesinden ekleyebilirsiniz mümkün ise

 

[burakozgen16]

Merhaba Arkadaşlar,
Bu konudaki whatsapp.xlsm dosyasını kendime göre düzenlemeye çalıştım fakat sanırım bir yerlerde hata yaptım.
Dosyanın orjinalinde mesaj göndermek için B ve C sütunlarından veri çekiyordu. Benim daha fazla sütunda veriye çekmeye ihtiyacım var.
Yardımcı olursanız çok memnun olurum.

Not: Sanırım daha önce @asri Bey dosyayı çalışır hale getirmiş. Tekrar yardımcı olabilirseniz çok memnun olurum.

 

[burakozgen16]

Dosyayı istediğim gibi düzenledim, test ettim, çalıştı. Kaydedip kapattım.
Şimdi kullanmak için açtığımda
"Run-time error '5': Invaild procedure call or argument hatası alıyorum.
Debug ile hatayı görmek istediğimde aşağıdaki kodda hata veriyor.
Call SendKeys (mesaj, True)

Sebebini anlayamıyorum, lütfen yardımcı olur musunuz?