I have some code that will put an image onto a document. If there is already a table in the footer, the image appears in the wrong place.
If I manually change the vertical position from 0.44 below 'paragraph' to below 'bottom margin', then it goes to the correct position for all documents.
I can't see any way to access this option in vba however.
Sub myFooter()
' Paste a logo into the footer.
'CTRL+SHIFT+F
Application.ScreenUpdating = False
Dim img As String, shp As Shape, oWD As Word.Document, Sctn As Section
On Error Resume Next
img = "G:\Shared Drives\footer.jpg"
Set oWD = ActiveDocument
For Each Sctn In oWD.Sections
With oWD.Sections(Sctn.Index).Footers(wdHeaderFooterPrimary).Shapes.AddPicture(img)
' for absolute positioning
.Left = CentimetersToPoints(15.75)
.Top = CentimetersToPoints(0.44)
'.below = BottomMargin
End With
Next Sctn
Set shp = Nothing
Application.ScreenUpdating = True
End Sub
Is there some other way to do this, or have I missed something for how to amend the absolute position of the image?
Amend your With section as follows:
With oWD.Sections(Sctn.Index).Footers(wdHeaderFooterPrimary).Shapes.AddPicture(img)
' for absolute positioning
.Left = CentimetersToPoints(15.75)
.RelativeVerticalPosition = wdRelativeVerticalPositionBottomMarginArea
.Top = CentimetersToPoints(0.44)
.TopRelative = wdShapePositionRelativeNone
End With
Related
This is my first time writing macro in VBA. My goal is to write a VBA macro that will automatically align (distribute) all images in a Word document horizontally (next to each other) with a small margin on each side of every image. If there is not enough space to fit another image, I need it to go to the next row(just below previous images) and continue with the horizontal alignment of images.
I have searched a lot on the internet, but I haven't found a way to achieve this...
NOTE: My macro already contains code for making all images have the same height(while keeping the same aspect ratio), so I think dimensions shouldn't be a problem...
Here is a small example of what I want to achieve:
I tried using code for Horizontal alignment from this link: https://www.excelcampus.com/vba/align-space-distribute-shapes/
But I got the following result:
Margins are weird and shapes are aligned infinitely instead of going into the next row...
My Code:
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dWidth As Double
Const dSPACE As Double = 8 'Set space between shapes in points
lCnt = 1
Dim image As Shape
If ActiveDocument.Shapes.Count > 0 Then
For Each image In ActiveDocument.Shapes
With image
.WrapFormat.Type = wdWrapSquare
.LockAspectRatio = msoTrue
.Height = InchesToPoints(3)
If lCnt > 1 Then
.Top = dTop
.Left = dLeft + dWidth + dSPACE
End If
dTop = .Top
dLeft = .Left
dWidth = .Width
End With
lCnt = lCnt + 1
Next
End If
End Sub
Thanks in advance!
Inserting your images into a table with fixed cell dimensions won't achieve what you say you want, since the images clearly don't have the same aspect ratio. What you need to do is to convert them to inlineshapes so that Word can handle the line wrapping. For example:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape
With ActiveDocument
Do While .Shapes.Count > 0
.Shapes(1).ConvertToInlineShape
Loop
For Each iShp In .InlineShapes
With iShp
.LockAspectRatio = True
.Height = InchesToPoints(3)
If .Range.Characters.Last.Next <> " " Then .Range.InsertAfter " "
End With
Next
End With
Application.ScreenUpdating = True
End Sub
You can adjust the vertical spacing between the images by changing the paragraph line spacing. Note too, that the horizontal alignment can be played around with by switching between left, centered and justified paragraph formats.
Since you are new to VBA I wanted to share a bit of code if you were to pursue a Table approach. The code below creates a single-row table that is fixed in width and will not expand width-wise unless you alter the individual cells. For demo purposes only, I insert the same picture into each cell to demonstrate that the image resizes automatically based on cell width.
Sub TableOfPictures()
Dim doc As Word.Document, rng As Word.Range
Dim Tbl As Word.Table, C As Long
Set doc = ActiveDocument
Set rng = Selection.Range
Set Tbl = rng.Tables.Add(rng, 1, 2, Word.WdDefaultTableBehavior.wdWord8TableBehavior)
Tbl.rows(1).Cells(1).Width = InchesToPoints(2)
Tbl.rows(1).Cells(2).Width = InchesToPoints(4.5)
For C = 1 To 2
Tbl.rows(1).Cells(C).Range.InlineShapes.AddPicture ("Y:\Pictures\Mk45 Gun Proj_Blast.jpg")
Next
End Sub
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
I currently work for a recruiting firm and I'm trying to write a program that will post my company's Logo on the Top Left Corner of a resume.
Some resumes have content in the header, some don't. I made two if's statements to address both circumstances, but for some odd reason, it does not seem to work.
This is my code below:
Dim i As Long
Dim FooterText As String
Dim Logo As Shape
Dim HeaderExists As Section
'Header:
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Set HeaderExists = ActiveDocument.Sections(1)
Set Logo = Selection.InlineShapes.AddPicture(FileName:="My company logo", _
LinkToFile:=False, SaveWithDocument:=True).ConvertToShape
If HeaderExists.Headers(wdHeaderFooterFirstPage).Exists = False Then
With Logo
.WrapFormat.Type = wdWrapBehind
.Left = -67
.Top = -30
.Width = 107
.Height = 48
End With
End If
If HeaderExists.Headers(wdHeaderFooterFirstPage).Exists = True Then
With Logo
.WrapFormat.Type = wdWrapBehind
.Left = 5
.Top = 5
.Width = 107
.Height = 48
End With
End If
As of right, the code only works for resumes WITH content in the Header. For some reason, when I change wdHeaderFooterPrimary to wdFooterFirstPage, it flips, and only works for resumes WITHOUT content in the Header.
Unless you want to logo to appear on every page, you'll need to apply a 'different first page' layout to documents that don't already have it. Then you'll need to decide what to do with documents that didn't have that layout but had a header, since the existing header will now only appear on the 2nd & subsequent pages (if there is more than one page). In the following code, I've enforced a 'different first page' layout, which obviates any concerns about what happens in your problem scenario, and have assumed the header & logo are only to appear on the first page:
Sub Demo()
Application.ScreenUpdating = False
Dim Sctn As Section, Rng As Range, Shp As Shape
Set Sctn = ActiveDocument.Sections.First
With Sctn
If .PageSetup.DifferentFirstPageHeaderFooter = False Then
'Apply a Different First Page layout
.PageSetup.DifferentFirstPageHeaderFooter = True
Set Rng = .Headers(wdHeaderFooterFirstPage).Range
With Rng
'Replicate the original Primary header
If Sctn.Headers(wdHeaderFooterPrimary).Range.Text <> "" Then
.FormattedText = Sctn.Headers(wdHeaderFooterPrimary).Range.FormattedText
.Characters.Last.Delete
End If
End With
'Delete the original Primary header
Sctn.Headers(wdHeaderFooterPrimary).Range.Text = vbNullString
End If
With Rng
.Collapse wdCollapseStart
'Add the logo
Set Shp = .InlineShapes.AddPicture(FileName:="My company logo", _
LinkToFile:=False, SaveWithDocument:=True).ConvertToShape
'Adjust the logo's formatting
With Shp
.WrapFormat.Type = wdWrapBehind
.Left = 5
.Top = 5
.LockAspectRatio = True
.Width = 107
End With
End With
End With
Application.ScreenUpdating = True
End Sub
If the document has multiple Sections, you'll also need to consider what to do with their page layouts & headers.
I have basic Macro and VBA knowledge yet cannot get my head around where I am going wrong here. (Code inserted at the bottom) I want my macro to move a selected image into the top centre of the page. The issue I am facing is that it will not work for each image in the document, it works for the first one then no longer performs the task. I am using Microsoft Word 2016.
The main command does what I want it to, I feel my error is within these two lines
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
Whole code;
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
With myDocument.Shapes(1)
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End Sub
If you want this to work with the selected image, and only the selected image, then more like this, where you get the Shape from the current selection.
Note how you should first check to make sure a Shape is selected...
Sub PositionSelectedShape()
Dim sel As word.Selection
Dim shp As word.Shape
Set sel = Selection
If sel.Type = wdSelectionShape Then
Set shp = sel.ShapeRange(1)
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
End If
End Sub
Exactly like Kim Raaness has suggested, you need to loop through all shapes of you would like to centre them all.
Try something like this:
Sub AlignToCentre()
'
' AlignToCentre
Dim shp As Shape
Set myDocument = ActiveDocument
For Each shp in myDocument.Shapes
With shp
.WrapFormat.Type = wdWrapSquare
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.Left = wdShapeCenter
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = InchesToPoints(1)
End With
Next shp
End Sub
I've been trying to fix this problem for a while. The following code inserts a picture from your choose to my excel document. It places the picture in cell B10 and resizes it to the height of one of my merged cells. Now the problem is that I can't get it centerd.
.Left = 35#
With the line above i can manually center one picture, but i want every other picture with other width's to be centerd aswell. Can anyone help me with this problem? The code below is what i've been using. Thanks in advance!
Sub Insert_Pic_Section_One()
Dim fileName1 As Variant
fileName1 = Application.GetOpenFilename(filefilter:="Tiff Files(*.tif;*.tiff),*.tif;*.tiff,JPEG Files (*.jpg;*.jpeg;*.jfif;*.jpe),*.jpg;*.jpeg;*.jfif;*.jpe,Bitmap Files(*.bmp),*.bmp", FilterIndex:=2, Title:="Choose picture", MultiSelect:=False)
If fileName1 = False Then
Exit Sub
Else
ActiveWorkbook.ActiveSheet.Select
Range("B10").Select
Dim picture1 As Object
Set picture1 = ActiveWorkbook.ActiveSheet.Pictures.Insert(fileName1)
With picture1
.Top = .Top
.Left = 35#
.Width = .Width
.Height = 233#
End With
End If
End Sub
No need to select anything. Because you use a merged cell you need to use .MergeArea otherwise it will only give you the height and width of the unmerged row and column.
Dim ws As Worksheet
Dim targetCell As Range
Dim picture1 As Picture
Set ws = ActiveSheet 'replace with actual worksheet if possible
Set targetCell = ws.Range("B10")
Set picture1 = ws.Pictures.Insert(fileName1)
With picture1
.Height = targetCell.MergeArea.Height 'set height first because width will change
.Top = targetCell.Top
.Left = targetCell.Left + (targetCell.MergeArea.Width - .Width) / 2
End With