none
Hiperlink em ListBox RRS feed

  • Pergunta

  • Olá amigos, não sou muito experiente em VBA EXCEL, mas estou desenvolvendo um planilha com formulários

    para cadastro e pesquisa.

    no frmPesquisar eu tenho uma listbox que é filtrada por um textbox. isso eu consegui fazer funcionar bem.

    No caso, a base da minha pesquisa e é uma Sheet com o nome "base". Nela há 4 colunas (A, B, C, D) e na coluna D fica o caminho de arquivos em pdf.

    O que eu preciso é o listbox no frmPesquisar,  abra com clique duplo o arquivo que está no caminho da coluna D

    Segue a planilha para download no DropBox:

    https://db.tt/IRIigRYF

    
    
    
    
    segunda-feira, 30 de setembro de 2013 18:22

Respostas

  • Option Explicit
    
    Const SW_SHOWMAXIMIZED = 3
    
    Dim TextoDigitado As String
    
    #If VBA7 And Win64 Then
        Private Declare PtrSafe Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
          (ByVal hwnd As LongPtr, _
           ByVal lpOperation As String, _
           ByVal lpFile As String, _
           ByVal lpParameters As String, _
           ByVal lpDirectory As String, _
           ByVal nShowCmd As LongPtr) As LongPtr
    #Else
        Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" _
          (ByVal hwnd As Long, _
           ByVal lpOperation As String, _
           ByVal lpFile As String, _
           ByVal lpParameters As String, _
           ByVal lpDirectory As String, _
           ByVal nShowCmd As Long) As Long
    #End If
           
    Sub fncShellExecute(strPath As String)
        'Abre um arquivo usando o programa padrão do Windows para sua extensão.
        
        ShellExecute hwnd:=Application.hwnd _
        , lpOperation:="open" _
        , lpFile:=strPath _
        , lpParameters:=vbNullString _
        , lpDirectory:=VBA.Environ("SystemDrive") _
        , nShowCmd:=SW_SHOWMAXIMIZED
    End Sub
    
    Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
        Dim lngRow As Long
            
        With ThisWorkbook.Worksheets("base")
            lngRow = fncMatch(Me.ListBox1.List(Me.ListBox1.ListIndex), .Columns("A"))
            fncShellExecute .Cells(lngRow, "D")
        End With
    End Sub
    
    Function fncMatch(ByVal str As String, ByVal varVetor As Variant) As Long
        Dim Temp As Long
        
        On Error Resume Next
        Temp = WorksheetFunction.Match(str + 0, varVetor, 0)
        If Temp = 0 Then Temp = WorksheetFunction.Match(CStr(str), varVetor, 0)
        fncMatch = Temp
    End Function
    
    Private Sub txtPesquisar_Change()
        TextoDigitado = txtPesquisar.Text
        Call PreencheLista
    End Sub
    
    Private Sub UserForm_Initialize()
        Call PreencheLista
    End Sub
    
    Private Sub PreencheLista()
        Dim ws As Worksheet
        Dim i As Integer
        Dim TextoCelula As String
        
        'Não se esqueça de qualificar suas planilhas com ThisWorkbook!
        'Caso contrário, você obterá um erro se tentar executar o código se
        'uma pasta de trabalho diferente estiver ativa.
        
        Set ws = ThisWorkbook.Worksheets("base")
        i = 1
        ListBox1.Clear
        With ws
            While .Cells(i, 1).Value <> Empty
                TextoCelula = .Cells(i, 1).Value
                If VBA.UCase(VBA.Left(TextoCelula, Len(TextoDigitado))) = VBA.UCase(TextoDigitado) Then
                    ListBox1.AddItem .Cells(i, 1)
                    ListBox1.List(ListBox1.ListCount - 1, 1) = .Range("B" & i)
                    ListBox1.List(ListBox1.ListCount - 1, 2) = .Range("C" & i)
                    ListBox1.List(ListBox1.ListCount - 1, 3) = .Range("D" & i)
                End If
                i = i + 1
            Wend
        End With
    End Sub


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    quarta-feira, 2 de outubro de 2013 01:49
    Moderador