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
Related
I am using a mySql server connection to get table data into excel. I have a total of three queries, two of which work perfectly and are copied correctly from copyFromRecordSet. However, the third query does not work correctly when I use copyFromRecordset. It gets two of the columns I want, but leaves off the next five. The query works correctly when I use it in a database GUI so that is not the issue.
I am trying to use an alternative to copyFromRecordSet, a piece of code which I altered from https://support.microsoft.com/en-us/help/246335/how-to-transfer-data-from-an-ado-recordset-to-excel-with-automation.
'Open and copy the recordset to an array to allow for copying into worksheet
RS.Open PriceChangeQuery
recArray = RS.GetRows
recCount = UBound(recArray, 2) + 1 '+1 since the array is zero-based
fldCount = RS.Fields.Count
' Check the array for contents that are not valid when
' copying the array to an Excel worksheet
For iCol = 0 To fldCount - 1
For iRow = 0 To recCount - 1
' Take care of Date fields
If IsDate(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = Format(recArray(iCol, iRow))
' Take care of OLE object fields or array fields
ElseIf IsArray(recArray(iCol, iRow)) Then
recArray(iCol, iRow) = "Array Field"
End If
Next iRow 'next record
Next iCol 'next field
'Transpose and copy the array to the worksheet,
'starting in cell A2
CompareFile.Sheets("VendorFilteredPriceChangeReport").Cells(2, 1).Resize(recCount, fldCount).Value = TransposeDim(recArray)
'CompareFile.Sheets("VendorFilteredPriceChangeReport").Range("A2").CopyFromRecordset RS
'Close ADO objects
RS.Close
And this is the TransposeDim function.
Function TransposeDim(v As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)
Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
Xupper = UBound(v, 2)
Yupper = UBound(v, 1)
ReDim tempArray(Xupper, Yupper)
For X = 0 To Xupper
For Y = 0 To Yupper
tempArray(X, Y) = v(Y, X)
Next Y
Next X
TransposeDim = tempArray
End Function
However, when I run this piece of code the query is again leaving off the last five columns.
Any insights as to how to fix this piece of code or insights as to why copyFromRecordSet would be behaving strangely would be appreciated
In order to access some records properly, a recordSet's cursor must be set to client side. I was able to do this by using:
RS.CursorLocation = adUseClient in my code, right after opening the recordset using my query. I was then able to copy the data from the recordset using only CompareFile.Sheets("VendorFilteredPriceChangeReport").Range("A2").CopyFromRecordset RS and I got the correct data in my workbook.
I have been trying to get the path to a linked table. I am looping thru the tables. it works one the first loop but not on the 2nd loop. it returns "".
Ive tried several different ways, calling the table by name or by number. the code originally comes from Neville Turbit. Neville's code calls the table by name, but I could not get that to work.
Public Function GetLinkedDBName(TableName As String)
Dim tblTable As TableDef
Dim strReturn As String
Dim i As Integer
On Error GoTo Error_NoTable ' Handles table not found
'---------------------------------------------------------------
'
i = 0
On Error GoTo Error_GetLinkedDBName ' Normal error handling
For Each tblTable In db.TableDefs
If tblTable.Name = TableName Then
strReturn = tblTable.Connect
strReturn = db.TableDefs(i).Connect
Exit For
End If
i = i + 1
Next tblTable
You don't need a loop:
Public Function GetLinkedDBName(TableName As String) As String
Dim strReturn As String
On Error Resume Next ' Handles table not found
strReturn = CurrentDb.TableDefs(TableName).Connect
GetLinkedDBName = strReturn
End Function
This is my modification from Gustav's.
CurrentDb.TableDefs(TableName).Connect command will returns a string like this:
"MS Access;PWD=p455w0rd;DATABASE=D:\Database\MyDatabase.accdb"
The string above contains 3 information and parted by ";" char.
You need to split this information and iterate through it to get specific one which contain database path.
I am not sure if different version of ms access will return exact elements and with exact order of information in return string. So i compare the first 9 character with "DATABASE=" to get the index of array returns by Split command and get path name from it.
Public Function getLinkedDBName(TableName As String) As String
Dim infos, info, i As Integer 'infos and info declared as Variant
i = -1
On Error Resume Next ' Handles table not found
'split into infos array
infos = Split(CurrentDb.TableDefs(TableName).Connect, ";")
'iterate through infos to get index of array (i)
For Each info In infos
i = i + 1
If StrComp(Left(info, 9), "DATABASE=") = 0 Then Exit For
Next info
'get path name from array value and return the path name
getLinkedDBName = Right(infos(i), Len(infos(i)) - 9)
End Function
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?
Is there a way of taking html code for a table and printing out the same table in a word document using VBA (VBA should be able to parse the html code block for a table)?
It is possible to take the contents of the table and copy them into a new table created in Word, however is it possible to recreate a table using the html code and vba?
For any of this, where can one begin to research?
EDIT:
Thanks to R3uK: here is the first portion of the VBA script which reads a line of html code from a file and uses R3uK's code to print it to the excel worksheet:
Private Sub button1_Click()
Dim the_string As String
the_string = Trim(ImportTextFile("path\to\file.txt"))
' still working on removing new line characters
Call PrintHTML_Table(the_string)
End Sub
Public Function ImportTextFile(strFile As String) As String
' http://mrspreadsheets.com/1/post/2013/09/vba-code-snippet-22-read-entire-text-file-into-string-variable.html
Open strFile For Input As #1
ImportTextFile = Input$(LOF(1), 1)
Close #1
End Function
' Insert R3uK's portion of the code here
This could be a good place to start, you will only need to check content after to see if there is any problem and then copy it to word.
Sub PrintHTML_Table(ByVal StrTable as String)
Dim TA()
Dim Table_String as String
Table_String = " " & StrTable & " "
TA = SplitTo2DArray(Table_String, "</tr>", "</td>")
For i = LBound(TA, 1) To UBound(TA, 1)
For j = LBound(TA, 2) To UBound(TA, 2)
ActiveSheet.Cells(i + 1, j + 1) = Trim(Replace(Replace(TA(i, j), "<td>", ""), "<tr>", ""))
Next j
Next i
End Sub
Public Function SplitTo2DArray(ByRef StringToSplit As String, ByRef RowSep As String, ByRef ColSep As String) As String()
Dim Rows As Variant
Dim rowNb As Long
Dim Columns() As Variant
Dim i As Long
Dim maxlineNb As Long
Dim lineNb As Long
Dim asCells() As String
Dim j As Long
' Split up the table value by rows, get the number of rows, and dim a new array of Variants.
Rows = Split(StringToSplit, RowSep)
rowNb = UBound(Rows)
ReDim Columns(0 To rowNb)
' Iterate through each row, and split it into columns. Find the maximum number of columns.
maxlineNb = 0
For i = 0 To rowNb
Columns(i) = Split(Rows(i), ColSep)
lineNb = UBound(Columns(i))
If lineNb > maxlineNb Then
maxlineNb = lineNb
End If
Next i
' Create a 2D string array to contain the data in <Columns>.
ReDim asCells(0 To maxlineNb, 0 To rowNb)
' Copy all the data from Columns() to asCells().
For i = 0 To rowNb
For j = 0 To UBound(Columns(i))
asCells(j, i) = Columns(i)(j)
Next j
Next i
SplitTo2DArray = asCells()
End Function
I am seeing a strange situation when a function takes a column of field values from an Access table and put those in a VBA collection and returns the collection. The function takes a table name and field name as arguments and returns a collection with all (or unique) values in the column of fields. When a sub runs this function, the sub can read out a count of elements in the resulting collection. However, when the sub tries to access the elements errors results.
I say “errors” because I get a different error when I try to access elements in different ways. For example if I try to access a collection element via the key:
For i=0 to col.count
Debug.Print col(Cstr(i)) ' results in error: "Automation error"
i=i+1
Next
I get an “Automation Error.” But when I try to access collection elements via For Each
For Each var in col
Debug.Print var ' results in error: "Object invalid or no longer set."
Next
What is also strange is that the elements of the collection can be accessed within the function that will be returning it, but not once the collection is returned to the calling sub. But the calling sub can access the collection count.
The same approach with Access tables works fine to put a column of field values into an array. After the function returns an array of a column of field values, the array can be converted to a collection. The resulting collection can be passed to and used in another sub. But the method does not work to have a function get info from Access, pack it into a collection and return the collection with info from Access to the calling sub.
My code is below. I've tried but could not find any even remotely related questions.
Option Compare Database
Option Explicit
Sub colUniqueTableValues_tester()
Dim col As New Collection
Dim var As Variant
Dim i As Integer
Dim strTable As String: strTable = "tbl_Projects"
Dim strField As String: strField = "Project_Code"
Set col = colUniqueTableValues(strTable, strField)
Debug.Print "colListOfUniqueValues_tester: col.count = " + CStr(col.Count)
' Set col = colAnyLengthAndStep(4, 1) ' sub will complete if the collection from Access is overwritten
i = 0
For Each var In col
i = i + 1
Debug.Print CStr(i) + ": " + col(CStr(i)) ' results in error: "Automation error"
Debug.Print var ' returns error: "Object invalid or no longer set."
Next
Set col = Nothing
End Sub
Function colUniqueTableValues(ByVal strTable As String, ByVal strField As String) As Collection
Dim strSQL As String
Dim rs As Recordset
Dim dbs As Database
Dim i As Integer
Dim col As New Collection
strSQL = "Select distinct " + strField + " from " + strTable
Set dbs = CurrentDb
Set rs = dbs.OpenRecordset(strSQL)
i = 0
rs.MoveFirst
Do While Not rs.EOF
col.Add rs.Fields(strField), CStr(i)
Debug.Print "Function: " + col(CStr(i)) 'check value
rs.MoveNext
i = i + 1
Loop
Set colUniqueTableValues = col
Debug.Print "colUniqueTableValues: colUniqueTableValues.count = " + CStr(colUniqueTableValues.Count)
Set dbs = Nothing
Set rs = Nothing
Set col = Nothing
End Function
Function colAnyLengthAndStep(ByVal intLength As Integer, ByVal intStep As Integer) As Collection
Dim col As New Collection
Dim i As Integer
Dim var As Variant
For i = 1 To intLength * intStep Step intStep
col.Add "Value" + CStr(i), CStr(i)
Next
Set colAnyLengthAndStep = col
Set col = Nothing
End Function
The first issue is due to the fact that rs.Fields(strField) is a field object. In many situations, when you do something with a field, you're implicitly referencing its default property, which is .Value. For example, these two are essentially the same:
Debug.Print rs.Fields(strField)
Debug.Print rs.Fields(strField).Value
However, the collection's .Add method is different in that it will accept the actual object itself instead of the object's .Value. To see what's actually happening, make this change in colUniqueTableValues():
col.Add rs.Fields(strField), CStr(i)
Debug.Print TypeName(col(CStr(i))) ' <- this says Field2 on my system
You must explicitly reference the field's .Value property to add it to the collection properly:
col.Add rs.Fields(strField).Value, CStr(i)
After that change, you will expose an error in colUniqueTableValues_tester. When you added items to the collection, you gave them keys using CStr(i) starting with i = 0. However, in the For Each loop in colUniqueTableValues_tester, i starts at 1. Change the loop to this:
For Each var In col
'i = i + 1
Debug.Print CStr(i) & ": " & col(CStr(i))
Debug.Print var
i = i + 1
Next