Alyson Ronnan Martins

@Rockers Marcate mandei uma DM aqui passando meu dados de contato.

Boa noite @wellington Barbosa, não entendi o está procurando. Esta querendo mudar a planilha que vai receber as informações do formulário? @wellington Barbosa

Boa noite. Eu pensei em uma função que faz a verificação e formatação do CPF: Function FormatarCPF(ByVal cpf As String) As String ' Remove qualquer caractere que não seja número cpf = Application.WorksheetFunction.Substitute(cpf, ".", "") cpf = Application.WorksheetFunction.Substitute(cpf, "-", "") cpf = Application.WorksheetFunction.Trim(cpf) ' Completa com zeros à esquerda caso o CPF tenha menos de 11 dígitos If Len(cpf) < 11 Then cpf = String(11 - Len(cpf), "0") & cpf End If ' Verifica se o CPF tem 11 dígitos If Len(cpf) = 11 Then ' Formata o CPF no padrão XXX.XXX.XXX-XX FormatarCPF = Left(cpf, 3) & "." & Mid(cpf, 4, 3) & "." & Mid(cpf, 7, 3) & "-" & Right(cpf, 2) Else ' Se o CPF não tiver 11 dígitos, retorna o CPF original sem formatar FormatarCPF = cpf End If End Function Ai faz a alterção no código para receber essa função e conseguir formatar: Sub ExportarParaCSV() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim fileName As String Dim fileNum As Integer Dim linhaCSV As String Dim cpfFormatado As String ' Definir a planilha que será usada Set ws = ThisWorkbook.Sheets("CPF") ' Mude o nome conforme necessário ' Encontrar a última linha com dados na coluna A lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Definir o nome do arquivo CSV fileName = ThisWorkbook.Path & "\Exportacao_CPF.csv" ' Abrir o arquivo CSV para gravação fileNum = FreeFile Open fileName For Output As fileNum ' Loop por todas as linhas da coluna A e B For i = 1 To lastRow ' Verificar se a célula contém CPF e garantir que seja tratado como texto If Len(ws.Cells(i, 1).Text) > 0 Then ' Formatar CPF utilizando a função personalizada cpfFormatado = FormatarCPF(ws.Cells(i, 1).Text) ' Montar a linha com CPF formatado linhaCSV = cpfFormatado & ";" & ws.Cells(i, 2).Text Else ' Se não houver CPF, apenas escrever a segunda coluna linhaCSV = ";" & ws.Cells(i, 2).Text End If ' Gravar a linha no arquivo CSV Print #fileNum, linhaCSV Next i ' Fechar o arquivo CSV Close fileNum MsgBox "Exportação concluída! Arquivo salvo como: " & fileName End Sub

