Align (distribute) images horizontally in Word with VBA macro - vba

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

Related

Using VBA how do I align the selected text to the middle vertically and center of a table cell?

I'm using MacOS or I would have tried the Macro recorder :(
I have a regular repetitive task to change the selected text at various positions within multiple tables to a set font and size as well as centered within the table and vertically in the middle. Rather than do this a thousand times a week I am trying to make a macro to do it for me with VBA.
So far I have the font and text size changing whatever text is selected but can't seem to figure out the alignment with my friend Google.
Sub SR()
With ActiveWindow.Selection.TextRange2.Font
.Name = "Roboto Light (Body)"
.Size = "10"
End With
End Sub
Solution:
Sub SR()
Dim oTbl As Table
Dim oSh As Shape
Dim lRow As Long
Dim lCol As Long
' Get a reference to the parent table
With ActiveWindow.Selection.ShapeRange(1).Table
' Find the selected cell
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
If .Cell(lRow, lCol).Selected Then
With .Cell(lRow, lCol).Shape.TextFrame2
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
With .Cell(lRow, lCol).Shape.TextFrame2.TextRange.Font
.Name = "Roboto Light (Body)"
.Size = "10"
End With
End If
Next
Next
End With
End Sub
Combine this with what you have and it should get you there.
You can set font and other characteristics of selected text, but to change the alignment, you need to work with the shape that contains the text.
Normally you could walk up the selected text's Parent chain to get the containing shape, but unfortunately, that doesn't work with text in table cells. PPTBug.
Instead, you have to look at each cell to find out whether it's selected and if so, drill down to its shape. Which is what we do here.
By the way, no version of PPT has a macro recorder any longer, not even Windows.
Sub Test()
Dim oTbl As Table
Dim oSh As Shape
Dim lRow As Long
Dim lCol As Long
' Get a reference to the parent table
With ActiveWindow.Selection.ShapeRange(1).Table
' Find the selected cell
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
If .Cell(lRow, lCol).Selected Then
With .Cell(lRow, lCol).Shape.TextFrame2
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
End If
Next
Next
End With
End Sub

Add picture "below margin"

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

Word shading exactly to text height

I'm currently working on a MS Word report.
To highlight certain sections, it would be great to shade some part of the text as seen in beneath image:
Unfortunately, I'm just able to add the shading for the full line height, as shown in the following image:
Is there a native way inside MS Word to accomplish the shading for just the text height?
Otherwise I'm forced to embed images inside my report as the headings (This is something I do not want for several reasons, e.g. complications in Table of Contents)
There is no direct way to have a shading as you desire, it's always to the full line height and not the cap height. And this also makes sense, when you think about how the shading would look like for letters with a tail (such as uppercase Q or a descender (such as lowercase g).
If you want to add the shading to single lines only you could mimic the desired effect by anchoring a rectangle shape to the paragraph and position it behind the text.
Here is a quick and dirty VBA macro that adds shading using shapes to the selected lines of text. You have to fine-tune the height and vertical offset of the shapes to the font and font size you are using.
Sub AddShading()
Dim rng As Range
Dim startPos As Integer
Dim endPos As Integer
Dim capHeight As Single
capHeight = 8
Dim verticalOffset As Single
verticalOffset = 3
' backup original select
Set rng = Selection.Range.Duplicate
' start undo transaction
Application.UndoRecord.StartCustomRecord "Add Shading"
Do
' select line of text
Selection.Collapse
Selection.Expand wdLine
If Selection.Start < rng.Start Then
Selection.Start = rng.Start
End If
If Selection.End > rng.End Then
Selection.End = rng.End
End If
' get range of current line to be able to retrieve position of line
Dim rngLine As Range
Set rngLine = Selection.Range.Duplicate
' get the left coordinate
Dim left As Single
left = rngLine.Information(wdHorizontalPositionRelativeToPage)
' get the top coordinate and add a vertical adjustment depending on the font used
Dim top As Single
top = rngLine.Information(wdVerticalPositionRelativeToPage) + verticalOffset
' move to the end position of the line
rngLine.Collapse wdCollapseEnd
If rngLine.Information(wdVerticalPositionRelativeToPage) > top Then
rngLine.Move wdCharacter, -1
End If
' calculate width of line
Dim width As Integer
width = rngLine.Information(wdHorizontalPositionRelativeToPage) - left
' add shape behind text
Dim shp As Shape
Set shp = rng.Document.Shapes _
.AddShape(msoShapeRectangle, left, top, width, capHeight, rng)
With shp
' grey shading
.Fill.ForeColor.RGB = RGB(192, 192, 192)
' no outline
.Line.Visible = msoFalse
' the shape should move with the text
.RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
' position the shape behind the text
.WrapFormat.Type = wdWrapBehind
End With
' continue with next line
Selection.Move wdLine
Loop While Selection.End < rng.End
' restore original selection
rng.Select
Application.UndoRecord.EndCustomRecord
End Sub

