Excelden Whatsapp ile pdf, rar, txt, resim, .... Dosya Gönderimi

[Çetin Çelik]

Arkadaşlar.

Excel ile whatsapp üzerinden dosya (pdf veya diğer dosya türleri) gönderimi olayı gördüğüm kadarı ile birçok kişinin sorunu ve yapılan makrolar ise kişilerin bilgisayar özelliklerine göre ayarlanması gerektiği için sonuçlar tam istenen şekilde olmuyor.

Sizlere müjde. Ben basit ve ayar gerektirmeyen 2 yöntem buldum. Henüz tam test sonuçlarına ulaşmadım ama denemelerimde çalışıyor. Kesin sonuçlara ulşınca paylaşacağım.

01.03.2024 tarihinde tatile gidiyorum. Dönünce sonuçları göreceğiz. Fazla değil 10 güne bile kalmaz kodları paylaşırım.

Haa bu arada whatsweb de kullanmıyor bu kodlar.

Hadi gözünüz aydın,

 

[Korhan Ayhan]

Sabırsızlıkla bekliyoruz...

İyi tatiller size..

 

[Çetin Çelik]

Arkadaşlar merhaba.
Şimdi baktımda beklentiyi fazla ileri sevyede tutmuşum. Ben daha acemiyim ama bulduğum yöntem bugün yaklaşık 50 kez denedim çalışıyor. Birkaç eksiği var onları farkettim. Ama usta makrocu arkadaşlar halleder bence ve harika bir sonuç çıkar. 2. Sonucu ise hiç test etmedim ama 2. Yöntemin daha iyi çalışma olasılığını yüksek görüyorum. Yine ön çalışma olarak sunulan dosyayı usta arkadaşlarımız harika olarak dağıtacaktır. Beklentiniz yüksek olmasın lütfen. Sadece ben çalıştırdım ve benim işimi gördü. En güzel yanı app kullanıyor olması.

 

[Çetin Çelik]

Bir an önce eklemek için tatildeyim ama yinede bir göz atayım kimseyi daha fazla bekletmeyim diye boş zaman buldukça el attım dosyaya.

 

[Çetin Çelik]

Lifebox Transfer: Upload File! Send and Share Large Files

Lifeboxtransfer is a fast file transfer service for sharing your files easily without membership. Click and start sharing your files fast and easily with lifeboxtransfer.

lifeboxtransfer.com

örnek dosyayı ekledim.

basit bir çalışma olduğunu biliyorum. Umarım işe yarar ve geliştirilir.

dosya süresi 1 hafta. ücretsiz olarak en uzun süre yani.

 

[Korhan Ayhan]

Tebrikler..

Elinize sağlık.. Paylaşımınız için teşekkürler..

 

[Çetin Çelik]

Tebrikler..

Elinize sağlık.. Paylaşımınız için teşekkürler..

Dilerim bi işe yarasın
bende teşekkür ederim

 

[Korhan Ayhan]

Ben sizin adınıza forumun altyapısında bulunması açısından ekte paylaşıyorum.

 

[Çetin Çelik]

Arkadaşlar
kodun aşağıdaki kısmını değiştirip en son numlock tuşundan önce Alt+F4 ile whatsapp kapatma kodunu da yazınca minimize sorunu ortadan kalkıyor. Fakat Whatsapp.exe klasörü her bilgisayarda ayrı oluyor sanırım PC kimliğine göre.
o nedenle başlama klasörü yolunu kendi bilgisayarınıza göre değiştirin.

Sub Dosya_Gonder()
On Error Resume Next
Application.ScreenUpdating = False
Application.CutCopyMode = False
Tel_Numarası
Application.Wait (Now + TimeValue("00:00:01"))
Shell ("C:\Program Files\WindowsApps\5319275A.WhatsAppDesktop_2.2407.10.0_x64__cv1g1gvanyjgm\WhatsApp.exe"), vbNormalFocus
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys ("^f")
Application.Wait (Now + TimeValue("00:00:01"))
.........................................................
devamını yazmaya gerek duymadım.

