Compile error: Constant expression required - vba

I've stumbled upon a compile error, but don't get what can be of the issue. When trying to chagne the symbol to an input variable ( TickerID ) I get the error, works perfectly fine otherwise when inputting e.g "yhoo" for the yahoo ticker name.
Code
Private Sub CmdBtn_Add_Click()
'---------------------------------------------------------------------------------------'
' Checks that inputted ticker name is correct and calls import class after confirmation
'---------------------------------------------------------------------------------------'
' General Variables---------'
Dim TickerID As String: TickerID = UCase(Add_Instrument.TxtBox_Instrument.Value)
'--------------------------'
'Check if input field is not empty
If TickerID = "" Or Application.WorksheetFunction.IsText(TickerID) = False Then
MsgBox "Please provide a valid ticker ID"
Exit Sub
End If
Debug.Print TickerID
'Check Ticker name exists through YQLBuilder class
Dim YQLBuilder As YQLBuilder: Set YQLBuilder = New YQLBuilder
Call YQLBuilder.TickerCheck(TickerID)
' Call ImportData(TickerID)
' MsgBox "Please check the ticker name. It is in the wrong format"
End Sub
Public Sub TickerCheck(TickerID As String)
'---------------------------------------------------------------------------------------'
' Built 2014-11-05 Allows parsing of XML data through YAHOO API YQL
' 2014-12-21: Not fully built yet, see where it can be of use
'---------------------------------------------------------------------------------------'
' General Variables---------'
Const ConnStringStart As String = "http://query.yahooapis.com/v1/public/yql?q="
Const ConnStringLast As String = "&diagnostics=true&env=store://datatables.org/alltableswithkeys"
'---------------------------'
Const ConnStringInput As String = "select * from yahoo.finance.stocks where symbol='" _
& TickerID & "'" **<----- Error here!**
Debug.Print ConnStringStart & ConnStringInput & ConnStringLast
Dim YQLNodes As MSXML2.IXMLDOMNodeList
Dim YQLReq As MSXML2.DOMDocument60
Set YQLReq = New MSXML2.DOMDocument60
YQLReq.async = False
YQLReq.Load ConnStringStart & ConnStringInput & ConnStringLast
YQLReq.setProperty "SelectionNamespaces", "xmlns:f='http://www.yahooapis.com/v1/base.rng'"
Set YQLNodes = YQLReq.SelectNodes("//CompanyName")
Dim xNode As MSXML2.IXMLDOMNode
For Each xNode In YQLNodes
Debug.Print xNode.Text
Next xNode
Debug.Print YQLNodes.Length
End Sub

The message is clear. When you declare a constant, the value you give it must be constant too. In this case, part of it is the parameter TickerId, which is variable. You cannot declare a constant with a variable value.
To solve this, I think you could just use Dim instead of Const and not make ConnStringInput a constant at all.

Related

VBA using ahtCommonOpenFileSave with ahtOFN_ALLOWMULTISELECT, error when selecting single file

