Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Explorar()
    Dim diretorio, fso, i As Integer, ex, d, f
    Set fso = CreateObject("Scripting.FileSystemObject")
    If ActiveCell(1, 2) > "" Then ' e um arquivo
       Set ex = CreateObject("Wscript.Shell")
       ex.Run """" & Cells(2, 1) & ActiveCell & """"
       Exit Sub
    End If
    If ActiveCell.Text = ".." Then
       Set diretorio = fso.getfolder(ActiveCell(2, 1).Text & "\..")
    Else
       Set diretorio = fso.getfolder(ActiveCell.Text)
    End If
    Cells.ClearContents
    Cells(1, 1) = ".."
    Cells(2, 1) = Replace(diretorio.Path & "\", "\\", "\")
    i = 3
    For Each d In diretorio.subfolders
        Cells(i, 1) = d.Path
        i = i + 1
    Next
    For Each f In diretorio.Files
        Cells(i, 1) = f.Name
        Cells(i, 2) = Format(f.datelastmodified, "dd/mm/yyyy hh:mm")
        Cells(i, 3) = f.Size
        Cells(i, 3).NumberFormat = "_(* #,##0_);_(* (#,##0);_(* ""-""??_);_(@_)"
        i = i + 1
    Next
End Sub
Sub progresso(atual, max)
Attribute progresso.VB_Description = "Macro gravada em 7/12/2009 por Gennari & Peartree"
Attribute progresso.VB_ProcData.VB_Invoke_Func = " \n14"
    Static barra
    If atual = 0 Then
       Set barra = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, 300, 11.25)
       barra.Fill.ForeColor.SchemeColor = 11
       barra.Fill.Visible = msoTrue
       barra.Fill.Solid
       Exit Sub
    End If
    If atual >= max Then
       barra.Delete
       Exit Sub
    End If
    barra.Width = 300 * (max - atual) / max
End Sub
Sub RodaEstrela()
    Dim estrela, i As Integer
    i = msoShape32pointStar
    Set estrela = ActiveSheet.Shapes.AddShape(i, 32.25, 45.75, 100#, 100#)
    For i = 0 To 300
      estrela.IncrementRotation 5
      estrela.Width = 100 - i / 3
      estrela.Height = 100 - i / 3
      progresso i, 300
      Sleep 10
      DoEvents
    Next
    estrela.Delete
End Sub
Sub Exporta()
   Dim caminho, nome, p, c, w
   nome = Range("nome")
   caminho = ActiveWorkbook.Path
   Set w = Workbooks.Open(caminho & "\" & nome & ".xls")
   Open caminho & "\" & nome & ".txt" For Output As #1
   For Each p In w.Sheets
       Print #1, "*" & vbTab & p.Name
       For Each c In Range(p.Cells(1, 1), p.Cells(1, 1).SpecialCells(xlLastCell))
           If c > "" Then
              Print #1, c.Row & vbTab & c.Column & vbTab & c
           End If
       Next
   Next
   Close #1
   w.Close
End Sub
Sub Importa()
    Dim nome, caminho, w As Workbook, i As Integer
    Dim linha, pedacos, p, ADeletar
    caminho = ActiveWorkbook.Path
    nome = Range("nome")
    Set w = Workbooks.Add
    w.SaveAs caminho & "\" & nome & ".xls"
    i = w.Sheets.Count
    Application.DisplayAlerts = False
    For i = i To 2 Step -1
       w.Sheets(i).Delete
    Next
    Set ADeletar = ActiveSheet
    Open caminho & "\" & nome & ".txt" For Input As #1
    Do Until EOF(1)
        Line Input #1, linha
        pedacos = Split(linha, vbTab)
        If pedacos(0) = "*" Then
            Set p = w.Sheets.Add(w.Sheets(1))
            w.Sheets(1).Name = pedacos(1)
        Else
            p.Cells(CInt(pedacos(0)), CInt(pedacos(1))) = pedacos(2)
        End If
     Loop
     ADeletar.Delete
     Close #1
     w.Save
End Sub
Sub testabarra()
    Dim i As Integer
    For i = 0 To 500
        progresso i, 500
        DoEvents   ' mostra agora o efeito
        Sleep 10  ' duração total: 5 segundos
    Next
End Sub