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
Related
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 written a couple of VBA functions which in the end return a Collection of Integers:
Public Function ValidIDs() As Collection
Now I want to run create a query in the QueryEditor with the following condition: WHERE TableID IN ValidIDs(). That does not work since access for some reason does not even find my function as long as it returns a Collection. Therefore I wrote a wrapper around it, which joins the Collection:
Public Function joinCollectionForIn(Coll As Collection) As String
Now a third function which calls ValidIDs(), passes the result to joinCollectionForIn and returns that result. Lets call it GetIDCollectionAsString().
As a result I can now change my query to WHERE TableID IN (GetIDCollectionAsString()). Note the added parenthesis since the IN needs them in any case, they can not just be at the end and the beginning of the String returned by GetID....
Running that query however results in
Data type mismatch in criteria expression.
I guess that results from the fact that I return a String, therefore access automatically wraps that string in ' for the SQL and the IN-clause no longer works because I would check if a number is IN a collection of 1 string.
Therefore my question is:
Is there a way to prevent access from wrapping the returned string for the SQL
or (would be a whole lot better):
Is there an already existing way to pass a collection or array to the WHERE IN-clause?
P.S.: I am currently using a workaround by writing a placeholder in the parenthesis following the IN (e.g. IN (1,2,3,4,5)) and replacing that placeholder in Form_Load with the result of GetIDCollectionAsString() - that works but it is not pretty...
Edit: The final query should look like SELECT * FROM TestTable t WHERE t.ID IN (1,2,3,4,5,6,7). That actually works using above method, but not in a nice way.
Well this required more work than it seems.... i couldn't find a straight solution so here is a workaround
Public Function ListforIn(inputString As String) As String
Dim qdf As QueryDef
Dim valCriteria As String
Dim strsql As String
Dim splitcounter As Byte
Dim valcounter As Byte
Set qdf = CurrentDb.QueryDefs(**TheNameOfQueryYouWantToModify**)
strsql = qdf.sql
strsql = Replace(strsql, ";", "") 'To get rid of ";"
splitcounter = Len(inputString) - Len(Replace(inputString, ",", ""))
For valcounter = 0 To splitcounter
valCriteria = valCriteria & ValParseText(inputString, valcounter, ",")
Next
strsql = strsql & " WHERE TableId IN (" & Left(valCriteria, Len(valCriteria) - 1) & ")"
qdf.sql = strsql
End Function
Public Function ValParseText(TextIn As String, X As Byte, Optional MyDelim As String) As Variant
On Error Resume Next
If Len(MyDelim) > 0 Then
ValParseText = "Val(" & (Split(TextIn, MyDelim)(X)) & "),"
Else
ValParseText = Split(TextIn, " ")(X)
End If
End 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 have a Repoerteq table with a REQ_NUM as ID and another column named "REQ_department".
REQ_department have defult values such as ""Finance".
I want to make VBA looks at the department and then set a prefix formate for REQ_NUM
example is department is finance then it would make id as "FIN 000"
the following code is what i manage fo far but it still not working
Option Compare Database
Function GetData() As String
Dim db As Database
Dim Rrs As DAO.Recordset
Dim RSQL As String
Dim RepData As String
Dim RepDep As String
'TO open connection to current Access DB
Set db = CurrentDb()
'TO create SQL statement and retrieve value from ReportReq table
RSQL = "select * from ReportReq"
Set Rrs = db.OpenRecordset(RSQL)
'Retrieve value if data is found
If Rrs.EOF = False Then
RepData = Rrs("REQ_NUM")
RepDep = Rrs("Req_department")
Else
RepData = "Not found"
RepDep = "Not found"
End If
Lrs.Close
Set Lrs = Nothing
GetData = RepData
If ReqDep = "finance" Then
Range("REQ_NUM") = Format$("FIN", REQ_NUM)
End If
End Function
You'll have to change your call to the Format() function which tries to format a number or date according to the format string. In addition, you're using an undefined variable REQ_NUM.
If ReqDep = "finance" Then
Range("REQ_NUM") = "FIN " & Format$("000", CLng(RepData))
' ^^^^^^ ^^^^^^^^^^^^^^^^^^^^
End If
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