MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    visualizador Imagens trocar Dir por FSO Recursiva

    Compartilhe

    doriangrey2000
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7
    Registrado : 19/09/2010

    visualizador Imagens trocar Dir por FSO Recursiva

    Mensagem  doriangrey2000 em Qui 30 Jul 2015, 21:03

    Olá Colegas!

    visualizador Imagens trocar Dir por  FSO Recursiva

    tenho um visualizador de imagens em ACCESS mdb e
    ele usa o Dir pra listar arquivos.

    gostaria de trocar o Dir por FSO FileSystemObject.

    segue abaixo trechos onde o dir aparece, e o arquivo anexo.
    ----------------------------------------------------
    Dir(TopDir, vbDirectory)
    -----------------------------------------------------------------
    End If
           MyName = Dir    ' Get next entry.
       Loop
    ---------------------------------------------
    gato!
    Anexos
    access-ImageViewer.zip
    Você não tem permissão para fazer download dos arquivos anexados.
    (47 Kb) Baixado 7 vez(es)

    doriangrey2000
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 7
    Registrado : 19/09/2010

    Re: visualizador Imagens trocar Dir por FSO Recursiva

    Mensagem  doriangrey2000 em Qui 30 Jul 2015, 21:28

    O codigo vba a ser alterado de dir pra FSO é o abaixo:

    ---------------------------------------------------------------------
    Private Sub TopDir_AfterUpdate()
    On Error GoTo Err_TopDir_AfterUpdate

       Dim MyName As String, DirectoryList As String, FileList As String, AddFile As Variant
       
       If Right$([TopDir], 1) = "\" Then
          'OK
       Else
           [TopDir] = [TopDir] & "\"
       End If
       
      'Retrieve the first entry
       MyName = Dir(TopDir, vbDirectory)

       Do While MyName <> ""
          'Ignore the current directory and the encompassing directory.
           If MyName <> "." And MyName <> ".." Then
              'Use bitwise comparison to make sure MyName is a directory.
               If (GetAttr(TopDir & MyName) And vbDirectory) = vbNormal Then
                  'Display entry if it is a file
                   AddFile = False
                   If ImageType = 1 Then
                       AddFile = True
                   ElseIf ImageType = 3 And Right$(MyName, 3) = "bmp" Then
                       AddFile = True
                   ElseIf ImageType = 4 And Right$(MyName, 3) = "gif" Then
                       AddFile = True
                   ElseIf ImageType = 5 And Right$(MyName, 3) = "jpg" Then
                       AddFile = True
                   ElseIf ImageType = 2 And (Right$(MyName, 3) = "bmp" Or Right$(MyName, 3) = "gif" Or Right$(MyName, 3) = "jpg") Then
                       AddFile = True
                   End If
                   If AddFile = True Then
                       FileList = IIf(FileList = "", "", FileList & ";'") & MyName & IIf(MyName = "" Or FileList = "", "", "'") & IIf(MyName = "", "", ";'" & Int(FileLen([TopDir] & MyName) / 1000) & "'")
                   End If
               ElseIf (GetAttr(TopDir & MyName) And vbDirectory) = vbDirectory Then
                  'Display entry if it is a directory
                   DirectoryList = IIf(DirectoryList = "", "", DirectoryList & ";'") & MyName & IIf(MyName = "" Or DirectoryList = "", "", "'")
               End If
           End If
          MyName = Dir    ' Get next entry.
       Loop
       [DirList].RowSource = DirectoryList
       [ImageList].RowSource = FileList

    Exit_TopDir_AfterUpdate:
       Exit Sub

    Err_TopDir_AfterUpdate:
       Select Case Err
           Case 2176
           'Too many files to store in list box.
           MsgBox "There are too many files in the directory to show them all in the file list. Some will not be displayed."
           [ImageList].RowSource = Left$(FileList, 2048)
           Resume Next
       Case Else
           MsgBox Error
           Resume Exit_TopDir_AfterUpdate
       End Select
       
    End Sub

      Data/hora atual: Qui 08 Dez 2016, 00:04