I'm using VBA in access to open up a protected word template, fill in the data, and then re-protect it.... this way, if the database system goes down, the word template can still be used manually in its protected state.
I have just started using VBA and in this line:
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
I'm concerned that whilst running the code in access, that if the user opens up another word document and makes it the focus, that it will occidentally get protected instead of the other. How do I keep active focus on the document I'm writing to... or do I need to reference my document somehow using WordApp.protect (or something similar that works)
Private Sub Command0_Click()
Dim WordApp As Word.Application
Dim strDatabasePath As String
Dim strTemplatePath As String
Dim strTemplate As String
Dim strJobTitle As String
Dim strFile As String
strFile1 = "testcoc.dotx"
strFile2 = "testcoc-private.dotx"
strDatabasePath = CurrentProject.Path & "\"
strTemplatePath = "\templates\"
strTemplate = strDatabasePath & strTemplatePath & strFile2
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WordApp = CreateObject("Word.Application")
End If
On Error GoTo ErrHandler
WordApp.Visible = True
WordApp.WindowState = wdWindowStateMaximize
WordApp.Documents.Add Template:=strTemplate, NewTemplate:=True
'strJobTitle = DLookup("JobTitle", "Job", "JobNum = " & [JobType])
strJobTitle = DLookup("JobTitle", "Job", "JobNum = 'J0456'")
With WordApp.Selection
'Unprotect the file
If ActiveDocument.ProtectionType <> wdNoProtection Then
ActiveDocument.Unprotect Password:=""
End If
.Goto what:=wdGoToBookmark, Name:="bm_0_4"
.TypeText strJobTitle
End With
'Reprotect the document.
'If ActiveDocument.ProtectionType = wdNoProtection Then
'ActiveDocument.Protect _
'Type:=wdAllowOnlyFormFields, NoReset:=True, Password:=""
'End If
DoEvents
WordApp.Activate
Set WordApp = Nothing
Exit Sub
ErrHandler:
Set WordApp = Nothing
End Sub
Thank You
I haven't tried this but WordApp.Documents.Add Template:=strTemplate, NewTemplate:=True does return the new document. So I would do something like
Dim doc as Word.Document
Set doc = WordApp.Documents.Add(Template:=strTemplate, NewTemplate:=True)
and reference doc throughout my code instead of ActiveDocument. It seems like doing that should get help you avoid the particular situation you're concerned about.
Related
I'm a beginner with VBA and coding in general and I'm stuck with a problem with my VBA code. Here's what I want to do :
I have two fillable fields (f_autpar_nom and f_autpar_fiche) with my Access database who need to be on my Word file at two formfield (eleves_nom and eleves_numfiche) with a command_click(). Then, my Word document opens and prompts me with a "do you want to save this" and then the Word document save as a PDF and is sent by email.
Everything is working except one thing : The formfields aren't updated when I print the PDF and return the default message I set (which is "erreur").
What I need is to find a way to update the formfield before my messagebox prompt me to send the email.
Here's the code I have with Access
Function fillwordform()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Path = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation parentale vierge envoyée\Autorisation_blank.docm"
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Set doc = appword.Documents.Open(Path, , False)
With doc
.FormFields("eleves_nom").Result = Me.f_autpar_nom
.FormFields("eleves_numfiche").Result = Me.f_autpar_fiche
appword.Visible = True
appword.Activate
End With
Set doc = Nothing
Set appword = Nothing
End Function
Private Sub Commande47_Click()
Dim mydoc As String
mydoc = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation_blank.docm"
Call fillwordform
End Sub
and with Word
Private Sub document_open()
Dim outl As Object
Dim Mail As Object
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Dim PDFname As String
Msg = "L'autorisation sera sauvegardée et envoyée par email. Continuer?"
Style = vbOKCancel + vbQuestion + vbDefaultButton2
Title = "Document"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbOK Then
ActiveDocument.Save
PDFname = ActiveDocument.Path & "\" & "Autorisation Parentale " & FormFields("eleves_nom").Result & ".pdf"
ActiveDocument.SaveAs2 FileName:=PDFname, FileFormat:=wdFormatPDF
Set outl = CreateObject("Outlook.Application")
Set Mail = outl.CreateItem(0)
Mail.Subject = "Autorisation parentale " & FormFields("eleves_nom").Result & " " & FormFields("eleves_numfiche")
Mail.To = ""
Mail.Attachments.Add PDFname
Mail.Display
Application.Quit SaveChanges:=wdDoNotSaveChanges
Else
MsgBox "Le fichier ne sera pas envoyé."
Cancel = True
End If
End Sub
I didn't mean to remove the Set Doc = Nothing. My intention was to point out that whatever changes you made before that command must be lost because they weren't saved. In the code below the document is closed and saved.
Private Sub Commande47_Click()
Dim mydoc As String
mydoc = "P:\Commun\SECTEUR DU TRANSPORT SCOLAIRE\Harnais\Autorisations Parentales\Autorisation_blank.docm"
Call FillWordForm
End Sub
Function FillWordForm(Ffn As String)
Dim appWord As Word.Application
Dim Doc As Word.Document
On Error Resume Next
Set appWord = GetObject(, "word.application")
If Err.Number Then Set appWord = New Word.Application
appWord.Visible = True
On Error GoTo 0
Set Doc = appWord.Documents.Open(Ffn, , False)
' the newly opened document is activated by default
With Doc
.FormFields("eleves_nom").Result = Me.f_autpar_nom
.FormFields("eleves_numfiche").Result = Me.f_autpar_fiche
.Close True ' close the file and save the changes made
End With
Set appWord = Nothing
End Function
However, I also agree with #Kazimierz Jawor that your construct is unfortunate. Basically, the document's On_Open procedure should run when you open the document from Access. Therefore the email is probably sent before you even get to setting the form fields. My suggestion to save the changes is likely to take effect only when you run the code the second time.
The better way should be to send the mail from either Access or Word. My preference would be the latter. It should be easy to extract two values from an Access table using Word, add them to a Word document and mail out the whole thing. I don't see, however, why you should use the Open event to do that. If that choice is the more logical one then doing everything from within Access would be the conclusion.
I'm recycling code from an old database.
For one person, located half way across the country, I believe there may be some connection issue.
Public Function BackUpBackend()
Dim Source As String
Dim Target As String
Dim retval As Integer
Source = "\\network\backend\accessfile.accdb"
Target = "\\network\backend\backup\"
Target = Target & Format(Date, "mm-dd") & "#"
Target = Target & Format(Time, "hh-mm") & ".accdb"
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
End Function
Is there any way to detect connection errors in this code? And if there is, can the connection be re-established or just stop the backup process all together when the issue comes up?
In VBA you can do
On Error Resume Next
which will continue past errors. This can be dangerous though, so it's often best to switch on error handling again as soon as possible with
On Error Goto 0
You can define custom handlers for errors that crop up that you want to take specific action on:
From the VBA Reference:
Sub InitializeMatrix(Var1, Var2, Var3, Var4)
On Error GoTo ErrorHandler
. . .
Exit Sub
ErrorHandler:
. . .
Resume Next
End Sub
So you might do something like: (I've not tested)
Public Function BackUpBackend()
Dim Source As String
Dim Target As String
Dim retval As Integer
Source = "\\network\backend\accessfile.accdb"
Target = "\\network\backend\backup\"
Target = Target & Format(Date, "mm-dd") & "#"
Target = Target & Format(Time, "hh-mm") & ".accdb"
retval = 0
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
On Error Goto ErrorHandler
retval = objFSO.CopyFile(Source, Target, True)
Set objFSO = Nothing
On Error Goto 0
Exit Function
ErrorHandler:
MsgBox("Backup failed. If this happens often contact IT", vbExclamation )
End Function
I am coding an Access database that will collect user input, then open a Word document and fill out various parts of the document.
The problem I am having is it will only work once for Drop Down Lists. Not sure why or where to look to fix this one. There are three types of items I am programmatically filling in. The first is bookmarks, no problem with this. Second is Content Control Checkboxes, these also work with no problems. The third is Content Control Drop Down Lists, this is where the problem is. First time I open the Access Database it works, but if I click the command button again, nothing (for Drop Downs). The main problem is that it doesn't produce an error message, so I am not sure where to look.
I am guessing it has something to do with the objects I am creating to do the drop down updates? any help would be great:
Dim WordApp As Word.Application
Dim strTemplateLocation As String
Dim dir As String
Dim path As String
Dim wDoc As Word.Document
path = Left(CurrentDb.Name, InStrRev(CurrentDb.Name, "\"))
strTemplateLocation = path & "UserDoc.docx"
On Error Resume Next
Set WordApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set WordApp = CreateObject("Word.Application")
End If
WordApp.Visible = True
WordApp.WindowState = wdWindowStateMaximize
WordApp.Documents.Add Template:=strTemplateLocation, newtemplate:=False
With WordApp
'Working Bookmark
.Selection.GoTo what:=wdGoToBookmark, Name:="COMPANY": .Selection.TypeText [fac]
'Working checkbox
If Me.RD = True Then: .ActiveDocument.ContentControls(9).Checked = True
'Works ONCE drop down
Dim objCC As ContentControl
Dim objCE As ContentControlListEntry
Dim ListSelection As String
ListSelection = Me.System_Type.ListIndex + 2
Set objCC = ActiveDocument.ContentControls(1): Set objCE = objCC.DropdownListEntries.Item(ListSelection): objCE.Select
End With
Should I be closing out the objCE and objCC at the end or something?
This is probably your problem:
Set objCC = ActiveDocument.ContentControls(1)
It should be
Set objCC = .ActiveDocument.ContentControls(1)
But much better would be:
Set wDoc = WordApp.Documents.Add(Template:=strTemplateLocation, newtemplate:=False)
and then always use wDoc instead of WordApp.ActiveDocument.
See here: VBA ActiveDocument Concerns / Alternatives?
I'm trying to figure out how to get form, control and property data from an Access form that is not in the Access database from where I start the code. I have figured out how to get the data from within the database but I cant figure out how to get the data from a form outside of the database.
I thought that if I were to set the foreign database to the current database, my code would work. However, after executing "For Each frm In appAccess.Forms," the cursor goes to "End Sub."
I tried to work with containers and I was able to return the form name but I wasn't able to figure out how to loop through the controls and properties collections.
Below is the code associated with my first thought. My end objective is to be able to save form data in a different database. Is there a small error with my code or is there a different method I should use to get the data?
Sub GetControlForm()
Dim strPath As String
Dim frm As Form
Dim ctrl As Control
Dim prop As Property
Dim appAccess As New Access.Application
Dim dbs As DAO.Database
strPath = "C:\Users\Tyrone\Desktop\Test14.accdb"
Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase (strPath)
'MsgBox appAccess.CurrentDb.Name
For Each frm In appAccess.Forms
MsgBox frm.Name
For Each ctrl In frm.Controls
MsgBox ctrl.Name
MsgBox ctrl.ControlType.TypeName
MsgBox TypeName(ctrl)
For Each prop In ctrl.Properties
If prop.Name = "RowSource" Then
MsgBox "stop it"
End If
If (TypeName(ctrl) = "ComboBox" Or TypeName(ctrl) = "TextBox") And (prop.Name = "RowSource" Or prop.Name = "ControlSource") Then
MsgBox prop.Value
End If
Next prop
Next ctrl
Next frm
End Sub
The reason your For Each has nothing to loop through is that the forms in the remote database are not open. Per the documentation:
"The properties of the Forms collection in Visual Basic refer to forms
that are currently open."
Try this:
Sub GetControlForm()
Dim strPath As String
Dim obj As AccessObject
Dim frm As Form
Dim ctrl As Control
Dim prop As Property
Dim appAccess As New Access.Application
Dim dbs As DAO.Database
strPath = "C:\Users\Tyrone\Desktop\Test14.accdb"
Set appAccess = CreateObject("Access.Application")
appAccess.OpenCurrentDatabase (strPath)
'MsgBox appAccess.CurrentDb.Name
For Each obj In appAccess.CurrentProject.AllForms
appAccess.DoCmd.OpenForm obj.Name
Set frm = appAccess.Forms(obj.Name)
MsgBox frm.Name
For Each ctrl In frm.Controls
MsgBox ctrl.Name
'MsgBox ctrl.ControlType.TypeName
MsgBox TypeName(ctrl)
For Each prop In ctrl.Properties
If prop.Name = "RowSource" Then
MsgBox "stop it"
End If
If (TypeName(ctrl) = "ComboBox" Or TypeName(ctrl) = "TextBox") And (prop.Name = "RowSource" Or prop.Name = "ControlSource") Then
MsgBox prop.Value
End If
Next prop
Next ctrl
appAccess.DoCmd.Close acForm, frm.Name
Next obj
Set frm = Nothing
appAccess.CloseCurrentDatabase
Set appAccess = Nothing
End Sub
Is it possible to loop through for all shortcuts (.lnk) in a given location and return the .TargetPath. If a shortcuts target matches a criteria an action can then be peformed on the shortcut?
To delete all shortcuts I would use the following:
Public Sub deleteAllShortcuts()
Dim shortCutPath As String
' compName = Computer Name, recordDirShort = directory where the shortcut lnks are
shortCutPath = compName & recordDirShort
shortCutPath = shortCutPath & "*.lnk"
On Error Resume Next
Kill shortCutPath
On Error GoTo 0
End Sub
I cant figure out how I would loop through all shortcuts in the directory using the above loop.
Any help on the above would be greatly appreciated
Cheers
Noel
Hopefully this may be good to someone.
To delete shortcuts by the shorcut target I used the following:
Public Sub deleteShortcutByTarget(targetFolderName As String)
Dim strDocPath As String
Dim strTarget As String
Dim obj As Object
Dim shortcut As Object
Dim objFso As Object
Dim objFolder As Object
Dim objFile As Object
Set obj = CreateObject("WScript.Shell")
Set objFso = CreateObject("Scripting.FileSystemObject")
strDocPath = compName & recordDirShort
Set objFolder = objFso.GetFolder(strDocPath)
Set objFile = objFolder.Files
For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "lnk" Then
Set shortcut = obj.CreateShortcut(objFile.Path)
strTarget = shortcut.TargetPath
shortcut.Save
If strTarget = strDocPath & targetFolderName Then
Kill objFile.Path
End If
End If
Next
Set obj = Nothing
Set objFile = Nothing
Set objFso = Nothing
Set objFolder = Nothing
Set shortcut = Nothing
End Sub
Within Access you could use the Dir() function. It would be something like this:
Dim strLink As String
strLink = Dir(shortCutPath & "*.lnk")
Do Until Len(strLink)=0
Kill strLink
strLink = Dir()
Loop
Dir() doesn't play well with network paths in all cases, though, so you might want to use the File System Object, instead. It's much more versatile and works better with networks. I use it only occasionally, so don't have the code at my fingertips, but have a look at it -- you might have no trouble figuring it out as the object model is pretty clearly designed.