Macro com erro.

[Moizevitch]

Olá pessoal!  

Gostaria de pedir a ajuda de vocês para solucionar um probleminha de macro.  😀

Bom, pra começar, vou pedir um pouco de paciência, pois eu entendo nadinha de macro. Eu consegui a tal macro com uma IA chat. O problema é que a tal IA chat não conseguiu solucionar o problema, por isso eis me aqui.

A macro em questão é essa (

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.ServerXMLHTTP") ' Tente usar ServerXMLHTTP
    totalLinks = ActiveDocument.Hyperlinks.count

    Application.ScreenUpdating = False
    Application.StatusBar = "Iniciando verificação de links..."
    startTime = Timer

    i = 0
    For Each hLink In ActiveDocument.Hyperlinks
        On Error Resume Next ' Ignora erros individuais de link

        i = i + 1
        Application.StatusBar = "Verificando link " & i & " de " & totalLinks & " (" & Format(i / totalLinks, "0%") & ")"

        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.StatusBar = "Verificação de links concluída. Links quebrados encontrados: " & count

    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

    Application.ScreenUpdating = True
    Application.StatusBar = False
End Sub
 

). E o problema que ela apresenta é esse (em anexo). Estou usando o Word 2007 (Sim, eu sei, é pre-histórico, mas me atende no momento).

Pra quem puder me ajudar, eu agradeço antecipadamente. 🙏

[Alyson Ronnan Martins]

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.

[Moizevitch]

Caro Alyson, inicialmente muito obrigado pelo seu tempo e ajuda, realmente aprecio muito a sua dedicação. ☺️

Bom, não imaginava que haviam diferenças entre versões do VBA no Word. Por isso as AI chat's não conseguiam achar a solução do problema. Desculpe pelo trabalho, quem é que usa essa versão pré-histórica além de mim? Hahaha...

Entretanto, eu lamento muito informar, mas a sua versão apresentou um probleminha: (imagem em anexo, por favor)

Sem querer abusar da sua imensa boa vontade, mas você poderia me ajudar nessa nova versão também?

Bom, ficarei no aguardo. Mais uma vez, muito obrigado!! 🙏