Maybe I'm overlooking the obvious, but I cant figure out how to deal with a single result in an array.
I'm using Ken Getz ahtCommonFileOpenSave API in VBA to enable selecting multiple files, using the following code.
Private Sub btn_openfiles_Click()
Dim strFilter As String
Dim strInputFileName As String
Dim strFiles() As String
Dim a As Long
strFilter = ahtAddFilterItem(strFilter, "Images (*.PNG)", "*.PNG")
strFiles = ahtCommonFileOpenSave( _
Filter:=strFilter, _
OpenFile:=True, _
InitialDir:="T:\DTP\Programs\Default\", _
DialogTitle:="Please select an input file...", _
Flags:=ahtOFN_EXPLORER + ahtOFN_ALLOWMULTISELECT)
If IsArray(strFiles) Then
For a = 0 To UBound(strFiles)
Me.test_filenames = Me.test_filenames & strFiles(a) & vbCrLf
Next a
Else
Me.test_filenames = strFiles
End If
End Sub
I know that the result is an array, because I'm setting the ahtOFN_ALLOWMULTISELECT flag. When multiple files are selected, this goes well. But if only one file is selected, an
error 13 is thrown (type mismatch on strFiles)
because the return value of ahtCommonFileOpenSave is not an array.
I may be able to force an Array type just by adding a dummy value to the array produced by ahtCommonFileOpenSave and disregard this when processing the file names in the form, but maybe there is a better solution. Anyone have a suggestion?
As I already mentioned, overlooking the obvious. Changing the variable type into variant did the trick . ahtComminFileOpenSave returns the complete array when multiple files are selected and is always a Variant type. Luuk's suggestion works too (a variant type is used by default when the variable type is omitted).
The corrected (and amended) code is like this and works like a charm!
Private Sub btn_openfiles_Click()
Dim strFilter As String
Dim strInputFileName As String
Dim varFiles As Variant
Dim a As Long
strFilter = ahtAddFilterItem(strFilter, "Images (*.PNG)", "*.PNG")
Me.test_filenames = ""
varFiles = ahtCommonFileOpenSave( _
Filter:=strFilter, _
OpenFile:=True, _
InitialDir:="T:\DTP\Programs\Default\", _
DialogTitle:="Please select an input file...", _
Flags:=ahtOFN_EXPLORER + ahtOFN_ALLOWMULTISELECT)
If IsArray(varFiles) Then
For a = 0 To UBound(varFiles)
Me.test_filenames = Me.test_filenames & varFiles(a) & vbCrLf
Next a
Else
Me.test_filenames = varFiles
End If
End Sub

How to create an VBA function in Access to replace any special character in table

