Çözüldü UserForm'dan Whatsapp'a Veri Gönderme

beyfendi · 9 Kas 2022

Merhaba üstadlarım,

aşağıdaki kod ile excel RD sayfasındaki belirlediğim aralığı resim olarak kopyalayıp aynı sayfada j1 hücresine yapıştırıp oradan da whatsapp uygulaması üzerinden ilgili numaraya gönderme işlemini yaptırıyordum ve gönderimi yaptımıda resmi J1 den sildiriyorum ama son zamanlarda gönderme işlemini yapmamaya başladı hata mesajı da vermiyor. Kopyalamayı mı yapmıyor veya j1'e yapıştırmayı mı yapmıyor anlamadım.

Kullanmış olduğum kod grubunu inceleyip yardımcı olmanızı rica ediyorum.

Kod:

Private Sub YIK_WGonder_Click()

If YIK1_BaslangıcT.Value = "" And YIK2_BitisT.Value = "" And YIK3_GorevT.Value = "" Then
MsgBox "ÖNCELİKLE YILLIK İZİN FORMUNU DOLDURUP KAYDEDİN VEYA LİSTEDEN YILLIK İZNE ÇİFT TIKLAYARAK SEÇİM YAPINIZ !..."
Else

Worksheets("YIF").Range("C30") = PSB6_CepTel.Value
Worksheets("YIF").Range("E5") = PSB9_Isyeri.Value
Worksheets("YIF").Range("E6") = PSB10_iSgkSicilNo.Value
Worksheets("YIF").Range("E9") = PSB1_AdSoyad.Value
Worksheets("YIF").Range("E10") = PSB2_TCNo.Value
Worksheets("YIF").Range("E11") = PSB4_IseGirisT.Value
Worksheets("YIF").Range("E14") = Label_YIKanuniYi
Worksheets("YIF").Range("E15") = YIK1_BaslangıcT.Value
Worksheets("YIF").Range("E16") = YIK2_BitisT.Value
Worksheets("YIF").Range("E17") = YIK3_GorevT.Value

ThisWorkbook.Activate
Dim sh As Worksheet
Set sh = Worksheets("YIF")
sh.Activate

Application.ScreenUpdating = False
Application.CutCopyMode = False

ActiveWorkbook.FollowHyperlink Address:="https://api.whatsapp.com/send/?phone=90" & sh.Range("C30")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{TAB}", True)
Application.Wait (Now + TimeValue("00:00:01"))

sh.Range("A1:H27").CopyPicture Appearance:=xlScreen, Format:=xlPicture
Application.Wait (Now + TimeValue("00:00:02"))
sh.Range("J1").Select
ActiveSheet.Paste
Selection.ShapeRange.Name = "Picture 1"
sh.Shapes("Picture 1").Copy
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("^v")
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("~", True)
Application.SendKeys "{NUMLOCK}%s"
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("^+W")
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("~", True)
sh.Shapes("Picture 1").Delete
End If
End Sub

Patron · 10 Kas 2022

Aşağıdaki gibi dener misiniz?

Kod:

Private Sub YIK_WGonder_Click()
    If YIK1_BaslangıcT.Value = "" And YIK2_BitisT.Value = "" And YIK3_GorevT.Value = "" Then
        MsgBox "ÖNCELİKLE YILLIK İZİN FORMUNU DOLDURUP KAYDEDİN VEYA LİSTEDEN YILLIK İZNE ÇİFT TIKLAYARAK SEÇİM YAPINIZ !..."
        Else
        Worksheets("YIF").Range("C30") = PSB6_CepTel.Value
        Worksheets("YIF").Range("E5") = PSB9_Isyeri.Value
        Worksheets("YIF").Range("E6") = PSB10_iSgkSicilNo.Value
        Worksheets("YIF").Range("E9") = PSB1_AdSoyad.Value
        Worksheets("YIF").Range("E10") = PSB2_TCNo.Value
        Worksheets("YIF").Range("E11") = PSB4_IseGirisT.Value
        Worksheets("YIF").Range("E14") = Label_YIKanuniYi
        Worksheets("YIF").Range("E15") = YIK1_BaslangıcT.Value
        Worksheets("YIF").Range("E16") = YIK2_BitisT.Value
        Worksheets("YIF").Range("E17") = YIK3_GorevT.Value
        ThisWorkbook.Activate
        Dim sh As Worksheet
        Set sh = Worksheets("YIF")
        sh.Activate
        Application.ScreenUpdating = False
        Application.CutCopyMode = False
        sh.Range("A1:H27").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        Application.Wait (Now + TimeValue("00:00:02"))
        sh.Range("J1").Select
        ActiveSheet.Paste
        Selection.ShapeRange.Name = "Picture 1"
        sh.Shapes("Picture 1").Copy
        Application.Wait (Now + TimeValue("00:00:02"))
        ActiveWorkbook.FollowHyperlink Address:="https://web.whatsapp.com/send/?phone=90" & sh.Range("C30")
        Application.Wait (Now + TimeValue("00:00:08"))
        Call SendKeys("^v")
        Application.Wait (Now + TimeValue("00:00:02"))
        Call SendKeys("~", True)
        Application.SendKeys "{NUMLOCK}%s"
        Application.Wait (Now + TimeValue("00:00:02"))
        Call SendKeys("^+W")
        Application.Wait (Now + TimeValue("00:00:02"))
        Call SendKeys("~", True)
        Application.Wait (Now + TimeValue("00:00:02"))
        sh.Shapes("Picture 1").Delete
        Application.ScreenUpdating = True
        Application.CutCopyMode = True
        MsgBox "tamam"
    End If
End Sub

beyfendi · 14 Kas 2022

Üstad çok çok teşekkür ederim Allah razı olsun, vermiş kod ile hiç takılmadan web.whatsapp üzerinden de ve whatsapp uygulaması kurulu ise direk uygulama üzerinden de takılmadan gönderiyor.

Sadece NUMLOCK kapalı olarak kalıyor yani sayı tuşlarını kullanmak için her gönderimden sonra NUMLOCK a basmak gerekiyor.

Başkada herhangi bir sıkıntı yok gayet takılmadan gönderimi yapıyor.

Foruma hoş geldin 👋 Ziyaretçi

Çözüldü UserForm'dan Whatsapp'a Veri Gönderme

beyfendi

Patron

beyfendi