Insert a picture into an InlineShape - vba

I’m writing a Document in which I have to include many Pictures. In the ongoing process the Pictures get changed many times.
My idea was to include Rectangle Shapes as placeholders and give them a suitable name. I created a Macro that selects the Shape, deletes the old Picture and inserts the new one into the Shape.
Sub InsertImage(Shape As String, Picture As String, Hight As Integer)
Dim shp As Word.Shape
Dim strFile As String
Dim strExt As String
strFile = "C:\Pictures"
strExt = ".png"
ActiveDocument.Shapes.Range(Array(Shape)).Select
Selection.TypeBackspace
Set shp = ActiveDocument.Shapes.AddPicture(Anchor:=Selection.Range, FileName:= _
strFile & "\" & Picture & strExt, LinkToFile:=False, SaveWithDocument:=True)
With shp
.LockAspectRatio = msoTrue
.Height = CentimetersToPoints(Hight)
End With
End Sub
Sub Insert1()
InsertImage "Shape01", "Pic01", 10
End Sub
I want this for floating Shapes as well as for InlineShapes.
When I set my Placeholder Shapes to InlineShapes the TypeBackspace line deletes the InlineShape and the picture does not get inserted into the InlineShape.

Thank you very much for the help. After many struggles, the solution with Tables + Bookmarks works perfekt.
Here is the code:
Sub InsertPic(Pic As String, Cut As Single)
Dim strFile As String
Dim strExt As String
Dim ils As InlineShape
strFile = "C:\Pictures“
strExt = ".png"
Application.ScreenUpdating = False
ActiveDocument.Bookmarks(Pic).Select
Selection.Delete
Set ils = Selection.InlineShapes.AddPicture(FileName:= _
strFile & "/" & Pic & strExt, _
LinkToFile:=False, SaveWithDocument:=True)
With ils
.PictureFormat.CropBottom = CentimetersToPoints(Cut)
.LockAspectRatio = msoTrue
.Height = .Range.Cells(1).Height
If .Width > .Range.Cells(1).Width Then
.Width = .Range.Cells(1).Width
End If
End With
ActiveDocument.Bookmarks.Add (Pic)
Application.ScreenUpdating = True
End Sub
Sub Insert01()
InsertPic "Image01", 20
MsgBox "Done"
End Sub
Some explanation:
For this code, the Bookmark and the Picture need the same Name. I made this to avoid mix-ups.
With the Selection.Delete command, the Bookmark gets also deleted, so I just added a new Bookmark with the same name at the end. I’m sure there are more elegant ways to solve this, but this solution works.
I have had many struggles because i wanted to crop the Picure. But the size gets changed to the size of the table-cell when its inserted and the cutting step comes afterwards. So the Picturs wasn´t filling the complete cell size. Therefore, I added a part to resize the Image to the table-cell Size. As well, im sure there are better ways to overcome this ...
Because of this resizing, the Makro needs a bit of time (at least for my document). So I disabled the Screenupdating.

Related

Keep Picture Ratio in Word File

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.

Word footer image alignment in VBA

I try to put a signature in the footer of a word document, but I can't align it at the bottom right of the footer.
Also, in my footer there is a line of text (i.e. my Company Inc) and the signature must be exactly over the text, as in the screenshot:
Any help, please?
My code, which works except for the positioning:
Sub Macro1()
Dim SHP as String
FIRMADOC = "C:\Users\user\Pictures\1.png"
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Set SHP = Selection.InlineShapes.AddPicture(FileName:=FIRMADOC, LinkToFile:=False, SaveWithDocument:=True)
With SHP
'AJUSTA A "ENFRENTE DEL TEXTO"
.ConvertToShape
' MANTIENE EL RATIO
.LockAspectRatio = msoTrue
'AJUSTA A ANCHO 1 inch
.Width = InchesToPoints(1)
' .Alignment = ' need this code for bottom-right, PLEASE
End With
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End sub
Because Shape objects "float" on the page, they can be easily positioned. They can also be easily (and accidentally) repositioned. Shape objects can also be tricky to hanlde using code. So a useful rule-of-thumb I use is: if an InlineShape works, use it rather than a Shape.
Three possibilities are out-lined, below; two for InlineShapes and one for a Shape.
An InlineShape can be positioned right-aligned to the page using two different methods (depending on whether it's alone in the paragraph).
Right-align the paragraph which contains the InlineShape. This is appropriate when the paragraph has no other content. Extracting just the code from the question for handling this:
Dim SHP as InlineShape
Set SHP = Selection.InlineShapes.AddPicture(FileName:=FIRMADOC, _
LinkToFile:=False, SaveWithDocument:=True)
SHP.Range.ParagraphFormat.Alignment = wdAlignParagraphRight
If the paragraph has other content to the left, then a right-aligned TAB stop with a TAB character preceding the InlineShape will work. A Footer by default has two TAB stops: one center-aligned, the second right-aligned.
For this, I'm going to change the entire code in the question in order to optimize working in a Footer. (The same approach applies to a Header BTW). The macro recorder produces code that emulates user actions, so it actually opens up the footer (or header) using things like ActiveWindow and Selection. These are somewhat difficult to control precisely; working with the actual Word objects is more reliable.
Think of a Range object like an invisible selection. The entire Footer area is assigned to a range (rng). Since the Footer already has content (the "Company Inc" text), it's necessary to "collapse" the Range. (Think of it like pressing left-arrow so that new content does not replace a selection.)
Then two TAB characters are added to it (rng.Text = vbTab & vbTab) and the signature is added.
Sub Macro1()
Dim FIRMADOC as String
Dim SHP as InlineShape
Dim rng as Word.Range
FIRMADOC = "C:\Users\user\Pictures\1.png"
Set rng = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
rng.Collapse wdCollapseStart
rng.Text = vbTab & vbTab 'position at second, right-aligned tab in the footer)
Set SHP = rng.InlineShapes.AddPicture(FileName:=FIRMADOC, LinkToFile:=False, SaveWithDocument:=True, Range:=rng)
With SHP
' MANTIENE EL RATIO
.LockAspectRatio = msoTrue
'AJUSTA A ANCHO 1 inch
.Width = InchesToPoints(1)
End With
End sub
If it's necessary to use a Shape object, then a combination of the Left and RelativeHorizontalPosition properties is required. Members of the wdShapePosition and WdRelativeHorizontalPosition enumerations specify these special settings.
Note that it also might be necessary to include the Top property to get the correct vertical position of the Shape to the "Company, Inc" text.
Sub Macro1()
Dim FIRMADOC as String
Dim SHP as InlineShape
Dim rng as Word.Range
FIRMADOC = "C:\Users\user\Pictures\1.png"
Set rng = ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range
rng.Collapse wdCollapseStart
Set SHP = rng.InlineShapes.AddPicture(FileName:=FIRMADOC, LinkToFile:=False, SaveWithDocument:=True, Range:=rng)
Set SHP = SHP.ConvertToShape
With SHP
' MANTIENE EL RATIO
.LockAspectRatio = msoTrue
'AJUSTA A ANCHO 1 inch
.Width = InchesToPoints(1)
.Left = wdShapeRight '-999996
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin '0
End With
End sub

Powerpoint VBA to insert image and change size

I think this could solve problems for a lot of people doing tedious pasting of images from one directory into powerpoint then resizing them.
My problem is that I have 16 images all in one directory which need updating each month and it's very slow to do it one by one. The task is:
Open directory
Open first image
Paste image into powerpoint
Reposition image to top left
Resize image to height 550 by width 960 (fills A4 page)
Send image to back
Move to next slide
Repeat for second image
Continue until no more images in directory
Directory is (e.g.) "C:\Users\xxxxxx\Documents\Work\Procurement Project\Slides"
First image name is (e.g.) "01 Summary", second is "02 Client Contracts" etc etc
I think I need a str and a path and a table for the str to add to path to create each new path using i and i + 1 etc
I think I then need some code that's a bit like this:
Sub Picture_size_and_position()
Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection
ActiveWindow.View.GotoSlide oSlide.SlideIndex
With ActiveWindow.Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = 550
.Width = 960
.Left = 0
.Top = 0
End With
End Sub
Then I'm sure I need a looping function to repeat this until there's nothing left in the directory using some combination of i and j...but the whole code is way beyond me, very frustratingly.
Could someone offer some tips, please? Much much appreciated!
Thank you!
Sub ImportABunch()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
' Edit these to suit:
strPath = "C:\Users\username\"
strFileSpec = "*.png"
strTemp = Dir(strPath & strFileSpec)
i = 1
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides(i)
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=960, _
Height:=550)
i = i + 1
With oPic
.LockAspectRatio = msoFalse
.ZOrder msoSendToBack
End With
' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
' without changing the proportions
' Leave the above commented out, uncomment this instead:
' With oPic
' If 3 * .width > 4 * .height Then
' .width = ActivePresentation.PageSetup.Slidewidth
' .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
' Else
' .height = ActivePresentation.PageSetup.Slideheight
' .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
' End If
' End With
' Optionally, add the full path of the picture to the image as a tag:
'With oPic
' .Tags.Add "OriginalPath", strPath & strTemp
'End With
' Get the next file that meets the spec and go round again
strTemp = Dir
Loop
End Sub
Credit to http://www.pptfaq.com/index.html - Great little site!
Have an idea to automate it/or upon manual launch of a new Macro Enabled PowerPoint Template file. To automate macro upon file open, add customUI: onLoad="ImagesToPowerPoint". Search "CustomUI Editor" for it.
Note I have not fully tested the automation part.
Option Explicit
Sub ImagesToPowerPoint()
Const FileType As String = "*.png"
Dim sSaveFilePath As String, sSaveFileName As String, sImagesFolder As String
Dim oLayout As CustomLayout, oSlide As Slide, i As Long, sFile As String
sImagesFolder = Environ("USERPROFILE") & "\Documents\Work\Procurement Project\Slides\"
' Prepare auto save PowerPoint file name
sSaveFilePath = Environ("USERPROFILE") & "\Documents\Work\PowerPoints\"
sSaveFileName = Format(Now, "yyyy_mmdd") & "_Procurement.pptx"
With ActivePresentation
' Use the first layout for all new slides
Set oLayout = .SlideMaster.CustomLayouts(1)
' Start processing all files in the folder
sFile = Dir(sImagesFolder & FileType)
Do Until sFile = ""
' Add new slide
Set oSlide = .Slides.AddSlide(.Slides.Count, oLayout)
' Delete all the shapes from that layout
For i = oSlide.Shapes.Count To 1 Step -1
oSlide.Shapes(i).Delete
Next
' Add the image to slide
With oSlide.Shapes.AddPicture(sImagesFolder & sFile, msoFalse, msoTrue, 0, 0, oLayout.Width, oLayout.Height)
.LockAspectRatio = msoFalse
.AlternativeText = Now & " | " & sImagesFolder & sFile
End With
sFile = Dir
Loop
.SaveAs sSaveFilePath & sSaveFileName
End With
Presentations(sSaveFileName).Close
If Presentations.Count = 0 Then Application.Quit
End Sub

Resizing image in VBA maintaining aspect ratio

I have a VBA macro that goes for an image in a file and sticks it into an Excel spreadsheet, in a worksheet called "Country Profile".
I would like to resize the image so that it has a width of 350px, while maintaining its aspect ratio.
This is the code that I wrote:
Public Sub Macro15()
Dim picname As String
Dim shp As Shape
Dim present As String
Sheets("Country Profile").Activate
Sheets("Country Profile").Select
ActiveSheet.Pictures.Delete
Cells(19, 40).Select 'This is where picture will be inserted (column)
picname = Sheets("REPORT ON").Range("A2").Value 'This is the picture name
Cells(19, 46).Select
Call ActiveSheet.Shapes.AddPicture("C:\Users\" & Environ("UserName") & "\Maps with Cities\" & picname & ".png", _
LockAspectRatio = msoTrue, msoCTrue, Left:=Cells(19, 40).Left, Top:=Cells(19, 46).Top, Width:=350, Height:=-1).Select
End Sub
The code works and the image is inserted in the desired file. However, the aspect ratio is not maintained. What can I do to correct this?
Try it like this:
With ActiveSheet.Pictures.Insert(PicPath)
.ShapeRange.LockAspectRatio = msoTrue
.Width = 350
End With

How to add a file from the active document directory

I have a document that creates a template page from a VBA script every time I need to insert a specific item into my document, its a great time saver, this includes an image. I have got a working foundation whereby it inserts the image and text wraps it where I want it to be, however the file path is an absolute one. I would like the file path to specify that the image file is within the same directory as the active document so that if I move the directory to a different location this macro will not be broken.
The problem is a little beyond my vba skills, I have worked out I should probably use the ActiveDocument.Path command but I am not sure how to. I appreciate your help. Thank you
Below is my code so far:
Sub Inser_Wrapped_Image()
Dim shp As Shape
Set shp = ActiveDocument.Shapes.AddPicture( _
FileName:="C:\Users\Edoardo\Documents\My Work\PhD\SkyDrive\Tutoring\Houria\Image Replacement.jpg", _
SaveWithDocument:=True, _
Anchor:=Selection.Range)
With shp
.WrapFormat.Type = wdSquare
.Left = 246
.Top = 50
.Width = 250
.Height = 188
End With
End Sub
I have tried writing it as follows but word freezes for a few seconds and then does nothing:
Sub Insert_image()
Dim shp As Shape
Set shp = ActiveDocument.Shapes.AddPicture( _
FileName:=ActiveDocument.Path & "\Image.jpg", _
SaveWithDocument:=True, _
Anchor:=Selection.Range)
End Sub
Try this:
Sub Inser_Wrapped_Image()
Dim shp As Shape
Dim imgpath As String
imgpath = ThisDocument.Path
imgpath = imgpath & "\" & "Image Replacement.jpg"
Set shp = ThisDocument.Shapes.AddPicture( _
FileName:=imgpath, SaveWithDocument:=True, _
Anchor:=Selection.Range)
With shp
.WrapFormat.Type = wdWrapSquare
.Left = 246
.Top = 50
.Width = 250
.Height = 188
End With
End Sub
I used ThisDocument to explicitly load the picture to the document that contains the macro.
It will work both ways thought if you want to stick to ActiveDocument.