Vídeo recomendado
https://youtu.be/diWPPPhW-9E

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

Fórum para dúvidas sobre os fundamentos da linguagem de programação Visual Basic no contexto do VBA
Avatar do usuário
filipeborelli
Colaborador
Colaborador
Mensagens: 10
Registrado em: Seg Dez 26, 2016 3:14 pm

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

Mensagem 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?


Disable adblock

This site is supported by ads and donations.
If you see this text you are blocking our ads.
Please consider a Donation to support the site.


Responder