I've come up with a bit of a weird situation. I have a string that was entered into a form from a webpage. I noticed that the string wasn't behaving as expected when I was trying to apply a filter.
The crux of the matter is depending on how I view the string it appears differently.
Form View - "523548"
Datasheet View - " 523548"
Raw Sql - " 523548"
Actually, when I view the datasheet value it appears as "523548 " but copies as " 523548".
Asc(Left(string),1) tells me the first character is Chr9 (Tab Key)
I am really stuck to find out why this is happening or more importantly, what I can do to correct it.
Thanks!
Dave.
I'd use the Trim() function here. Although the link is for Excel, it's the same syntax in Access.
Use this function when you write the value to the table, and you can use this function to clean up your current data as well. This should remove phantom tabs, as well as spaces.
Thanks for the tips. I found this function and added in a couple of items to suit my needs.
' Strip Illegal Characters
' http://www.utteraccess.com/wiki/index.php/Strip_Illegal_Characters
' Code courtesy of UtterAccess Wiki
' Licensed under Creative Commons License
' http://creativecommons.org/licenses/by-sa/3.0/
'
' You are free to use this code in any application,
' provided this notice is left unchanged.
'
' rev date brief descripton
' 1.0 2010-10-23 Writing files to disk that contain illegal file characters can cause sometimes obscure error message(s)
'
Public Function fStripIllegal(strCheck As String, Optional strReplaceWith As String = "") As String
On Error GoTo StripIllErr
'illegal file name characters included in default string are ? [ ] / \ = + < > :; * " , '
Dim intI As Integer
Dim intPassedString As Integer
Dim intCheckString As Integer
Dim strChar As String
Dim strIllegalChars As String
Dim intReplaceLen As Integer
If IsNull(strCheck) Then Exit Function
strIllegalChars = "?[]/\=+<>:;,*" & Chr(34) & Chr(39) & Chr(32) & Chr(9) 'add/remove characters you need removed to this string
intPassedString = Len(strCheck)
intCheckString = Len(strIllegalChars)
intReplaceLen = Len(strReplaceWith)
If intReplaceLen > 0 Then 'a character has been entered to use as the replacement character
If intReplaceLen = 1 Then 'check the character itself isn't an illegal character
If InStr(strIllegalChars, strReplaceWith) > 0 Then
MsgBox "You can't replace an illegal character with another illegal character", _
vbOKOnly + vbExclamation, "Invalid Character"
fStripIllegal = strCheck
Exit Function
End If
Else 'only one replacement character allowed
MsgBox "Only one character is allowed as a replacement character", _
vbOKOnly + vbExclamation, "Invalid Replacement String"
fStripIllegal = strCheck
Exit Function
End If
End If
If intPassedString < intCheckString Then
For intI = 1 To intCheckString
strChar = Mid(strIllegalChars, intI, 1)
If InStr(strCheck, strChar) > 0 Then
strCheck = Replace(strCheck, strChar, strReplaceWith)
End If
Next intI
Else
For intI = 1 To intPassedString
strChar = Mid(strIllegalChars, intI, 1)
If InStr(strCheck, strChar) > 0 Then
strCheck = Replace(strCheck, strChar, strReplaceWith)
End If
Next intI
End If
fStripIllegal = Trim(strCheck)
StripIllErrExit:
Exit Function
StripIllErr:
MsgBox "The following error occured: " & err.Number & vbCrLf _
& err.Description, vbOKOnly + vbExclamation, "Unexpected Error"
fStripIllegal = strCheck
Resume StripIllErrExit
End Function
Well, adjust your routine to not include the tab for new entries.
The old entries you can adjust with Replace:
NewValue = Replace([OldValue], Chr(9), "")
Related
I've been working on a spread sheet to allow my team to manage our workload more effectively, whilst the business is developing a new tool. Anyway, what the sheet does is inject information, then at the click of a button, it populates an OFT email template so that the info can be sent out.
Problem is, we rely heavily on bullet lists for our emails, and I'm really struggling to find a way of adding bullets effectively from an ActiveX Textbox.
At the moment, I have a button which adds the follow to a text box:
[bullets]
* Bullet 1
* Bullet 2
* Bullet 3
[/bullets]
I then have Replace statements that look for strings and it replaces them with the appropriate HTML tags. Here's the code:
' Add HTML formatting to text updates so it displays correctly in the email.
LatestUpdate.Text = Replace(LatestUpdate, "[bullets]", "<ul>")
LatestUpdate.Text = Replace(LatestUpdate, "[/bullets]", "</ul>")
LatestUpdate.Text = Replace(LatestUpdate, "* ", "<li>")
LatestUpdate.Text = Replace(LatestUpdate, vbCrLf, "<br>")
The problem I'm having, is that non-technical people are using this document, so I would really like to have it in such a way were they don't have to look at the markup, but can simple add bullets straight from the textbox.
I was originally thinking about replacing "* " with "< li >" however, that doesn't add the correct < ul > tags, so it's not actually a bullet list within the email.
Can anyone help in simplifying this process for the end users please? I'm really stuck.
The holy grail would be to enable rich text formatting on the textbox, but I don't believe that's possible from all the research I've done?
TIA.
Based on your last comment, what you are looking for is not just a bullet point in your textbox but indentation as well. So here is an attempt at it:
First add the below in your <textbox>_KeyUp function:
Private Sub txtBulletPoints_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim STRING_LENGTH As Long: STRING_LENGTH = 49
Dim aLine() As String
Dim aLineSpace() As String
Dim iC As Integer
Dim sText As String
Dim bUpdate As Boolean
' Only do this if there is a string to work with
If Len(Me.txtBulletPoints.Text) > 0 Then
' Set initial values
aLine = Split(Me.txtBulletPoints.Text, vbCrLf)
bUpdate = False
' First lets indent the last line if we need to
If Left(aLine(UBound(aLine)), 2) = "- " Then
For iC = LBound(aLine) To UBound(aLine)
If iC = UBound(aLine) Then
sText = sText & vbTab & aLine(iC)
Else
sText = sText & aLine(iC) & vbCrLf
End If
Next
Me.txtBulletPoints.Text = sText
End If
' Now the tricky bit. Check if we have reached the end of the
' line so that we can indent the text into the next line
If (Len(aLine(UBound(aLine))) >= STRING_LENGTH) And (InStr(1, aLine(UBound(aLine)), vbTab) = 1) Then
For iC = LBound(aLine) To UBound(aLine)
If iC = UBound(aLine) Then
aLineSpace = Split(aLine(iC), " ")
' As we have to indent the last bullet point line, call the finction to do that
sText = sText & SetIndentsInString(aLine(iC), STRING_LENGTH)
Else
sText = sText & aLine(iC) & vbCrLf
End If
Next
Me.txtBulletPoints.Text = sText
End If
End If
End Sub
Now add the below UDF where your form code is (essentially at the same place where your <textbox>_KeyUp function is):
Function SetIndentsInString(ByVal sString As String, ByVal iIndentLen As Long) As String
Dim iC As Long
Dim iLastTab As Long: iLastTab = 0
Dim aSpace() As String
Dim aTab() As String
Dim sCurString As String
' Check if the string is the same as what it was last
' time (sLastString is a private module variable initialised
' to "" when the form is activated)
If Replace(sString, vbTab, "") = Replace(sLastString, vbTab, "") Then
' Its the same string so lets return it as is
SetIndentsInString = sString
Else
' Its not the same string so set initial values
sLastString = sString
SetIndentsInString = ""
' Loop to see how many lines we have based on number of TABs in the string
Do While InStr(iLastTab + 1, sString, vbTab) > 0
iLastTab = iLastTab + InStr(iLastTab + 1, sString, vbTab)
Loop
' If there is only 1 TAB, simply indent the line
If iLastTab = 1 Then
aSpace = Split(sString, " ")
SetIndentsInString = Mid(sString, 1, Len(sString) - Len(aSpace(UBound(aSpace)))) & vbTab & " " & aSpace(UBound(aSpace))
Else
' More then 1 TAB.. damn!. Ok well lets work it
aTab = Split(sString, vbTab)
sCurString = aTab(UBound(aTab))
' Check if the last line of our bullet point has more characters then allowed in a line
If Len(sCurString) >= iIndentLen Then
' It does. Now loop through all the lines in our bullet point and set the last character in a new line with indent
aSpace = Split(sCurString, " ")
For iC = LBound(aTab) To UBound(aTab)
If iC = UBound(aTab) Then
SetIndentsInString = SetIndentsInString & Mid(sCurString, 1, Len(sCurString) - Len(aSpace(UBound(aSpace)))) & vbTab & " " & aSpace(UBound(aSpace))
Else
SetIndentsInString = SetIndentsInString & aTab(iC) & vbTab
End If
Next
Else
' It doesnt. Loop through and send the string back
SetIndentsInString = sString
End If
End If
End If
End Function
Now in the same module, make the following declaration at the top:
Private sLastString As String
Essentially the above will act like a bullet point as it would be in a Rich Text box. Things to remember is that you will have to set STRING_LENGTH to the number of characters your textbox will take in a given bullet point line (you will have to play around with that). Below is a screen print of how it worked for me
This question was asked in the topic with a similar name earlier, but the answer provided didn't really indicate HOW those events would help determine whether somebody was typing in the combo box or selecting an item in the list. I think that it really answered the other question about how to determine when somebody was done typing, but without seeing the event handlers, I can't be sure.
Unfortunately, I'm new here and don't have enough reputation to post a comment asking for clarification, so I have to start a new question. Here's what I'm trying to do:
I have a form with a combo box in the Header and, as I type in the combo box, I want the characters that I've typed to be used as a filter on the Details part of the form. Both the combo box control source and the form's record source use the same query string.
I've tried numerous iterations of the code below, but I can't get it to work correctly.
Private Sub cmbAppName_Change()
Dim strApp As String
Dim nSelStart As Integer
Dim nSelLen As Integer
Dim nSelected As Integer
Dim strMsg As String
On Error GoTo ERR_SUB
strMsg = ""
Me.cmbAppName.SetFocus
' Get current selection details
nSelStart = Me.cmbAppName.SelStart
nSelLen = Me.cmbAppName.SelLength
nSelected = Me.cmbAppName.ListIndex
Me.cmbAppName.SetFocus
strApp = Nz(Me.cmbAppName.Text, "")
Debug.Print "Index = " & nSelected & "; SelStart = " & nSelStart & "; SelLen = " & nSelLen
If nSelected = -1 Then
Debug.Print "Change by typing: " & strApp
Else
Debug.Print "Change by list selection: " & strApp
End If
' Get the part of the text that the user has typed
If nSelStart > 0 Then
strApp = Left(strApp, nSelStart)
Debug.Print "App piece = '" & strApp & "'"
End If
' If there is text, set a filter (MatchAppName = InStr(strApp, datbase_column_value)
If strApp <> "" Then
Me.Filter = "MatchAppName('" & strApp & "', " & DCApplications_Application_Col & ") > 0"
Me.FilterOn = True
' Me.txtApplication.SetFocus
' Call DoCmd.FindRecord(strApp, acStart, False, acSearchAll, False, acCurrent, True)
' Me.cmbAppName.SetFocus
Else
Me.Filter = ""
Me.FilterOn = False
End If
EXIT_SUB:
' Restore the selection in the combo box's text box
Me.cmbAppName.SetFocus
Me.cmbAppName.SelStart = nSelStart
Me.cmbAppName.SelLength = nSelLen
Exit Sub
ERR_SUB:
If ERR.Number = 2185 Then
strApp = Nz(Me.cmbAppName.Value, "")
Me.cmbAppName.SetFocus
Debug.Print "Using " & strApp
Resume Next
End If
Me.Filter = ""
Me.FilterOn = False
Debug.Print ErrorMessage(ERR.Description, "cmbAppName_Change", ERR.Number, "Value = '" & Me.cmbAppName.Value & "'", False)
Resume EXIT_SUB
End Sub ' cmbAppName_Change
As you can see from the error handling code, I'd often get an error 2185 telling me that my control didn't have focus when using the Text property despite having a SetFocus call right before it.
If somebody selects from the list (either by clicking or moving the selection), I'd like to go to that record, but I at least need the above piece working first.
After searching the Web, I found out that a Details section with zero records causes the 2185 error. Apparently, filtering like that causes problems when all records are filtered out.
The solutions on the Web said that you can set the Allow Additions property of the form to True, but that always displays one row in the Details section. This can be especially confusing if the rows in the Details section contain controls, which will be displayed in the "addition" row. Also, I would still get an error typing additional characters after the one that caused the Details section to have zero records.
Eventually, I replaced the combo box with a simple text control to filter the Details section. When the Details section has rows, I turn Allow Additions off and make the controls visible; when it doesn't have rows, I turn Allow Additions on and hide the controls.
Here's the code that I used:
Private Sub txtApplicationFilter_Change()
Dim strApp As String
Dim nSelStart As Integer
Dim nSelLen As Integer
Dim strFilter As String
Dim strQuery As String
Dim strWhere As String
Dim nRecs As Integer
On Error GoTo ERR_SUB
' Save text selection
nSelStart = Me.txtApplicationFilter.SelStart
nSelLen = Me.txtApplicationFilter.SelLength
' Get application name typed and selection information
strApp = Nz(Me.txtApplicationFilter.Text, "")
strFilter = "[" & DCApplications_Application_Col & "] LIKE '*" & EscapeQuotes(strApp) & "*'"
nRecs = DCount("[" & DCApplications_Application_Col & "]", LocalTableName(DCApplications_Tab), strFilter)
' Kludge code to prevent various errors (like 2185) when no records are returned in the form
Call UpdateList(nRecs)
' Update the record source to reflect the filtered list of apps
strWhere = " WHERE APPS." & strFilter
strQuery = strSelect & strFrom & strWhere & strOrderBy
Me.RecordSource = strQuery
' 20200423 SHM: Restore or update filter to avoid issues with Delete and Backspace and applications with spaces in their names
Me.txtApplicationFilter.SetFocus
Me.txtApplicationFilter = strApp
Me.txtApplicationFilter.SelStart = nSelStart
Me.txtApplicationFilter.SelLength = nSelLen
EXIT_SUB:
Me.btnAddNew.enabled = (Nz(Me.txtApplicationFilter, "") <> "")
Exit Sub
ERR_SUB:
' NOTE: ErrorMessage is a helper function that basically displays a form displaying the error
Call ErrorMessage(ERR.Description, "txtApplicationFilter_Change", ERR.Number, "Filter = " & strApp & " Records = " & nRecs)
Resume EXIT_SUB
Resume Next
End Sub ' txtApplicationFilter_Change
Private Sub UpdateList(nRecs As Integer)
Dim bShowControls As Boolean
On Error GoTo ERR_SUB
bShowControls = (nRecs > 0)
' Kludge code to turn off checkbox control source
If bShowControls Then
strSelect = strSelectStart & ", (" & strAppUser & ") AS " & strCtrlSource
Me.chkTestedByMe.ControlSource = strCtrlSource
Else
strSelect = strSelectStart
Me.chkTestedByMe.ControlSource = ""
End If
' Kludge code to prevent various errors (like 2185) when no records are returned in the form
' Turning on AllowAdditions prevents errors when no records are returned.
' However, that puts an empty row in the form, but the controls are showing, so we have to hide them to prevent confusing the user.
Me.AllowAdditions = Not bShowControls
Me.btnAddExisting.visible = bShowControls
Me.chkTestedByMe.visible = bShowControls
EXIT_SUB:
Exit Sub
ERR_SUB:
Call ErrorMessage(ERR.Description, "UpdateList", ERR.Number, " Records = " & nRecs)
Resume EXIT_SUB
Resume Next
End Sub ' UpdateList
I would use a work around to settle this issue
A simple code bellow demonstrate the work around using Tag property of Combo Box and keypress event along with change event, I hope it can be applied in your code
Private Sub Combo2_Change()
If Combo2.Tag = 1 Then
Text4 = "change - from key"
Else
Text4 = "change - from select"
End If
Combo2.Tag = 0
End Sub
Private Sub Combo2_KeyPress(KeyAscii As Integer)
Combo2.Tag = 1
End Sub
Don't forget to set Tag property of Combo Box to 0 on design view to avoid error at comparing empty Tag with number
The answer is probably really simple - I just can't come up with the right search term, I suspect.
I have a form that opens another form, displaying any employee record that matches the search as entered You can search by surname, given name, or employee ID (using separate buttons); it gives you a little message box if your search turns up nothing.
The code works fine, except for the usual problem with handling apostrophes in names ("O'Neill," "O'Brien," etc.) I found a really simple apostrophe handling function, but when I try to use the function in the search query it still throws up a 3075 runtime error, and I'm not sure why. It only throws up the runtime error with apostrophe-containing searches, so I feel like the function maybe isn't doing what I think it is.
I am happy to entertain solutions that involve "using this function but adding more quotation marks (or whatever)" as well as whole new ideas. I'd prefer to use something like this function, though, because it's so small and thus it'll be much faster and cleaner to replace the search-by-name code each place that it appears.
This is the code that works fine:
Private Sub btnSearchSurname_Click()
Dim frm As Form
Dim strSearch As String
strSearch = "[List_Employees.Surname] like '" & Me.EmpSurname & "*'"
strSearch = strSearch & " AND [CurrentEmployee] = " & True
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
Set frm = Forms("Employee_Entry_Extended_Certs")
If frm.Recordset.RecordCount > 0 Then
frm.Visible = True
Else
MsgBox ("Employee not found. Try the 'all' button to see if they're inactive. If that doesn't work, please check for typos and try again.")
DoCmd.Close acForm, "Employee_Entry_Extended_Certs"
Call OpenPayrollCloseRest
End If
DoCmd.Close acForm, "Find_An_Employee"
I'm trying to use this simple public function to handle apostrophes:
Public Function adhHandleQuotes(ByVal varValue As Variant, Optional Delimiter As String = "'") As Variant
' Replace all instances of a string delimiter with TWO instances,
' thereby handling the darned quote issue once and for all. Also,
' surround the string with the delimiter, as well.
' Returns Null if the String was Null, otherwise
' returns the String with all instances of strDelimiter
' replaced with two of each.
adhHandleQuotes = strDelimiter & Replace(varValue, strDelimiter, strDelimiter & strDelimiter) & strDelimiter
End Function
I modified the search code to use the function by inserting three lines lines in place of the first "strSearch = " line:
Dim strSearch As String
Dim strTerm As String
strTerm = adhHandleQuotes(Me.EmpSurname)
strSearch = "[List_Employees.Surname] like '" & strTerm & "*'"
strSearch = strSearch & " AND [CurrentEmployee] = " & True
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
And this is the runtime error dialogue box:
Why do you even need a function? Just simply incorporate a Double Quotes, my hack is to use Chr(34).
Private Sub btnSearchSurname_Click()
Dim frm As Form
Dim strSearch As String
strSearch = "[List_Employees.Surname] Like " & Chr(34) & Me.EmpSurname & "*" & Chr(34)
strSearch = strSearch & " AND [CurrentEmployee] = True"
DoCmd.OpenForm "Employee_Entry_Extended_Certs", , , strSearch, , acHidden
Set frm = Forms("Employee_Entry_Extended_Certs")
If frm.Recordset.RecordCount > 0 Then
frm.Visible = True
Else
MsgBox ("Employee not found. Try the 'all' button to see if they're inactive. If that doesn't work, please check for typos and try again.")
DoCmd.Close acForm, "Employee_Entry_Extended_Certs"
Call OpenPayrollCloseRest
End If
DoCmd.Close acForm, "Find_An_Employee"
End Sub
You might want to try this:
Access VBA, unescaped single quotes, Replace(), and null
Rather than doubling your apostrophe, it surrounds it with double quotes.
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.....
I need to remove line breaks from the beginning of a memo type records. I dont want to use the replace function as it would remove all line breaks from the record which is not desired. Its only the line breaks at the beginning of the field that I am interested in removing.
Furthermore, the my records do not always begin with a line break so I cant really use text positioning, the solution would be to look for line break at the beginning instead of always expecting it at the beginning.
If Len(string) > 0 Then
Do While Left(string,1)= chr(13) Or Left(string,1)= chr(10) or Left(string,1) = " "
string = Right(string, len(string)-1)
Loop
End If
This will check to make sure the string isn't empty, then runs a simple loop to remove the left-most character as long as it is either a CR (chr(13)), LF (chr(10)), or a space (" ").
Once the loop hits the first character that doesn't match the criteria, it stops and you have the desired result of trimming all extra CR, LF, and space characters only from the beginning of the string.
Since it's relatively short, I just put it in the event procedure where needed, you could also modify it to be a public function in a module if you see fit.
Replace does not replace all occurences when you use the count argument: http://office.microsoft.com/en-us/access/HA012288981033.aspx
You can test it like so:
s1 = vbCrLf & "abc"
s2 = "ab" & vbCrLf & "c"
MsgBox "---" & IIf(Left(s1, 2) = vbCrLf, Replace(s1, vbCrLf, "", , 1), s1)
MsgBox "---" & IIf(Left(s2, 2) = vbCrLf, Replace(s2, vbCrLf, "", , 1), s2)
Improving upon what SBinVA wrote
The following code does not need the if statement and it is easy to expand to more character (space, tabs, etc.).
(It also assumes line breaks can originate from a file that can comes from other systems, so vbCr and vbLf are used separately, which takes care of all scenarios.)
Public Function trimCrOrLf(ByVal s As String) As String
Dim firstChar As String
firstChar = Left(s, 1)
Do While InStr(vbCr & vbLf, firstChar) > 0
s = Mid(s, 2)
firstChar = Left(s, 1)
Loop
trimCrOrLf = s
End Function
Consider a SQL UPDATE statement to discard only those CRLF at the beginning of each memo field.
UPDATE MyTable SET MyTable.memo_field = Mid([memo_field],3)
WHERE (((MyTable.memo_field) Like Chr(13) & Chr(10) & "*"));
Private Sub TestLineFeed()
Dim strString$, strTestChar, booStartsWith_CR As Boolean
strString = Chr$(13) & "some text"
strTestChar = "2"
'strTestChar = Chr$(13) ''This is a CR.
booStartsWith_CR = (Left(strString, 1) = strTestChar)
Debug.Print "-----"
Debug.Print "Raw: " & strString
Debug.Print booStartsWith_CR
If booStartsWith_CR Then
strString = Mid(strString, 2, 100)
End If
Debug.Print "-----"
Debug.Print "New: " & strString
End Sub
Note alternatives for strTestChar so you can see the action. You should notice "-----" in your Immediate Window is followed by a CR, thus a blank line; and this can be removed. Mid(strString, 2, 100) will need some tweaking, but the idea is to copy over your memo string without the first character.
I would use a function like this. It's fairly straight-forward and easily adapted to other circumstances. For example, to remove leading spaces too, add another test to the if (c = vbCr) line.
Function LTrimCRLF(s As String) As String
Dim index As Integer, start As Integer, strLen As Integer
Dim c As String
strLen = Len(s)
index = 1
start = -1
Do While (index <= strLen) And (start = -1)
c = Mid(s, index, 1)
If (c = vbCr) Or (c = vbLf) Then
index = index + 1
Else
start = index
End If
Loop
If start = -1 Then
LTrimCRLF = ""
Else
LTrimCRLF = Mid(s, start)
End If
End Function
Here's a test routine:
Sub TestLTrimCRLF()
Dim withWS As String, noWS As String, blank As String, onlyWS As String
withWS = vbCrLf & " this string has leading white space"
noWS = "this string has no leading white space"
onlyWS = vbCrLf & " " & vbCrLf & " "
blank = ""
Say "with WS: {" & LTrimCRLF(withWS) & "}"
Say "no WS: {" & LTrimCRLF(noWS) & "}"
Say "only WS: {" & LTrimCRLF(onlyWS) & "}"
Say "blank: {" & LTrimCRLF(blank) & "}"
End Sub
BTW, I tried looking at your sample data, but it says the document is not available. Maybe you need to make it public or something?
My contribution to VBA trimwhitespace() function, loop finds for first non-whitespace index, splits a string, then same thing for trailing whitespaces. Left+Right functions are run only once. If you need just leftTrim or rightTrim it's easy to introduce new arguments or separate functions.
Function trimWhitespace(str As String) As String
Dim idx As Long
Dim ch As String
' LeftTrim
If Len(str) > 0 Then
idx = 1
ch = Mid(str, idx, 1)
Do While ch = Chr(13) Or ch = Chr(10) Or ch = " "
idx = idx + 1
ch = Mid(str, idx, 1)
Loop
If (idx > 1) Then str = Right(str, Len(str) - idx)
End If
' RightTrim
idx = Len(str)
If idx > 0 Then
ch = Mid(str, idx, 1)
Do While ch = Chr(13) Or ch = Chr(10) Or ch = " "
idx = idx - 1
ch = Mid(str, idx, 1)
Loop
If (idx < Len(str)) Then str = Left(str, idx)
End If
trimWhitespace = str
End Function
This will trim all leading and trailing spaces, carriage returns, tabs, and other non-printable characters.
Public Function TrimSpecial(InputString As Variant) As String
' This will trim leading/trailing spaces and non-printable characters from the passed string.
Dim i As Integer
Dim str As String
On Error GoTo ErrorHandler
str = InputString
For i = 1 To Len(str)
If Asc(Mid(str, i, 1)) > 32 And Asc(Mid(str, i, 1)) < 127 Then
' Valid character found. Truncate leading characters before this.
str = Mid(str, i)
Exit For
End If
Next i
For i = Len(str) To 1 Step -1
If Asc(Mid(str, i, 1)) > 32 And Asc(Mid(str, i, 1)) < 127 Then
' Valid character found. Truncate trailing characters after this.
str = Mid(str, 1, i)
Exit For
End If
Next i
TrimSpecial = str
Exit_Function:
Exit Function
ErrorHandler:
MsgBox "Error #" & Err.Number & " - " & Err.Description & vbCrLf & "in procedure TrimSpecial"
GoTo Exit_Function
Resume Next
Resume
End Function
You can use this routine to test it:
Public Sub Test_TrimSpecial()
' Run this to test the TrimSpecial function.
Dim x As String
x = vbCrLf & " " & vbTab & " ab cd" & vbCrLf & vbTab & " xyz " & vbCr & vbCrLf
Debug.Print "-----"
Debug.Print ">" & x & "<"
Debug.Print "-----"
Debug.Print ">" & TrimSpecial(x) & "<"
Debug.Print "-----"
End Sub
Like "*" & Chr(13) & Chr(10)
(Access used carriage return + line feed, characters 13 and 10, for a new line).
To remove the carriage return/line feed, change the query to an update query and enter the following in the Update to line:
Replace([FieldName], Chr(13) & Chr(10), "")
or
Replace([FieldName], Chr(10),"")
Replace([FieldName], Chr(13),"")