I need some help regarding the Shapes Layout in Word Format. I have a word template that has some shapes in it, I want the result when the user tries to print the file or save it in PDF, it should not include the shape borders in it.
My Word File: Download Here
Desired File: Download Here
Actual File - While Editing The Document
While Printing CTRL+P (Desired Result)
I have found a script online that removes the shapes completely, I only want to remove the borders and retain the text/images inside the shape.
The script is as follows:
Sub PrintNoImagesOrShapesInDoc()
Dim objDoc As Document
Dim objInLineShape As InlineShape
Dim objShape As Shape
' Initialization
Set objDoc = ActiveDocument
' Find all images and shapes in the active document and then hide them to prevent from being
printed.
With objDoc
For Each objInLineShape In .InlineShapes
objInLineShape.Select
Selection.Font.Hidden = False
Next objInLineShape
Options.PrintDrawingObjects = False
End With
Dialogs(wdDialogFilePrint).Show
With objDoc
For Each objInLineShape In .InlineShapes
objInLineShape.Select
Selection.Font.Hidden = False
Next objInLineShape
End With
End Sub
Any Positive Help will be appreciated
Thanks,
For example, to save as a PDF:
Sub Demo()
Application.ScreenUpdating = False
Dim objUndo As UndoRecord, Shp As Shape
Set objUndo = Application.UndoRecord
With ActiveDocument
objUndo.StartCustomRecord ("RecordName")
For Each Shp In .Shapes
Shp.Line.Visible = False
Next
.SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
objUndo.EndCustomRecord
.Undo
End With
Application.ScreenUpdating = True
End Sub
Related
I am trying to insert and resize an image in word 2019 using vba. I have lot of images to insert and using vba will save a lot of time.
The issue is that I can select the image, but the height does not change. I am sure it is something pretty basic that I am doing wrong. The code, which I found online and I have adjusted a little, is below and any advice would be great. Thank you.
Sub insertimage()
On Error Resume Next
' InsertPic Macro
Dim FD As FileDialog
Dim strPictureFile As String
Dim wrdDoc As Word.Document
Dim ishp As Word.InlineShapes
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Title = "Select the Picture that you wish to insert."
.Filters.Clear
.Filters.Add "Pictures", "*.jpg; *.bmp; *.gif"
.AllowMultiSelect = False
If .Show = -1 Then
strPictureFile = .SelectedItems(1)
Else
MsgBox "You did not select a Picture."
Exit Sub
End If
End With
Set wrdDoc = ActiveDocument
With wrdDoc
If .Bookmarks.Exists("BasketIso1") Then
.InlineShapes.AddPicture FileName:=strPictureFile, LinkToFile:=False, SaveWithDocument:=True, Range:=.Bookmarks("BasketIso1").Range
.InlineShapes(1).LockAspectRatio = True
.InlineShapes(1).Height = InchesToPoints(1.78)
End If
End With
End Sub
`
You seem to see the picture being inserted, which suggests that the code up to and including .AddPicture works OK.
But then you are referencing the first picture in the document via .InlineShapes(1) (i.e. that does not reference the first picture in the bookmarks range). If it isn't actually the first picture, another picture will be resized (and you may not notice if it is already set to that size.
So you could redefine the type of ishp, which you don't seem to use at present, using
Dim ishp As Word.InlineShape
then use
Set ishp = .InlineShapes.AddPicture(FileName:=strPictureFile, LinkToFile:=False, SaveWithDocument:=True, Range:=.Bookmarks("BasketIso1").Range)
ishp.LockAspectRatio = True
ishp.Height = InchesToPoints(1.78)
Set ishp = Nothing
or a variation on that, e.g.
Set ishp = .InlineShapes.AddPicture(FileName:=strPictureFile, LinkToFile:=False, SaveWithDocument:=True, Range:=.Bookmarks("BasketIso1").Range)
With ishp
.LockAspectRatio = True
.Height = InchesToPoints(1.78)
End With
Set ishp = Nothing
or the
With .InlineShapes.AddPicture(FileName:=strPictureFile, LinkToFile:=False, SaveWithDocument:=True, Range:=.Bookmarks("BasketIso1").Range)
.LockAspectRatio = True
.Height = InchesToPoints(1.78)
End With
NB, probably not a problem in this case but using a generic
On Error Resume Next
when debugging can make it harder to see the cause of an error.
I add a picture via VBA in the Left Header Cell of a Word document - works fine with the following code. Now I want to keep the ratio of the Picture but want to change the size and I don't know how to do it:
Sub AutoOpen()
Dim dd1 As Document: Set dd1 = ActiveDocument
Dim rng1 As Range, seC As Section, an(2) As Long
Dim rngO As Range, rngAN As Range
Dim strToPict As String
For Each rngO In dd1.StoryRanges
ActiveDocument.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If rngO.StoryType = wdEvenPagesHeaderStory Then
Set rng1 = rngO.Duplicate
For Each seC In rng1.Sections
an(0) = seC.Headers(1).Range.InlineShapes(1).Height
an(1) = seC.Headers(1).Range.InlineShapes(1).Width
Set rngAN = seC.Headers(1).Range.InlineShapes(1).Range.Duplicate
seC.Headers(1).Range.InlineShapes(1).Delete
seC.Headers(1).Range.InlineShapes.AddPicture FileName:=strToPict, _
LinkToFile:=False, SaveWithDocument:=True, Range:=rngAN
With seC.Headers(1).Range.InlineShapes(1)
.Height = 50
.LockAspectRatio = True
End With
Next
Dim i As Long
ActiveDocument.Save
'Footer changing'
For i = 1 To ActiveDocument.Sections.Count
With ActiveDocument.Sections(i)
.Footers(wdHeaderFooterPrimary).Range.Text = ActiveDocument.Name + "Text"
End With
Next
End If
Next
End Sub
EDIT: I post the whole code of the Makro.
«I add a picture via VBA in the Left Header Cell of a Word document». There is no such thing as a 'Left Header Cell' in a Word document. The only headers (and footers) Word has are Primary, First Page and Even Pages.
And, as Timothy said, you "really need to learn to use the tools at you fingertips". Moreover, having found LockAspectRatio, a simple web search - if that was really necessary - would show you how to use it.
In any event, since all it seems you're trying to do is to resize the inlineshape and repeat the primary page header, you could use something along the lines of:
Sub AutoOpen()
Application.ScreenUpdating = False
Dim Rng As Range, iShp As InlineShape, Sctn As Section, StrNm As String
With Dialogs(wdDialogInsertPicture)
.Display
StrNm = .Name
End With
With ActiveDocument
If StrNm <> "" Then
Set Rng = .Sections.First.Headers(wdHeaderFooterPrimary).Range.Tables(1).Cell(1, 1).Range
Set iShp = .InlineShapes.AddPicture(FileName:=StrNm, _
LinkToFile:=False, SaveWithDocument:=True, Range:=Rng)
With iShp
.LockAspectRatio = True
.Height = 50
End With
End If
Set Rng = .Sections.First.Footers(wdHeaderFooterPrimary).Range
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="FILENAME", PreserveFormatting:=False
Rng.InsertAfter vbTab & "Text"
For Each Sctn In .Sections
Sctn.Headers(wdHeaderFooterPrimary).LinkToPrevious = True
Sctn.Footers(wdHeaderFooterPrimary).LinkToPrevious = True
Next
End With
Application.ScreenUpdating = True
End Sub
You really need to learn to use the tools at you fingertips - IntelliSense, the Object Browser, and online help.
Scrolling through the options that IntelliSense gives you, or looking up InlineShape in the Object Browser, you would find LockAspectRatio. If you weren’t sure whether that was what you needed, pressing F1 would take you to the online help.
I am writing this VBA code in Excel which makes changes in a powerpoint file. Everything is working fine except the below.
When I call the FormatICTable function, I get a runtime error i.e."Type mismatch". It looks like to me that shape object which I am passing as the first argument is creating the problem. Any suggestions ?
Sub controlPPT()
Dim PPT As Object
Set PPT = CreateObject("PowerPoint.Application")
Dim pres As Presentation
With Application.FileDialog(1)
.AllowMultiSelect = False
.Show
.Filters.Clear
.Filters.Add "PPT files", "*.pptx"
.FilterIndex = 1
If .SelectedItems.Count > 0 Then
PPT.Presentations.Open .SelectedItems(1)
Dim sld As Slide
Set pres = PPT.ActivePresentation
For Each sld In pres.Slides
sld.Select
If sld.Shapes(1).TextFrame2.TextRange.Text = "Internal comparison" Then
Call FormatICTable(sld.Shapes(2), sld)
End If
Next
pres.Save
Set pres = Nothing
End If
End With
End Sub
Function FormatICTable(shp As Shape, sld As Slide)
'My code here
End Function
So, I got the answer myself
Shape object should be decalred as PowerPoint.Shape in function signature instead of using only Shape class.
Function FormatICTable(shp As PowerPoint.Shape, sld As Slide)
'My code here
End Function
I used some code from this site to make a macro to do a keyword search on Word docs and highlight the results.
I would like to replicate the effect in PowerPoint.
Here is my code for Word.
Sub HighlightKeywords()
Dim range As range
Dim i As Long
Dim TargetList
TargetList = Array("keyword", "second", "third", "etc") ' array of terms to search for
For i = 0 To UBound(TargetList) ' for the length of the array
Set range = ActiveDocument.range
With range.Find ' find text withing the range "active document"
.Text = TargetList(i) ' that has the words from the array TargetList
.Format = True ' with the same format
.MatchCase = False ' and is case insensitive
.MatchWholeWord = True ' and is not part of a larger word
.MatchAllWordForms = False ' and DO NOT search for all permutations of the word
Do While .Execute(Forward:=True)
range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow
Loop
End With
Next
End Sub
Here is what I have so far in PowerPoint, it is in no way functional.
Sub HighlightKeywords()
Dim range As range
Dim i As Long
Dim TargetList
TargetList = Array("keyword", "second", "third", "etc") ' array of terms to search for
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
For i = 0 To UBound(TargetList) ' for the length of the array
With range.txtRng ' find text withing the range "shape, text frame, text range"
.Text = TargetList(i) ' that has the words from the array TargetList
.Format = True ' with the same format
.MatchCase = False ' and is case insensitive
.MatchWholeWord = True ' and is not part of a larger word
.MatchAllWordForms = False ' and DO NOT search for all permutations of the word
Do While .Execute(Forward:=True)
range.HighlightColorIndex = wdYellow ' highlight the keywords from the for loop yellow
Loop
End With
Next
End Sub
I ended up finding my answer through the MSDN, but it was very close to the answer I selected as correct from what people submitted.
Here is the code I went with:
Sub Keywords()
Dim TargetList
Dim element As Variant
TargetList = Array("First", "Second", "Third", "Etc")
For Each element In TargetList
For Each sld In Application.ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
Set foundText = txtRng.Find(FindWhat:=element, MatchCase:=False, WholeWords:=True)
Do While Not (foundText Is Nothing)
With foundText
.Font.Bold = True
.Font.Color.RGB = RGB(255, 0, 0)
End With
Loop
End If
Next
Next
Next element
End Sub
Turns out that code worked, but was a performance nightmare. The code I selected as the correct answer below runs much more smoothly. I've adjusted my program to match the answer selected.
AFAIK there is no inbuilt way to highlight the found word with a color. You could go out of the way to create a rectangular shape and place it behind the found text and color it but that is a different ball game altogether.
Here is an example which will search for the text in all slides and then make the found text BOLD, UNDERLINE and ITALICIZED. If you want you can also change the color of the font.
Let's say we have a slide which looks like this
Paste this code in a module and then try it. I have commented the code so that you will not have a problem understanding it.
Option Explicit
Sub HighlightKeywords()
Dim sld As Slide
Dim shp As Shape
Dim txtRng As TextRange, rngFound As TextRange
Dim i As Long, n As Long
Dim TargetList
'~~> Array of terms to search for
TargetList = Array("keyword", "second", "third", "etc")
'~~> Loop through each slide
For Each sld In Application.ActivePresentation.Slides
'~~> Loop through each shape
For Each shp In sld.Shapes
'~~> Check if it has text
If shp.HasTextFrame Then
Set txtRng = shp.TextFrame.TextRange
For i = 0 To UBound(TargetList)
'~~> Find the text
Set rngFound = txtRng.Find(TargetList(i))
'~~~> If found
Do While Not rngFound Is Nothing
'~~> Set the marker so that the next find starts from here
n = rngFound.Start + 1
'~~> Chnage attributes
With rngFound.Font
.Bold = msoTrue
.Underline = msoTrue
.Italic = msoTrue
'~~> Find Next instance
Set rngFound = txtRng.Find(TargetList(i), n)
End With
Loop
Next
End If
Next
Next
End Sub
Final Screenshot
I'd like to extend #Siddharth Rout answer which is good and rather recommended (awarder +1 from me). However, there is possibility to 'highlight' a word (range of words) in PP, too. There is one serious disadvantage of setting highlight- it destroys other font settings. Therefore, if one really need to use highlight than we need to return appropriate font settings afterwards.
Here is an example for single word in single text frame:
Sub Highlight_Word()
Dim startSize, startFont, startColor
With ActivePresentation.Slides(1).Shapes(1).TextFrame2.TextRange.Words(8).Font
'read current state
startSize = .Size
startFont = .Name
startColor = .Fill.ForeColor.RGB
'set highlight
.Highlight.RGB = RGB(223, 223, 223) 'light grey
'return standard parameters
.Size = startSize
.Name = startFont
.Fill.ForeColor.RGB = startColor
End With
End Sub
That kind of solution could be placed somewhere inside of #Siddharth solution.
And if you need to preserve the original text formatting completely, you could:
On finding a shape that includes the target text,
Duplicate the shape
Send the duplicate to the original shape's Z-order
Do the highlighting on the duplicate shape
Apply tags to both the duplicate and original to indicate that they need attention later
e.g.
oOriginalShape.Tags.Add "Hilighting", "Original"
oDupeShape.Tags.Add "Hilighting", "Duplicate"
Set the original shape invisible
Then if you need to reverse the highlighting and restore original formatting, you'd simply loop through all shapes; if the shape has a Hilighting tag = "Original", make it visible. If it has Higlighting tag = "Duplicate", delete it.
The hitch here is that if somebody's edited the highlighted shape, the edits will be lost when you revert. Users would have to be taught to revert, edit, then re=highlight.
I have around 100 documents for which the header and footer need to be changed.
Is there a possibility that i can do it just by writing a vba code or Macro in a word file?
Is it possible to give a specific folder in a macro which ll add the header and footer for all the documents in that footer?
the below code gives me
error-5111
Private Sub Submit_Click()
Call openAllfilesInALocation
End Sub
Sub openAllfilesInALocation()
Dim i As Integer
With Application.FileSearch
.NewSearch
.LookIn = "C:\MyFolder\MySubFolder"
.SearchSubFolders = False
.FileName = "*.xls"
.Execute
For i = 1 To .FoundFiles.Count
'Open each workbook
Set Doc = Documents.Open(FileName:=.FoundFiles(i))
'Perform the operation on the open workbook
'wb.Worksheets("sheet1").Range("A1") = Date
'Save and close the workbook
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Header goes here"
.Footers(wdHeaderFooterPrimary).Range.Text = "Footer goes here"
End With
Doc.Save
Doc.Close
'On to the next workbook
Next i
End With
End Sub
In the code you provided you have tried to use old .FileSearch property. It used to work until MS Office 2003 but not now. Here goes code improved for you. It will open a standard file window where you can pick one or few files to process.
Sub openAllfilesInALocation()
Dim Doc
Dim i As Integer
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Header goes here"
.Footers(wdHeaderFooterPrimary).Range.Text = "Footer goes here"
End With
Doc.Save
Doc.Close
Next i
End Sub