Ver ficheiros JPG ou PDF no controlo WebBrowser, descompactar via 7-Zip

Olá a todos,

A propósito de questão de colega neste tópico, partilho exemplo para ver ficheiros PDF ou CBR (ficheiros JPG depois de descompactados) no  Controlo de Navegador WebBrowser ou no programa instalado associado à extensão.

Neste exemplo é utilizado o 7-Zip para descompactar os ficheiros do tipo CBR para uma pasta Temporária que é eliminada ao fechar o formulário.

Código do exemplo:

Código:

Option Compare Database
Dim strCaminho, strArquivo, strTemp, strExtensao As String

Private Sub Form_Load()
'Álvaro Teixeira (ahteixeira) 2021 para MaximoAccess
'Adiciona ficheiros PDF e CBR à listagem

    strCaminho = CurrentProject.Path & "\Revistas\"
    strArquivo = Dir$(strCaminho & "*.*")
    
    Do While Len(strArquivo) > 0
        strExtensao = Right(strArquivo, 4)
        
        If strExtensao = ".pdf" Or strExtensao = ".cbr" Then
            Me.lstFicheiros.AddItem Item:=strArquivo
        End If
        strArquivo = Dir$()
    Loop
    
End Sub

Private Sub cmdVerShell_Click()
'Álvaro Teixeira (ahteixeira) 2021 para MaximoAccess
'Abrir com programa associado à extensão

    Dim objShell As Object

    strCaminho = CurrentProject.Path & "\Revistas\" & Me.lstFicheiros
    Set objShell = CreateObject("Shell.Application")

    If Len(Me.lstFicheiros & "") = 0 Then
        MsgBox "Selecione primeiro o ficheiro que pretende abrir.", vbCritical, "Aviso"
        Exit Sub
    End If

    objShell.Open (strCaminho)

End Sub

Private Sub lstFicheiros_Click()
'Álvaro Teixeira (ahteixeira) 2021 para MaximoAccess
'---------------------------------------------------
'Verifica a pasta das revistas e preenche a lista com ficheiros PDF e CBR
'Se é ficheiro CBR, descompacta utilizando o 7z.exe para pasta temporaria
'Mostra listagem secundaria para navegar pelas imagens e mostra no controlo webbrowser

    If Len(Me.lstFicheiros & "") = 0 Then
        MsgBox "Selecione primeiro o ficheiro que pretende abrir.", vbInformation, "Aviso"
        Exit Sub
    End If

    'Me.WB2.ScriptErrorsSuppressed() = True 'access 2010
    Me.WB2.Silent = True 'access 2007 e menor
    Me.WB2.Visible = False
    Me.WB2.Navigate ""  'para não dar erro ao navegar em varios registos


    strCaminho = CurrentProject.Path & "\Revistas\" & Me.lstFicheiros

    If Right(Me.lstFicheiros, 4) = ".cbr" Then    'verifica se é ficheiro com entensão CBR
        Dim unZip, str7z, strCmd As String
        
        Me.lstImagens.RowSource = ""     'limpa lista
        Me.lstImagens.Visible = True     'mostra lista
        
        str7z = CurrentProject.Path & "\7z\7z.exe"     'caminho 7-zip
        strTemp = CurrentProject.Path & "\Temp\" & Me.lstFicheiros.ListIndex     'caminho temporario
        
        If Len(Dir(str7z, vbArchive) & "") = 0 Then    'verifica se tem o 7z.exe
            MsgBox "É necessário ter o 7z.dll e 7z.exe na sub-pasta 7z , verifique.", vbCritical, ""
            Exit Sub
        End If
        
       'definir linha de comando do 7z para executar
        strCmd = Chr(34) & str7z & Chr(34) & " e " & Chr(34) & strCaminho & Chr(34) _
                & " -o" & Chr(34) & strTemp & Chr(34) & " -y"
        unZip = Shell(strCmd, vbHide)      'executar 7z
      
        'fazer delay de 1 segundo
        Dim xTime, xNow
        xTime = Time
        xTime = DateAdd("s", 1, xTime)
        Do Until xNow >= xTime
            xNow = Time
        Loop
 
        'Adiciona ficheiros JPG à listagem
        strArquivo = Dir$(strTemp & "\*.*")
        
        Do While Len(strArquivo) > 0
            strExtensao = Right(strArquivo, 4)
            
            If strExtensao = ".jpg" Then
                Me.lstImagens.AddItem Item:=strArquivo
            End If
            strArquivo = Dir$()
        Loop

    Else 'PDF
        Me.lstImagens.Visible = False    'oculta lista
        Me.lstImagens.RowSource = ""     'limpa lista
                
        Me.WB2.Navigate strCaminho
        Me.WB2.Visible = True
    End If

End Sub

Private Sub lstImagens_Click()
    strCaminho = strTemp & "\" & Me.lstImagens
    
    Me.WB2.Navigate strCaminho
    Me.WB2.Visible = True
    
End Sub

Private Sub Form_Close()
'Álvaro Teixeira (ahteixeira) 2021 para MaximoAccess
'Apagar pasta Temp ao sair
On Error Resume Next

    Dim FSO As New FileSystemObject
    Set FSO = CreateObject("Scripting.FileSystemObject")
    FSO.DeleteFolder CurrentProject.Path & "\Temp", False
End Sub


Nota: No anexo apenas tem o ficheiro MDB, aconselho o download completo no link abaixo:
cld.pt/dl/download/7e65a02c-78cb-429f-9d4d-1c8d719a649f/VerPDFeCDR_7zip.zip

Abraço e bons estudos

Ficou perfeito ahteixeira,quem sabe sabe,muito obrigado por dispor do teu tempo pra ajudar a gente.
Valeu amigo.