I have a dynamic array that I want to append values to. The number of values to be appended is not fixed
I was trying to do something like this:
Dim array() As Integer
ReDim Preserve array(UBound(array)+1)
bulkJob(UBound(array) + 1) = Me.ID
I get subscript out of range error at ReDim Preserve array(UBound(array)+1). Is there a way to do this?
Not quite clear what you are trying to do, but this could get you some ideas:
Public Function BuildJobs(Id As Integer)
Static bulkJob() As Integer
Dim Upper As Integer
On Error Resume Next
Upper = UBound(bulkJob) + 1
On Error GoTo 0
ReDim Preserve bulkJob(Upper)
' Fill in value.
bulkJob(Upper) = Id
' Do something.
Debug.Print UBound(bulkJob), bulkJob(Upper)
End Function
"Restart" the array like this:
ReDim bulkJob(0)
bulkJob(0) = 0
I was hoping someone could help me figure out why this script will not return the link names. I am trying to return a sub-string from 'http://textfiles.com/directory.html' which just writes the link names to the console, but I am struggling. The main problem - as far as I can see - is in the 'do until' loop. The working code outputs the html text to the console more for my sake than anything else (it does this successfully), but this feature may also help you guys understand the total picture I am facing. Maybe after seeing the code/ understanding my goal you guys can see where I am going wrong AND/OR suggest a better method for achieving my goal. Thanks a ton!
Imports System.IO
Imports System.Text
Module Module1
Sub Main()
Dim line As String = ""
Dim lowBound As String = "<a href="""
Dim highBound As String = """>"
Console.WriteLine("Grab link names from textfiles.com")
Console.WriteLine("")
Dim siteName As String = "http://textfiles.com/directory.html"
Dim tmpString As StringBuilder = New StringBuilder
My.Computer.Network.DownloadFile(siteName, "C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html", False, 500)
Dim myReader As StreamReader = New StreamReader("C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html")
While Not IsNothing(line)
line = myReader.ReadLine()
If Not IsNothing(line) Then
tmpString.Append(line)
End If
End While
Dim pageText As String = tmpString.ToString
Console.WriteLine(pageText)
Dim intCounter As Integer = 1
Do Until intCounter >= Len(pageText)
Dim checkSub As String = Mid(pageText, intCounter + 1, (Len(pageText) - intCounter))
Dim positLow As Integer = InStr(checkSub, lowBound)
Dim positHigh As Integer = InStr(checkSub, highBound)
If (positLow > 0 And positHigh > 0) And positLow < positHigh Then
Dim indexLow As Integer = checkSub.IndexOf(lowBound)
Dim indexHigh As Integer = checkSub.IndexOf(highBound)
Dim foundLink As String = checkSub.Substring(indexLow + Len(lowBound), indexHigh - Len(highBound))
Console.WriteLine(foundLink)
intCounter = intCounter + (Len(lowBound) + Len(highBound) + Len(foundLink) - 1)
Else
intCounter = Len(pageText)
End If
Loop
Console.ReadLine()
myReader.Close()
My.Computer.FileSystem.DeleteFile("C:\~\VisualStudio\BeginnerPractice\TextFileDotCom_GrabLinkNames\TextFileDotCom_GrabLinkNames\bin\debug\directory.html")
End Sub
End Module
have been googling around for a code to extract tables from emails and am trying to adapt the codes by changing early binding to late binding.
However, the code seems to bug out at the objHTML.body.innerHTML = objMailItem.HTMLBody line.
Code seems to run alright when used in Excel but bugs out when I run on outlook vba.
any help to point me in the right direction would be appreciated!
Public Function ExtractOutlookTables(objMailItem As Object) As Object
Dim vTable As Variant
Dim objHTML As Object: Set objHTML = CreateObject("htmlFile")
Dim objEleCol As Object
objHTML.Body.innerHTML = objMailItem.HTMLBody ' <<error line>>
With objHTML
objHTML.Body.innerHTML = objMailItem.HTMLBody
Set objEleCol = .getElementsByTagName("table")
End With
'import in Excel
Dim x As Long, y As Long
For x = 0 To objEleCol(0).Rows.Length - 1
For y = 0 To objEleCol(0).Rows(x).Cells.Length - 1
vTable(x, y) = objEleCol(0).Rows(x).Cells(y).innerText
Next y
Next x
ErrorHandler:
Set objHTML = Nothing: Set objEleCol = Nothing
End Function
''
' Function that returns a dictionary of arrays of strings, each representing a table in the email; key = 0 represents the most recent table
' #param objMailItem object representing an Outlook Mail Item object
' #return Dictionary of arrays of strings where each key represents the index of the table (0 being the most recent table)
' #remarks Please note that index 0 = table in the most recent email conversation
' #see none
Public Function fnc_ExtractTablesFromMailItem(objMailItem As Object) As Object
Dim objHTMLDoc As Object: Set objHTMLDoc = CreateObject("HTMLFile")
Dim dicTables As Object: Set dicTables = CreateObject("scripting.Dictionary")
Dim arrTable() As String
Dim objTable As Object
Dim lngRow As Long
Dim lngCol As Long
Dim intCounter As Integer: intCounter = 0
objHTMLDoc.body.innerHTML = objMailItem.htmlbody
' Loop through each table in email
For Each objTable In objHTMLDoc.getElementsByTagName("table")
ReDim arrTable(objTable.Rows.Length - 1, objTable.Rows(1).Cells.Length - 1)
For lngRow = 0 To objTable.Rows.Length - 1
Set rw = objTable.Rows(lngRow)
For lngCol = 0 To rw.Cells.Length - 1
' Ignore any problems with merged cells etc
On Error Resume Next
arrTable(lngRow, lngCol) = rw.Cells(lngCol).innerText ' Store each table in 1 array
On Error GoTo 0
Next lngCol
Next lngRow
dicTables(intCounter) = arrTable ' Store each array as a dictionary item
intCounter = intCounter + 1
Next objTable
Set fnc_ExtractTablesFromMailItem = dicTables
' Garbage collection
Set dicTables = Nothing: Set objTable = Nothing: Set objHTMLDoc = Nothing
End Function
The problem seems to be in the code that is calling the function. You should post that code.
If the only thing that you actual want from objMailItem is it's HTMLBody then objMailItem As Object should be removed from function signature should and replaced with HTMLBody as String.
You must be missing a couple of lines of code; because vTablewas never allocated and will throw a type mismatch error the way the function is written.
You should also wrap your test whether objEleCol is Nothing before you try and use it.
Here I pass the MailItem to fnc_ExtractTablesFromMailItem from Application_ItemSend to in Outlook. There are no errors.
The Application_NewMail and Application_NewMailEx events do not recieve MailItems as parameters. How are you retrieving the MailItem that you are passing into your function?
I have a pop-up window in Microsoft Access containing text box fields that are required to be filled out by the user, for example:
First Name:
Last Name:
Now I'm trying to create a button that when clicked would look into C:\mytextfile.txt
and auto-populate those fields.
inside the text file it would look like this:
##$##%#$543%#$%#$$#%LAST NAME:BOB#$##$##$##$##FIRST NAME:DERRICK$#%$#%$#%#$%$#%$#
So essentially I'm looking for 3 things:
to access the text file
to parse for the data
to populate it into the text boxes. (The data doesn't need to go into a table until the "SAVE" button is clicked")
Update:
This is what I've written so far, I'm not sure why it's not working.
Private Sub LoadText_Click()
Dim myFile As String myFile = "C:\myFile.txt"
Me.NameofTextbox = Mid(myFile, 7, 3)
End Sub
Here example for file you provided and controls on Form that are named txtboxLastName and txtboxFirstName
Dim mFields() As String ' array with fields' names in file
Dim mControls() As String ' corresponding controls' names
Dim mStopChars() As String ' Characters that put after values
Dim tmpstr As String
Dim content As String
Dim i As Long
Dim fStart As Long
Dim valStart As Long
Dim valEnd As Long
Dim FieldValue As String
Dim j As Long
Dim tmp As Long
' prepare maps
' here : included in field name for common case
mFields = Split("LAST NAME:,FIRST NAME:", ",")
mControls = Split("txtboxLastName,txtboxFirstName", ",")
mStopChars = Split("#,$,#,%", ",")
' read file into string
Open "c:\mytextfile.txt" For Input As #1
Do While Not EOF(1)
Input #1, tmpstr
content = content & tmpstr
Loop
Close #1
' cycle through fields and put their values into controls
For i = LBound(mFields) To UBound(mFields)
fStart = InStr(1, content, mFields(i))
If fStart > 0 Then
valStart = fStart + Len(mFields(i)) 'value start at this pos
'cycle through possible stop chars to locate end of current value
valEnd = Len(content)
For j = LBound(mStopChars) To UBound(mStopChars)
tmp = InStr(valStart, content, mStopChars(j))
If tmp > 0 Then
If tmp <= valEnd Then
valEnd = tmp - 1
End If
End If
Next j
' cut value
FieldValue = Mid(content, valStart, valEnd - valStart + 1)
' assign to control
Me.Controls(mControls(i)).Value = FieldValue
End If
Next i
I have a ms access table that is tracking 50 products with their daily sold volumes. I would like to export using vba 1 csv file (including headers) for each product showing the daily volumes from a recordset without saving the recordset to a permanent query. I am using the below code but I am stuck at the point of the actual export highlighted below in code.
Any assistance in fixing this is appreciated.
Dim rst As Recordset
Dim rstId As Recordset
SQLExportIds = "SELECT DISTINCT tblDailyVols.SecId FROM tblDailyVols WHERE tblDailyVols.IsDeleted=False"
Set rstId = CurrentDb.OpenRecordset(SQLExportIds)
If rstId.EOF = True Then
MsgBox "No Products Found"
Exit Sub
End If
Do While rstId.EOF = False
SecId = rstId.Fields("SecId")
SQLExportQuotes = " SELECT tblDailyVols.ID , tblDailyVols.TradedVolume, tblDailyVols.EffectiveDate FROM tblDailyVols "
SQLExportQuotes = SQLExportQuotes & " WHERE tblDailyVols.IsDeleted=False and tblDailyVols.ID = " & SecId
SQLExportQuotes = SQLExportQuotes & " ORDER BY tblDailyVols.EffectiveDate "
Set rst = CurrentDb.OpenRecordset(SQLExportQuotes)
If rst.EOF = True Then
MsgBox "No Quotes Found"
Exit Sub
End If
IDFound = rst.Fields("ID")
OutputPlace = “C:\Output” & IDFound & ".csv"
Set qdfTemp = CurrentDb.CreateQueryDef("", SQLExportQuotes)
**DoCmd.TransferText acExportDelim, , 1, OutputPlace, True** <--This Here Line Fails
Set rst = Nothing
rstId.MoveNext
Loop
Set rstId = Nothing
You will have to create an actual named QueryDef object for TransferText to work with, but then you can just delete it afterwards. Something like this:
Set qdfTemp = CurrentDb.CreateQueryDef("zzzTemp", SQLExportQuotes)
Set qdfTemp = Nothing
DoCmd.TransferText acExportDelim, , "zzzTemp", OutputPlace, True
DoCmd.DeleteObject acQuery, "zzzTemp"
You asked for a VBA solution, and I detect a preference for not creating new Access objects; you may well have good reasons for that, but the 'pure' VBA solution is a lot of work.
A solution that implements encapsulating text fields in quotes is the bare minimum for a competent answer. After that, you need to address the three big issues:
Optimising away VBA's clunky string-handling;
The Byte Order Marker, which VBA embeds in every string it saves to
file, ensuring that some of the most common consumers of a csv file
cannot read it properly;
...And there's rarely any middle ground between writing the file
line-by-line, forever, and writing it in one big chunk that'll throw
an out-of-memory error on larger recordsets.
Beginners in VBA may find the string-optimisations difficult to understand: the biggest performance gain available in native VBA is to avoid string allocation and concatenation ( here's why: http://www.aivosto.com/vbtips/stringopt2.html#huge ) - so I use join, split, and replace instead of myString = MyString & MoreString
The trailing loop, with the RecordSet.GetRows() call at the very end, will raise eyebrows among coders with strong opinions about structured programming: but there are constraints on how you can order the code so that the 'chunks' are concatenated into the file without any missed bytes, out-of-register shifts in the byte order, or blank lines.
So here goes:
Public Function RecordsetToCSV(ByRef rst As ADODB.Recordset, _
ByRef OutputFile As String, _
Optional ByRef FieldList As Variant, _
Optional ByVal CoerceText As Boolean = True, _
Optional ByVal CleanupText As Boolean = True _
) As Long
' Output a recordset to a csv file and returns the row count.
' If the output file is locked, or specified in an inaccessible location, the
' 'ByRef' OutputFile parameter becomes a file in the user's local temp folder
' You can supply your own field list. This isn't a substituted file header of
' aliased field names: it is a subset of the field names, which ADO will read
' selectively from the recordset. Each item in the list matches a named field
' CoerceText=TRUE will encapsulate all items, numeric or not, in quote marks.
' CleanupText=TRUE strips quotes and linefeeds from the data: FALSE is faster
' You should only set them FALSE if you're confident that the data is 'clean'
' with no quote marks, commas or line breaks in any unencapsulated text field
' This code handles unicode, and outputs a file that can be read by Microsoft
' ODBC and OLEDB database drivers by removing the Byte Order Marker.
On Error Resume Next
' Coding note: we're not doing any string-handling in VBA.Strings: allocating
' deallocating and (especially!) concatenating are SLOW. We are using the VBA
' Join and Split functions ONLY. Feel free to optimise further by declaring a
' faster set of string functions from the Kernel if you want to.
'
' Other optimisations: type pun. Byte Arrays are interchangeable with strings
' Some of our loops through these arrays have a 'step' of 2. This optimises a
' search-and-replace for ANSI chars in an array of 2-byte unicodes. Note that
' it's only used to remove known ANSI 'Latin' characters with a 'low' byte of
' zero: any other use of the two-byte 'step' will fail on non-Latin unicodes.
' ** THIS CODE IS IN THE PUBLIC DOMAIN **
' Nigel Heffernan Excellerando.Blogspot.com
Const FETCH_ROWS As Long = 4096
Dim COMMA As String * 1
Dim BLANK As String * 4
Dim EOROW As String * 2
COMMA = ChrW$(44)
BLANK = ChrW$(13) & ChrW$(10) & ChrW$(13) & ChrW$(10)
EOROW = ChrW$(13) & ChrW$(10)
Dim FetchArray As Variant
Dim i As Long ' i for rows in the output file, records in the recordset
Dim j As Long ' j for columns in the output file, fields in the recordset
Dim k As Long ' k for all other loops: bytes in individual data items
Dim i_Offset As Long
Dim i_LBound As Long
Dim i_UBound As Long
Dim j_LBound As Long
Dim j_UBound As Long
Dim k_lBound As Long
Dim k_uBound As Long
Dim hndFile As Long
Dim varField As Variant
Dim iRowCount As Long
Dim arrBytes() As Byte
Dim arrTemp1() As String
Dim arrTemp2() As String
Dim arrTemp3(0 To 2) As String
Dim boolNumeric As Boolean
Dim strHeader As String
Dim arrHeader() As Byte
Dim strFile As String
Dim strPath As String
Dim strExtn As String
strFile = FileName(OutputFile)
strPath = FilePath(OutputFile)
strExtn = FileExtension(strFile)
If rst Is Nothing Then Exit Function
If rst.State <> 1 Then Exit Function
If strExtn = "" Then
strExtn = ".csv"
End If
With FSO
If strFile = "" Then
strFile = .GetTempName
strFile = Left(strFile, Len(strFile) - Len(".tmp"))
strFile = strFile & strExtn
End If
If strPath = "" Then
strPath = TempSQLFolder
End If
If Right(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
strExtn = FileExtension(strFile)
If strExtn = "" Then
strExtn = ".csv"
strFile = strFile & strExtn
End If
OutputFile = strPath & strFile
End With
If FileName(OutputFile) <> "" Then
If Len(VBA.FileSystem.Dir(OutputFile, vbNormal)) <> 0 Then
Err.Clear
VBA.FileSystem.Kill OutputFile ' do it now, and reduce wait for deletion
If Err.Number = 70 Then ' permission denied: change the output file name
OutputFile = FileStripExtension(OutputFile) & "_" & FileStripExtension(FSO.GetTempName) & FileExtension(OutputFile)
End If
End If
End If
' ChrW$() gives a 2-byte 'Wide' char. This coerces all subsequent operations to UTF16
arrTemp3(0) = ChrW$(34) ' Encapsulating quote
arrTemp3(1) = vbNullString ' The field value will go here
arrTemp3(2) = ChrW$(34) ' Encapsulating quote
If rst.EOF And rst.BOF Then
FetchArray = Empty
ElseIf rst.EOF Then
rst.MoveFirst
End If
' An empty recordset must still write a header row of field names: we put this in the
' output buffer and write it to the file before we start looping through the records.
ReDim FetchArray(0 To rst.Fields.Count, 0 To 0)
i_LBound = 0
i_UBound = 0
If IsMissing(FieldList) Then
For j = LBound(FetchArray, 1) To UBound(FetchArray, 1) - 1 Step 1
FetchArray(j, i_UBound) = rst.Fields(j).Name
Next j
Else
j = 0
For Each varField In FieldList
j_UBound = j_UBound + 1
Next varField
ReDim arrTemp2(j_LBound To j_UBound)
For Each varField In FieldList
FetchArray(j, i_UBound) = CStr(varField)
j = j + 1
Next varField
End If
ReDim arrTemp1(i_LBound To i_UBound) ' arrTemp1 is the rowset we write to file
ReDim arrTemp2(j_LBound To j_UBound) ' arrTemp2 represents a single record
Do Until IsEmpty(FetchArray)
i_LBound = LBound(FetchArray, 2)
i_UBound = UBound(FetchArray, 2)
j_LBound = LBound(FetchArray, 1)
j_UBound = UBound(FetchArray, 1)
If UBound(arrTemp1) <> i_UBound + 1 Then
ReDim arrTemp1(i_LBound To i_UBound + 1)
arrTemp1(i_UBound + 1) = vbNullString ' The 'Join' operation will insert a trailing row
End If ' delimiter here (Not required by the last chunk)
If UBound(arrTemp2) <> j_UBound Then
ReDim arrTemp2(j_LBound To j_UBound)
End If
' Data body. This is heavily optimised to avoid VBA String functions with allocations
For i = i_LBound To i_UBound Step 1
' If this is confusing... Were you expecting FetchArray(i,j)? i for row, j for column?
' FetchArray comes from RecordSet.GetRows(), which returns a TRANSPOSED array: i and j
' are still the field and record ordinals, row(i) and column(j) in the output file.
For j = j_LBound To j_UBound
If IsNull(FetchArray(j, i)) Then
arrTemp2(j) = ""
Else
arrTemp2(j) = FetchArray(j, i) ' confused? see he note above
End If
If CleanupText Or (i_UBound = 0) Then ' (i_UBound=0): always clean up field names
arrBytes = arrTemp2(j) ' Integer arithmetic is faster than string-handling for
' this: all VBA string operations require an allocation
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
Select Case arrBytes(k)
Case 10, 13, 9, 160
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 32 ' replaces CR, LF, Tab, and non-breaking
End If ' spaces with the standard ANSI space
Case 44
If Not CoerceText Then
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 32 ' replace comma with the ANSI space
End If
End If
Case 34
If arrBytes(k + 1) = 0 Then
arrBytes(k) = 39 ' replaces double-quote with single quote
End If
End Select
Next k
arrTemp2(j) = arrTemp2(j)
End If ' cleanup
If CoerceText Then ' encapsulate all fields in quotes, numeric or not
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join$(arrTemp3, vbNullString)
ElseIf (i = 0) And (i = i_UBound) Then ' always encapsulate field names
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join$(arrTemp3, vbNullString)
Else ' selective encapsulation, leaving numeric fields unencapsulated:
' we *could* do this by reading the ADODB field types: but that's
' slower, and you may be 'caught out' by provider-specific types.
arrBytes = arrTemp2(j)
boolNumeric = True
For k = LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) < 43 Or arrBytes(k) > 57 Then
If arrBytes(k) <> 69 Then
boolNumeric = False
Exit For
Else
If k > UBound(arrBytes) - 5 Then
boolNumeric = False
Exit For
ElseIf arrBytes(k + 2) = 45 Then
' detect "1.234E-05"
ElseIf arrBytes(k + 2) = 43 Then
' detect "1.234E+05"
Else
boolNumeric = False
Exit For
End If
End If
End If
Next k
If boolNumeric Then
For k = 1 + LBound(arrBytes) To UBound(arrBytes) Step 2
If arrBytes(k) <> 0 Then
boolNumeric = False
Exit For
End If
Next k
End If
arrBytes = vbNullString
If Not boolNumeric Then ' text field, encapsulate it
arrTemp3(1) = arrTemp2(j)
arrTemp2(j) = Join(arrTemp3, vbNullString)
End If
End If ' CoerceText
Next j
arrTemp1(i) = Join(arrTemp2, COMMA)
Next i
iRowCount = iRowCount + i - 2
' **** WHY WE 'PUT' A BYTE ARRAY INSTEAD OF A VBA STRING VARIABLE **** ****
'
' Put #hndFile, , StrConv(Join(arrTemp1, EOROW), vbUnicode)
' Put #hndFile, , Join(arrTemp1, EOROW)
'
' If you pass unicode, Wide or UTF-16 string variables to PUT, it prepends a
' Unicode Byte Order Mark to the data which, when written to your file, will
' render the field names illegible to Microsoft's JET ODBC and ACE-OLEDB SQL
' drivers (which can actually read unicode field names, if the helpful label
' isn't in the way). The primeval 'PUT' statement writes a Byte array as-is.
'
' **** **** **** **** **** **** **** **** **** **** **** **** **** **** ****
arrBytes = Join$(arrTemp1, vbCrLf)
If hndFile = 0 Then
i_Offset = 1
If Len(Dir(OutputFile)) > 0 Then
VBA.FileSystem.Kill OutputFile
End If
WaitForFileDeletion OutputFile
hndFile = FreeFile
Open OutputFile For Binary Access Write As #hndFile
End If
Put #hndFile, i_Offset, arrBytes
i_Offset = i_Offset + 1 + UBound(arrBytes)
Erase arrBytes
If rst.EOF Then
Erase FetchArray
FetchArray = Empty
Else
If IsMissing(FieldList) Then
FetchArray = rst.GetRows(FETCH_ROWS)
Else
FetchArray = rst.GetRows(FETCH_ROWS, , FieldList)
End If
End If
Loop ' until isempty(FetchArray)
If iRowCount < 1 Then '
iRowCount = 0 ' Row Count excludes the header
End If
RecordsetToCSV = iRowCount
ExitSub:
On Error Resume Next
If hndFile <> 0 Then
Close #hndFile
End If
Erase arrBytes
Erase arrTemp1
Erase arrTemp2
Exit Function
ErrSub:
Resume ExitSub
End Function
Public Function FilePath(Path As String) As String
' Strip the filename from a path, leaving only the path to the folder
' The last char of this path will be the backslash
' This does not check for the existence or accessibility of the file:
' all we're doing here is string-handling
Dim strPath As String
Dim arrPath() As String
Const BACKSLASH As String * 1 = "\"
strPath = Trim(Path)
If strPath = "" Then Exit Function
If Right$(strPath, 1) = BACKSLASH Then Exit Function
arrPath = Split(strPath, BACKSLASH)
If UBound(arrPath) = 0 Then ' does not contain "\"
FilePath = ""
Else
arrPath(UBound(arrPath)) = vbNullString
FilePath = Join$(arrPath, BACKSLASH)
End If
Erase arrPath
End Function
Public Function FileName(Path As String) As String
' Strip the folder and path from a file's path string, leaving only the file name
' This does not check for the existence or accessibility of the file:
' all we're doing here is string-handling
Dim strPath As String
Dim arrPath() As String
Const BACKSLASH As String * 1 = "\"
strPath = Trim(Path)
If strPath = "" Then Exit Function
If Right$(strPath, 1) = BACKSLASH Then Exit Function
arrPath = Split(strPath, BACKSLASH)
If UBound(arrPath) = 0 Then ' does not contain "\"
FileName = Path
Else
FileName = arrPath(UBound(arrPath))
End If
Erase arrPath
End Function
Public Function FileExtension(Path As String) As String
' Return the extension of the file
' This is just string-handling: no file or path validation is attempted
' The file extension is deemed to be whatever comes after the final '.'
' The extension is returned with the dot, eg: ".txt" not "txt"
' If no extension is detected, FileExtension returns an empty string
Dim strFile As String
Dim arrFile() As String
Const DOT_EXT As String * 1 = "."
strFile = FileName(Path)
strFile = Trim(strFile)
If strFile = "" Then Exit Function
If Right$(strFile, 1) = DOT_EXT Then Exit Function
arrFile = Split(strFile, DOT_EXT)
If UBound(arrFile) = 0 Then ' does not contain "\"
FileExtension = vbNullString
Else
FileExtension = arrFile(UBound(arrFile))
FileExtension = Trim(FileExtension)
If Len(FileExtension) > 0 Then
FileExtension = DOT_EXT & FileExtension
End If
End If
Erase arrFile
End Function
Public Function FileStripExtension(Path As String) As String
' Return the filename, with the extension removed
' This is just string-handling: no file validation is attempted
' The file extension is deemed to be whatever comes after the final '.'
' Both the dot and the extension are removed
Dim strFile As String
Dim arrFile() As String
Const DOT_EXT As String * 1 = "."
strFile = FileName(Path)
If strFile = "" Then Exit Function
If Right$(strFile, 1) = DOT_EXT Then Exit Function
strFile = Trim(strFile)
arrFile = Split(strFile, DOT_EXT)
If UBound(arrFile) = 0 Then ' does not contain "\"
FileStripExtension = vbNullString
Else
ReDim Preserve arrFile(LBound(arrFile) To UBound(arrFile) - 1)
FileStripExtension = Join$(arrFile, DOT_EXT)
End If
Erase arrFile
End Function
You'll also need the three path-and-file-name utility functions, if you don't have your own versions already:
FileName()
FilePath()
FileStripExtension()
There's room for improvement in the string-encapsulation logic: the correct approach is to look up the recordset's field types and apply quote marks accordingly, and it may well turn out to be faster than my clunky byte-counting.
However, my approach is all about the file consumers and what they expect to see; and that doesn't always line up with what they ought to accept.
If you succeed in coding a faster and more robust version do, please, let me know: if I'm asked to, I may well code up encapsulation by field type myself.
just thought I would toss in; macros offer this feature - and it is quite simple to set up;
select the export macro, select the query to export, select the format.... if you leave the destination selector blank it will launch the standard Windows file picker....
after a decade+ of coding in vba - macros have won me over for this particular function.....