We import XML files into an Access database. This data includes a description column which can contain special characters like ä é etc. We use this database to export a table to our Financial programm. This programm can't handle these special characters. Therefore I would like to make a VBA function that can replace any special character within a specific table/colomn.
I am fairly new to using VBA, so I used Google a lot to try to find some background about this topic. I have found this code for Excel, and think this can be used in Access as well. However, I can't make the connection with the Update table function.
Function RemovePunctuation(Txt As String) As String
With CreateObject("VBScript.RegExp")
.Pattern = "[^A-Z0-9 ]"
.IgnoreCase = True
.Global = True
RemovePunctuation = .Replace(Txt, "")
End With
End Function
The Function above (RemovePunctuation) works with the Query in Access and returns a list with the values of the original table without any punctuation. I used the following Query:
SELECT RemovePunctuation([ColumnName]) AS [Add]
FROM TableName;
However, this returns a new table instead of replacing the values in the original table. Can information be shared on a different Query which uses the function to update originale table?
Cause I'm really new to this, I can't show much. I would expect the code to look like:
Function UpdateTable(Table As String, Column As String) As String
Update Table Set Column =
With CreateObject("VBScript.RegExp")
.Pattern = "[^A-Z0-9 ]"
.IgnoreCase = True
.Global = True
RemovePunctuation = .Replace(Txt, "")
End With
End Function
But this returns nothing.
Expected result should be returning spaces where special characters are in column selected.
As mentioned, code returns nothing so far as this isn't a valid function at all. Please advise.
In case the xml file is not linked, but indeed imported, you have full control of the imported data. You could create an additional table, where you have a field 'TableName' for each xml file, a field 'FieldName' for each column, a field 'CharIn' for each special character to validate and a field 'CharOut' for the replacing character. Then build code to walk through the imported data, and then search and replace based upon your new additional table. Replace is a default function, but you could write your own, something like
Function ReplaceString(strCaller As String, memText As Variant, strSearch As String, strReplace As String) As Variant
'Define variables
Dim dblPos As Double 'pointer in text
'Walk through the text, search and replace
dblPos = InStr(memText, strSearch)
Do While dblPos > 0
If Asc(strSearch) = Asc(Mid$(memText, dblPos, 1)) Then
memText = Left$(memText, dblPos - 1) + strReplace + Mid$(memText, dblPos + Len(strSearch))
dblPos = Abs(dblPos - Len(strSearch))
End If
dblPos = InStr(dblPos + 1, memText, strSearch)
Loop
ReplaceString = memText
Based on code provided by #jeroen jong, the question is answered. Provided code to replace special characters in any given table in Access is the following:
One module is made with the following code:
Option Compare Database
Option Explicit
Private Const strObject As String = "modConversion"
Function ReplaceString(strCaller As String, memText As Variant, strSearch As String,
strReplace As String) As Variant
On Error GoTo Err_Function
'Define variables
Dim strProcedure As String 'name of current procedure
Dim dblPos As Double 'pointer in text
'Initialise variables
strProcedure = "ReplaceString"
'Walk through the text, search and replace
dblPos = InStr(memText, strSearch)
Do While dblPos > 0
If Asc(strSearch) = Asc(Mid$(memText, dblPos, 1)) Then
memText = Left$(memText, dblPos - 1) + strReplace + Mid$(memText, dblPos + Len(strSearch))
dblPos = Abs(dblPos - Len(strSearch))
End If
dblPos = InStr(dblPos + 1, memText, strSearch)
Loop
ReplaceString = memText
Exit_Function:
Exit Function
Err_Function:
MsgBox Err.Number, Err.Description, Err.Source, strObject, strProcedure
ReplaceString = memText
Resume Exit_Function
End Function
One function is created the call the ReplaceString function. In this case it is called from a Form with a button:
Option Compare Database
Option Explicit
Private Const strObject As String = "frmReplace"
Private Sub cmdReplace_Click()
On Error GoTo Err_Sub
'Define variables
Dim strProcedure As String 'name of current procedure
Dim dbs As DAO.Database
Dim rsTable As DAO.Recordset
Dim rsReplace As DAO.Recordset
Dim strFieldName As String
'Initialise variables
strProcedure = "cmdReplace_Click"
'Initialise database and recordset
Set dbs = CurrentDb
Set rsReplace = dbs.OpenRecordset("tblReplace", dbReadOnly)
With rsReplace
Do While Not .EOF
'Open table
Set rsTable = dbs.OpenRecordset(!TableName, dbOpenDynaset)
'Walk through all records, and replace char in field
Do While Not rsTable.EOF
rsTable.Edit
rsTable(!FieldName) = ReplaceString(strProcedure, rsTable(!FieldName), !TextSearch, !TextReplace)
rsTable.Update
rsTable.MoveNext
Loop 'rsTable
.MoveNext
rsTable.Close
Loop 'rsReplace
.Close
End With
MsgBox "Replacement of special characters is completed", vbInformation, "Replace"
Exit_Sub:
On Error Resume Next
rsTable.Close
Set rsTable = Nothing
rsReplace.Close
Set rsReplace = Nothing
dbs.Close
Set dbs = Nothing
Exit Sub
Err_Sub:
MsgBox Err.Number & " - " & vbLf & Err.Description & " - " & vbLf & Err.Source, vbCritical, strObject & "-" & strProcedure
Resume Exit_Sub
End Sub
The table to provide data to search and replace consists of the following columns:
Id As Id;
TableName As String;
FieldName As String;
Replace As Boolean;
TextSearch As String;
TextReplace As String;
CaseSensitive As Boolean;
Again thanks for solving my question!

VBA Handling multiple custom datatype possibilities