Ayrıca diğer sorun 5 seçenek ve 6 senek olayı whatsapp kapatıp açınca ortaya çıkıyormuş. onuda çözdüm.
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("{UP 3}", True)
kısmını
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("{DOWN 2}", True)
olarak değiştirin.

bu durumda uzun bir listeye gönderim yapıyorsanız döngünüz bitene kadar işlem devam eder. bende çalıştı yani.

Ayrıca bir sorgu lazım.
"C:\Program Files\WindowsApps\5319275A.WhatsAppDesktop_2.2407.10.0_x64__cv1g1gvanyjgm\
bu klasör bilgisayarda mevcut ise makro çalışmaya başlasın.
Whatsapp güncelleme alınca büyük ihtimal bu klasörün adı değişecektir.

NOT: PDF dosyalarınızda isim kısmında " - " (bokluk, tire, boşluk) kullanınca arama yapınca bulamıyor. bunu neden yapıyor anlamadım.

Örnek : dosyanızın adı - 001 yazdığınızda bulamıyor. dosyanızınadı-001 olunca buluyor.

bilgisayarda aynı isimde 2 dosya saklayamadığımıza göre dosyalarımızı isimlendirirken uygun bir isim ile kaydedip göndermek isteyince sorunsuz çalıştı.

 

[Çetin Çelik]

Arkadaşlar, bende çalışan makro tam olarak bu.
bekletmelerin çoğu gereksiz aslında ama sağlam olsun diye bekletme yaptım. sorunsuz olarak çooook fazla deneme yaptım.

Sub Dosya_Gonder()
Dim DataObject As Object
Set DataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

On Error Resume Next

