I whould like to fill a word with values and export to pdf multiple times.
If is use a SaveAs2 the firt time it make a pdf but second or third it doesen't work.
'ActiveDocument.SaveAs2 FileName:="C:\alap\" & fajlneve & ".pdf", FileFormat:=wdFormatPDF
If I use the CutePDf printer, the result is the same, first time i=1 it works, but second it doesen't.
Public compname As String
Public filename As String
Function FillwordForm()
Dim appword As Word.Application
Dim doc As Word.Document
Dim Path As String
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = New Word.Application
appword.Visible = True
End If
Path = "C:\pelda\MINTA.docx"
Set doc = appword.Documents.Open(Path, , True)
With doc
.formfields("szerzCegnev").result = compname
End With
appword.Visible = True
appword.Activate
Set doc = Nothing
Set appword = Nothing
appword.ActivePrinter = "CutePDF Writer"
ActiveDocument.PrintOut OutPutFileName:="C:\pelda\" & filename & ".pdf"
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Word.Application.Quit
End Function
'---------------------------------------------------------------
Sub cucc()
For i = 1 To 2
compname = Cells(i, 1)
filename = Cells(i, 2)
Call FillwordForm
Next i
End Sub
can you use:
ActiveDocument.SaveAs2(docname,17);
?
(17 is PDF-format -link to fileformats)
Greetz
Related
I wrote code in Access database 2016 contains functions and macros, then I move this file to share with some users that don't have Access Application so, I install Access runtime it works well but I face many problems with reference libraries.
I decided to use late binding (by writing EarlyBinding = 0 in a database property of VBA editor)
and uncheck all references except two (I can't uncheck) and covert
Set appWord = New Word.Application
to
Set appWord = CreateObject(Word.Application)
note 1: I have a function to open Word document from Access form.
note 2: I convert the database extension from .accdb to .accdr
after I made changes in late binding and convert the previous statement no message error (for reference) appears but the function of open Word doesn't work.
is there a tool like Access runtime for Word? so I can't open for this reason?
below the code of this function:
Function fillWordForm()
Dim appWord As Object
Dim doc As Object
Dim path As String
Dim myID As String
On Error Resume Next
Error.Clear
'Set appWord = CreateObject("word.application")
Set appWord = CreateObject(Word.Application)
If Err.Number <> 0 Then
'Set appWord = New Word.Application
'Set appWord = CreateObject(Word.Application)
appWord.Visible = True
End If
'path = Application.CurrentProject.path & "\H_F.docx"
'path = "\\ubcdatacenter\Public\UBCIEDatabase\DOC\H_F.docx"
path = "C:\Users\LENOVO\Desktop\UBC Database\H_F.docx"
If FileExists(path) = False Then
MsgBox "Template File Not Found", vbExclamation, "File Not Found"
Else
Set doc = appWord.Documents.Add(path, , True)
myID = DLookup("ID", "Exports_imports_Table", "[ID] = " & Me.ID)
With doc
.FormFields("BookID").Result = [ID]
.FormFields("Book_BC_date").Result = Me.date_BC
.FormFields("Book_AH_date").Result = Me.date_AH
.FormFields("Book_AH_date").Result = Me.date_AH
.FormFields("BookTopic").Result = Me.topic
.FormFields("BookProjectName").Result = Me.projectName
.FormFields("BookCompanyName").Result = Me.companyName
.FormFields("BookContent").Range.Text = Me.content
'Result = Me.content
appWord.Visible = True
appWord.Active
End With
Set doc = Nothing
Set appWord = Nothing
End If
End Function
this code to ensure that file is excite
Function FileExists(ByVal strFile As String, Optional bFindFolders As Boolean) As Boolean
'Purpose: Return True if the file exists, even if it is hidden.
'Arguments: strFile: File name to look for. Current directory searched if no path included.
' bFindFolders. If strFile is a folder, FileExists() returns False unless this argument is True.
'Note: Does not look inside subdirectories for the file.
'Author: Allen Browne. http://allenbrowne.com June, 2006.
Dim lngAttributes As Long
'Include read-only files, hidden files, system files.
lngAttributes = (vbReadOnly Or vbHidden Or vbSystem)
If bFindFolders Then
lngAttributes = (lngAttributes Or vbDirectory) 'Include folders as well.
Else
'Strip any trailing slash, so Dir does not look inside the folder.
Do While Right$(strFile, 1) = "\"
strFile = Left$(strFile, Len(strFile) - 1)
Loop
End If
'If Dir() returns something, the file exists.
On Error Resume Next
FileExists = (Len(Dir(strFile, lngAttributes)) > 0)
End Function
what should also convert to make all code late binding?
Editing
after Mathieu's changes
Function fillWordForm()
Dim appWord As Object
Dim doc As Object
Dim path As String
Dim myID As String
On Error Resume Next
Error.Clear
Set appWord = GetWordApp
If appWord Is Nothing Then
'can't get ahold of Word.Application... now what?
MsgBox "No thing :(((((((((((((("
'Exit Sub
End If
appWord.Visible = True '<~ unconditional
'Set appWord = CreateObject("word.application")
'Set appWord = CreateObject(Word.Application)
'If Err.Number <> 0 Then
'Set appWord = New Word.Application
'Set appWord = CreateObject(Word.Application)
'appWord.Visible = True
'End If
'path = Application.CurrentProject.path & "\H_F.docx"
path = "\\ubcdatacenter\Public\UBCIEDatabase\DOC\H_F.docx"
'path = "C:\Users\LENOVO\Desktop\UBC Database\H_F.docx"
If FileExists(path) = False Then
MsgBox "Template File Not Found", vbExclamation, "File Not Found"
Else
Set doc = appWord.Documents.Add(path, , True)
myID = DLookup("ID", "Exports_imports_Table", "[ID] = " & Me.ID)
With doc
.FormFields("BookID").Result = [ID]
.FormFields("Book_BC_date").Result = Me.date_BC
.FormFields("Book_AH_date").Result = Me.date_AH
.FormFields("Book_AH_date").Result = Me.date_AH
.FormFields("BookTopic").Result = Me.topic
.FormFields("BookProjectName").Result = Me.projectName
.FormFields("BookCompanyName").Result = Me.companyName
.FormFields("BookContent").Range.Text = Me.content
'Result = Me.content
appWord.Visible = True
appWord.Active
End With
Set doc = Nothing
Set appWord = Nothing
End If
End Function
Private Function GetWordApp() As Object
On Error Resume Next
Set GetWordApp = CreateObject("Word.Application")
End Function
'Set appWord = CreateObject("word.application")
Set appWord = CreateObject(Word.Application)
If Err.Number <> 0 Then
'Set appWord = New Word.Application
'Set appWord = CreateObject(Word.Application)
appWord.Visible = True
End If
Several things are wrong with this code. CreateObject wants a ProgID string, and you're giving it Word.Application, which shouldn't even compile (expecting "Object Required" error on the .Application member call, and "Variable not declared"1 on Word). If it compiles, you've referenced the Word object library and need to remove it. The commented-out statement is well-formed.
Now If Err.Number <> 0, then appWord wasn't Set, and its reference is Nothing. That means if CreateObject fails, the code enters an error state and remains in an error state for the remainder of the procedure, because the error is never cleared, and error handling is never restored.
Take the error stuff into its own limited scope:
Private Function GetWordApp() As Object
On Error Resume Next
Set GetWordApp = CreateObject("Word.Application")
End Function
Now your procedure only needs to check if the function returned a valid object reference:
Set appWord = GetWordApp
If appWord Is Nothing Then
'can't get ahold of Word.Application... now what?
Exit Sub
End if
appWord.Visible = True '<~ unconditional
1 assuming Option Explicit is at the top of the module, as it should be.
I have a code which copies data from a spreadsheet into specific bookmarks on a particular document. When it is run it works fine, but the bookmarks are deleted from the spreadsheet. Is there a way I can keep the bookmarks in the document
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Open "C:\GR1 CPA Test1.docx" ' change as required
With objWord.ActiveDocument
.Bookmarks("CN1").Range.Text = ws.Range("C25").Value
.Bookmarks("CN2").Range.Text = ws.Range("C25").Value
.Bookmarks("CNo").Range.Text = ws.Range("C26").Value
.Bookmarks("CL1").Range.Text = ws.Range("C27").Value
.Bookmarks("Ex1").Range.Text = ws.Range("C28").Value
.Bookmarks("Ex2").Range.Text = ws.Range("C28").Value
.Bookmarks("Su1").Range.Text = ws.Range("C29").Value
.Bookmarks("Su2").Range.Text = ws.Range("C29").Value
.Bookmarks("Su3").Range.Text = ws.Range("C29").Value
.Save
.Close
End With
Set objWord = Nothing
End Sub
I've used this in the past:
'Replace the text in a bookmark or insert text into an empty (zero-length) bookmark
Sub SetBookmarkText(oDoc As Word.Document, sBookmark As String, sText As String)
Dim BMRange As Word.Range
If oDoc.Range.Bookmarks.Exists(sBookmark) Then
Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
BMRange.Text = sText
oDoc.Range.Bookmarks.Add sBookmark, BMRange
Else
MsgBox "Bookmark '" & sBookmark & "' not found in document '" & oDoc.Name & "'" & _
vbCrLf & "Content not updated"
End If
End Sub
Usage:
Dim ws As Worksheet, doc as object
Set ws = ThisWorkbook.Sheets("Sheet6")
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set doc = objWord.Documents.Open("C:\GR1 CPA Test1.docx")
SetBookmarkText doc, "CN1", ws.Range("C25").Value
SetBookmarkText doc, "CN2", ws.Range("C25").Value
'etc etc
doc.Save
doc.Close
Set objWord = Nothing
End Sub
I am working on the macro which can copy and paste the data excel to word to create the offer letter. Example, we already have the offer letter template in which we will have to modify the few details to roll out offer letter. could you please help me to fix this or it would be big help if you can provide me the new code.
please find the below codes
Public Declare Function CountClipboardFormats Lib "user32" () As Long
Dim appWd As Word.Application
Dim wdFind As Object
Dim ClipT As String
Function IsClipboardEmpty() As Boolean
IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function
Sub CheckClipBrd()
If IsClipboardEmpty() = True Then
ClipEmpty.PutInClipboard
End If
End Sub
Sub FormatPaste()
wdFind.Replacement.Text = ""
wdFind.Forward = True
wdFind.Wrap = wdFindContinue
wdFind.Execute
Call CheckClipBrd
appWd.Selection.Paste
CutCopyMode = False
End Sub
Sub NoFormatPaste()
wdFind.Replacement.Text = ""
wdFind.Forward = True
wdFind.Wrap = wdFindContinue
wdFind.Execute
Call CheckClipBrd
appWd.Selection.PasteSpecial DataType:=wdPasteText
CutCopyMode = False
End Sub
Sub CopyDatatoWord()
Dim docWD As Word.Document
Dim OL As Object
Set appWd = CreateObject("Word. Application")
appWd.Visible = True
Set docWD = appWd.Documents.Open("\\X:\Users\yuan\Financial Director - Offer Letter.docx")
'Select Sheet where copying from in excel
Set OL = Sheets("OL")
Set wdFind = appWd.Selection.Find
ClipT = " "
OL.Range("B4").Copy
wdFind.Text = "<Date>"
Call FormatPaste
OL.Range("B6").Copy
wdFind.Text = "Qwerty02"
Call FormatPaste
OL.Range("B7").Copy
wdFind.Text = "Qwerty03"
Call FormatPaste
OL.Range("B8").Copy
wdFind.Text = "Qwerty04"
Call FormatPaste
OL.Range("B9").Copy
wdFind.Text = "Qwerty05"
Call FormatPaste
OL.Range("B11").Copy
wdFind.Text = "Qwerty06"
Call FormatPaste
OL.Range("B13").Copy
wdFind.Text = "Qwerty07"
Call FormatPaste
OL.Range("B15").Copy
wdFind.Text = "Qwerty08"
Call NoFormatPaste
OL.Range("B17").Copy
wdFind.Text = "Qwerty09"
Call NoFormatPaste
OL.Range("B18").Copy
wdFind.Text = "Qwerty10"
Call NoFormatPaste
OL.Range("B20").Copy
wdFind.Text = "Qwerty11"
Call NoFormatPaste
OL.Range("B22").Copy
wdFind.Text = "Qwerty12"
Call NoFormatPaste
OL.Range("B24").Copy
wdFind.Text = "Qwerty13"
Call NoFormatPaste
End If
'docWD.SaveAs (Dir2 & ".docx")
docWD.SaveAs ("\\annapurna\Shared\Practice Quarterly Reports\Q1_2011\Test.docx")
'appWD.Quit
Set appWd = Nothing
Set docWD = Nothing
End Sub
There is probably a simpler way to do this, but what I've done in the past is embed a WORD template into my excel workbook on another worksheet. The WORD doc has empty bookmarks for where I want to input info. So I basically just open the embedded doc, save a blank copy of it to the user's computer (business requirement to ensure we also use a blank template), then open that blank copy we just saved and fill it out. Then save it.
'opens embedded doc
Set o = .OLEObjects("Object 1")
o.Verb xlVerbOpen
Dim WDApp As Word.Application
Dim wdDoc2 As Word.Document
Dim nIndex As Integer
Set WDApp = GetObject(, "Word.Application")
Set wdDoc = WDApp.ActiveDocument
'must have already named your FilePath
'saves blank copy of template to the user's computer. will override if one exists.
wdDoc.SaveAs2 FilePath & "temp-name" & ".docx"
'closes out of the original doc. then opens the one we saved to the computer
wdDoc.Close
WDApp.Quit
Set WDApp2 = CreateObject("Word.Application")
Set wdDoc2 = WDApp2.Documents.Open(FilePath & "temp=name" & ".docx")
Set objRange = wdDoc2.Bookmarks("Plan").Range
WDApp2.Visible = False
Sheets("Sheet2").Select
'fills out the bookmarks in the doc with values from the worksheet
wdDoc2.FormFields("Pol").Result = Range("B2").Value & Range("E2").Value
wdDoc2.FormFields("Pol2").Result = Range("B2").Value & Range("E2").Value
wdDoc2.FormFields("Name").Result = Range("C3").Value
wdDoc2.FormFields("Name2").Result = Range("C3").Value
wdDoc2.FormFields("Owner").Result = Range("C8").Value
wdDoc2.FormFields("DueDate").Result = Range("B5").Value
wdDoc2.FormFields("Amt").Result = Format(Range("B6").Value, "Currency")
'shows the doc so the use could review, and then press OK to save (not required)
WDApp2.Visible = True
MsgBox "Please Review Letter and Press OK to Continue"
WDApp2.Visible = False
'saves as a docx and a PDF
wdDoc2.SaveAs2 FilePath & "filename" & ".docx"
wdDoc2.SaveAs2 FilePath & "filename" & ".pdf", 17
wdDoc2.Close
WDApp2.Quit
MsgBox "Letter Created Successfully!"
Set WDApp2 = Nothing
Set wdDoc2 = Nothing
Maybe that could help you if all else fails.
I am new to VBA and obviously I am missing something. My code works for opening a word doc and sending data to it BUT does NOT for an ALREADY OPEN word doc. I keep searching for an answer on how to send info from Excel to an OPEN Word doc/Bookmark and nothing works.
I hope it is okay that I added all the code and the functions called. I really appreciate your help!
What I have so far
Sub ExcelNamesToWordBookmarks()
On Error GoTo ErrorHandler
Dim wrdApp As Object 'Word.Application
Dim wrdDoc As Object 'Word.Document
Dim xlName As Excel.Name
Dim ws As Worksheet
Dim str As String 'cell/name value
Dim cell As Range
Dim celldata As Variant 'added to use in the test
Dim theformat As Variant 'added
Dim BMRange As Object
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Set wb = ActiveWorkbook
strPath = wb.Path
If strPath = "" Then
MsgBox "Please save your Excel Spreadsheet & try again."
GoTo ErrorExit
End If
'GET FILE & path of Word Doc/Dot
strPathFile = strOpenFilePath 'call a function in MOD1
If strPathFile = "" Then
MsgBox "Please choose a Word Document (DOC*) or Template (DOT*) & try again." 'strPath = Application.TemplatesPath
GoTo ErrorExit
End If
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
'NONE OF THESE WORK
Set wrdApp = GetObject(strPathFile, "Word.Application")
'Set wrdApp = Word.Documents("This is a test doc 2.docx")
'Set wrdApp = GetObject(strPathFile).Application
Else
'all ok 'Create a new Word Session
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
wrdApp.Activate 'bring word visiable so erros do not get hidden.
'Open document in word
Set wrdDoc = wrdApp.Documents.Open(Filename:=strPathFile) 'Open vs wrdApp.Documents.Add(strPathFile)<=>create new Document1 doc
End If
'Loop through names in the activeworkbook
For Each xlName In wb.Names
If Range(xlName).Cells.Count = 1 Then
celldata = Range(xlName.Value)
'do nothing
Else
For Each cell In Range(xlName)
If str = "" Then
str = cell.Value
Else
str = str & vbCrLf & cell.Value
End If
Next cell
'MsgBox str
celldata = str
End If
'Get format and strip away the spacing, negative color etc etc
'I know this is not right... it works but not best
theformat = Application.Range(xlName).DisplayFormat.NumberFormat
If Len(theformat) > 8 Then
theformat = Left(theformat, 5) 'was 8 but dont need cents
Else
'do nothing for now
End If
If wrdDoc.Bookmarks.Exists(xlName.Name) Then
'Copy the Bookmark's Range.
Set BMRange = wrdDoc.Bookmarks(xlName.Name).Range.Duplicate
BMRange.Text = Format(celldata, theformat)
'Re-insert the bookmark
wrdDoc.Bookmarks.Add xlName.Name, BMRange
End If
Next xlName
'Activate word and display document
With wrdApp
.Selection.Goto What:=1, Which:=2, Name:=1 'PageNumber
.Visible = True
.ActiveWindow.WindowState = wdWindowStateMaximize 'WAS 0 is this needed???
.Activate
End With
GoTo WeAreDone
'Release the Word object to save memory and exit macro
ErrorExit:
MsgBox "Thank you! Bye."
Set wrdDoc = Nothing
Set wrdApp = Nothing
Exit Sub
'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & "; There is a problem"
If Not wrdApp Is Nothing Then
wrdApp.Quit False
End If
Resume ErrorExit
End If
WeAreDone:
Set wrdDoc = Nothing
Set wrdApp = Nothing
End Sub
file picking:
Function strOpenFilePath() As String
Dim intChoice As Integer
Dim iFileSelect As FileDialog 'B
Set iFileSelect = Application.FileDialog(msoFileDialogOpen)
With iFileSelect
.AllowMultiSelect = False 'only allow the user to select one file
.Title = "Please... Select MS-WORD Doc*/Dot* Files"
.Filters.Clear
.Filters.Add "MS-WORD Doc*/Dot* Files", "*.do*"
.InitialView = msoFileDialogViewDetails
End With
'make the file dialog visible to the user
intChoice = Application.FileDialog(msoFileDialogOpen).Show
'determine what choice the user made
If intChoice <> 0 Then
'get the file path selected by the user
strOpenFilePath = Application.FileDialog( _
msoFileDialogOpen).SelectedItems(1)
Else
'nothing yet
End If
End Function
checking if file is open...
Function FileLocked(strFileName As String) As Boolean
On Error Resume Next
' If the file is already opened by another process,
' and the specified type of access is not allowed,
' the Open operation fails and an error occurs.
Open strFileName For Binary Access Read Write Lock Read Write As #1
Close #1
' If an error occurs, the document is currently open.
If Err.Number <> 0 Then
' Display the error number and description.
MsgBox "Function FileLocked Error #" & str(Err.Number) & " - " & Err.Description
FileLocked = True
Err.Clear
End If
End Function
ANSWER BELOW. Backstory... So, after input from you guys and more research I discovered that I needed to set the active word document by using the file selection the user picked and that is then passed via late binding to the sub as an object to process. NOW it works if the word file is not in word OR if it is currently loaded into word AND not even the active document. The below code replaces the code in my original question.
Set Object app as word.
grab the file name.
Make the word doc selected active to manipulate.
Set the word object to the active doc.
THANK YOU EVERYONE!
If FileLocked(strPathFile) Then 'Err.Number = 70 if open
'read / write file in use 'do something
Set wrdApp = GetObject(, "Word.Application")
strPathFile = Right(strPathFile, Len(strPathFile) - InStrRev(strPathFile, "\"))
wrdApp.Documents(strPathFile).Activate ' need to set picked doc as active
Set wrdDoc = wrdApp.ActiveDocument ' works!
This should get you the object you need.
Dim WRDFile As Word.Application
Set WRDFile = GetObject(strPathFile)
'Have Microsoft Word 16.0 Object Library selected in your references
Dim wordapp As Object
Set wordapp = GetObject(, "Word.Application")
wordapp.Documents("documentname").Select
'works if you only have one open word document. In my case, I'm trying to push updates to word links from excel.
I try to call a VBA subroutine from VBS with passing a string variable from VBS to VBA, but can't find the appropiate syntax:
'VBS:
'------------------------
Option Explicit
Set ArgObj = WScript.Arguments
Dim strPath
mystr = ArgObj(0) '?
'Creating shell object
Set WshShell = CreateObject("WScript.Shell")
'Creating File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Getting the Folder Object
Set ObjFolder = objFSO.GetFolder(WshShell.CurrentDirectory)
'Getting the list of Files
Set ObjFiles = ObjFolder.Files
'Creat a Word application object
Set wdApp = CreateObject("Word.Application")
wdApp.DisplayAlerts = True
wdApp.Visible = True
'Running macro on each wdS-File
Counter = 0
For Each objFile in objFiles
If UCase(objFSO.GetExtensionName(objFile.name)) = "DOC" Then
set wdDoc = wdApp.Documents.Open(ObjFolder & "\" & ObjFile.Name, 0, False)
wdApp.Run "'C:\Dokumente und Einstellungen\kcichini\Anwendungsdaten\Microsoft\Word\STARTUP\MyVBA.dot'!Test_VBA_with_VBS_Args" (mystr) 'how to pass Argument???
Counter = Counter + 1
End if
Next
MsgBox "Macro was applied to " & Counter & " wd-Files from current directory!"
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
'------------------------
'VBA:
'------------------------
Sub Test_VBA_with_VBS_Args()
Dim wdDoc As Word.Document
Set wdDoc = ActiveDocument
Dim filename As String
Dim mystr As String
'mystr = how to recognize VBS-Argument ???
filename = ActiveDocument.name
MsgBox "..The file: " & filename & " was opened and the VBS-Argument: " & mystr & "recognized!"
wdDoc.Close
End Sub
'------------------------
You need to specify parameters in your VBA Sub and use them as you would do if using it from VBA normally.
For example, I tried the following VBScript
dim wd: set wd = GetObject(,"Word.Application")
wd.Visible = true
wd.run "test", "an argument"
and the VBA
Sub Test(t As String)
MsgBox t
End Sub
which worked successfully, generating a message box.
Addendum to #user69820 answer, if arguments are VBScript variables, they need to be cast as appropriate type before calling the subroutine:
This does not work:
dim argumentVariable
argumentVariable = "an argument"
wd.run "test", argumentVariable
This does:
dim argumentVariable
argumentVariable = "an argument"
wd.run "test", CStr(argumentVariable)
Tested on Excel 2010, Win7SP1 x64