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, 






Nenhum comentário:

Postar um comentário

diHITT - Notícias