How to position a command button in MS Word via VBA

I currently have a VBA script that works as it should apart from the position of the command button in the MS word documant. Currently the button is positioned as the very first thing on the document pushing the existing text to the right.
The VBA code I have use for the button is:
Dim doc As Word.Document
Dim shp As Word.InlineShape
Set doc = ActiveDocument
Set shp = doc.Content.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
shp.OLEFormat.Object.Caption = "Create PDF and print"
How do I position the button? On the same line but centered would do fine. Centered but at the very end of the document (following the letter as it is typed), even better.
Thank you.
You must add the button to a specific paragraph of the document. For example:
doc.Content.InsertParagraphAfter
Set shp = doc.Content.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1", _
Range:=doc.Paragraphs.Last.Range)
Thus you can format the button paragraph as you want. For example:
doc.Paragraphs.Last.Alignment = wdAlignParagraphCenter
Sub Add_InlineShapes_To_EachLine()
Dim shp As Word.InlineShape
Dim NbOfLines, cpt As Integer
'Count the number of non blank lines in current document
NbOfLines = ActiveDocument.BuiltInDocumentProperties(wdPropertyLines)
cpt = 1
Set p = ActiveDocument.Paragraphs.First
For Lin = 1 To NbOfLines
Set shp = p.Range.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
With shp.OLEFormat.Object
.Caption = cpt
.FontSize = 8
.Width = 20
.Height = 20
End With
Set p = p.Next
cpt = cpt + 1
Next Lin
End Sub

Inserting an Online Picture to Excel with VBA

I'm currently working on a project and need to fill in cells with pictures via URLs. All URLs are in one column, and I'd like to load the images in an adjacent column. I'm no VBA expert, but I found some code that worked, but for some reason I get an error (usually 5 images in) that says:
Run-time error '1004':
Unable to get the Insert property of the Pictures Class
Again, I'm using a system where URLs are in one column i.e.:
xxxx.com/xxxx1.jpg
xxxx.com/xxxx2.jpg
xxxx.com/xxxx3.jpg
xxxx.com/xxxx4.jpg
Through some searching, I found that it could be linked to my Excel version (using 2010), though I'm not completely sure.
Here's the current code I'm using:
Sub URLPictureInsert()
Dim cell, shp As Shape, target As Range
Set Rng = ActiveSheet.Range("a5:a50") ' range with URLs
For Each cell In Rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set shp = Selection.ShapeRange.Item(1)
With shp
.LockAspectRatio = msoTrue
.Width = 100
.Height = 100
.Cut
End With
Cells(cell.Row, cell.Column + 1).PasteSpecial
Next
End Sub
Any help would be much appreciated!
Original code source: http://www.mrexcel.com/forum/excel-questions/659968-insert-image-into-cell-url-macro.html
This is an almost identical solution that I posted about a month ago:
Excel VBA Insert Images From Image Name in Column
Sub InsertPic()
Dim pic As String 'file path of pic
Dim myPicture As Picture 'embedded pic
Dim rng As Range 'range over which we will iterate
Dim cl As Range 'iterator
Set rng = Range("B1:B7") '<~~ Modify this range as needed. Assumes image link URL in column A.
For Each cl In rng
pic = cl.Offset(0, -1)
Set myPicture = ActiveSheet.Pictures.Insert(pic)
'
'you can play with this to manipulate the size & position of the picture.
' currently this shrinks the picture to fit inside the cell.
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
'
Next
End Sub
I know this thread is 5 years old but just wanted to say it really helped me with a project.
I'm using VBA to bring in data from an orders database. When I click on an order from those results it brings in more details about the orders including an image URL.
The problem I had was that the code above was designed to add the image in place of the URL. I wanted to replace the image from a previous query with the image from the new query. After some tweaks I got it working but it was just laying a new image on top of the old image. In time my Excel file could get really big so here's my solution. The only problem I have right now is that it deletes my company's logo that I put on the sheet. There may be a way to be more selective, or I could just change the procedure to insert the logo from another sheet in the workbook every time it deletes pictures but that seems a bit cheesy.
Sub InsertPic()
Dim productImageUrl As String
Dim productImage As Picture 'Declare image picture object
Dim productImageUrlRng As Range 'Declare range object to contain image URL
Dim productImageRng As Range 'Location image will be placed
'Delete any existing pictures:
Set productImageRng = ActiveSheet.Range("J1:J15") 'Where I want to put the image
Set productImageUrlRng = Range("BA2") 'Cell containing image URL
productImageUrl = productImageUrlRng
productImageRng.Select
'productImageRng.Delete --Does not delete pictures in range
ActiveSheet.Pictures.Delete 'Delete existing images
Set productImage = ActiveSheet.Pictures.Insert(productImageUrl)
With productImage
.ShapeRange.LockAspectRatio = msoTrue
'.Width = productImageRng.Width
.Height = productImageRng.Height
' .Top = Rows(cl.Row).Top
' .Left = Columns(cl.Column).Left
End With
End Sub