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,