Option Compare Database
Option Explicit
' Requisitos:
'* Referencia VBA Microsoft Scripting Runtime (filesystemobject)
Public Function MergeTXTs(ByRef aFiles() As String, ByVal OutputFile As String, Optional ByVal bIncluirNombreInicio As Boolean, Optional ByVal bIncluirNombreFinal As Boolean, Optional ByVal txtFinalFichero As String = "") As Boolean
On Error GoTo error
Dim fso As New FileSystemObject
Dim i As Integer
Dim File As Variant
Dim TmpFolder As String
TmpFolder = CurrentProject.Path & "\Temp\" & GetWindowsUser
If Not fso.FolderExists(TmpFolder) Then MakeDirFullPath TmpFolder
DoCmd.Hourglass True
Dim sAllLinesFiles As String
For i = 0 To UBound(aFiles)
Debug.Print "file " & i & ": " & aFiles(i)
sAllLinesFiles = sAllLinesFiles & _
IIf(Nz(sAllLinesFiles, "") <> "", vbCrLf, "") & _
IIf(bIncluirNombreInicio, "-- " & DimeNombreFichero(aFiles(i)) & " --" & vbCrLf, "") & _
ReadTxt(aFiles(i)) & _
IIf(bIncluirNombreFinal, vbCrLf & "-- " & DimeNombreFichero(aFiles(i)) & " --", "") & _
IIf(txtFinalFichero <> "", vbCrLf & txtFinalFichero, "")
Next
MergeTXTs = WriteTxt(OutputFile, sAllLinesFiles)
Set fso = Nothing
SysCmd acSysCmdClearStatus
DoCmd.Hourglass False
Exit Function
Resume
error:
DoCmd.Hourglass False
MergeTXTs = False
MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function
Public Function MakeDirFullPath(ByVal sPath As String) As Boolean
On Error GoTo error
'crear todo el path de un directorio
If Right(sPath, 1) = "\" Then
sPath = Left(sPath, Len(sPath) - 1)
End If
Dim SplitPath() As String
SplitPath = Split(sPath, "\")
Dim Value As Integer
Dim Merge As String
For Value = 0 To UBound(SplitPath)
If Value <> 0 Then
Merge = Merge & "\"
End If
Merge = Merge & SplitPath(Value)
If Dir(Merge, vbDirectory) = "" Then
MkDir Merge
End If
Next
SetAttr sPath, vbNormal
MakeDirFullPath = True
Exit Function
error:
MakeDirFullPath = False
Debug.Print Err.Description
End Function
Public Function DimeNombreFichero(ByVal sFichero As String) As String
On Error GoTo error
Dim fso As New FileSystemObject
If Not fso.FileExists(sFichero) Then Exit Function
DimeNombreFichero = fso.GetFileName(sFichero)
Set fso = Nothing
Exit Function
error:
DimeNombreFichero = ""
MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function
Public Function GetWindowsUser() As String
On Error GoTo error
Dim sUsername As String
Dim objNetwork As Object
sUsername = Environ$("username")
If sUsername = "" Then
Set objNetwork = CreateObject("WScript.Network")
sUsername = objNetwork.UserName
Set objNetwork = Nothing
End If
GetWindowsUser = sUsername
Exit Function
error:
Debug.Print Err.Description
GetWindowsUser = ""
End Function
Public Function WriteTxt(ByVal sPathFileName As String, ByVal sValue As String, Optional ByVal bAppend As Boolean = False) As Boolean
On Error GoTo error
Dim SFName As String 'ruta y nombre completo del fichero de texto
Dim iFNumber As Integer
SFName = sPathFileName
'crear la ruta completa si no existe
MakeDirFullPath (Left(SFName, InStrRev(SFName, "\") - 1))
'obtener numero de fichero
iFNumber = FreeFile
'añadir o sobreescribir el fichero
If bAppend Then
Open SFName For Append As #iFNumber
Else
Open SFName For Output As #iFNumber
End If
Print #iFNumber, sValue
Close #iFNumber
WriteTxt = True
Exit Function
error:
WriteTxt = False
Debug.Print Err.Description
End Function
Public Function ReadTxt(ByVal sPathFileName As String) As String
On Error GoTo error
Dim sLines, sLine As String
Dim iFile As Integer: iFile = FreeFile
Open sPathFileName For Input As #iFile
Do Until EOF(1)
Line Input #1, sLine
sLines = sLines & IIf(Nz(sLines, "") <> "", vbCrLf, "") & sLine
Loop
Close #iFile
ReadTxt = sLines
Exit Function
error:
ReadTxt = ""
MsgBox "error nº " & Err.Number & " - " & Err.Description, vbExclamation
End Function
