If-Then-Else Opening Word Document - ms-access

I'm trying to create an If-Then-Else statement in MS Access VBA.
This statement is to open a specific word document but if the word document does not exist then open a different word document.
Below is the code I have and it works if I get rid of the else but that doesn't solve my problem because I need the else statement.
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
Set appWord = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appWord = New Word.Application
appWord.Visible = True
End If
If Value = "Excused" Then
Path = "C:\...existing docx"
Else
Path = "C:\...different docx"
End If
Set doc = appWord.Documents.Open(Path, , True)

Use appword.Documents.Add to return a new Document. You should also add an Error Handler when using GetObject. You may also consider using Len(Dir(Path)) to test if the file exists.
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Set appword = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
On Error GoTo 0
If Value = "Excused" Then
Path = "C:\...existing docx"
Set doc = appword.Documents.Open(Path, , True)
Else
Set doc = appword.Documents.Add
End If

Validate the document exists and if not add a new document.
Sub T()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
Set appword = New Word.Application
appword.Visible = True
If Len(Dir("C:\...existing docx")) > 0 And Value = "Excused" Then
Path = "C:\...existing docx"
Set doc = appword.Documents.Open(Path, , True)
Else
Set doc = appword.Documents.Add
End If
End Sub

Related

Save Excel Workbook From Access VBA

I am exporting a recordset from an access query to an Excel Workbook. The export goes fine, and my syntax prompts the user for a filename/location just as I need. However, the file is not actually saved. Am I missing a step in the process or what code changes need to take place in order to have this function?
Sub ETE()
Dim ExcelApp As Object, wbOutput As Object, wsOutput As Object, bExcelOpened As Boolean
Dim db As DAO.Database, rs As DAO.Recordset, targetRow As Long
Dim targetPath As String, fd As FileDialog, Title As String, saveInfo As Variant
DoCmd.Hourglass True
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
On Error GoTo Error_Handler
Set ExcelApp = CreateObject("Excel.Application")
bExcelOpened = False
Else
bExcelOpened = True
End If
On Error GoTo Error_Handler
ExcelApp.ScreenUpdating = False
ExcelApp.Visible = False
Set wbOutput = ExcelApp.Workbooks.Add()
Set wsOutput = wbOutput.Sheets(1)
Set db = CurrentDb
Set rs = db.OpenRecordset("qryTakeDataToExcel", dbOpenSnapshot)
With rs
If .RecordCount <> 0 Then
'Write the data to Excel
End If
End With
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.AllowMultiSelect = False
.Title = "Select Save Location And File Name"
.InitialFileName = "File_" & Format(Now(), "mmddyyyy") & ".xlsx"
If .Show = True Then
wbOutput.SaveAs FileName:=fd.InitialFileName, FileFormat:=50
wbOutput.Close
End If
End With
End Sub
Your filedialog code is not working as expected, and because of that, you're not getting a valid file name and location.
If you want to return the file name picked, you should use .SelectedItems(1), not .InitialFileName. .InitialFileName sets an initial value and doesn't return the full path.
If .Show = True Then
wbOutput.SaveAs FileName:=.SelectedItems(1), FileFormat:=50
wbOutput.Close
End If
This would've probably been easier to catch if you'd have used a valid error handler. Use On Error GoTo 0 to use the default error handler.

Add new sheets to the exported excel using vba and do a lookup between two sheets using access VBA [duplicate]

I am running a few modules of code in access and am writing data into
Excel. When I write the first time, data gets written properly. But again
when I try, the new data is written on top of the old data. What should I do to
insert a new sheet?
My existing code is
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Dim objSht As Excel.Worksheet
Dim objRange As Excel.Range
Set objexcel = CreateObject("excel.Application")
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
Set objSht = wbexcel.Worksheets("Sheet1")
objSht.Activate
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
objexcel.Workbooks.Add
Set wbexcel = objexcel.ActiveWorkbook
Set objSht = wbexcel.Worksheets("Sheet1")
End If
I think that the following code should do what you want. It's very similar to yours, except it uses the return values from the .Add methods to get the objects you want.
Public Sub YourSub()
Dim objexcel As Excel.Application
Dim wbexcel As Excel.Workbook
Dim wbExists As Boolean
Set objexcel = CreateObject("excel.Application")
'This is a bad way of handling errors. We should'
'instead check for the file existing, having correct'
'permissions, and so on, and actually stop the process'
'if an unexpected error occurs.'
On Error GoTo Openwb
wbExists = False
Set wbexcel = objexcel.Workbooks.Open("C:\REPORT1.xls")
wbExists = True
Openwb:
On Error GoTo 0
If Not wbExists Then
Set wbexcel = objexcel.Workbooks.Add()
End If
CopyToWorkbook wbexcel
EndSub
Private Sub CopyToWorkbook(objWorkbook As Excel.Workbook)
Dim newWorksheet As Excel.Worksheet
set newWorksheet = objWorkbook.Worksheets.Add()
'Copy stuff to the worksheet here'
End Sub

Passing MS-Access string >255 characters to MS-Word field