Pelo que você descreveu, parece que a macro que você está tentando usar apresenta problemas de compatibilidade com o Word 2007. A versão do Word 2007 possui algumas limitações em relação às bibliotecas mais modernas usadas na macro, como a `MSXML2.ServerXMLHTTP`, que pode não ser totalmente compatível com essa versão. Aqui estão algumas possíveis causas e soluções para o problema: ### Possíveis Causas do Erro: 1. **Compatibilidade do Word 2007 com a biblioteca `MSXML2.ServerXMLHTTP`**: - O Word 2007 pode não suportar adequadamente o objeto `MSXML2.ServerXMLHTTP`, especialmente quando se trata de fazer requisições web. 2. **Erro em algum link específico**: - Um dos links pode estar causando um erro inesperado que o `On Error Resume Next` não está ignorando corretamente. 3. **Problema com o método `Application.StatusBar`**: - Alterar a barra de status durante a execução de uma macro no Word pode ser um problema nas versões mais antigas. ### Soluções Sugeridas: 1. **Verificar a versão do MSXML**: - Tente usar a biblioteca `MSXML2.XMLHTTP` no lugar de `MSXML2.ServerXMLHTTP`. A `XMLHTTP` é uma versão mais básica que pode funcionar em versões mais antigas do Word: ```vba Set httpRequest = CreateObject("MSXML2.XMLHTTP") ``` 2. **Remover/Adaptar o uso da barra de status**: - Caso o problema esteja relacionado ao `Application.StatusBar`, você pode remover ou adaptar as linhas que usam essa funcionalidade: ```vba ' Substitua ou comente as linhas que atualizam a barra de status ' Application.StatusBar = "Verificando link " & i & " de " & totalLinks & " (" & Format(i / totalLinks, "0%") & ")" ' Application.StatusBar = "Verificação de links concluída. Links quebrados encontrados: " & count ``` 3. **Adicionar mais detalhes ao tratamento de erros**: - O `On Error Resume Next` pode ocultar erros críticos. Para ajudar a depurar, você pode comentar essa linha temporariamente para ver qual erro exato está acontecendo. 4. **Testar com diferentes links**: - Tente rodar a macro em um documento com poucos links simples e verifique se o erro continua. Isso pode ajudar a identificar se há algum link específico causando o problema. Aqui está uma versão ajustada da macro com as alterações sugeridas: Sub CheckHyperlinksWithProgress() Dim hLink As Hyperlink Dim brokenLinks As String Dim count As Integer Dim httpRequest As Object Dim totalLinks As Integer Dim i As Integer Dim startTime As Single Dim timeout As Integer Dim saveFile As Variant Dim responseStatus As Integer Dim userTimeout As Integer Dim followRedirects As Boolean userTimeout = InputBox("Informe o tempo de timeout (em segundos):", "Timeout", 3) If IsNumeric(userTimeout) And userTimeout > 0 Then timeout = userTimeout Else MsgBox "Valor de timeout inválido. Usando padrão de 3 segundos." timeout = 3 End If followRedirects = MsgBox("Deseja seguir redirecionamentos?", vbYesNo, "Redirecionamentos") = vbYes count = 0 Set httpRequest = CreateObject("MSXML2.XMLHTTP") ' Tente usar XMLHTTP totalLinks = ActiveDocument.Hyperlinks.count Application.ScreenUpdating = False ' Removi as atualizações de barra de status startTime = Timer i = 0 For Each hLink In ActiveDocument.Hyperlinks On Error GoTo LinkError ' Melhor tratamento de erro i = i + 1 If hLink.Address <> "" Then If Left(hLink.Address, 5) <> "https" Then brokenLinks = brokenLinks & hLink.Address & " (Não é HTTPS)" & vbCrLf count = count + 1 GoTo ContinueNext End If On Error GoTo LinkError httpRequest.Open "HEAD", hLink.Address, False httpRequest.send responseStatus = httpRequest.Status If followRedirects And (responseStatus = 301 Or responseStatus = 302) Then httpRequest.Open "HEAD", httpRequest.getResponseHeader("Location"), False httpRequest.send responseStatus = httpRequest.Status End If If responseStatus <> 200 Then brokenLinks = brokenLinks & hLink.Address & " (Erro " & responseStatus & ")" & vbCrLf count = count + 1 End If End If ContinueNext: On Error Resume Next ' Reseta o tratamento de erro para ignorar falhas menores LinkError: brokenLinks = brokenLinks & hLink.Address & " (Falha na verificação)" & vbCrLf count = count + 1 Resume ContinueNext Next hLink Application.ScreenUpdating = True If count > 0 Then saveFile = Application.GetSaveAsFilename(InitialFileName:="LinksQuebrados.txt", FileFilter:="Text Files (*.txt), *.txt", Title:="Salvar links quebrados") If saveFile <> False Then Dim fileNum As Integer fileNum = FreeFile Open saveFile For Output As #fileNum Print #fileNum, brokenLinks Close #fileNum MsgBox count & " links quebrados encontrados e salvos em " & saveFile Else MsgBox count & " links estão quebrados:" & vbCrLf & brokenLinks End If Else MsgBox "Todos os links estão funcionando!" End If End Sub Teste essa versão para ver se resolve o problema no Word 2007. Se continuar com dificuldades, posso ajustar mais conforme os detalhes que você fornecer.

Boa tarde, pelo que entendi sua "query" está sendo executada dentro do access correto? (fiz essa suposição pela conexão com o arquivo do access 2019) Nesse caso seria melhor substituir o sql que esta utilizando para uma função nativa do access em SQL, assim você vai conseguir executar a query. Qual o objetivo da função "calc_idade2"?

