I have been looking all over for an answer to this issue. It seems like it should be a relatively simple fix but I'm not sure what I'm missing here.
The outcome should be the user selects a file from a folder (PickFile is a function that does that). Then from that selected file it will open that word doc, copy all of it's contents and paste it into DocText field in the form.
Any help or push in the right direction would be really appreciated.
I've been looking all over but nothing I've found has worked.
Private Sub Updatebtn_Click()
Dim FName As String
Dim WordApp As Object
Dim WordDoc As Object
Dim WordRng As Object
Dim s As String
'Add new SOP Doc
s = PickFile("\\page\data\NFInventory\groups\CID\SOPs\", False, True)
If s <> "" Then FileName = s
'Update SOP Doc Text
StatusBox = ""
doctxt = ""
FName = "\\page\data\NFInventory\groups\CID\SOPs\" & FileName
'Status "Loading SOP..."
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
'Status "Opening SOP..."
Set WordDoc = WordApp.Documents.Open(FName)
'Status "Copying Text..."
Set WordRng = WordDoc.Range(1)
WordRng.WholeStory
WordRng.Copy
'Status "Pasting Text..."
DocText.SetFocus
DoCmd.RunCommand acCmdPaste ' <----error
Nametxt.SetFocus
If IsNull(Nametxt) Then Nametxt = Left(doctxt, 10)
'Status "Closing Word..."
WordDoc.Close False
WordApp.Quit False
'Status "Done"
Set WordApp = Nothing
Set WordDoc = Nothing
Set WordRng = Nothing
End Sub
Related
I am modifying someone's access database. The person has a button to create a report that fills out a preprinted form on a dot matrix printer. Now he would like to print it out on a laser printer. I suggested creating a Word document and have Access fill it out and then he can print however many copies he needs.
The previous programmer created a really nice way to print preview and print the reports. I want to add a button to print it to Word.
I have created a document with bookmarks.
I have added the button and have added the code as follows:
Private Sub Print_Test_Click()
On Error GoTo Err_Print_Test_Click
'Print customer slip for current customer.
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim dbs As DAO.Database
Dim rs As DAO.Recordset
Dim SelectNum As Long
'Avoid error 429, when Word isn't open.
On Error Resume Next
Err.Clear
'Set wApp object variable to running instance of Word.
Set wApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
'If Word isn't open, create a new instance of Word.
Set wApp = New Word.Application
End If
Set dbs = CurrentDb
If Me.OpenArgs = "FromViewContracts" Then
Set wDoc = wApp.Documents.Open("C:\Shafer\Contract.dotx", , True)
SelectNum = Forms![PrintDialog]![ContractNum]
Set rs = dbs.OpenRecordset("SELECT * FROM PRINTContract WHERE ContNum = SelectNum")
Else
Set wDoc = wApp.Documents.Open("C:\Shafer\Invoice.dotx", , True)
SelectNum = Forms![PrintDialog]![InvoiceNum]
Set rs = dbs.OpenRecordset("SELECT * FROM PRINTInvoice WHERE InvNum = SelectNum")
End If
If rs.NoMatch Then
MsgBox "Record not found."
GoTo Exit_Print_Test_Click
Else
MsgBox "Customer name: " & rs!Customers.Name
End If
wApp.Visible = True
wDoc.Bookmarks("CustName").Range.Text = Nz(rs!Customers.Name, "")
wDoc.Bookmarks("CustAddress").Range.Text = Nz(rs!Customers.Address, "")
wDoc.Bookmarks("CustCity").Range.Text = Nz(rs!Customers.City, "")
wDoc.Bookmarks("CustState").Range.Text = Nz(rs!Customers.State, "")
wDoc.Bookmarks("CustZip").Range.Text = Nz(rs!Customers.Zip, "")
wDoc.Bookmarks("Date").Range.Text = Nz(rs!Date, "")
wDoc.Bookmarks("ContNum").Range.Text = Nz(rs!ContNum, "")
If Me.OpenArgs = "FromViewContracts" Then
' Contract bookmarks here
Else
wDoc.Bookmarks("InvNum").Range.Text = Nz(rs!InvNum, "")
wDoc.Bookmarks("SalesPerson").Range.Text = Nz(rs!Salesperson, "")
wDoc.Bookmarks("Terms").Range.Text = Nz(rs!Terms.Name, "")
End If
wApp.Visible = True
rs.Close
rsTable.Close
Set wDoc = Nothing
Set wApp = Nothing
Set rs = Nothing
Set rsTable = Nothing
Exit Sub
Exit_Print_Test_Click:
Exit Sub
Err_Print_Test_Click:
MsgBox Err.Description
Resume Exit_Print_Test_Click
End Sub
Here is the problem: When this runs, all I get is "Record Not Found"
If I display the value of InvNum or ContNum I have a value, lets say 18500. If I display the value of SelectNum, I have a value of 18500. But I cannot get it to work.
If I change SelectNum to 18500 in the Select statement, it works.
Please help.
I want to copy a certain section (e.g. subject of the document then main body) to another Word document. The documents have different formatting so I need to copy to a predetermined location in the document.
The code below copies the whole of the source document to the target document.
Sub CopyPaste()
Dim Word As New Word.Application
Dim WordDoc As New Word.Document 'active document
Dim WordDoc1 As New Word.Document 'document to extract from
Dim dialogBox As FileDialog
Set dialogBox = Application.FileDialog(msoFileDialogOpen)
Dim Dest_path As String
dialogBox.AllowMultiSelect = False
dialogBox.Title = "Select a file to copy from"
'Show the file path and file name
If dialogBox.Show = -1 Then
MsgBox "You have selected: " & dialogBox.SelectedItems(1)
End If
' Starts extracting from source document
Set WordDoc1 = Word.Documents.Open(dialogBox.SelectedItems(1), ReadOnly:=True)
Application.Browser.Target = wdBrowseSection
For i = 1 To ((WordDoc1.Sections.Count) - 1)
WordDoc1.Bookmarks("\Section").Range.Copy
'Paste into an active document
ActiveDocument.Bookmarks("\Section").Range.PasteAndFormat wdFormatOriginalFormatting
WordDoc.ActiveWindow.Visible = True
WordDoc1.Close
Next i
End Sub
Since you're apparently running this from Word with an activedocument, you really don't want any of:
Dim Word As New Word.Application
Dim WordDoc As New Word.Document 'active document
Dim WordDoc1 As New Word.Document 'document to extract from
since that starts a new Word session and two new empty Word documents before you even get to the dialog.
As for:
.Bookmarks("\Section")
that only works in code like:
Set Rng = ActiveDocument.GoTo(What:=wdGoToSection, Name:=i)
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\section")
Try something along the lines of:
Sub Replicate()
Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.Title = "Select a file for content replication"
'Show the file path and file name
If .Show = -1 Then
MsgBox "You have selected: " & .SelectedItems(1)
Set DocSrc = Documents.Open(.SelectedItems(1), ReadOnly:=True, Visible:=False)
Else: Exit Sub
End If
End With
Set DocTgt = ActiveDocument
' Starts extracting from source document
For i = 1 To ((DocSrc.Count) - 1)
Set RngTgt = DocTgt.Sections(i).Range
RngTgt.End = RngTgt.End - 1
Set RngSrc = DocSrc.Sections(i).Range
RngSrc.End = RngSrc.End - 1
RngTgt.FormattedText = RngSrc.FormattedText
Next i
DocSrc.Close False
End Sub
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 am writing VBA to pull in the "Last Saved By" user that is identified on under the "Properties" of a file.
I am able to access the "Last Modified Date" & "Last Accessed Date". But I am completely stumped on getting the "Last Saved By" data.
Please let there be someone out there that knows how to do this!!! :)
Here is the current code I am using to extract the "Last Modified Date":
Function FileLastModifiedDate(strFullFileName As String)
Dim fs As Object, f As Object, s As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
s = UCase(strFullFileName) & vbCrLf
s = f.datelastmodified
FileLastModifiedDate = s
Set fs = Nothing: Set f = Nothing
End Function
The Function below will work for both Excel and Word Files:
Function FileLastSavedBy(strFullFileName As String)
Dim fs As Object, f As Object, s As String
Dim wb As Workbook
Dim wordApp As Object
Dim wordDoc As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
If UCase(strFullFileName) Like "*XLS*" Then ' <-- check Excel file
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(strFullFileName)
Set wb = Workbooks.Open(f)
FileLastSavedBy = wb.BuiltinDocumentProperties("Last Author")
wb.Close False
Set fs = Nothing
Set f = Nothing
ElseIf UCase(strFullFileName) Like "*DOC*" Then ' <-- check Word file
Set wordApp = CreateObject("word.Application")
Set wordDoc = wordApp.Documents.Open(strFullFileName)
FileLastSavedBy = wordDoc.BuiltinDocumentProperties("Last Author")
wordDoc.Close False
Set wordDoc = Nothing
wordApp.Quit
Set wordApp = Nothing
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
End Function
Sub Code (to test the Function)
Sub testFunc()
Dim a As String
a = FileLastSavedBy("C:\Users\Shai\Desktop\North Carolina.xlsx") '<-- modify this to your file name and path (Excel File)
a = FileLastSavedBy("C:\Users\Shai\Desktop\GanName.Docx") '<-- modify this to your word document name and path (Word document)
MsgBox a
End Sub
I'm pretty sure I'm real close on this one, I used a combination of this question for text selection and this other question regarding importing tables for what I've gotten so far.
I'm trying to find certain value in a word file, with the most identifiable preceding text being a "VALUE DATE" on the line above it. The value I want is in the line below this "VALUE DATE". I want the macro to be able to search the word doc for the desired text and paste it into excel, as normally we would have to do this manually about 50 times. Very tedious.
For reference here's what the text looks like in the word doc.
TRANSACTIONS VALUE DATE
31-08-15 X,XXX.XX
I want to pull value X,XXX.XX and paste it into a destination in excel, let's just use A1 for simplicity.
Sub wordscraper9000()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
'''''dim tbl as object --> make string
Dim TextToFind As String, TheContent As String
Dim rng1 As Word.Range
FlName = Application.InputBox("Enter filepath of .doc with desired information")
'establish word app object
On Error Resume Next
Set oWordApp = GetObject(, "Word.application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'open word doc
Set oWordDoc = oWordApp.documents.Open(FlName)
'--> enter something that will skip if file already open
'''''set tbl = oworddoc.tables(1) --> set word string
'declare excel objects
Dim wb As Workbook, ws As Worksheet
'Adding New Workbook
Set wb = Workbooks.Add
'Saving the Workbook
ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
Set ws = wb.Sheets(1)
'what text to look for
TextToFind = "VALUE DATE"
'''''problems here below
Set rng1 = oWordApp.ActiveDocument.Content
rng.Find.Execute findtext:=TextToFind, Forward:=True
If rng1.Find.found Then
If rng1.Information(wdwithintable) Then
TheContent = rng.Cells(1).Next.Range.Text 'moves right on row
End If
Else
MsgBox "Text '" & TextToFind & "' was not found!"
End If
'copy text range and paste into cell A1
'tbl.range.copy
ws.Range("A1").Activate
ws.Paste
End Sub
At the line
set rng1.oWordApp.ActiveDocument.Content
I get a run-time 8002801d error - automation error, library not registered.
I couldn't find anything on here that was perfect for my case, however the 2nd question I linked to is very, very close to what I want, however I'm trying to import text rather than a table.
This will extract the "X,XXX.XX" value into a new Excel file, sheet 1, cell A1:
Option Explicit
Public Sub wordscraper9000()
Const FIND_TXT As String = "VALUE DATE"
Const OUTPUT As String = "\DummyWB.xlsx"
Dim fName As Variant, wrdApp As Object, wrdTxt As Variant, sz As Long, wb As Workbook
fName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
"Enter filepath of .doc with desired information")
If fName <> False Then
'get Word text --------------------------------------------------------------------
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set wrdApp = CreateObject("Word.Application")
Err.Clear
End If: wrdApp.Visible = False
wrdTxt = wrdApp.Documents.Open(fName).Content.Text: wrdApp.Quit
'get value ------------------------------------------------------------------------
sz = InStr(1, wrdTxt, FIND_TXT, 1)
If Len(sz) > 0 Then
wrdTxt = Trim(Right(wrdTxt, Len(wrdTxt) - sz - Len(FIND_TXT)))
wrdTxt = Split(Trim(Right(wrdTxt, InStr(wrdTxt, " "))))(0)
'save to Excel ----------------------------------------------------------------
Set wb = Workbooks.Add
wb.Sheets(1).Cells(1, 1) = wrdTxt
Application.DisplayAlerts = False
wb.Close True, CreateObject("WScript.Shell").SpecialFolders("Desktop") & OUTPUT
Application.DisplayAlerts = True
End If
End If
End Sub
.
This code is specific to this pattern:
"Reference" (any # of spaces) (any word without a space) (any # of spaces) "ExtractValue"
Search for reference (FIND_TXT)
Find and skip the next word (text without a space in it) after any number of spaces or empty lines
Extract the second word, separated by any number of spaces or lines from the skipped first word
Modifying your code a bit and if the information you want is in a fixed position within a Word table, you can do this:
Sub wordscraper90000()
Dim oWordApp As Object, oWordDoc As Object
Dim FlName As String
Dim TheContent As String
FlName = Application.GetOpenFilename("Word Files (*.Doc*),*.Doc*", , _
"Enter filepath of .doc with desired information")
'establish word app object
On Error Resume Next
Set oWordApp = GetObject(, "Word.application")
If Err.Number <> 0 Then
Set oWordApp = CreateObject("Word.application")
End If
Err.Clear
On Error GoTo 0
oWordApp.Visible = True
'open word doc
Set oWordDoc = oWordApp.Documents.Open(FlName)
'declare excel objects
Dim wb As Workbook, ws As Worksheet
'Adding New Workbook
Set wb = Workbooks.Add
'Saving the Workbook
ActiveWorkbook.SaveAs "C:\Users\iansch\Desktop\DummyWB.xlsx"
Set ws = wb.Sheets(1)
TheContent = oWordDoc.Tables.Item(1).Cell(2, 3).Range.Text
ws.Range("A1").Activate
ws.Range("A1").Value = Trim(Replace(TheContent, Chr(7), Chr(32))) 'Remove strange character at the end
End Sub
Whereas the data to be extracted it is in row 2, column 3: