Microsoft Sql Server. Crear un alias. Aunar el nombre y el puerto de un servidor sql en un alias. Ej. srvql,10001 -> alias SERVIDOR

En las herramientas de configuración del Sql crearemos el alias

Una vez configurado el alias este se podrá usar sin tener que indicar el puerto.

En el ejemplo hemos creado un alias sobre srvsql,10051 equivale a SERVIDOR (nombre del alias) 

VBA Access. Módulo para combinar ficheros de texto.

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