O erro ocorre porque os métodos ListItems e ListSubItems são utilizados com o controle ListView, não com o controle ListBox do VBA. O controle ListBox não possui esses métodos e propriedades. Para alterar a cor de uma linha em um ListBox no VBA, você precisa adotar uma abordagem diferente, como alterar a cor do texto manualmente ao carregar os itens na caixa de listagem. Infelizmente, o controle ListBox nativo do VBA não suporta mudança de cor de linha diretamente. No entanto, você pode usar um ListView em vez de um ListBox, se for essencial ter essa funcionalidade. Aqui está uma abordagem alternativa usando um controle ListView: Sub corLinha() On Error GoTo erro Dim i As Integer For i = 1 To Me.lstview1.ListItems.Count If Me.lstview1.ListItems(i).ListSubItems(10).Text = "Enviado" Then Me.lstview1.ListItems(i).ForeColor = &HC000& Else Me.lstview1.ListItems(i).ForeColor = &HC0& End If Next i Exit Sub erro: MsgBox "Erro!", vbCritical, "CriterioCor" End Sub Se você realmente precisa utilizar um ListBox, você pode considerar carregar os itens com cores diferentes em um controle alternativo ou adicionar alguma indicação visual (como prefixos no texto) para diferenciar os itens.

Você pode marcar a linha do seu código e ir acompanhando até chegar em uma linha que não vai passar, seu erro. Sabe fazer isso?

Boa noite @RASouza, qual o erro? Achei estranho essa linha: pdfName fileName = "Y:\Veiculos\R.A.SOUZA\VENDAS BRASIL\" & todayDate & ws.Range("A1").Value & "Venda de veículos.pdf" O correto acho que deveria ser assim: pdfName = "Y:\Veiculos\R.A.SOUZA\VENDAS BRASIL\" & todayDate & ws.Range("A1").Value & "Venda de veículos.pdf" Removendo o "fileName"

Bom dia @ACRMENDES As vezes o valor no banco não é vazio (“”) e sim nulo (null). Coloque outra condicional agora verificando se o campo está nulo: isNull(seu_campo), desta forma você válida se o campo é nulo. Também a sua tabela pode não ter retornado registro nenhum, rs.EOF (final da tabela). Nessa hipótese você pode fazer de várias maneiras.

O Selenium é um pouco chatinho de usar mais funciona bem.

