I'm trying to use ms Access to open up ms word, create formfield and tables but always end up empty. I tried using the same code but replacing the entire code between "with doc" to .formfields("TxtDate").result = me.txt2 and is able to transfer whatever i typed in txt2 into the formfield located in ms word. Thus I'm unsure which portion of the code went wrong. Would like to seek help on my code. Thanks
Function FillWordForm()
Dim appword as Word.Application
Dim doc as Word.Document
Dim Path as String
On Error Resume Next
Error.Clear
Path = "H:\project delta\test.docx"
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
Selection.TypeParagraph
Selection.FormFields.Add Range:=Selection.Range, Type:= _
WdFieldFormTextInput
ActiveDocument.FormFields.Shaded = Not ActiveDocument.FormFields.Shaded
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=13, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Table Grid" then
.Style = "Table Grid"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = True
.Cell(1,1).Select
Selection.TypeText Text:="S/N"
.Cell(1,2).Select
Selection.TypeText Text:="Package Title"
.Cell(1,3).Select
Selection.TypeText Text:="Reference"
.Cell(1,4).Select
Selection.TypeText Text:="Month"
End With
appword.Visible = True
appword.Activate
End With
Set doc = Nothing
Set appword = Nothing
End Function
Considering comments, issue is likely due to a Word process still running in background even though not showing in Task Manager. This can be caused by unqualified references to Word objects.
Prefix appword. in front of every Selection and ActiveDocument usage and code should then run every time. It does for me now.
This can also happen with automation code for other Office apps - Excel, Outlook, PowerPoint, etc.
Related
My intention is to use a VBA code to extract the comments from a PowerPoint document and paste the information in a table in Word.
I started to build a code that works on Word and I tried to adapt in to work with PowerPoint. Unfortunately I run in some errors like Error 07 memory issue, while the code works perfectly to extract comments form a word document...
I am lost and do not know what to do...
Is there an expert who could help me verifying the code? I made notes in the code to make it easy to read.
PS: In PowerPoint VBA Editor, I did enabled the reference for Word.
Sub Tansfer_PPT_comments_in_WordDoc()
Dim n As Long
Dim nCount As Long
Dim ppt As Presentation
Dim wdapp As Word.Application
Dim wddoc As Word.Document
Dim wdtable As Table
Set ppt = ActivePresentation
nCount = ActivePresentation.Comments.Count
'Open a Word document
On Error Resume Next
Set wdapp = GetObject(, "Word.Application")
If Err.Number <> 0 Then 'Word isn't already running
Set wdapp = CreateObject("Word.Application")
End If
On Error GoTo 0
'Create word page with landscape orientation
Set wddoc = Documents.Add
wddoc.PageSetup.Orientation = wdOrientLandscape
'Insert a 5-column table
With wddoc
.Content = ""
Set wdtable = .Tables.Add _
(Range:=Selection.Range, _
Numrows:=nCount + 1, _
NumColumns:=5)
End With
'DOCUMENT FORMATTING
'Define Normal and Header style
With wddoc.Styles(wdStyleNormal)
.Font.Name = "Arial"
.Font.Size = 10
.ParagraphFormat.LeftIndent = 0
.ParagraphFormat.SpaceAfter = 6
End With
With wddoc.Styles(wdStyleHeader)
.Font.Size = 8
.ParagraphFormat.SpaceAfter = 0
End With
'Format table
With wdtable
.Range.Style = wdStyleNormal
.AllowAutoFit = False
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Columns(1).PreferredWidth = 2
.Columns(2).PreferredWidth = 20
.Columns(3).PreferredWidth = 40
.Columns(4).PreferredWidth = 8
.Columns(5).PreferredWidth = 40
.Rows(1).HeadingFormat = True
.Columns(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Rows(1).Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.Font.ColorIndex = wdDarkBlue
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColor = wdColorAutomatic
Selection.Shading.BackgroundPatternColor = -603937025
End With
'Add table borders
With wdtable.Borders
.InsideLineStyle = Options.DefaultBorderLineStyle
.InsideLineWidth = Options.DefaultBorderLineWidth
.InsideColor = Options.DefaultBorderColor
.OutsideLineStyle = Options.DefaultBorderLineStyle
.OutsideLineWidth = Options.DefaultBorderLineWidth
.OutsideColor = Options.DefaultBorderColor
End With
'DOCUMENT CONTENT
'Define table headings names
With wdtable.Rows(1)
.Range.Font.Bold = True
.Cells(1).Range.Text = "Page"
.Cells(2).Range.Text = "Comment scope"
.Cells(3).Range.Text = "Comment text"
.Cells(4).Range.Text = "Author"
.Cells(5).Range.Text = "Parexel response"
End With
'Insert information from the comments in ppt into the wddoc table
For n = 1 To nCount
With wdtable.Rows(n + 1)
'Page number
.Cells(1).Range.Text = _
ppt.Comments(n).Scope.Information(wdActiveEndPageNumber)
'The text marked by the comment
.Cells(2).Range.Text = ppt.Comments(n).Scope
'The comment itself
.Cells(3).Range.Text = ppt.Comments(n).Range.Text
'The comment author
.Cells(4).Range.Text = ppt.Comments(n).Author
End With
Next n
ScreenUpdating = True
Application.ScreenRefresh
wddoc.Activate
Set ppt = Nothing
Set wddoc = Nothing
Set wdtable = Nothing
End Sub
Your code will fail at:
ActivePresentation.Comments.Count
since Comments are not a Presentation property. And, once you get over that hurdle, your code will fail at:
.Scope.Information(wdActiveEndPageNumber)
since PowerPoint Comments don't have a scope property and, even if they did, '.Information(wdActiveEndPageNumber)' refers to a Word constant, not a PowerPoint one.
You can't simply take VBA methods, properties, and constants that apply to one application and assume they apply to another in the same way. You need to develop your PowerPoint code using valid PowerPoint methods, properties, and constants.
For some code to get you started on the right tack, see: http://www.pptfaq.com/FAQ00900_Export_comments_to_a_text_file_-PowerPoint_2002_and_later-.htm
So to summarize things, I am creating a word document and pasting an excel table into the Word document. The only problem I'm facing now is that the texts in the Word document is aligned left but I want it Justified. However, no matter what I do I can't seem to get it to justify unless I manually do it on Word.
Please find below my code less all the non-relevant stuff. I'm a VBA noob so how I've been doing it is just copy pasting and trying to adapt it to what I need. So far everything works except the justifying part.
Dim obj As Object
Set obj = GetObject(, "Word.Application")
If obj Is Nothing Then
Set obj = CreateObject("Word.Application")
End If
obj.Visible = True
Set objDoc = obj.Documents.Add
a = Sheets("Print").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Print").Range("A1:F" & a).Copy
objDoc.Range.PasteExcelTable False, False, True
objDoc.Activate
objDoc.Tables(1).AutoFitBehavior wdAutoFitContent
Application.CutCopyMode = False
On Error GoTo 0
With objDoc.Tables(1)
.PreferredWidth = 505
End With
With objDoc.PageSetup
.TopMargin = Application.InchesToPoints(0.71)
.BottomMargin = Application.InchesToPoints(0.71)
.LeftMargin = Application.InchesToPoints(0.71)
.RightMargin = Application.InchesToPoints(0.71)
End With
With objDoc
.Range.ParagraphFormat.LineSpacingRule = wdLineSpace1pt5
'set paragraph spacing after to 0
.Range.ParagraphFormat.SpaceAfter = 10
.Range.ParagraphFormat.Alignment = wdAlignParagraphJustify
End With
Sheets("DCN Inputs").Select
End Sub
The problem is that you use the Word enumeration value wdAlignParagraphJustify but you don't have a reference to the Word object library. Excel VBA doesn't recognize this member of the Word object model without a specific reference (Tools/References).
If you want to use late-binding, as you have otherwise throughout your code, then you need to substitute the numerical value of the enumeration, which in this case is 3. For example:
objDoc.Range.PasteExcelTable False, False, True
objDoc.Activate
Set objTable = objDoc.Tables(1)
With objTable
.AutoFitBehavior wdAutoFitContent
.PreferredWidth = 505
.Range.ParagraphFormat.Alignment = 3 'wdAlignParagraphJustify
End With
Application.CutCopyMode = False
I have several word files. They are build like this
text
text
text
Name: Mick
Date: 1-1-1
text
text
Item: Item11 material: Gold
text
text
I am building a macro that can open a word file, put the name in Cell A1 and put the item in Cell A2. I have found a code on internet and adjusted it a little. The following code makes a selection from the beginning of the word doc until a word is found and copies that selection in a given cell.
I hope someone can show me how i can adjust this so the selection begins right before the needed value an stops after it
code below is for item:
Dim wdApp As Object, wdDoc As Object, wdRng As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("path", False, True, False)
With wdDoc
Set wdRng = .Range(0, 0)
With .Range
With .Find
.Text = "material"
.Forward = True
.MatchWholeWord = True
.MatchCase = True
.Execute
End With
If .Find.found = True Then
wdRng.End = .Duplicate.Start
Sheets("sheet1").Range("A2").value = wdRng
End If
End With
.Close False
End With
.Quit
End With
Set wdRng = Nothing: Set wdDoc = Nothing: Set wdApp = Nothing
Anyone any suggestions?
Try the procedure below. It will open the specified Word document, parse the required values via Regular Expressions, place those values into cells A1 and A2, and then close the Word document.
When calling the procedure, specify the full path and filename of the Word document.
For example: SetNameAndItem "C:\Temp\Doc1.docx"
Public Sub SetNameAndItem(strPath As String)
Dim wdApp As Object: Set wdApp = CreateObject("Word.Application")
Dim wdDoc As Object: Set wdDoc = wdApp.Documents.Open(strPath, False, True, False)
Dim objRegEx As Object: Set objRegEx = CreateObject("VBScript.RegExp")
Dim objMatches As Object
On Error GoTo ProcError
With objRegEx
.Global = False
.MultiLine = True
.IgnoreCase = False
.Pattern = "^Name:\s(.*?)$"
End With
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Name: No match."
Else
Range("A1").Value = objMatches(0).SubMatches(0)
End If
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
Set objMatches = objRegEx.Execute(wdDoc.Content)
If objMatches.Count = 0 Then
Debug.Print "Item: No match."
Else
Range("A2").Value = objMatches(0).SubMatches(0)
End If
ProcExit:
On Error Resume Next
wdDoc.Close False
wdApp.Quit
Set objMatches = Nothing
Set objRegEx = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
Exit Sub
ProcError:
MsgBox "Error# " & Err.Number & vbCrLf & Err.Description, , "SetNameAndItem"
Resume ProcExit
End Sub
Result:
Note: Please ensure that the line breaks in your Word document consist of the normal Carriage Return / Line Feed character combination (the results of pressing pressing the Enter key). When I copied/pasted the text from your Question, the document looked as expected, but what appeared to be line feeds were actually Vertical Tab characters, so the Regular Expressions did not work. I'm not saying there was any error on your part, it's probably an artifact of pasting text the web page. Just something to be aware of.
UPDATE:
If the Regular Expressions in the above code don't work, then perhaps it was not a copy/paste issue after all, and you really do have Vertical Tab characters in your document. If that's the case, try modifying the SetNameAndItem procedure in the Excel VBA code as follows.
Replace these two lines (which use ^ and $ to represent start and end of line, respectively):
.Pattern = "^Name:\s(.*?)$"
objRegEx.Pattern = "^Item:\s(.*?)\smaterial"
With these two lines (which use \v to represent vertical tab):
.Pattern = "\vName:\s(.*?)\v"
objRegEx.Pattern = "\vItem:\s(.*?)\smaterial"
Here is a possible solution of your problem:
Use this function to read the word file:
Option Explicit
Public Function f_my_story() as string
Dim wdApp As Object
Dim wdDoc As Object
Set wdApp = CreateObject("Word.Application")
With wdApp
.Visible = True
Set wdDoc = .Documents.Open("C:\Users\v\Desktop\text.docx", False, True, False)
f_my_story = wdDoc.Range(0, wdDoc.Range.End)
wdDoc.Close False
.Quit
End With
End Function
Once you have read the file, you get a string. Now you need a macro, which separates the string by space and it returns the values, that are after the values you are looking for.
You can write those values anywhere you want.
I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.
I am writing a vba macro to search a word document line by line and trying to find certain names in the document. The looping works fine except for when it gets to the end of the document, it just continues from the top and starts over. Here is the code:
Application.ScreenUpdating = False
Dim i As Integer, Rng As Range
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "?"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchWildcards = True
.Execute
End With
Do While .Find.found
i = i + 1
Set Rng = .Duplicate
Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\line")
MsgBox "Line " & i & vbTab & Rng.Text
If Rng.Bookmarks.Exists("\EndOfDoc") Then Exit Do
.start = Rng.End
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
Set Rng = Nothing
Application.ScreenUpdating = True
I have also tried this piece of code:
Dim appWD As Word.Application
Dim docWD As Word.Document
Dim rngWD As Word.Range
Dim strDoc As String
Dim intVal As Integer
Dim strLine As String
Dim bolEOF As Boolean
bolEOF = False
' Set strDoc here to include the full
' file path and file name
On Error Resume Next
Set appWD = GetObject(, "Word.Application")
If Err.Number <> 0 Then
Set appWD = CreateObject("Word.Application")
End If
Err.Clear
On Error GoTo 0
strDoc = "c:\KenGraves\Project2\output\master.doc"
Set docWD = appWD.Documents.Open(strDoc)
appWD.Visible = True
docWD.Characters(1).Select
Do
appWD.Selection.MoveEnd Unit:=wdLine, Count:=1
strLine = appWD.Selection.Text
Debug.Print strLine
intVal = LineContainsDescendant(strLine)
If intVal = 1 Then
MsgBox strLine
End If
appWD.Selection.Collapse wdCollapseEnd
If appWD.Selection.Bookmarks.Exists("\EndOfDoc") Then bolEOF = True
Loop Until bolEOF = True
Neither seem to recognize the bookmark ("\EndOfDoc"). It doesn't matter which one gets working. Is it possible that my document does not contain this bookmark?
Not terribly elegant, but this change to one line of your first procedure seems to stop it at the appropriate time. I believe you actually have to insert bookmarks into your document if you want to reference them. They aren't automatically generated.
If i >= ActiveDocument.BuiltInProperties("NUMBER OF LINES") Then Exit Do
Cheers, LC
Unless you have a corrupted document, all Word documents should have the \EndOfDoc bookmark. You can check using simply ActiveDocument.Range.Bookmarks("\EndOfDoc").Exists. If it doesn't then you'll need to supply more details on the version of Word and if possible supply a sample document via Dropbox or the like.
I'm not sure why you're looping to the start of the Word document, when I run the code it works fine. However, if I put a footnote at the end of the document it runs into an endless loop, depending on your documents you may run into additional situations like this where your code fails to handle the document setup.
I would suggest modifying slightly how you check for the end of the document to make your code a bit more robust. I'd still use the bookmark "\EndOfDoc", however I'd check the limits of the range against your current search range.
So at the top of your code declare a range variable and set it to range of the end of the document eg:
Dim rEnd As Range
Set rEnd = ActiveDocument.Bookmarks("\EndOfDoc").Range
and then in your loop, instead of this line:
If Rng.Bookmarks.Exists("\EndOfDoc") Then Exit Do
use this line:
If Rng.End >= rEnd.End Then Exit Do