For i = 4 To Range("E65536").End(xlUp).Row
If Cells(i, 5).Value <> "" Then
Application.ScreenUpdating = False
Application.CutCopyMode = False
DataObject.SetText Cells(i, 3).Value 'Telefon numarasının satır ve sütunu
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:01"))
Shell ("C:\Program Files\WindowsApps\5319275A.WhatsAppDesktop_2.2407.10.0_x64__cv1g1gvanyjgm\WhatsApp.exe"), vbNormalFocus
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys ("^f")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:05"))
Application.SendKeys ("{TAB}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("+{TAB}")
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("{DOWN 2}", True)
Application.Wait (Now + TimeValue("00:00:02"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys ("{TAB 5}")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{F4}")
DataObject.SetText Cells(i, 4).Value 'Dosya yolunun satır ve sütunu
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys ("{BS 100}")
Application.Wait (Now + TimeValue("00:00:03"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB}")
DataObject.SetText Cells(i, 5).Value 'Dosya adının satır ve sütunu (dosya adına uzantıyı eklemeyin.)
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:02"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB 3}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{UP}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "{NUMLOCK}"
End If
Next i
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("%{F4}")
End Sub

 

[Çetin Çelik]

Arkadaşlar Merhaba.

Whatsapp mesaj veya dosya gönderme olayında küçük bir değişiklik yaptım.
api.whatsapp.com adresine gidin ve herzaman izin ver seçeneğini seçin.
daha sonra aşağıdaki kodu butonunuza yazın.
kodlardaki ayarları kendi hücre seçimlerinize göre ayarlayın. Bende telefon numaraları C sütununda dosya adı ise E sütununda. Dosya yolu da D sütununda. siz kendinize göre ayarlayın.
C sütun bilgileri : Telefon Numarası (5555555555) sıfır olmadan
D sütun bilgileri : Dosya Yolu (C:\Program Files\Dosya Gönder\
E sütun bilgileri : Dosya adı (dosya gönder.pdf yada txt, yada jpg .....)

bu değişikliği yapma sebebim whatsapp exe yolu güncelleme geldikçe değişiyor. yada excel dosyasını başka bilgisayarda çalıştırınca o bilgisayrda farklı olduğu için göndermiyor. göndermediği gibi. aşağıdaki kodlar bitene kadar işleme devam ettiğinden bilgisayarınızdaki verileri karıştırıyor.
bu değişiklik ile o sorunlar kalktı. fakat bu işlemi başlatınca bilgisayarınızda başka hiç bir işlem yapmamalısınız.

ben şuana kadar 1000 den fazla dosya gönderdim. hiç sorun yaşamadım.

Sub Dosya_Gonder()
Dim DataObject As Object
Set DataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

On Error Resume Next

For i = 4 To Range("A65536").End(xlUp).Row
If Cells(i, 5).Value <> "" And Cells(i, 3).Value <> "" Then
Shell "C:\Program Files\Google\Chrome\Application\chrome.exe" & " https://api.whatsapp.com/"
Application.Wait (Now + TimeValue("00:00:06"))
Shell ("taskkill /F /IM chrome.exe*")
Application.ScreenUpdating = False
DataObject.SetText Cells(i, 3).Value
DataObject.PutInClipboard
Application.SendKeys ("^f")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:03"))
Application.SendKeys ("{TAB}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("+{TAB}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{DOWN 2}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB 5}")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{F4}")
DataObject.SetText Cells(i, 4).Value
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{BS 100}")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB}")
DataObject.SetText Cells(i, 5).Value
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB 3}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{UP}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("%{F4}")
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "{NUMLOCK}"
End If
Next i
Application.ScreenUpdating = True
MsgBox ("Gönderim İşlemi Tamamlanmıştır...")
End Sub

 

[meslek5]

Arkadaşlar Merhaba.

Whatsapp mesaj veya dosya gönderme olayında küçük bir değişiklik yaptım.
api.whatsapp.com adresine gidin ve herzaman izin ver seçeneğini seçin.
daha sonra aşağıdaki kodu butonunuza yazın.
kodlardaki ayarları kendi hücre seçimlerinize göre ayarlayın. Bende telefon numaraları C sütununda dosya adı ise E sütununda. Dosya yolu da D sütununda. siz kendinize göre ayarlayın.
C sütun bilgileri : Telefon Numarası (5555555555) sıfır olmadan
D sütun bilgileri : Dosya Yolu (C:\Program Files\Dosya Gönder\
E sütun bilgileri : Dosya adı (dosya gönder.pdf yada txt, yada jpg .....)

bu değişikliği yapma sebebim whatsapp exe yolu güncelleme geldikçe değişiyor. yada excel dosyasını başka bilgisayarda çalıştırınca o bilgisayrda farklı olduğu için göndermiyor. göndermediği gibi. aşağıdaki kodlar bitene kadar işleme devam ettiğinden bilgisayarınızdaki verileri karıştırıyor.
bu değişiklik ile o sorunlar kalktı. fakat bu işlemi başlatınca bilgisayarınızda başka hiç bir işlem yapmamalısınız.

ben şuana kadar 1000 den fazla dosya gönderdim. hiç sorun yaşamadım.

Sub Dosya_Gonder()
Dim DataObject As Object
Set DataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

On Error Resume Next

For i = 4 To Range("A65536").End(xlUp).Row
If Cells(i, 5).Value <> "" And Cells(i, 3).Value <> "" Then
Shell "C:\Program Files\Google\Chrome\Application\chrome.exe" & " https://api.whatsapp.com/"
Application.Wait (Now + TimeValue("00:00:06"))
Shell ("taskkill /F /IM chrome.exe*")
Application.ScreenUpdating = False
DataObject.SetText Cells(i, 3).Value
DataObject.PutInClipboard
Application.SendKeys ("^f")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:03"))
Application.SendKeys ("{TAB}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("+{TAB}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{DOWN 2}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB 5}")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{F4}")
DataObject.SetText Cells(i, 4).Value
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{BS 100}")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB}")
DataObject.SetText Cells(i, 5).Value
DataObject.PutInClipboard
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("^v")
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("{TAB 3}")
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{UP}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Call SendKeys("{ENTER}", True)
Application.Wait (Now + TimeValue("00:00:01"))
Application.SendKeys ("%{F4}")
Application.Wait (Now + TimeValue("00:00:01"))
SendKeys "{NUMLOCK}"
End If
Next i
Application.ScreenUpdating = True
MsgBox ("Gönderim İşlemi Tamamlanmıştır...")
End Sub

Bu güzel ve faydalı çalışmanız için teşekkür ederim. Sanırım bu kodlar Pc'de Whatsapp uygulaması yüklü ise çalışıyor. Tarayıcıda çalıştırmak için nasıl bir düzenleme yapılabilir.