I am using VBA in Word 2016 and I want to create a rectangle the size of the paragraph (I can't use the border feature for other reasons).
I can get the position of the first character using this code, but what about the bottom and right end of the paragraph?
x = Selection.Information(wdHorizontalPositionRelativeToPage)
y = Selection.Information(wdVerticalPositionRelativeToPage)
Unfortunately, the following is just my wishful thinking:
w = Selection.Paragraphs(1).Width
h = Selection.Paragraphs(1).Height
In the end, I want to execute the following to generate a rectangle the same size as a bounding box around the paragraph:
ActiveDocument.Shapes.AddShape msoShapeRectangle, x, y, w, h
Any help would be appreciated. Thank you!
You are on the right track when you think in terms of the paragraph indicated by your selection. My preference is to deal with the range indicated by the selection, but that is a matter of personal preference. Anyway, the paragraph can be divided into - inter alia - a first character and a last character. As you have already stated, the fist character's position on the page is very near to the top left corner of your rectangle. A similar relationship can be established for the last character. The following code may help you on your way.
Private Sub TestPos()
Dim Rng As Range
Dim x As Single, y As Single
Set Rng = Selection.Range
Set Rng = Rng.Paragraphs(1).Range
With Rng
x = .Information(wdHorizontalPositionRelativeToPage)
y = .Information(wdVerticalPositionRelativeToPage)
Debug.Print x, y
.Collapse wdCollapseEnd
x = .Information(wdHorizontalPositionRelativeToPage)
y = .Information(wdVerticalPositionRelativeToPage)
Debug.Print x, y
Debug.Print .Paragraphs(1).LineSpacing
End With
End Sub
As for the left and right you should refer to the margins set for the paragraph. The following code contains the syntax you will need.
Private Sub ShowPageSetup()
Dim Rng As Range
With ActiveDocument.PageSetup
Debug.Print .LeftMargin, .RightMargin
End With
Set Rng = Selection.Range
With Rng.Paragraphs(1).Range.ParagraphFormat
Debug.Print .LeftIndent, .RightIndent
End With
End Sub
Related
I am using a Word table as a placeholder for images, where table cells contain only pictures and no text.
When inserting a picture into a Word table, I have no problems when inserting an Inline Shape. The picture appears into the expected cell. However, with the "equivalent" code which inserts the picture as a Shape, the shape does not always appear in the expected cell. So far, I have seen this problem in Word 2013, 32 bit version.
Sub test()
Dim s As Shape
Dim x As String
Dim f As String
Dim r As Long
Dim c As Long
Dim h As Single
Dim w As Single
Dim rng As Word.Range
Dim ins As Word.InlineShape
f = "file name of a picture, .bmp .jpg etc."
Word.Application.ScreenUpdating = False
If Selection.Information(wdWithInTable) Then
' insert a picture in a table cell
r = Selection.Information(wdStartOfRangeRowNumber)
c = Selection.Information(wdStartOfRangeColumnNumber)
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
' Works reliably
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
s.height = h
s.width = w
' Not at all reliable
' Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
Else
' insert a picture at the cursor
h = 100
w = 100
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h)
End If
Word.Application.ScreenUpdating = True
s.WrapFormat.Type = wdWrapInline
s.Title = "Title"
s.AlternativeText = "Some metadata"
End Sub
The idea is to select either a cell in a table in a document or somewhere on the page outside of the table. The outside of the table case works as expected where the picture appears at the cursor location.
To see the problem, start with a fresh document, single page, add a 3 x 3 table and deepen the rows a bit. Be sure to supply a file to insert, variable f. Select one of the cells, then run the code. This works correctly when the picture is inserted as an inline shape then immediately converted to a shape. That happens with this line:
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
However, the preferred solution would be to insert a Shape from the beginning with code something like this:
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
The picture appears, but usually not in the expected location. It could be placed into a different cell or somewhere outside the table.
Is the rng argument to Shapes.AddPicture being ignored or mangled somehow?
Experimenting some more with the 3 x 3 table - adding pictures then setting every possible WrapFormat.Type (there are 8 possible values), I see that:
for every WrapFormat.Type except wdWrapInLine, picture insertion works correctly as long as they are done from left to right on a table row, and;
for every WrapFormat.Type without exception, when the row is initially empty, pictures inserted in columns 2 or 3 appear one column to the left.
Making the picture smaller, such as setting h = .height * 0.5 and w = .width * 0.5, has no effect on placement.
Thanks very much for any insight or elucidation.
The main problem appears to be about the pictures inserting in the wrong column. This would be because the "focus point" (location of the Range) of an empty table cell has its starting point in the previous cell. Doesn't really make a lot of sense, but that's how Word works...
Try collapsing the Range to the End, rather than the Start (wdCollapseEnd) in this extract from your code:
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseEnd 'instead of wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
In the end, selective usage of rng.collapse did the trick. I have yet to check whether this behaviour is the same in Word 2010 or 2016.
For the first shape anywhere in a table row, rng.collapse wdCollapseEnd.
For all subsequent shapes on that table row, rng.collapse wdCollapseBegin.
I used the following code to count up the shapes in table rows:
Dim numShapes() As Integer
Dim cel As Word.cell
ReDim numShapes(1 To Selection.Tables(1).Rows.Count)
For Each cel In Selection.Tables(1).Range.Cells
If cel.Range.ShapeRange.Count <> 0 Then
numShapes(cel.RowIndex) = numShapes(cel.RowIndex) + 1
End If
Next cel
and the check is simply
If numShapes(r) <> 0 Then
rng.collapse wdCollapseStart
Else
rng.collapse wdCollapseEnd
End If
where r is the row number from the first code example.
Initial experiments with merged cells suggest other problems...
Recently, in an interview I encountered a question in VBA. The question is:
Write a program to sort the shapes in a worksheet, like for example : I have various shapes like circle, triangle, rectangle, pentagon... This needs to be sorted and placed one below the other.
I tried with Shapes object and msoshapeRectangle method. But it didnt work.
Could you please tell me is this possible to be done?
Thanks
It was an interesting challenge, so I did it. Might as well post the result (commented for clarity):
Sub tgr()
'There are 184 total AutoShapeTypes
'See here for full list
'https://msdn.microsoft.com/VBA/Office-Shared-VBA/articles/msoautoshapetype-enumeration-office
Dim aShapeTypes(1 To 184) As String
Dim ws As Worksheet
Dim Shp As Shape
Dim i As Long, j As Long
Dim vShpName As Variant
Dim dLeftAlign As Double
Dim dTopAlign As Double
Dim dVerticalInterval As Double
Dim dHorizontalInterval As Double
Dim dPadding As Double
Set ws = ActiveWorkbook.ActiveSheet
'Sort order will be by the AutoShapeType numerical ID
'Using this, shapes will be sorted in this order (incomplete list for brevity):
' Rectangle, Parallelogram, Trapezoid, Diamond, Rounded rectangle, Octagon, Isosceles triangle, Right triangle, Oval, Hexagon
'Note that you can use a Select Case to order shapes to a more customized list
'I use this method to put the -2 (indicates a combination of the other states) at the bottom of the sort order
For Each Shp In ws.Shapes
Select Case Shp.AutoShapeType
Case -2: aShapeTypes(UBound(aShapeTypes)) = aShapeTypes(UBound(aShapeTypes)) & "||" & Shp.Name
Case Else: aShapeTypes(Shp.AutoShapeType) = aShapeTypes(Shp.AutoShapeType) & "||" & Shp.Name
End Select
Next Shp
'Now that all shapes have been collected and put into their sort order, perform the actual sort operation
'Adjust the alignment and vertical veriables as desired
'The Padding variable is so that the shapes don't start at the very edge of the sheet (can bet set to 0 if that's fine)
'I have it currently set to sort the shapes vertically, but they can be sorted horizontally by uncommenting those lines and commenting out the vertical sort lines
dPadding = 10
dLeftAlign = 5
dTopAlign = 5
dVerticalInterval = 40
dHorizontalInterval = 40
j = 0
For i = LBound(aShapeTypes) To UBound(aShapeTypes)
If Len(aShapeTypes(i)) > 0 Then
For Each vShpName In Split(Mid(aShapeTypes(i), 3), "||")
With ws.Shapes(vShpName)
'Vertical Sort
.Left = dLeftAlign
.Top = j * dVerticalInterval + dPadding
'Horizont Sort
'.Top = dTopAlign
'.Left = j * dHorizontalInterval + dPadding
End With
j = j + 1
Next vShpName
End If
Next i
End Sub
So I have been trying to make every 3 words in a word docuemnt bold in a specific selection or if there is nothing selected every 3 words in the whole document. I tried different approaches but nothing worked.
I should say "What have you tried so far?" and "Lets see your code.", but I haven't really coded in Word so thought I'd give it a go....
This seems to do the trick, although there may be a much better way to code it:
Public Sub BoldText()
Dim wrd As Range
Dim x As Long
Dim doc As Variant
If Selection.Start = Selection.End Then
Set doc = ThisDocument
Else
Set doc = Selection
End If
x = 0
For Each wrd In doc.Words
x = x + 1
If x Mod 3 = 0 Then
wrd.Bold = True
End If
Next wrd
End Sub
I'm creating a sales channel map and use the .Left/.Top w/ + (.5*.width/.Height) to get the center of the images I'm connecting. I'd like to also use this method to select the cell that corresponds to this coordinate.
The only solution I can think of (and could implement, but I'd rather avoid an iterative approach) would be something like:
Sub FindCellLoc(DesiredYLocation,DesiredXLocation)
'Finds the Column Number of the X coordinate
RunningTotalX = 0
For X = 1 to 100000000
RunningTotalX = RunningTotalX + Cells(1,X).width
if RunningTotalX >= DesiredXLocation then
TargetCol = Cells(1,X).Column
Goto FoundCol
End if
Next X
FoundCol:
'Finds the Column Number of the X coordinate
RunningTotalY = 0
For Y = 1 to 100000000
RunningTotalY = RunningTotalY + Cells(Y,1).width
if RunningTotalY >= DesiredYLocation then
TargetRow = Cells(Y,0).Column
Goto FoundRow
End if
Next Y
FoundRow
Cells(TargetRow,TargetCol).Select
End Sub
I'd really appreciate any input about a non-iterative approach.
Thanks,
-E
Here is a routine to select a cell based on the x and y position:
Public Sub SelectCellByPos(x, y)
With ActiveSheet.Shapes.AddLine(x, y, x, y)
.TopLeftCell.Select
.Delete
End With
End Sub
I assume you have access to the shape object from which you got the desired locations. If so, you could do something like
Function GetCenterCell(shp As Shape) As Range
Dim lRow As Long, lCol As Long
lRow = (shp.TopLeftCell.Row + shp.BottomRightCell.Row) \ 2
lCol = (shp.TopLeftCell.Column + shp.BottomRightCell.Column) \ 2
Set GetCenterCell = shp.Parent.Cells(lRow, lCol)
End Function
Sub test()
Dim shp As Shape
Set shp = Sheet1.Shapes(1)
Debug.Print GetCenterCell(shp).Address
End Sub
That won't give you the exact middle if there isn't an exact middle. It will skew top and left as the integer division truncates (I think). But using the TopLeftCell and BottomLeftCell properties will be far superior to iterating, even if it means you're iterating through the cells in that range or some other implementation.
Hi there!
I am trying to color a graph (a task tracker) via VBA, in excel. The idea is to color all "categories" a certain color -- visually, it would mean making all bars on each "row" a particular color. I'm using the following code, which I copied from http://peltiertech.com/vba-conditional-formatting-of-charts-by-category-label/:
Sub ColorByCategoryLabel()
Dim rPatterns As Range
Dim iCategory As Long
Dim vCategories As Variant
Dim rCategory As Range
Set rPatterns = ActiveSheet.Range("A1:A5")
With ActiveChart.SeriesCollection(2)
vCategories = .XValues
For iCategory = 1 To UBound(vCategories)
Set rCategory = rPatterns.Find(What:=vCategories(iCategory))
.Points(iCategory).Format.Fill.ForeColor.RGB = rCategory.Interior.Color
Next
End With
End Sub
and I can't figure out what is wrong.
Basically, I have a series (series2), with horizontal (category) axis labels consisting of integers from 1-5. This category determines the vertical position of the bar, but I also want to color each bar in this series according to this vertical position, according to the color in the range(a1:a5) -- which is exactly what this code seems to be doing.
Any suggestions, as to the code, or perhaps, any alternative way to color bar graphs based on the value of the "horizontal (category) axis"?
Thanks!
Well, I found an answer to my problem by stepping through it. I can't imagine this to be the easiest way to horizontal bar graphs according to their height but it works.
Sub ColorByCategoryLabel()
Dim iCategory As Long
Dim vCategories As Variant
Dim rCategory As Range
Dim CurColor As Double
Dim CurColorIndex As Long
Dim CurHeight As Double
CurHeight = 0
CurColorIndex = 1
CurColor = ActiveSheet.Cells(CurColorIndex + 1, 10).Interior.Color
ActiveSheet.ChartObjects("Chart 1").Select
With ActiveChart.SeriesCollection(2)
vCategories = .XValues
For iCategory = 1 To UBound(vCategories)
If .Points(iCategory).Top > CurHeight Then
CurColorIndex = CurColorIndex + 1
CurColor = ActiveSheet.Cells(CurColorIndex + 1, 10).Interior.Color
CurHeight = .Points(iCategory).Top
End If
.Points(iCategory).Format.Fill.ForeColor.RGB = CurColor
Next
End With
End Sub
You would need to modify the line
Curcolor = ActiveSheet.Cells(CurColorIndex+1,10).Interior.Color
To properly specify the cells whose background color you wish to copy.
By the way, if anyone is interested in the timetracker, it is hosted here: https://drive.google.com/file/d/0B85fvjQDbl3lUVpPNmdGT1VkWW8/view?usp=sharing