basSaveExcelAsTabDelimitedText

Public Function SaveExcelAsTabDelimitedText(ExcelFilePath As String, _
    Optional ExcelMessageUser As Boolean = True, Optional TextFilePath, _
    Optional TextMessageUser As Boolean = True) As Boolean
' This function opens an Excel file and saves it as a tab delimited text file.
' It only acts on the first (active) worksheet.
'
' ExcelFilePath
'   The complete path to the Excel file.
' ExcelMessageUser
'   If True, the user will get messages for missing file or file in use.
' TextFilePath
'   The complete path to the tab delimited text file.  If this is missing, it
'   uses the name of the Excel file to build the text file name.
' TextMessageUser
'   If True, the user will get a message for file overwrite.
'
' SaveExcelAsTabDelimitedText() Version 1.0.0
' Copyright © 2023 Extra Mile Data, www.extramiledata.com.
' For questions or issues, please contact [email protected].
' Use (at your own risk) and modify freely as long as proper credit is given.
'
On Error GoTo Err_Handler

    Dim xlsApp As Object
    Dim xlsWB As Object
    Dim strTextFile As String
    Dim intPos As Integer
    Dim strName As String
    Dim strPrompt As String
    Const xlTextWindows As Long = 20

    ' Validate.
    If Len(Dir(ExcelFilePath, vbNormal)) = 0 Then
        ' Message the user if required.
        If ExcelMessageUser Then
            strPrompt = "The Excel file '" & ExcelFilePath & "' does not exist."
            MsgBox strPrompt, vbInformation, "Missing File"
        End If
        ' Cannot continue.  Exit.
        SaveExcelAsTabDelimitedText = False
        GoTo Exit_Proc
    End If

    If FileInUse(ExcelFilePath) = True Then
        If ExcelMessageUser Then
            strPrompt = "The Excel file '" & ExcelFilePath & "' is currently open.  " _
            & "Please close the file and try again."
            MsgBox strPrompt, vbInformation, "File is Open"
        End If
        ' Cannot continue.  Exit.
        SaveExcelAsTabDelimitedText = False
        GoTo Exit_Proc
    End If

    ' Verify.
    If IsMissing(TextFilePath) Then
        intPos = InStrRev(ExcelFilePath, ".")
        strName = Left(ExcelFilePath, intPos - 1)
        strTextFile = strName & ".txt"
    Else
        strTextFile = TextFilePath
    End If
    
    If Len(Dir(strTextFile, vbNormal)) <> 0 Then
        ' Message the user if required.
        If TextMessageUser Then
            strPrompt = "The existing text file '" & strTextFile & "' will be " _
            & "overwritten.  Continue?"
            If MsgBox(strPrompt, vbQuestion + vbYesNo, "Overwrite Text File?") = vbNo Then
                SaveExcelAsTabDelimitedText = False
                GoTo Exit_Proc
            End If
        End If
        ' Delete the file.
        Kill strTextFile
    End If

    ' Open the Excel file.
    Set xlsApp = CreateObject("Excel.Application")
    Set xlsWB = xlsApp.Workbooks.Open(ExcelFilePath)
    
    ' Save the worksheet as a text file.
    xlsApp.DisplayAlerts = False
    xlsApp.ActiveSheet.SaveAs FileName:=strTextFile, FileFormat:=xlTextWindows
    xlsWB.Close SaveChanges:=True
    xlsApp.DisplayAlerts = True

    SaveExcelAsTabDelimitedText = True

Exit_Proc:
    On Error Resume Next
    Set xlsWB = Nothing
    Set xlsApp = Nothing
    Exit Function

Err_Handler:
    MsgBox Err.Number & " " & Err.Description, vbCritical, "SaveExcelAsTabDelimitedText"
    SaveExcelAsTabDelimitedText = False
    Resume Exit_Proc
End Function
'
Private Function FileInUse(FileName As String) As Boolean
' This procedure determines if the file is open.  If it is, then
' it passes back True.
' Modified from:
' https://stackoverflow.com/questions/9373082/detect-whether-excel-workbook-is-already-open.
On Error GoTo Err_Handler

    Open FileName For Binary Access Read Lock Read As #1
    Close #1
    
    FileInUse = False

Exit_Proc:
    On Error Resume Next
    Exit Function

Err_Handler:
    FileInUse = True
    Resume Exit_Proc
End Function