Comando Sendkeys, digitar um caractere por vez

[Fernando Oliveira Cabral]

Olá, estou criando um procedimento bem simples, para envio de sms através de uma lista de contatos no excel.

A execução vai bem, até o momento da busca do contato, nesse momento o site recebe a informação mas por ser case sensitive ele não faz a restrição automática normalmente, ele demora muito pra trazer o resultado e no tempo programado ele continua a ação, porém, sem localizar o contato.

A solução, através de testes realizados é que na digitação a cada caractere a busca acontece quase instantaneamente.

ALguma luz?

 

Sub Enviar()

'não pode fazer clicks ou mudar o foco do mause nem pressionar teclas
Dim text As String
Dim Contato As String

text = Sheets(1).TextBox1

If text = "" Then
MsgBox "Digite a Mensagem a ser envida!", 64, "ERRO DE PROCEDIMENTO"
Exit Sub
End If

ActiveWorkbook.FollowHyperlink Address:=" https://messages.google.com/web"
'Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://https://messages.google.com/web"

Fazer (15000)
 
linha = 8
Do Until Sheets(1).Cells(linha, 1) = ""

Fazer (2000)
Contato = Cells(linha, 1)

If Contato = "" Then
MsgBox "Preencha os endereços de contatos!", 64, "Insira pelo menos um Contato"
Exit Sub
End If

Fazer (2000)
 Call SendKeys("{TAB}", True)
Fazer (2000)
 Call SendKeys("{TAB}", True)
Fazer (2000)
 Call SendKeys("{ENTER}", True)
 Fazer (2000)

'aqui é onde ocorre o problema
Call SendKeys(Contato, True)
 Fazer (20000)
 Call SendKeys("{TAB}", True)
 Fazer (2000)
 Call SendKeys("{ENTER}", True)
 Fazer (2000)
 Call SendKeys(text, True)
 Fazer (2000)
 Call SendKeys("{ENTER}", True)
 
 

linha = linha + 1

Loop

'ActiveWorkbook.FollowHyperlink Address:=" https://web.whatsapp.com/"
'Shell "C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " https://web.whatsapp.com/"
' 'Application.Wait TimeSerial(0, 0, 1)
' Fazer (7000)
' SendKeys "{TAB}", True
'' SendKeys "camilly", True
' Call SendKeys(text, True)
'SendKeys "{ENTER}", True
'
'Fazer (2000)
'Call SendKeys(text, True)
'SendKeys "{ENTER}", True
'Call SendKeys("~", True)


End Sub

Function Fazer(ByVal Acao As Double)

Application.Wait (Now() + Acao / 24 / 60 / 60 / 1000)

'milliSeconds
End Function