Sim, é possível enviar mensagens pelo WhatsApp utilizando VBA no Excel, mas é importante notar que você precisará de uma API ou uma integração que permita o envio de mensagens. Uma das opções mais populares é usar a API do WhatsApp Business. Vou descrever um passo a passo de como você pode fazer isso: ### Passo a Passo para Enviar Mensagens pelo WhatsApp usando VBA 1. **Obtenha Acesso à API do WhatsApp Business:** - Registre-se e configure a conta do WhatsApp Business API. - Obtenha o `API Key` e a `URL` para enviar mensagens. 2. **Configure uma Tabela no Excel:** - Crie uma planilha onde cada linha contém os dados necessários: matrícula, nome do funcionário, número do WhatsApp, e caminho do arquivo de holerite. 3. **Escreva o Código VBA:** - O código VBA irá iterar sobre as linhas da planilha e enviar uma mensagem personalizada para cada número de WhatsApp. Aqui está um exemplo básico de como o código VBA pode ser estruturado para enviar mensagens pelo WhatsApp: ```vba Sub EnviarWhatsApp() Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim matricula As String Dim nomeFuncionario As String Dim numeroWhatsApp As String Dim caminhoArquivo As String Dim apiURL As String Dim apiKey As String Dim jsonBody As String Dim objHTTP As Object ' Configure a URL da API e a chave da API apiURL = "https://api.whatsapp.com/send?" apiKey = "YOUR_API_KEY" ' Defina a planilha e encontre a última linha com dados Set ws = ThisWorkbook.Sheets("Planilha1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Iterar sobre cada linha e enviar mensagem For i = 2 To lastRow ' Supondo que a linha 1 contém os cabeçalhos matricula = ws.Cells(i, 1).Value nomeFuncionario = ws.Cells(i, 2).Value numeroWhatsApp = ws.Cells(i, 3).Value caminhoArquivo = ws.Cells(i, 4).Value ' Construa o corpo da mensagem em JSON jsonBody = "{""number"": """ & numeroWhatsApp & """, ""message"": ""Olá " & nomeFuncionario & ", segue seu holerite."", ""attachment"": """ & caminhoArquivo & """}" ' Configure e envie a requisição HTTP Set objHTTP = CreateObject("MSXML2.XMLHTTP") With objHTTP .Open "POST", apiURL, False .setRequestHeader "Content-Type", "application/json" .setRequestHeader "Authorization", "Bearer " & apiKey .send jsonBody End With ' Verificar o status da resposta If objHTTP.Status = 200 Then MsgBox "Mensagem enviada para " & nomeFuncionario Else MsgBox "Erro ao enviar mensagem para " & nomeFuncionario End If Set objHTTP = Nothing Next i End Sub ``` ### Nota Importante: 1. **Configuração da API:** Você precisa substituir `"YOUR_API_KEY"` com a chave de API real obtida do WhatsApp Business API. 2. **Formato do JSON:** O formato do corpo do JSON pode variar dependendo da API que você está usando. Certifique-se de ler a documentação da API para saber como formatar corretamente as mensagens e anexos. 3. **Segurança:** Nunca compartilhe sua chave de API em locais públicos ou não seguros. 4. **Autorização:** Certifique-se de que o envio de mensagens está de acordo com as políticas de privacidade e autorização dos destinatários. ### Alternativa Se você não tiver acesso à API do WhatsApp Business, uma alternativa é utilizar serviços de automação, como o Twilio, que oferece integração com o WhatsApp. O processo será semelhante, mas você usará a API e as credenciais fornecidas por esses serviços. Espero que isso ajude! Se precisar de mais detalhes ou ajuda com a configuração específica, estou à disposição. Se você não tem acesso ao WhatsApp Business API, ainda há maneiras de enviar mensagens pelo WhatsApp usando VBA, mas elas são mais complexas e podem não ser tão confiáveis ou estáveis. Uma alternativa seria usar uma interface web para enviar mensagens via WhatsApp Web. Isso pode ser feito utilizando um navegador automatizado, como o Selenium, junto com VBA. ### Usando Selenium com VBA Para usar Selenium com VBA, você precisará: 1. **Instalar o Selenium WebDriver:** - Baixe o Selenium WebDriver e o driver específico para o navegador que você deseja usar (por exemplo, ChromeDriver para Google Chrome). 2. **Referenciar o Selenium no VBA:** - No Excel, vá para `Ferramentas > Referências` e adicione a referência para `Selenium Type Library`. ### Exemplo de Código VBA usando Selenium Aqui está um exemplo básico de como você pode automatizar o envio de mensagens pelo WhatsApp Web: 1. **Baixe e instale os pré-requisitos:** - [Baixe o Selenium WebDriver](https://sites.google.com/a/chromium.org/chromedriver/downloads) - Coloque o `chromedriver.exe` em uma pasta de fácil acesso. 2. **Instale a Selenium Type Library:** - Use o VBA WebDriver (disponível em [GitHub](https://github.com/florentbr/SeleniumBasic/releases)). 3. **Código VBA para enviar mensagens pelo WhatsApp Web:** ```vba Sub EnviarWhatsApp() Dim driver As New WebDriver Dim ws As Worksheet Dim lastRow As Long Dim i As Long Dim matricula As String Dim nomeFuncionario As String Dim numeroWhatsApp As String Dim caminhoArquivo As String Dim mensagem As String ' Defina a planilha e encontre a última linha com dados Set ws = ThisWorkbook.Sheets("Planilha1") lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' Inicialize o driver do Chrome driver.Start "Chrome" driver.Get "https://web.whatsapp.com" ' Esperar que o usuário escaneie o código QR MsgBox "Por favor, escaneie o código QR do WhatsApp Web e pressione OK." ' Iterar sobre cada linha e enviar mensagem For i = 2 To lastRow ' Supondo que a linha 1 contém os cabeçalhos matricula = ws.Cells(i, 1).Value nomeFuncionario = ws.Cells(i, 2).Value numeroWhatsApp = ws.Cells(i, 3).Value caminhoArquivo = ws.Cells(i, 4).Value mensagem = "Olá " & nomeFuncionario & ", segue seu holerite." ' Navegar para o chat do contato driver.Get "https://web.whatsapp.com/send?phone=" & numeroWhatsApp & "&text=" & URLEncode(mensagem) ' Esperar carregar o chat e enviar a mensagem Application.Wait Now + TimeValue("00:00:05") ' Espera 5 segundos driver.FindElementByCss("span[data-icon='send']").Click ' Adicionar um pequeno atraso para evitar problemas Application.Wait Now + TimeValue("00:00:02") ' Espera 2 segundos Next i ' Finalizar o driver driver.Quit MsgBox "Mensagens enviadas com sucesso!" End Sub Function URLEncode(StringVal As String) As String Dim TempAns As String Dim i As Integer Dim Char As String TempAns = "" For i = 1 To Len(StringVal) Char = Mid(StringVal, i, 1) If Char Like "[A-Za-z0-9-_.!~*'()]" Then TempAns = TempAns & Char Else TempAns = TempAns & "%" & Hex(Asc(Char)) End If Next i URLEncode = TempAns End Function ``` ### Nota Importante: 1. **Interação Manual:** Esse método requer interação manual para escanear o código QR do WhatsApp Web. 2. **Confiabilidade:** O Selenium pode ser interrompido se o layout do WhatsApp Web mudar ou se houver verificações de segurança adicionais. 3. **Limitações:** O WhatsApp pode detectar automações e bloquear o envio de mensagens em massa. Esse método oferece uma solução temporária para enviar mensagens pelo WhatsApp sem usar a API do WhatsApp Business, mas deve ser usado com cautela e consciência das limitações.

