Página 1 de 1

Repetir ação para próximos (Modulo)

Enviado: Qui Jul 11, 2019 9:06 am
por filipeborelli
Integração ao whatsapp, módulo de envio de mensagens.
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



Ele só está enviando para um contato da planilha, preciso que ele repita para as próximas células seguintes.
Alguma ideia?