Results 1 to 3 of 3
  1. #1
    neuk is offline Novice
    Windows 10 Access 2016
    Join Date
    May 2019
    Posts
    12

    Change Query Field Names on Export


    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.

    Code:
    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
    

  2. #2
    neuk is offline Novice
    Windows 10 Access 2016
    Join Date
    May 2019
    Posts
    12
    I figured out another way to do it. Basically delete everything between the red comments above and change

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

    Code:
    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...

  3. #3
    ranman256's Avatar
    ranman256 is offline VIP
    Windows Vista Access 2010 32bit
    Join Date
    Apr 2014
    Location
    Kentucky
    Posts
    7,990
    or make a query that has the 'corrected' captions:
    select [FirstName] as Fname , [LastName] as Lname from table

    then just post the field.name

Please reply to this thread with any new information or opinions.

Similar Threads

  1. Replies: 7
    Last Post: 03-21-2018, 04:58 AM
  2. Replies: 2
    Last Post: 02-03-2018, 06:54 PM
  3. Update Query to Change Names of Hyperlinks
    By d-mcc56 in forum Queries
    Replies: 5
    Last Post: 01-11-2018, 05:14 PM
  4. Replies: 8
    Last Post: 06-24-2015, 08:22 AM
  5. Export to Excel displaying field names instead of captions
    By kattatonic1 in forum Import/Export Data
    Replies: 3
    Last Post: 04-10-2014, 09:13 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  
Tech Forums: Microsoft Office Forums