Bom dia, preciso de uma ajuda no seguinte comando:
Código: Selecionar todos
Sub EnviarMensagens()
Dim b, nenhumselecionado, cont, x, a As Integer
Dim Exe As String
Dim EInicial, Delay As Integer
Exe = Planilha5.Range("B3")
EInicial = Planilha5.Range("B4")
Delay = Planilha5.Range("B5")
EsperaContato = Planilha5.Range("G1")
cont = Planilha1.Range("S1")
b = 1
nenhumselecionado = 0
For x = 1 To cont
If Planilha1.Range("K" & x) = "x" And Planilha1.Rows("" & x & ":" & x & "").EntireRow.Hidden = False Then
nenhumselecionado = 1
Exit For
End If
Next x
If nenhumselecionado = 0 Then
MsgBox "Selecione um contato para enviar a mensagem", vbCritical, "Aviso"
Exit Sub
End If
If (MsgBox("Lembre-se de conferir os seguintes itens:" + vbCrLf + _
"- Estar com o WhatsApp Desktop aberto", vbExclamation + vbYesNo, "Atencao")) = vbYes Then
'não pode fazer clicks ou mudar o foco do mause nem pressionar teclas
Dim text As String
Dim Contato As String
Dim cont1 As Integer
cont1 = Planilha3.Range("S1")
'mensagem = Split(Replace(TextBox_Mensagem, "<nome>", ListView1.ListItems(i).SubItems(1)), vbCrLf)
Shell Exe
Fazer (EInicial)
i = 3
Call SendKeys("{TAB}", True)
Do While i <= 3
If Planilha1.Range("K" & i) = "x" And Planilha1.Rows("" & i & ":" & i & "").EntireRow.Hidden = False _
And Planilha1.Range("B" & i) <> "" Then
For a = 1 To cont1
If CStr(Planilha3.Range("A" & a)) = CStr(Planilha1.Range("D" & i)) Then
texto10 = Replace(Planilha3.Range("C" & a), "[A]", Planilha1.Range("A" & i))
'texto10 = Replace(TextBox_Mensagem, "<coluna1>", ListView1.ListItems(i).SubItems(1))
texto9 = Replace(texto10, "[B]", Planilha1.Range("B" & i))
texto8 = Replace(texto9, "[C]", Planilha1.Range("C" & i))
texto7 = Replace(texto8, "[D]", Planilha1.Range("D" & i))
texto6 = Replace(texto7, "[E]", Planilha1.Range("E" & i))
texto5 = Replace(texto6, "[F]", Planilha1.Range("F" & i))
texto4 = Replace(texto5, "[G]", Planilha1.Range("G" & i))
texto3 = Replace(texto4, "[H]", Planilha1.Range("H" & i))
texto2 = Replace(texto3, "[I]", Planilha1.Range("I" & i))
mensagem = Split(Replace(texto2, "[J]", Planilha1.Range("J" & i)), vbCrLf)
End If
Next a
Fazer (Delay) 'Evitar bug na hora de quebrar a mensagem
Contato = Planilha1.Range("A" & i)
numero = Planilha1.Range("B" & i)
If Contato = "" Then
MsgBox "Preencha os endereços de contatos!", 64, "Insira pelo menos um Contato"
Exit Sub
End If
'link = "https://web.whatsapp.com/send?phone=55" & ListView1.ListItems(i).SubItems(2)
'Fazer (3000)
Call SendKeys("^f", True)
Call SendKeys("^a", True)
Fazer (Delay) 'Delay para dar tempo de colar o numero
Call SendKeys(numero, True)
Call SendKeys("~", True)
Fazer (Delay) 'Delay para colar a mensagem inteira
For a = 3 To 13
If Planilha1.Range("M" & a) <> "" Then
Range("X" & a).Select
ActiveSheet.Pictures.Insert( _
"" & Planilha1.Range("M" & a) & "").Select
Selection.ShapeRange.Name = "Foto" & a & ""
Selection.Name = "Foto" & a & ""
Selection.Copy
Fazer (300)
Call SendKeys("^v", True)
Fazer (Delay)
ActiveSheet.Shapes.Range(Array("Foto" & a & "")).Select
Selection.Delete
End If
Next a
Fazer (Delay)
Call SendKeys("~", True)
Fazer (Delay)
Fazer (Delay)
For x = 0 To UBound(mensagem)
Call SendKeys(mensagem(x), True)
Call SendKeys("+~", True)
Fazer (100)
Next x
'Call SendKeys("{ENTER}", True)
Fazer (Delay - 800)
Call SendKeys("~", True)
Fazer (EsperaContato)
Planilha1.Range("K" & i) = "x" ' Só para mudar o tempo da funcao AleatorioEntre
End If
i = i + 1
Loop
Range("E1").Select
MsgBox "Mensagens Enviadas com sucesso", vbInformation, "OK"
End If
End Sub
Function Fazer(ByVal Acao As Double)
Application.Wait (Now() + Acao / 24 / 60 / 60 / 1000)
'milliSeconds
End Function
Sub ExportaContatos()
Dim FileNum As Integer
Dim iRow As Double
Dim i As Long
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Application.DefaultFilePath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
FileNum = FreeFile
OutFilePath = sItem & "\ContatosExportados.VCF"
Open OutFilePath For Output As FileNum
Dim cont As Integer
cont = Planilha1.Range("S1")
'Loop through Excel Sheet each row and write it to VCF File
For x = 3 To 4
If Planilha1.Range("B" & x) <> "" Then
LName = Planilha1.Range("A" & x)
'FName = VBA.Trim(Sheets("Planilha1").Cells(iRow, 2))
PhNum = Planilha1.Range("B" & x)
Print #FileNum, "BEGIN:VCARD"
Print #FileNum, "VERSION:3.0"
Print #FileNum, "N:" & LName & ";" & FName & ";;;"
Print #FileNum, "FN:" & LName & " " & FName
Print #FileNum, "TEL;TYPE=CELL;TYPE=PREF:" & PhNum
Print #FileNum, "END:VCARD"
End If
Next x
'Close The File
Close #FileNum
MsgBox "Contatos convertidos e salvos em: " & OutFilePath & " ", vbInformation
End Sub
Alguma ideia?