Change Query Field Names on Export

[neuk]

Basically I'm trying to change field names to its associated caption in a query so that when I export it to excel, the caption shows as the field name. I posted the below code
with everything explained in my comments for your situational awareness. The area in question is highlighted in red and is the only thing I haven't been able to get to work.

Sub XLParam()

Call XLSend("qryRecordExport", "Record Set", "C:\Desktop\a.xlsx")
'Call XLSend("qryInterval", "Interval", "C:\Desktop\a.xlsx")
'Call XLSend("qryRecordZ", "Record Sum", "C:\Desktop\a.xlsx")
'Call XLSend("qryIntervalZ", "Interval Sum", "C:\Desktop\a.xlsx")

End Sub

Public Function XLSend(strTQName As String, strSheetName As String, strFilePath As String)
' strTQName is the name of the table or query to send to Excel
' strSheetName is the name of the sheet to send it to
' strFilePath is the name and path of the file to send the data to.
Dim val As String
Dim prp As DAO.Property
Dim fld As DAO.Field
Dim rst As DAO.Recordset
Dim qdef As QueryDef
Dim prm As Parameter
Dim ApXL As Object
Dim xlWBk As Object
Dim xlWSh As Object
Dim i As Long
'xlCenter and xlBottom belong to the constants enumeration in excel.
    'since the same constants don't exist in Access, I manually redefined
    'what is needed here. I pulled this from the following site:
        'https://docs.microsoft.com/en-us/office/vba/api/excel.constants
Const xlCenter As Long = -4108
Const xlBottom As Long = -4107
'in the event of an error, bypass the function and go to err_handler
    'to ensure the code doesn't get stuck in manual
On Error GoTo err_handler
'I used a number of field values and random variables to calculate new values in a query.
    'It seems these values are called parameters and are automatically calculated by Access
    'whenever running the query. Of course, I have to manually do this in vba. So, before opening
    'the recordset, I evaluate each parameter. To do this, I set the query in question to
    '"QueryDef". I then write a simple loop statement to run through each parameter available.
    'With the qdef now "defined", I'm able to open the querydef as the recordset.
Set qdef = CurrentDb.QueryDefs(strTQName)
For Each prm In qdef.Parameters
    prm.Value = Eval(prm.Name)
Next prm
'Before opening the recordset, I'd like to change the name of the field to the caption
    'I assigned in the query, So, I set val equal to the given fields caption. I then
    'assign it to the field property. Next I try to append it, but it results in an error.
For Each fld In qdef.Fields
    val = fld.Properties("Caption").Value
    Set prp = fld.CreateProperty("Caption", dbText, val)
    Debug.Print prp
    fld.Properties.Append prp 'this is where it errors out (3367, "cannot append. An object with that name already exists in the collection")
Next
'**************
Set rst = qdef.OpenRecordset
'test if any records are available in the recordset, if for whatever reason there
'are no records available, exit the function. 
If rst.RecordCount = 0 Then
    MsgBox "There are no records to export"
    Exit Function
End If
'create the excel object to receive the record set
Set ApXL = CreateObject("Excel.Application")
'open the workbook
        '***to create a new workbook do something like this:
            'set xlWBk = Apxl.Application.WorkBooks.Add
            'xlWBk.SaveAs (strPath)
Set xlWBk = ApXL.Workbooks.Open(strFilePath)
'though not necessary, you can view the process by making
        'the workbook visible. However, only recommend this
        'for testing purposes.
'ApXL.Visible = True
'find the existing worksheet
    '***you can also add a new worksheet:
        'Set xlWSh = xlWBk.Worksheets.Add
    '***rename a new worksheet:
        'xlWSh.Name = strSheetName
    '***you can also use index numbers to find worksheets
        'set xlWsh = xlWBk.Worksheets(1)
Set xlWSh = xlWBk.Worksheets(strSheetName)
'start with the first field name and insert it on A1 .cells(1, 0+1) and field 0
    'when complete, move to the next field and add 1 to i to make A2 (1,1+1) and field 1
For i = 0 To rst.Fields.Count - 1
    xlWSh.Cells(1, i + 1) = rst.Fields(i).Name
Next i
rst.MoveFirst
'after the header has been inserted move to A2 and paste the recordset
xlWSh.Range("A2").CopyFromRecordset rst
'I included this to show what you can do about formatting
    'With xlWSh.Range("1:1").Font
    '    .Name = "Arial"
    '    .Size = 12
    '    .Strikethrough = False
    '    .Superscript = False
    '    .Subscript = False
    '    .OutlineFont = False
    '    .Shadow = False
    '    .Bold = True
    'End With
    'With xlWSh.Range("1:1")
    '    .HorizontalAlignment = xlCenter
    '    .VerticalAlignment = xlBottom
    '    .WrapText = False
    '    .Orientation = 0
    '    .AddIndent = False
    '    .IndentLevel = 0
    '    .ShrinkToFit = False
    '    .MergeCells = False
    'End With
'autofit the columns
xlWSh.Cells.EntireColumn.AutoFit
'Close the recordset
rst.Close
Set rst = Nothing
Set qdef = Nothing
'set display alerts to false to avoid nuissance warning messages by excel
    'such as "There is a large amount of information on the clipboard..."
ApXL.DisplayAlerts = False
'save the file before closing
If Dir(strFilePath) = "" Then
    xlWBk.SaveAs strFilePath
Else
    xlWBk.Save
End If
'close the workbook
xlWBk.Close
ApXL.DisplayAlerts = True
'close the application
ApXL.Quit
Set ApXL = Nothing
Exit Function
'show the error description and number to diagnose
err_handler:
DoCmd.SetWarnings True
MsgBox Err.Description, vbExclamation, Err.Number
End Function

[neuk]

I figured out another way to do it. Basically delete everything between the red comments above and change

For i = 0 To rst.Fields.Count - 1
    xlWSh.Cells(1, i + 1) = rst.Fields(i).Name
Next i

to

For i = 0 To rst.Fields.Count - 1
    xlWSh.Cells(1, i + 1) = rst.Fields(i).Properties("Caption").Value
Next i

I guess I answered my own question...

[ranman256]

or make a query that has the 'corrected' captions:
select [FirstName] as Fname , [LastName] as Lname from table

then just post the field.name