I have done some research and haven't found any similar question.
I have a VBA macro that imports a .CSV file containing telegrams sent by a device.
In the end of this macro, I want to create a graph with the time elapsed on the x-axis and the value corresponding to the telegram.
The issue is that this value can be of different types: hexadecimal, boolean, integer... And that they don't respect the standard Excel number format, which means that they can't be used to create a graph.
Here are some examples (with " around the value to show its start and end) :
hexadecimal : "A7 C8"
Boolean : "$00" or ""$01"
Percentage : "$30"
And here is an example of data, with custom time format and boolean value
Here is my related code so far, where I try to convert into a custom type then convert back to numeric to get a common number datatype :
If wsRes.Range("R1").Value Like "$##" Then
wsRes.Range("R1:R" & plotLine).NumberFormat = "$##"
wsRes.Range("R1:R" & plotLine).NumberFormat = General
End If
If wsRes.Range("R1").Value Like "??[ ]??" Then
Dim valArray(1) As String
For i = 1 To plotLine Step 1
valArray = Split(wsRes.Range("R" & i), " ")
wsRes.Range("R" & i).Value = ToInt32(valArray(0) + valArray(1), 16)
wsRes.Range("" & i).NumberFormat = General
Next i
End If
I haven't been able to test it with hexa yet, but the conversion trick doesn't work with percentage/boolean
EDIT :
First, thank you for your answers.
Here is my final code for anyone's interested, adapted from Vityata's.
This method will allow to easily add other datatypes if needed.
Sub TestMe()
Dim RangeData as String
Set wsRes = ActiveWorkbook.Sheets("Results")
For i = 1 To plotLine Step 1 'plotLine is the last line on which I have data
DetectType wsRes.Range("R" & i).Value, i
Next i
RangeData = "Q1:R" & plotLine
CreateGraph RangeData 'Call My sub creating the graph
End Sub
Public Sub DetectType(str As String, i As Integer)
Select Case True
Case wsRes.Range("R" & i).Value Like "??[ ]??"
wsRes.Range("R" & i).Value = HexValue(str)
Case wsRes.Range("R" & i).Value Like "?##"
wsRes.Range("R" & i).Value = DecValue(str)
Case Else
MsgBox "Unsupported datatype detected : " & str
End
End Select
End Sub
Public Function HexValue(str As String) As Long
Dim valArray(1) As String 'Needed as I have a space in the middle that prevents direct conversion
valArray(0) = Split(str, " ")(0)
valArray(1) = Split(str, " ")(1)
HexValue = CLng("&H" & valArray(0) + valArray(1))
End Function
Public Function DecValue(str As String) As Long
DecValue = Right(str, 2)
End Function
You need three boolean functions, following your business logic and some of the Clean Code principles (although the author of the book does not recognize VBA people as programmers):
IsHex()
IsBoolean()
IsPercentage()
Public Sub TestMe()
Dim myInput As Variant
myInput = Array("A7C8", "$01", "$30")
Dim i As Long
For i = LBound(myInput) To UBound(myInput)
Debug.Print IsHex(myInput(i))
Debug.Print IsBoolean(myInput(i))
Debug.Print IsPercentage(myInput(i))
Debug.Print "-------------"
Next i
'or use this with the DetectType() function below:
'For i = LBound(myInput) To UBound(myInput)
' Debug.Print DetectType(myInput(i))
'Next i
End Sub
Public Function IsHex(ByVal str As String) As Boolean
On Error GoTo IsHex_Error
IsHex = (WorksheetFunction.Hex2Dec(str) <> vbNullString)
On Error GoTo 0
Exit Function
IsHex_Error:
End Function
Public Function IsBoolean(ByVal str As String) As Boolean
IsBoolean = CBool((str = "$00") Or (str = "$01"))
End Function
Public Function IsPercentage(ByVal str As String) As Boolean
IsPercentage = (Len(str) = 3 And Left(str, 1) = "$" And IsNumeric(Right(str, 2)))
End Function
Then some additional logic is needed, because $01 is both Boolean and Percentage. In this case, you can consider it Percentage. This is some kind of a mapper, following this business logic:
Public Function DetectType(str) As String
Select Case True
Case IsHex(str)
DetectType = "HEX!"
Case IsPercentage(str) And IsBoolean(str)
DetectType = "Boolean!"
Case IsPercentage(str)
DetectType = "Percentage!"
Case Else
DetectType = "ELSE!"
End Select
End Function

Access variables and their names from the current scope

Is it possible to:
Access a list of all variables in a VBA runtime environment?
Access the name of a variable with VBA?
Example:
function v2S(str as string) as string
For each variable in Variables
dim I as integer
for I = 1 to 10
v2S = replace(v2S,"%" & variable.name & "%", variable.value)
next
next
end function
Example use case:
Dim skyColor as string
skyColor = "green"
Debug.Print v2S("The sky is %skyColor% today!")
There is an application I can send commands to via a com object and I wish to do something along the lines of:
Dim i a integer
for i = 1 to MI.Eval("numtables()")
MI = GetObject(,"MapInfo.Application.x64")
debug.print MI.Eval(v2S("tableinfo(%i%,1)")) ' Print name of table
next
The above looks much cleaner than:
Dim i a integer
for i = 1 to MI.Eval("numtables()")
MI = GetObject(,"MapInfo.Application.x64")
debug.print MI.Eval(v2S("tableinfo(" & i & ",1)")) ' Print name of table
next
But of course if it were possible I would want it to be general which may be difficult...
For my own use case this is pretty good.
However it still isn't very readable. This is another option. It's more readable but also more cluttered:
Sub Main()
Dim Vars as object, myString as string
set Vars = CreateObject("scripting.Dictionary")
Vars.add "Var1","Val1"
Vars.add "Var2","Val2"
'...
myString = r("Var1: #{Var1} and Var2: #{Var2}", Vars)
End Sub
function r(byval s as string, byval o as object) as string
for each key in o.keys
s = replace(s,"#{" & key & "}",o.item(key))
next
r = s
end function
I wish string interpolation functionality existed by default in VBA.

Calling excel's function.ets from Access VBA

I'm trying to call excel's FORECAST.ETS from VBA in my access project but it seems like no matter what I do I get this error:
"VBA Error 1004 Invalid number of arguments."
Here's what I'm doing -
'**********************************************
Public Sub testFCsof()
Dim testrfXL As Object
Dim testrfNowDate As Date
Dim testrfempSQLStr As String
Dim testrfempSQLRS As DAO.Recordset
Dim testrfRecNo As Integer
Dim testrfDateARRAY() As Date
Dim testrfPointsARRAY() As Double
Dim testrfFDFCAST As Double
Dim fdtestempID As Long
On Error GoTo Err_testrfNBA
Set todaysDB = CurrentDb()
fdtestempID = 382
testrfFDFCAST = 1000000
testrfempSQLStr = "SELECT NBAFANempPER.eventTime, NBAFANempPER.FDpoints " & _
"FROM NBAFANempPER WHERE ((NBAFANempPER.empID)= " & fdtestempID & ") ORDER BY NBAFANempPER.eventTime;"
Set testrfempSQLRS = todaysDB.OpenRecordset(testrfempSQLStr, dbOpenDynaset, dbSeeChanges, dbReadOnly)
If Not (testrfempSQLRS.BOF And testrfempSQLRS.EOF) Then 'only do this if we have records
testrfempSQLRS.MoveLast
ReDim testrfDateARRAY(testrfempSQLRS.RecordCount - 1)
ReDim testrfPointsARRAY(testrfempSQLRS.RecordCount - 1)
testrfempSQLRS.MoveFirst
testrfRecNo = 0
Do While Not testrfempSQLRS.EOF
testrfDateARRAY(testrfRecNo) = CDate(dateHeadFunk(CDate(testrfempSQLRS!eventTime)))
testrfPointsARRAY(testrfRecNo) = CDbl(testrfempSQLRS!FDpoints)
testrfRecNo = testrfRecNo + 1
testrfempSQLRS.MoveNext
Loop
Set testrfXL = CreateObject("Excel.Application")
testrfNowDate = Now()
testrfFDFCAST = testrfXL.WorksheetFunction.Forecast.ets(Arg1:=testrfNowDate, Arg2:=testrfPointsARRAY, Arg3:=testrfDateARRAY, Arg4:=0, Arg5:=1, Arg6:=5)
Set testrfXL = Nothing
End If
Exit_testrfNBA:
Erase testrfPointsARRAY
Erase testrfDateARRAY
testrfNowDate = Empty
testrfempSQLStr = ""
If Not testrfempSQLRS Is Nothing Then
testrfempSQLRS.Close
Set testrfempSQLRS = Nothing
End If
Exit Sub
Err_testrfNBA:
MsgBox "Got a sucky forecast number back.."
generic.TestODBCErr
Resume Exit_testrfNBA
End Sub
'**********************************************
The arrays fill up just fine, both the same size.
I can call other Excel functions without a problem.
Can't figure out what the problem could be. I've tried this with and without the "Arg=" tags, with and without the last three optional arguments, tried wrapping the arrays with Array(myArray), even set the Arrays to Variant.
At least in Excel VBA, the function name is Forecast_ETS, not Forecast.ETS.