Você pode subir o código no google drive e compartilhar o arquivo aqui no forum. Você conseguiu passar o registro?

Boa tarde @DJoaquim Isso acontece porque você deve estar movendo utilizando numero do registro. Pelo que lembro da para mover sem ser pelo registro. Esse é um exemplo sem entender direito como estar o seu projeto. Dim db As DAO.Database Dim rs As DAO.Recordset Set db = CurrentDb() Set rs = db.OpenRecordset("Tabela1") 'Substitua "Tabela1" pelo nome da sua tabela Do While Not rs.EOF ' Processar o registro atual Debug.Print rs!Campo1 'Substitua "Campo1" pelo nome do campo que você deseja ler ' Mover para o próximo registro rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing Se estiver precisando de aular particulares online manda DM

@Junior Ribeiro Boa noite. Conseguiu resolver o seu problema?

Entendi! Parece que o conflito está ocorrendo porque ambos os módulos de classe (TextBoxMoney e ValidadorTextBox) estão tentando controlar eventos das caixas de texto (MSForms.TextBox) e isso está causando interferências. Para resolver esse problema, você pode mesclar as funcionalidades dos dois módulos de classe em um único módulo, evitando assim os conflitos. Aqui está um exemplo de como você poderia fazer isso: Option Explicit Private WithEvents txtBox As MSForms.TextBox Private commaAllowed As Boolean Private decimalSeparator As String Public Sub InitializeTextBox(ByVal txt As MSForms.TextBox) Set txtBox = txt ' Define o separador decimal com base nas configurações regionais decimalSeparator = Application.International(xlDecimalSeparator) If txtBox.Tag = "Money" Then commaAllowed = True End If End Sub Private Sub txtBox_Change() If txtBox.Tag = "Money" Then Dim valor As String Dim parteInteira As String Dim parteDecimal As String Dim ponto As Long valor = txtBox.Text ' Verifica se o valor começa com "R$ " If Left(valor, 3) = "R$ " Then ' Remove o prefixo "R$ " valor = Mid(valor, 4) End If ' Remove o separador de milhares atual, se houver valor = Replace(valor, ".", "") ' Verifica se o separador decimal é uma vírgula (configuração regional) If decimalSeparator = "," Then ' Substitui vírgulas por pontos para garantir a uniformidade valor = Replace(valor, ",", ".") End If ' Divide o valor em parte inteira e parte decimal ponto = InStr(valor, ".") If ponto > 0 Then parteInteira = Left(valor, ponto - 1) parteDecimal = Mid(valor, ponto + 1) Else parteInteira = valor parteDecimal = "" End If ' Adiciona pontos de demarcação para milhares parteInteira = Format(parteInteira, "#,##0") ' Reconstroi o valor completo valor = parteInteira If Len(parteDecimal) > 0 Then valor = valor & decimalSeparator & parteDecimal End If ' Verifica se o valor numérico foi removido If valor = "" Then ' Remove o prefixo "R$ " se o valor for vazio txtBox.Text = "" Else ' Adiciona o prefixo "R$ " valor = "R$ " & valor ' Atualiza o valor na caixa de texto txtBox.Text = valor End If ' Move o cursor para o final do texto txtBox.SelStart = Len(txtBox.Text) End If End Sub