VBA Tips - Manipulando arquivos - All File Operations.

Termo de Responsabilidade 

Desenvolver com o VBA prescinde o conhecimento de manipulação de arquivos. Copiar, mover, excluir, ver quantos têm disponível em determinado local, e assim por diante. Acredito que as funcionalidades reunidas abaixo serão muito úteis nesse respeito, para ampliar o seu conhecimento. Aproveite. Aahh e deixe seus comentários.

Crie um módulo e copie tudo isso para dentro dele:

Option Explicit

 Private Declare Function ShellExecute Lib "shell32.dll" Alias _

           "ShellExecuteA" (ByVal hwnd As Long, ByVal lpszOp As _

           String, ByVal lpszFile As String, ByVal lpszParams As String, _

           ByVal lpszDir As String, ByVal FsShowCmd As Long) As Long

Private Declare Function GetDesktopWindow Lib "user32" () As Long

           Const SW_SHOWNORMAL = 1

           Const SE_ERR_FNF = 2&

           Const SE_ERR_PNF = 3&

           Const SE_ERR_ACCESSDENIED = 5&

           Const SE_ERR_OOM = 8&

           Const SE_ERR_DLLNOTFOUND = 32&

           Const SE_ERR_SHARE = 26&

           Const SE_ERR_ASSOCINCOMPLETE = 27&

           Const SE_ERR_DDETIMEOUT = 28&

           Const SE_ERR_DDEFAIL = 29&

           Const SE_ERR_DDEBUSY = 30&

           Const SE_ERR_NOASSOC = 31&

           Const ERROR_BAD_FORMAT = 11&

