Parsing hyperlinks from Access VBA to Word template - ms-access

I'm using VBA in Access 2010 form to populate a Word template with data from my tables.
What I can't achieve so far is inserting a hyperlink in the text.
To make things easier for me I'm inserting all the data into table in the template like this:
Private Sub button_Click()
On Error GoTo myError
Dim objWRD As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strRecords As String
'open a query and prepare the data'
Set db = CurrentDb()
Set qfd = db.QueryDefs("my_query")
Set rs = qfd.OpenRecordset()
'open a Word template'
Set objWRD = CreateObject("Word.Application")
objWRD.Visible = True
Set objDoc = objWRD.Documents.Add("path_to_my_document_template", , , True)
objWRD.ScreenUpdating = False
'insert records into template'
Dim i As Integer
i = 1
While Not rs.EOF
objDoc.Tables(i).Cell(2, 1).Range.Text = "" & rs("hyperlink")
objDoc.Tables(i).Cell(2, 2).Range.Text = "" & rs("description")
rs.MoveNext
i = i + 1
Wend
rs.Close
Set rs = Nothing
leave:
Exit Sub
myError:
MsgBox Error$
Resume Next
End Sub
Can anyone please help me to insert a working hyperlink to the template into rs("hyperlink") place?

Where you reference the table cell to hold the hyperlink, try this:
objDoc.Hyperlinks.add Anchor:=objDoc.tables(i).Cell(2, 1).Range, _
Address:=rs("hyperlink")
And to add additional text to the same cell (In this case I'm inserting "Text to Insert" prior to the hyperlink.
With objDoc.Tables(i).Cell(2, 1).Range
.Collapse Direction:=wdCollapseStart
.Text = "Text to Insert" & Chr(11)
End With
so your While Loop would look something like this:
Dim i As Integer
i = 1
While Not rs.EOF
objDoc.Hyperlinks.add Anchor:=objDoc.Tables(i).Cell(2, 1).Range, _
Address:=rs("hyperlink")
With objDoc.Tables(i).Cell(2, 1).Range
.Collapse Direction:=wdCollapseStart
.Text = "Text to Insert" & Chr(11)
End With
objDoc.Tables(i).Cell(2, 2).Range.Text = "" & rs("description")
rs.MoveNext
i = i + 1
Wend

Related

Get contents of laccdb file through VBA

I want to be able to view the contents of my access database's laccdb file through VBA so I can use it to alert users (through a button) who else is in the database.
I specifically don't want to use a 3rd Party tool. I have tried using:
Set ts = fso.OpenTextFile(strFile, ForReading)
strContents = ts.ReadAll
This works fine if only 1 user is in the database. But for multiple users it gets confused by the presumably non-ASCII characters and goes into this kind of thing after one entry:
Does anyone have any suggestions? It's fine if I just open the file in Notepad++...
Code eventually used is as follows (I didn't need the title and have removed some code not being used):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection, rs As New ADODB.Recordset
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & CurrentDb.Name
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
While Not rs.EOF
Debug.Print rs.Fields(0)
rs.MoveNext
Wend
End Sub
I found this which should help, it's not actually reading the ldb file, but it has the info that you need (Source: https://support.microsoft.com/en-us/kb/198755):
Sub ShowUserRosterMultipleUsers()
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=c:\Northwind.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=c:\Northwind.mdb"
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set rs = cn.OpenSchema(adSchemaProviderSpecific, _
, "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
Debug.Print rs.Fields(0).Name, "", rs.Fields(1).Name, _
"", rs.Fields(2).Name, rs.Fields(3).Name
While Not rs.EOF
Debug.Print rs.Fields(0), rs.Fields(1), _
rs.Fields(2), rs.Fields(3)
rs.MoveNext
Wend
End Sub
I put together some code to read through the lock file and output a message listing users currently using the system.
Trying to read the whole file in at once seems to result in VBA treating the string as Unicode in the same way notepad does so I read in character by character and filter out non printing characters.
Sub TestOpenLaccdb()
Dim stm As TextStream, fso As FileSystemObject, strLine As String, strChar As String, strArr() As String, nArr As Long, nArrMax As Long, nArrMin As Long
Dim strFilename As String, strMessage As String
strFilename = CurrentProject.FullName
strFilename = Left(strFilename, InStrRev(strFilename, ".")) & "laccdb"
Set fso = New FileSystemObject
Set stm = fso.OpenTextFile(strFilename, ForReading, False, TristateFalse) 'open the file as a textstream using the filesystem object (add ref to Microsoft Scripting Runtime)
While Not stm.AtEndOfStream 'Read through the file one character at a time
strChar = stm.Read(1)
If Asc(strChar) > 13 And Asc(strChar) < 127 Then 'Filter out the nulls and other non printing characters
strLine = strLine & strChar
End If
Wend
strMessage = "Users Logged In: " & vbCrLf
'Debug.Print strLine
strArr = Split(strLine, "Admin", , vbTextCompare) 'Because everyone logs in as admin user split using the string "Admin"
nArrMax = UBound(strArr)
nArrMin = LBound(strArr)
For nArr = nArrMin To nArrMax 'Loop through all machine numbers in lock file
strArr(nArr) = Trim(strArr(nArr)) 'Strip leading and trailing spaces
If Len(strArr(nArr)) > 1 Then 'skip blank value at end
'Because I log when a user opens the database with username and machine name I can look it up in the event log
strMessage = strMessage & DLast("EventDescription", "tblEventLog", "[EventDescription] like ""*" & strArr(nArr) & "*""") & vbCrLf
End If
Next
MsgBox strMessage 'let the user know who is logged in
stm.Close
Set stm = Nothing
Set fso = Nothing
End Sub

Embed HTML email attatchment in body from access query

I have a database. It has a form that sends an email, attaching query results to it (the attachment is an HTML document).
My VBA code for the form is:
Private Sub button_send_Click()
DoCmd.SendObject acSendQuery, Me!query_name, acFormatTXT, me!email_address, , , "Subject Line"
End Sub
I would not like my form to attach the query results. I need it to put the content from the attachment into the main body of the email instead.
Is there a way of doing this with VBA?
Use a function like this to list the output:
Public Function ListQuery() As String
Dim qdy As DAO.QueryDef
Dim rst As DAO.Recordset
Dim fld As DAO.Field
Dim List As String
Set qdy = CurrentDb.QueryDefs("YourQueryName")
qdy.Parameters(0).Value = Forms!NameOfYourForm!NameOfSomeTextbox.Value
qdy.Parameters(1).Value = Forms!NameOfYourForm!NameOfOtherTextbox.Value
Set rst = qdy.OpenRecordset()
If rst.RecordCount > 0 Then
While Not rst.EOF
For Each fld In rst.Fields
List = List & fld.Value & vbTab
Next
List = List & vbCrLf
rst.MoveNext
Wend
End If
rst.Close
Set fld = Nothing
Set rst = Nothing
Set qdy = Nothing
ListQuery = List
End Function
Then:
Dim MessageText As String
MessageText = ListQuery
DoCmd.SendObject acSendNoObject, , acFormatTXT, Me!email_address, , , "Subject Line", MessageText

Adding DBfailonerror in access vb creates compile error invalid use of property

An import sub that has been created in access works OK but when DBfailonerror is added a compile error invalid use of property is encountered when the sub is run from the vb editor.
Any advice re: this would be most appreciated. Code is as follows:
Sub Importcl()
'DATA DECLARATIONS
Dim fso As New FileSystemObject
Dim t As TextStream
Dim strFilePath As String
Dim Cnr As String
Dim Cnri As String
Dim Cnrii As String
Dim Cnriii As String
Dim Sqlstr As String
Dim Db As DAO.Database
'SET COUNTERS TO ZERO
Cnr = 0
Cnri = 0
Cnrii = 0
Cnriii = 0
'Point to DB
Set Db = CurrentDb()
'SET TXT FILE PATH
strFilePath = "C:\Users\Vlad\CSV import\EV WORK\Book1.txt"
'ERROR HANLDER FOR TXT FILE PATH AND COUNTING OF TXT FILE LINE ITEMS
If fso.FileExists(strFilePath) Then
Set t = fso.OpenTextFile(strFilePath, ForReading, False)
Do While t.AtEndOfStream <> True
t.SkipLine
Cnr = Cnr + 1
Loop
t.Close
Else: MsgBox ("Txt File not Found - Check File Path")
Exit Sub
End If
'DISPLAY LINE RECORDS COUNTED IN TXT FILE TO BE ADDED TO TABLE
Debug.Print Cntr; " Incl header"
MsgBox (Cnr - 1 & " records to be added")
'COUNT & DISPLAY CURRENT RECORD COUNT IN TARGET TABLE
Cnri = DCount("[Case Date]", "All Caseload Data New")
If MsgBox(Cnri & " -Current Records in table- All Caseload Data New - Continue
with Import?", vbYesNo, "Import") = vbYes Then
Db.Execute _
"INSERT INTO [All Caseload Data New] SELECT * FROM[Text;FMT=Delimited;HDR=Yes;
DATABASE=C:\Users\Dev\CSV import\DEV WORK\].[Book1#txt];"
dbFailOnError
Db.TableDefs.Refresh
Else: Exit Sub
End If
Cnrii = DCount("[Case Date]", "All Caseload Data New")
Cnriii = Cnrii - Cnri
MsgBox (Cnriii & " New records added to table All Caseload Data New")
End Sub
With this code to start ...
Dim db As DAO.database
Dim strInsert As String
strInsert = "INSERT INTO tblFoo (some_text) VALUES ('bar');"
Set db = CurrentDb
Then these 2 Execute statements ..
db.Execute strInsert
dbFailOnError ' triggers error
db.Execute strInsert, dbFailOnError ' compiles without error
Include dbFailOnError on the same line as Execute. Placing dbFailOnError on a separate line triggers that "invalid use of property" compile error.

Compare two recordset variables gives type mismatch

I have a bound form with several subforms. some of these subforms can 0 or more records, others have 1 or more.
The form is always open in read-only and on it there are an "edit" and a "close" button.
When the user clicks on the edit button I save the content of the current record togehter with all records of the subforms so that when he/she clicks on the close button I can ask wether to save or not and, if not, discard the changes restoring from saved records.
So far this is the code of the edit button (where GclnAllCnts is a global variable of type Dictionary):
Private Sub EditLibroBtn_Click()
On Error GoTo Err_EditLibroBtn_Click
Dim lngID As Long
Dim ctlCnt As Control
Dim rs As Recordset
lngID = Me.ID
Set GclnAllCnts = New Dictionary
GclnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
GclnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
GclnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
DoCmd.Close acForm, Me.Name
DoCmd.OpenForm GCstMainFrmName, , , "ID = " & lngID, acFormEdit, acDialog
Exit_EditLibroBtn_Click:
Set ctlCnt = Nothing
Set rs = Nothing
Exit Sub
Err_EditLibroBtn_Click:
MsgBox err.Description & vbNewLine & "Error number: " & err.Number, vbCritical, "Errore"
Resume Exit_EditLibroBtn_Click
End Sub
And this is the code of the close button:
Private Sub ChiudiBtn_Click()
On Error GoTo Err_ChiudiBtn_Click
Dim intBoxAwr As Integer
Dim stSQL As String
Dim vKey As Variant
Dim ctlCnt As Control
Dim clnAllCnts As Dictionary
Dim bSaveNeeded As Boolean
bSaveNeeded = False
If (Me.AllowEdits And Me.ID <> "" And Not IsNull(Me.ID)) Then
Set clnAllCnts = New Dictionary
clnAllCnts.Add Me.Name, Me.RecordsetClone
For Each ctlCnt In Me.Controls
If (ctlCnt.ControlType = acSubform) Then
Set rs = ctlCnt.Form.RecordsetClone
If rs.RecordCount > 0 Then
clnAllCnts.Add ctlCnt.Name, ctlCnt.Form.RecordsetClone
Else
clnAllCnts.Add ctlCnt.Name, Null
End If
End If
Next
If clnAllCnts.Count <> GclnAllCnts.Count Then
bSaveNeeded = True
Else
For Each vKey In clnAllCnts.keys()
If Not GclnAllCnts.Exists(vKey) Then
bSaveNeeded = True
Exit For
Else
'*********** Next Gives error **********
If clnAllCnts.Item(vKey) <> GclnAllCnts.Item(vKey) Then
bSaveNeeded = True
Exit For
End If
End If
Next
End If
If bSaveNeeded Then
intBoxAwr = MsgBox("Salvare le modifiche al libro?", vbYesNo + vbQuestion, "Salvare")
If intBoxAwr = vbYes Then
'etc., omitting code
End Sub
The error I get is Type mismatch (nr. 13) and it is given by the <> comparison (I can Debug.print IsNull(clnAllCnts.Item(vKey)) and IsNull(GclnAllCnts.Item(vKey)).
How can I compare the two recordset variables?
Comparing two Recordset objects by simply saying If rst1 <> rst2 could be dicey anyway, because what does that really mean? Such an expression could very well return True every time, if rst1 and rst2 really are different objects (even if they are of the same object Type).
It appears that you are interested in whether the contents of the two Recordsets is the same. In that case, I would be inclined to serialize the recordset data and store the resulting String instead of storing the Recordset object itself.
The following VBA Function may prove helpful in that case. It loops through a recordset object and produces a JSON-like string containing the current recordset data.
(Note that the function may NOT necessarily produce valid JSON. It doesn't escape non-printing characters like vbCr and vbLf. It doesn't escape backslashes (\). It stores all values as either "string" or null. In other words, in its current form it is not designed to produce a string that could later be deserialized.)
Private Function rstSerialize(ByVal rst As DAO.Recordset)
' loop through the recordset and generate a JSON-like string
' NB: This code will NOT necessarily produce valid JSON!
'
Dim s As String, fld As DAO.Field, rowCount As Long, fldCount As Long
s = "{"
If Not (rst.BOF And rst.EOF) Then
rst.MoveFirst
rowCount = 0
Do Until rst.EOF
If rowCount > 0 Then
s = s & ", "
End If
s = s & """row"": {"
fldCount = 0
For Each fld In rst.Fields
If fldCount > 0 Then
s = s & ", "
End If
s = s & """" & fld.Name & """: " & IIf(IsNull(fld.Value), "null", """" & fld.Value & """")
fldCount = fldCount + 1
Next
s = s & "}"
rowCount = rowCount + 1
rst.MoveNext
Loop
End If
s = s & "}"
rstSerialize = s
End Function
Data Example: If the Recordset contained
DonorID Amount
------- ------
1 10
2 20
the function would return the string
{"row": {"DonorID": "1", "Amount": "10"}, "row": {"DonorID": "2", "Amount": "20"}}
Usage Example: On a form that contains a subform, a button on the main form could do the following
Private Sub Command3_Click()
Dim rst As DAO.Recordset, originalState As String
Set rst = Me.MemberDonationsSubform.Form.RecordsetClone
originalState = rstSerialize(rst)
rst.MoveFirst
rst.Edit
rst!Amount = rst!Amount + 1
rst.Update
Debug.Print "(Recordset updated.)"
If rstSerialize(rst) = originalState Then
Debug.Print "Recordset does not appear to have changed."
Else
Debug.Print "Recordset appears to have changed."
End If
End Sub
which would print the following in the VBA Immediate Window
(Recordset updated.)
Recordset appears to have changed.

Cannot open word file for editing from access using vba

The following code runs as far as the marked line. Word then shows a file locked for editing/ open read only prompt. I need to be able to edit the document (that is the whole point of the code).
Sorry for incredibly long code block - I felt it was important to show everything so that it was easier to find the problem.
The code is also kind of clunky with the multiple recordsets, if anyone has any better ideas would love to here them.
Option Explicit
Option Compare Database
Sub InputSafetyData()
Dim dbCur As Database
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim dlgCur As FileDialog
Dim rngCcCur As Range
Dim varDlgCur As Variant
Dim strDocName As String
Dim strDocPath As String
Dim strSQL As String
Dim rsIt As DAO.Recordset
Dim rsHc As DAO.Recordset
Dim rsHz As DAO.Recordset
Dim rsPr As DAO.Recordset
Dim strHc As String
Dim strHz As String
Dim strPr As String
Set dbCur = CurrentDb()
Set dlgCur = Application.FileDialog(msoFileDialogFolderPicker)
With dlgCur
.AllowMultiSelect = False
If .Show <> -1 Then End
varDlgCur = .SelectedItems(1)
End With
strDocPath = CStr(varDlgCur) & "\"
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Set dlgCur = Nothing
Do While strDocName <> ""
'Runs as far here
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, ReadOnly:=False, Visible:=False)
If docCur.ReadOnly = False Then
Set rngCcCur = docCur.ContentControls(6).Range
rngCcCur = ""
appCur.ActiveDocument.Tables.Add Range:=rngCcCur, NumRows:=1, NumColumns:=4
With rngCcCur.Tables(0)
If .Style <> "Table Grid" Then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
.Style = "Light Shading"
.AutoFitBehavior wdAutoFitWindow
.Cell(1, 1).Range.InsertAfter "Item"
.Cell(1, 2).Range.InsertAfter "Hazcard"
.Cell(1, 3).Range.InsertAfter "Hazard"
.Cell(1, 4).Range.InsertAfter "Precaution"
'select distinct item based on filename
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
Set rsIt = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsIt.BOF And rsIt.EOF) = True Then
While Not rsIt.EOF
.Rows.Add
.Cell(rsIt.AbsolutePosition + 2, 1).Range.InsertAfter rsIt.Fields(1).Value
'select distinct hazcard based on item
strSQL = "Select Distinct Hazcard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHc = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHc.BOF And rsHc.EOF) = True Then
While Not rsHc.EOF
strHc = strHc & " " & rsHc.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 2).Range.InsertAfter strHc
rsHc.MoveNext
Wend
End If
rsHc.Close
Set rsHc = Nothing
'select distinct hazard based on item
strSQL = "Select Distinct Hazard From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsHz = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsHz.BOF And rsHz.EOF) = True Then
While Not rsHz.EOF
strHc = strHz & " " & rsHz.Fields(2).Value
.Cell(rsIt.AbsolutePosition + 2, 3).Range.InsertAfter strHz
rsHz.MoveNext
Wend
End If
rsHz.Close
Set rsHz = Nothing
'select distinct precaution based on item
strSQL = "Select Distinct Precaution From IHR where item is"
strSQL = strSQL & rsIt.Fields(1).Value
Set rsPr = dbCur.OpenRecordset(strSQL, dbOpenDynaset)
If Not (rsPr.BOF And rsPr.EOF) = True Then
While Not rsPr.EOF
strPr = strPr & " " & rsPr.Fields(4).Value
.Cell(rsIt.AbsolutePosition + 2, 4).Range.InsertAfter strPr
rsPr.MoveNext
Wend
End If
rsPr.Close
Set rsPr = Nothing
rsIt.MoveNext
Wend
End If
End With
rsIt.Close
Set rsIt = Nothing
Debug.Print (docCur.Name)
docCur.Save
End If
docCur.Close
Set docCur = Nothing
strDocName = Dir
Loop
Set appCur = Nothing
End Sub
Focus on the immediate problem --- "Cannot open word file for editing".
I created a folder, C:\share\testdocs\, and added Word documents. The code sample below uses a constant for the folder name. I wanted a simple test, so got rid of FileDialog. I also discarded all the recordset code.
I used Visible:=True when opening the Word documents. I didn't understand why you have the Word application visible, but the individual documents not visible. Whatever the logic for that, I chose to make them visible so I could observe the content changes.
I tested this with Access 2007, and it works without errors. If it doesn't work for you, double-check the file system permissions for the current user for both the folder and the target documents.
Public Sub EditWordDocs()
Const cstrFolder As String = "C:\share\testdocs\"
Dim appCur As Word.Application
Dim docCur As Word.Document
Dim strDocName As String
Dim strDocPath As String
Dim strMsg As String
On Error GoTo ErrorHandler
strDocPath = cstrFolder
strDocName = Dir(strDocPath & "*.docx")
Set appCur = New Word.Application
appCur.Visible = True
Do While strDocName <> ""
Debug.Print "strDocName: " & strDocName
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=True)
Debug.Print "FullName: " & docCur.FullName
Debug.Print "ReadOnly: " & docCur.ReadOnly
' add text to the document ... '
docCur.content = docCur.content & vbCrLf & CStr(Now)
docCur.Close SaveChanges:=wdSaveChanges
Set docCur = Nothing
strDocName = Dir
Loop
ExitHere:
On Error Resume Next
appCur.Quit SaveChanges:=wdDoNotSaveChanges
Set appCur = Nothing
On Error GoTo 0
Exit Sub
ErrorHandler:
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure EditWordDocs"
MsgBox strMsg
Debug.Print strMsg
GoTo ExitHere
End Sub
Assuming you're able to get past the read-only problem, I think you have more challenges ahead. Your SELECT statements look highly suspicious to me ...
'select distinct item based on filename '
strSQL = "Select Distinct Item From IHR where filename is"
strSQL = strSQL & strDocName
For example, if strDocName contains "temp.docx", strSQL will contain this text ...
Select Distinct Item From IHR where filename istemp.docx
That is not a valid SELECT statement. I think you may need something more like this ...
SELECT DISTINCT [Item] FROM IHR WHERE filename = 'temp.docx'
Item is a reserved word, so I enclosed it in square brackets to avoid confusing the db engine. Use the equality operator (=) instead of "is" for your string comparisons.
It is extremely useful to Debug.Print your strSQL string, so that you may directly examine the completed statement you're asking the db engine to run ... view it instead of relying on your imagination to guess what it looks like. And when it fails, you can copy the Debug.Print output from the Immediate window and paste it into SQL View of a new query for testing.
However, those Access query issues don't matter until you can get past the read-only issue with your Word documents.
To follow up on the issue of visibility vs. read-only, my code opened the Word documents and modified them without throwing errors when I included either or both of these two changes:
appCur.Visible = False
and
Set docCur = appCur.Documents.Open(FileName:=strDocPath & strDocName, _
ReadOnly:=False, Visible:=False)
I had the same problem with a file opened read only. You can try putting in the following code:
appcur.ActiveWindow.View.ReadingLayout = False