I'm using .FormFields("WordBookmarkName").Result = stringFromAccess method to pass data out of MS-Access to an MS-Word document.
It seems it can only pass up to 255 characters. Is there a way I can pass more to my field in MS-Word?
Edit:
This is a simplified version of the code I was using that works ok up to 255 characters:
Dim startForms As String
Dim appWord As Word.Application
Dim doc As Word.Document
startForms = String(256, "x")
Set appWord = GetObject(, "Word.Application") 'Set appWord object variable to running instance of Word.
If Err.Number <> 0 Then
Set appWord = New Word.Application 'If Word isn't open, create a new instance of Word.
End If
Set doc = appWord.Documents.Open("C:\myFolder\MyForm.docx", , True)
With doc
.FormFields("wdStartForms").Result = "" 'Clear anything currently in the form's field
.FormFields("wdStartForms").Result = startForms
.Visible = True
.Activate
End With
Set doc = Nothing
Set appWord = Nothing
JohnnyBones: this is the code I adapted after your answer; using ActiveDocument wasn't working, so I continued to use the doc reference I'd made and it seemed to work ok with 256+ characters after that:
Dim startForms As String
Dim appWord As Word.Application
Dim doc As Word.Document
startForms = String(256, "x")
Set appWord = GetObject(, "Word.Application") 'Set appWord object variable to running instance of Word.
If Err.Number <> 0 Then
Set appWord = New Word.Application 'If Word isn't open, create a new instance of Word.
End If
Set doc = appWord.Documents.Open("C:\myFolder\MyForm.docx", , True)
With doc
.FormFields("wdStartForms").Result = "" 'Clear anything currently in the form's field
.Bookmarks("wdStartForms").Range.Fields(1).Result.Text = startForms
.Visible = True
.Activate
End With
Set doc = Nothing
Set appWord = Nothing
If you use:
Dim FmFld As FormField, Str1 As String
Str1 = (a long string > 256 characters)
Set FmFld = ActiveDocument.FormFields(1)
FmFld.Result = Str1
You get an error: “String too long” (a ridiculous “design” feature, given that you can do it manually without problems!).
Same if you use:
ActiveDocument.Formfields("Text1").Result = Str1
You can get round this by using:
ActiveDocument.Unprotect
FmFld.Range.Fields(1).Result.Text = Str1
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
Or if you're referring to the formfield by name:
ActiveDocument.Unprotect
ActiveDocument.Bookmarks("Text1").Range.Fields(1).Result.Text = Str1
ActiveDocument.Protect Type:=wdAllowOnlyFormFields, NoReset:=True
You could also try passing multiple strings and concatenating them, chopping each string into chunks less than 255 characters.

Read file using MS Access

I am working on ms access 2013 but found some error. I'm trying to read data from text file but it show error. I search everywhere but not replicate the problem. Please help me to resolve this problem.
Code
Set fs = Application.FileSearch 'Get Error on this line
With fs
Debug.Print CABPath
.LookIn = CABPath
.SearchSubFolders = True
.FileName = ConFileNm
If .Execute() > 0 Then
For FileNum = 1 To .FoundFiles.Count
Next
End If
End With
Error Description
Run-time error 2455:
You entered an expression that has an invalid reference to the property FileSearch
Application.FileSearch, has been discontinued since 2007 versions. So it would not be available to use on 2013. You have some alternatives like Scripting.FileSystem object. There is some explanation and alternatives in this site : http://www.mrexcel.com/forum/excel-questions/268046-application-filesearch-gone-excel-2007-alternatives.html
Hope this helps ! Good luck.
There are also multiple workarounds for this to be found through google;
Function GetFiles(MatchString As String, StartDirectory As String, Optional DrillSubfolders As Boolean = False) As Variant
Dim Results() As Variant
ReDim Results(0 To 0) As Variant
CheckFiles Results, MatchString, StartDirectory, DrillSubfolders
If UBound(Results) > 0 Then
GetFiles = Results
Else
GetFiles = ""
End If
End Function
Sub CheckFiles(ByRef Results As Variant, MatchString As String, StartDir As String, Drill As Boolean)
Dim fso As Object
Dim fld As Object
Dim sf As Object
Dim fil As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set fld = fso.GetFolder(StartDir)
For Each fil In fld.Files
If LCase(fil.Name) Like LCase(MatchString) Then
If LBound(Results) > 0 Then
ReDim Preserve Results(1 To UBound(Results) + 1)
Else
ReDim Results(1 To 1)
End If
Results(UBound(Results)) = fil.Name
End If
Next
If Drill Then
For Each sf In fld.SubFolders
CheckFiles Results, MatchString, sf.Path, Drill
Next
End If
Set fil = Nothing
Set sf = Nothing
Set fld = Nothing
Set fso = Nothing
End Sub
You would call this in your form through something like this;
Dim FileList As Variant
Dim Counter As Long
FileList = GetFiles("*.jpeg", "c:\folder\subfolder", True)
' to NOT look in subfoldres:
'FileList = GetFiles("*.jpeg", "c:\folder\subfolder", True)
If IsArray(FileList) Then
With DoCmd
.SetWarnings False
For Counter = LBound(FileList) To UBound(FileList)
.RunSQL "INSERT INTO [mytable] (FilePath) VALUES ('" & _
FileList(Counter) & "')"
Next
.SetWarnings True
End With
End If
NOTE: Code found through google: http://www.experts-exchange.com/Database/MS_Access/Q_28027899.html

VBA ActiveDocument Concerns / Alternatives?

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.