Function StartDoc (DocName As String) As Long

                   Dim Scr_hDC As Long

                   

                   Let Scr_hDC = GetDesktopWindow()

                   Let StartDoc = ShellExecute(Scr_hDC, "Open", DocName, _

                   "", "C:\", SW_SHOWNORMAL)

End Function

     

Function File_Copy (strCopyFrom As String, strCopyTo As String)

       FileCopy strCopyFrom, strCopyTo

End Function

Function Current_Dir() As String

       Let Current_Dir = CurDir

End Function

Function Change_Dir (strChangeTo As String)

       ChDir strChangeTo

End Function

Function Change_Drive (strChangeTo As String) As String

       ChDrive (strChangeTo)

       

        Let Change_Drive = CurDir

End Function

Function File_Exists (strToCheck As String) As Integer       

       Dim retval As String

       

       Let retval = Dir$(strToCheck)

       

       If retval = strToCheck Then

               Let File_Exists = 1

       Else

               Let File_Exists = 0

       End If

End Function

Function File_Rename (strOldName As String, strNewName As String)

       Name strOldName As strNewName

End Function

Function File_Delete (strToDelete As String)

       Kill strToDelete

End Function

Function Create_Dir (strToCreate)

       MkDir strToCreate

End Function

Function Remove_Dir (strToRemove As String)

       RmDir strToRemove

End Function

Function File_Move (strMoveFrom As String, strMoveTo As String)

               Kill strMoveTo

               FileCopy strMoveFrom, strMoveTo

End Function

Function File_ReadLine (strToRead As String, LineNum As Integer) As String

       Dim intCtr As Integer

       Dim strValue As String

       Dim intFNum As Integer

       Dim intMsg As Integer 

       

       Let intFNum = FreeFile

       Open strToRead For Input As #intFNum

               

                 Let intCtr = LineNum

                 Input #intFNum, strValue

                 Let File_ReadLine = strValue

                                           

       Close #intFNum

       

End Function

Function Run_Application (strPathOfFile As String)

       Dim r As Long, msg As String

                   Let r = StartDoc (strPathOfFile)

                   If r <= 32 Then

                           'There was an error

                           Select Case r

                                   Case SE_ERR_FNF

                                           Let msg = "Arquivo não encontrado"

                                   Case SE_ERR_PNF

                                           Let msg = "Caminho não encontrado"

                                   Case SE_ERR_ACCESSDENIED

                                           Let msg = "Accesso protegido"

                                   Case SE_ERR_OOM

                                           Let msg = "Fora da memória"

                                   Case SE_ERR_DLLNOTFOUND

                                           Let msg = "DLL não encontrada"

                                   Case SE_ERR_SHARE

                                           Let msg = "Ocorreu uma violação de compartilhamento"

                                   Case SE_ERR_ASSOCINCOMPLETE

                                          Let msg = "Associação inválida ou incompleta de arquivo"

                                   Case SE_ERR_DDETIMEOUT

                                           Let msg = "DDE Time out"

                                   Case SE_ERR_DDEFAIL

                                           Let msg = "DDE transaction failed"

                                   Case SE_ERR_DDEBUSY

                                           Let msg = "DDE busy"

                                   Case SE_ERR_NOASSOC

                                           Let msg = "Nenhuma associação de arquivo para essa extensão"

                                   Case ERROR_BAD_FORMAT

                                           Let msg = "Invalid EXE file or error in EXE image"

                                   Case Else

                                           Let msg = "Erro desconhecido"

                           End Select                           

                   End If           

End Function

Function File_Time (strFileName As String) As String

       Dim strDate As String

       Dim intcount, intDateLen As Integer

       

       Let strDate = FileDateTime(strFileName)

       Let intcount = InStr(1, strDate, " ", vbTextCompare)

       Let intDateLen = Len(strDate)

       Let File_Time = Mid$(strDate, intcount + 1, intDateLen)       

End Function

Function File_Date (strFileName As String) As String

       Dim strDate As String

       Dim intcount As Integer

       

       Let strDate = FileDateTime (strFileName)

       Let intcount = InStr (1, strDate, " ", vbTextCompare)

       Let File_Date = CDate (Mid$(strDate, 1, intcount)

End Function

References:

Tags: VBA, Tips, File, files, archive, arquivo, arquivos, 

VBA Excel - Reduzindo o tamanho das suas planilhas - SHRINK REDUCE EXCEL FILE SIZE

Termo de Responsabilidade 

Suponha que ao receber um arquivo ele tivesse uns poucos Kbytes ou não mais do que algo entre 5 ou 6 MBytes. Aí, você efetuou algumas alterações pequenas, insignificantes, e salvou-o novamente na sua pasta. Neste momento você tem uma grande surpresa. Descobre que o tamanho da sua planilhas foi multiplicado entre 3 a 100 vezes mais!

Sim, isso é possível de acontecer no MS Excel.

Option Explicit

Sub SHRINK_EXCEL_FILE_SIZE()

    Dim WSheet As Worksheet

    Dim CSheet As String 'New Worksheet

    Dim OSheet As String 'Old WorkSheet

    Dim Col As Long

    Dim ECol As Long 'Last Column

    Dim lRow As Long

    Dim BRow As Long 'Last Row

    Dim Pic As Object

   

    For Each WSheet In Worksheets

        WSheet.Activate

         'Put the sheets in a variable to make it easy to go back and forth

        Let CSheet = WSheet.Name

         'Rename the sheet to its name with _Delete at the end

        

Let 

OSheet = CSheet & "_Delete"

        

Let 

WSheet.Name = OSheet

         'Add a new sheet and call it the original sheets name

        Sheets.Add

        

Let 

ActiveSheet.Name = CSheet

        Sheets(OSheet).Activate

   

        'Find the bottom cell of data on each column and find the further row

        For Col = 1 To Columns.Count 'Find the actual last bottom row

            If Cells(Rows.Count, Col).End(xlUp).Row > BRow Then

                

Let 

BRow = Cells(Rows.Count, Col).End(xlUp).Row

            End If

        Next

       

        'Find the end cell of data on each row that has data and find the furthest one

        For lRow = 1 To BRow 'Find the actual last right column

            If Cells(lRow, Columns.Count).End(xlToLeft).Column > ECol Then

                

Let 

ECol = Cells(lRow, Columns.Count).End(xlToLeft).Column

            End If

        Next

       

        'Copy the REAL set of data

        Range(Cells(1, 1), Cells(BRow, ECol)).Copy

        Sheets(CSheet).Activate

        'Paste Every Thing

        Range("A1").PasteSpecial xlPasteAll

        'Paste Column Widths

        Range("A1").PasteSpecial xlPasteColumnWidths

        Sheets(OSheet).Activate

        For Each Pic In ActiveSheet.Pictures

            Pic.Copy

            Sheets(CSheet).Paste

            Sheets(CSheet).Pictures(Pic.Index).Top = Pic.Top

            Sheets(CSheet).Pictures(Pic.Index).Left = Pic.Left

        Next Pic

        Sheets(CSheet).Activate

       

       'Reset the variable for the next sheet

        

Let 

BRow = 0

        

Let 

ECol = 0

    Next WSheet

   

     ' Since, Excel will automatically replace the sheet references for you on your formulas,

     ' the below part puts them back.

     ' This is done with a simple replace, replacing _Delete with nothing

    For Each WSheet In Worksheets

        WSheet.Activate

        Cells.Replace "_Delete", ""

    Next WSheet

   

    'Roll through the sheets and delete the original fat sheets

    For Each WSheet In Worksheets

        If Not Len(Replace(WSheet.Name, "_Delete", "")) = Len(WSheet.Name) Then

            

Let 

Application.DisplayAlerts = False

            WSheet.Delete

            

Let 

Application.DisplayAlerts = True

        End If

    Next

End Sub

Tags: VBA, Excel,, size, small, reduce, file, archive, tamanho, planilha, reduzir 

VBA Powerpoint - Use VBA para ler o texto de um arquivo - Use VBA to read text from a file

| Blog Office VBA | Blog Excel | Blog Access |

Use VBA para ler o texto de um arquivo

A seguinte rotina simplesmente abre um arquivo texto, lê cada linha em uma variável, coloca-o numa janela Immediate (pressione Ctrl + G para ver a janela imediata no IDE), em seguida, fecha o arquivo.

Sub ReadAsciiFile()

    Dim sFileName As String

    Dim iFileNum As Integer

    Dim sBuf As String

    ' Edit this:

    Let sFileName = "C:\Bernardes\ABL.TXT"

    ' Does the file exist?  simpleminded test:

    If Len(Dir$(sFileName)) = 0 Then

        Exit Sub

    End If

    Let iFileNum = FreeFile()

    Open sFileName For Input As iFileNum

    Do While Not EOF(iFileNum)

        Line Input #iFileNum, sBuf

        ' Now you have the next line of the file in sBuf

          ' Do something useful:

        Debug.Print sBuf

    Loop

    ' Close the file

    Close iFileNum

End Sub

Tags: Powerpoint, Slide, UDF, text, read, file, archive, arquivo

VBA Access - Como apagar arquivos - Delete, Kill, Erase

 Não é rara a necessidade de precisarmos apagar arquivos temporários que utilizamos para importação, exportação, consolidação, geração de relatórios externos, etc...

Como posso excluir a tais?

A instrução Kill exclui os arquivos de um disco.

Sintaxe: Kill pathname

O argumento pathname é uma expressão de seqüência de caracteres que especifica um ou mais nomes de arquivo a serem excluídos. O pathname pode incluir o diretório ou pasta e a unidade.

No Microsoft Windows, Kill aceita o uso de curingas de múltiplos caracteres (*) e de um único caractere (?) para especificar múltiplos arquivos. Entretanto, no Macintosh, esses caracteres são tratados como caracteres de nomes de arquivo válidos e não podem ser usados como curingas para especificar múltiplos arquivos.

Como o Macintosh não aceita os curingas, use o tipo de arquivo para identificar grupos de arquivos a excluir. Você pode usar a função MacID para especificar o tipo de arquivo em vez de repetir o comando com nomes de arquivo separados. Por exemplo, a instrução a seguir exclui todos os arquivos TEXT da pasta atual.

Kill MacID ("TEXT")

Se você usar a função MacID com Kill no Microsoft Windows, ocorrerá um erro. Se você tentar usar Kill para excluir um arquivo aberto, ocorrerá um erro.

Você pode deletar vários arquivos em um diretório

Estou tentando apagar arquivos temporários que o MS Word às vezes deixa para trás, quando não os consegue limpar corretamente. 

Digamos os arquivos como ~$lename.dot. Utilizar apenas o comando Kill, não funciona para arquivos ocultos como estes. mas, se eu mudar seus atributos ele funciona perfeitamente. 

Existe uma comando que pode matar arquivos ocultos também? Se não, como posso contornar uma situação como este problema que impede alguns modelos mailmerge de serem excluídos? 

Como quero executar o comando fora de um botão. Estou pegando o caminho de um DLookup, pois varia de local para local.

Function KillTempFiles()

If Dir(DLookup("[Path]", "tblMailmerge", "mID=1") & "~*.dot") > "" Then

Kill (DLookup("[Path]", "tblMailmerge", "mID=1") & "~*.dot")

End If

On Error Resume Next

End Function

No entanto, a declaração Kill não pode excluir arquivos somente leitura, por isso, a menos que não exista chance de que o arquivo possa ser marcado como readonly, deve-se primeiro remover o atributo readonly do arquivo. Pode fazer isso da seguinte forma:

Dim KillFile As String

Let KillFile = "c:\bernardes\inanyplace.doc"

' Checa se o arquivo existe

If Len(Dir$(KillFile)) > 0 Then

    ' Primeiro remove o atributo de readonly, caso esteja assim configurado

    SetAttr KillFile, vbNormal

    ' Deleta o aqruivo.

     Kill KillFile

End If

Para deletar todos os arquivos em um diretório:

' Faz um Loop através de todos os arquivos em um diretório por usar a função Dir$

Dim MyFile As String

Let MyFile = Dir$ ("c:\Bernardes\*.*")

Do While MyFile <> ""

    KillProperly "c:\Bernardes\" & MyFile

    ' É necessário especificar o caminho novamente, porque o arquivo foi deletado.

    Let MyFile = Dir$ ("c:\Bernardes\*.*")

Loop

Alternativamente, você pode ler todos os valores em uma matriz, e excluir todos os arquivos usando um loop. Esse será um processo mais rápido se o diretório for muito grande, caso contrário não notará qualquer diferença.

Referências: StackoverFlow

               Bytes

               MVPS

Tags: 

Access, Kill, Delete, Del, Excluir, deletar, apagar, arquivo, file, archive

André Luiz Bernardes

A&A® - Work smart, not hard.

VBA Blogs

  

bernardes@.com

       

VBA - Deletando arquivos - Deletando pastas - Deletando Diretórios - Delete via Vba

Já tentou apagar um arquivo externo à sua aplicação, talvez uma planilha ou um arquivo texto? 

Pense, como posso excluir um arquivo?

Delete Files Via Vba

Delete Text File

Delete a folder and all subfolders and files

Delete files in a folder VBA

Deleting a file in VBA

How remove file

How to delete files using VBA

How to use VBA to delete files

I need to copy, rename and delete files in a folder

Macro to delete all files

Move and Delete files and folders

Remove Files

Poderia basicamente usar o comando Kill, mas um programador preocupado precisa permitir a possibilidade de existir um arquivo que está sendo usado somente como leitura, eis a função para você:

 DeleteFile ("Bernardes_Dashboard_Results.txt")

Sub DeleteFile(ByVal FileToDelete As String)

   If FileExists(FileToDelete) Then 'See above

      SetAttr FileToDelete, vbNormal

      Kill FileToDelete

   End If

End Sub

Não se esqueça da função que checa a existência do arquivo:

Function FileExists(ByVal FileToTest As String) As Boolean

   Let FileExists = (Dir(FileToTest) <> "")

End Function

Ahhh, você pode definir uma referência para a biblioteca Scripting.Runtime e depois usar o FileSystemObject, este tem dois métodos DeleteFile e FileExists.

Não vou esconder que temos outras opções:

Let nTest = Dir(filename)

If not nTest="" then

Kill(Filename)

end if

O código a seguir pode ser usado para testar a existência de um arquivo, e depois excluí-lo:

Dim aFile As String

Let nFile = "c:\Bernardes_Dashboard_Results.txt"

If Len(Dir$(nFile)) > 0 Then

     Kill nFile

End If

Estava me segurando, mas preciso avisar-lhe quanto a não permitir que o código retorne uma mensagem de erro do tipo "Descupe-me, mas não existe nenhum código para apagar", então coloque também algo como o mostrado abaixo:

On Error Resume Next 

Kill "

c:\Bernardes_Dashboard_Results.txt

"

On Error Goto 0

Return Len(Dir$(aFile)) > 0 

As opções não param. Aqui está um método simples de apagar uma pasta e todos os arquivos e subpastas. Ele usa o File System Object (objeto sistema de arquivos). 

Para usá-lo, você terá que definir uma referência para o Microsoft Scripting Runtime geralmente encontrada em C:\WINDOWS\system32\scrrun.dll.

Sub DeleteAllFolders(FolderPath As String)

   Dim fso As Scripting.FileSystemObject

   Set fso = New Scripting.FileSystemObject

  

   On Error Resume Next

   fso.DeleteFolder (FolderPath)

   Set fso = Nothing

End Sub

O método fso.DeleteFolder não pode retirar a barra à direita ("\")  do path, por isso precisamos removê-la quando aparecer.

Function CorrectPath(FolderPath As String) As String

    

    Let FolderPath = Trim(FolderPath)

    If Right(FolderPath, 1) = "\" Then

        Let CorrectPath = Left(FolderPath, Len(FolderPath) - 1)

    Else

        Let CorrectPath = FolderPath

    End If

End Function

Referências: MSDN

                    Stackoverflow

                    Tektips

Tag: Bernardes, MS, Microsoft, Office, files, arquivo

, archive,

 deletar, apagar, excluir, kill

André Luiz Bernardes

A&A® - Work smart, not hard.

VBA Blogs

 

bernardes@.com