WORD VBA Move image into a Table - vba

I'm in the process of writing a code to convert a PDF into DOCX. In the first step, i save the PDF as DOCX using acrobat object. The example shown in attachment is from one of the pages. Wrench Image is wrapped as "Behind the text" and it is not part of the table. My questions are,
how do i move it in to or make it as part of the table cell above using VBA. I tried wrap tight etc. It works for some of the images and not for majority of them. As the code goes through 100's of images, user does not have a visual of result from change in wrap format.
When i try to delete first blank paragraph using code, the wrench image shown in attachment gets deleted as it is not part of the table. How do i delete the first empty paragraph without deleting the image if the image is not part of table and is in "behind the text format".
Thanks
Edit1: Conversion of shape to inlineshape (with inline text wrap format) throws the image out of the table as shown in 2nd attachment.
Edit2:
Sub Resizeimage(iDoc As Word.Document)
Dim i As Long
On Error GoTo eh
With iDoc
' For i = .Shapes.Count To 1 Step -1
' With .Shapes(i)
' If .Type = msoPicture Then
' .ConvertToInlineShape
' End If
' End With
' Next
For i = .Shapes.Count To 1 Step -1
'Application.StatusBar = "Resizing & formatting Images - " &
Round((iDoc.Shapes.Count - (i + 1)) / iDoc.Shapes.Count * 100, 0) & "%
completed..."
With .Shapes(i)
If .width > Application.InchesToPoints(6) Then
.LockAspectRatio = msoTrue
.width = Application.InchesToPoints(6.9)
.Left = wdShapeCenter
'.WrapFormat.Type = wdWrapTight
End If
If .width > Application.InchesToPoints(3) Then
.RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
'.ZOrder msoBringToFront
.Left = wdShapeCenter
'.WrapFormat.Type = wdWrapTight
ElseIf .width > Application.InchesToPoints(1.75) And .width <
Application.InchesToPoints(2.75) And .WrapFormat.Type = wdWrapTight Then
.RelativeHorizontalPosition =
wdRelativeHorizontalPositionLeftMarginArea
.Left = Application.InchesToPoints(0.1)
.ZOrder msoBringToFront
ElseIf .width < Application.InchesToPoints(1.75) Then
.RelativeHorizontalPosition =
wdRelativeHorizontalPositionRightMarginArea
.Left = Application.InchesToPoints(-2)
End If
End With
Next
End With
Exit Sub
eh:
Call Errorhandler("Resizeimage", Err)
End Sub

When a floating shape is converted to inline, it moves to the position where its anchor formerly was. So we can predict the image position by finding the anchor location. After conversion, expand the range to include the picture, then cut it and paste into the table:
Sub Float2Inline()
Dim oRange As Range
Set oRange = ActiveDocument.Shapes(1).Anchor
ActiveDocument.Shapes(1).ConvertToInlineShape
With oRange
.Expand Unit:=wdParagraph
.Cut
End With
ActiveDocument.Tables(1).Rows(2).Cells(3).Range.Paste
End Sub

Related

Changing Font Outline color inside a Table Cell with VBA using Application.CommandBar.ExecuteMSO

Win10x64 Office 365 PPT v 16.0.12325.202080 64-bits
I need to show a character with a yellow font color but a black outline, for readability purposes. This character goes inside a Powerpoint table Cell.
The following link has a method that I'm currently using that consists of creating a dummy shape, adding text to it, modify the shape's textframe2 textrange font line properties and then copying it and pasting it back to the table cell.
http://www.vbaexpress.com/forum/archive/index.php/t-43787.html
This was asked 8 years ago, but I'm currently seeing the same behaviour where we can't directly manipulate the textframe2 wordart format of text inside a cell. The program doesn't show an error but doesn't work.
I have given up on trying to modify the textrame2 textrange font line properties directly from VBA.
I have managed to get it to activate the font outline color using
Application.CommandBars.ExecuteMso ("TextOutlineColorPicker")
After it's activated I thought I could modify the textframe2 textrange font line properties, but it still doesn't work.
Is there an Application.CommandBars idMso for changing the font outline color and font outline line width inside a table cell?
Or another other than pasting the formatted text inside a table cell.
Edit:
Adding an image to illustrate what I mean by text color and text outline color and the menu used to show them in red circle:
Edit2
Added another snapshot to exemplify a character inside a cell with black outline and a character inside a cell without an outline
Thanks
Here's an example to access a Table on a given slide and change one cell's attributes. The example slide I'm using looks like this
The code itself creates a function that allows you to select a table from a particular slide, and a single cell within the table and highlight it.
Option Explicit
Sub test()
HighlightTableCell 1, 2, 3
End Sub
Sub HighlightTableCell(ByVal slideNumber As Long, _
ByVal thisRow As Long, _
ByVal thisCol As Long)
Dim theSlide As Slide
Set theSlide = ActivePresentation.Slides(slideNumber)
Dim shp As Shape
For Each shp In theSlide.Shapes
If shp.Type = msoTable Then
Dim theTable As Table
Set theTable = shp.Table
With theTable.Cell(thisRow, thisCol)
With .Shape.TextFrame2.TextRange.Characters.Font.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 0)
.Transparency = 0
.Solid
End With
With .Shape.TextFrame2.TextRange.Characters.Font.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorText1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
End With
End With
End If
Next shp
End Sub
This question should be answered by Microsoft Office developers.
Currently, to overcome this bug-some situation, I think, copying the formatted text outside the table and pasting it into a table cell is the only work-around for this trouble.
As you mentioned, according to John Wilson, one of the most brilliant PowerPoint MVPs(http://www.vbaexpress.com/forum/archive/index.php/t-43787.html), if we copy the text from a textbox or shape that is located outside of the table, the format of the text can be preserved even for the text in a table cell.
Option Explicit
Sub test()
Dim shp As Shape, tshp As Shape
Dim sld As Slide
Dim tbl As Table
Dim r%, c%
If ActiveWindow.Selection.Type = ppSelectionNone Then MsgBox "Select a table first.": Exit Sub
Set shp = ActiveWindow.Selection.ShapeRange(1)
Set sld = shp.Parent
'add a temporary textbox for copying the formatted text into a cell
Set tshp = sld.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 541, 960, 540)
tshp.Visible = False
Set tbl = shp.Table
For r = 1 To tbl.Rows.Count
For c = 1 To tbl.Columns.Count
'1) cell -> 'tshp'
tbl.Cell(r, c).Shape.TextFrame2.TextRange.Copy
tshp.TextFrame2.TextRange.Paste
'2) outline the text in 'tshp'
With tshp.TextFrame2.TextRange.Font.Line
.Visible = msoTrue
.Weight = 0.2
.ForeColor.RGB = RGB(255, 127, 127)
End With
'3) 'tshp' -> cell
tshp.TextFrame2.TextRange.Copy
tbl.Cell(r, c).Shape.TextFrame2.TextRange.Paste
'// the code below doesn't work
'With tbl.Cell(r, c).shape.TextFrame2.TextRange.Characters.Font.Line
'With tbl.Cell(r, c).shape.TextFrame2.TextRange.Font.Line
' .Visible = msoTrue
' .Weight = 0.5
' .ForeColor.RGB = RGB(255, 127, 127)
'End With
Next c
Next r
'remove the tempoarary textbox
tshp.Delete
End Sub
The above snippet creates a temporary textbox on left-top area of the slide and applies the outlined text format. Then, it copies the content of each cell to the temporary textbox and copy/paste the formatted text back to the cell. By using this method, we can apply the outlined text format to the text in a cell.

How to find the index of a Powerpoint Shape

I'm writing a VBA script to copy+paste charts from an Excel worksheet to an existing Powerpoint presentation as Picture.
So far I was successful to do the copy-paste as Picture, but failed to change the size of the pasted picture. I believe the pasted picture is a shape, so I'm trying to do something like:
For Each iChart In arrChart
xlWorkBook.Worksheets("PPT").ChartObjects(iChart).CopyPicture
ActivePresentation.Slides(iCurrSlide).Shapes.Paste
'Reshape
ActivePresentation.Slides(iCurrSlide).Select
With ActivePresentation.Slides(iCurrSlide).Shapes.Item(5)
.Select
.Height = ActiveWindow.Presentation.PageSetup.SlideHeight
.Width = ActiveWindow.Presentation.PageSetup.SlideWidth
.Left = 0
.Top = 0
End With
iCurrSlide = iCurrSlide + 1
Next iChart
However I seem to get the wrong index, so I'm wondering if there is a way to capture the index of the picture (as a shape)? I have my hands tied as I cannot name the picture (if I'm to name each picture pasted, I'd rather throw the script into garbage can and simply paste manually), and I cannot change anything about the pptx and xlsx.
Avoid selecting anything unless it's absolutely necessary, which it seldom is.
Assuming this is happening in VBA within PPT:
Dim oSh as Shape
For Each iChart In arrChart
xlWorkBook.Worksheets("PPT").ChartObjects(iChart).CopyPicture
' Set a reference to the just-pasted shape
Set oSh = ActivePresentation.Slides(iCurrSlide).Shapes.Paste(1)
'Reshape
' You don't need this:
' ActivePresentation.Slides(iCurrSlide).Select
' With ActivePresentation.Slides(iCurrSlide).Shapes.Item(5)
With oSh
' No need to select it as long as you've got a reference to it:
'.Select
' I'd use ActivePresentation.PageSetup here but it may not matter
.Height = ActiveWindow.Presentation.PageSetup.SlideHeight
.Width = ActiveWindow.Presentation.PageSetup.SlideWidth
.Left = 0
.Top = 0
End With ' oSh
iCurrSlide = iCurrSlide + 1
Next iChart

VBA Word Shape location - top left corner

I have written a small function, based on example provided by producer of Stroke Scribe ActiveX object. This is an plugin which allows us to create in Microsoft Word by VBA Macro an QR Code object.
The problem is with setting up a shape location
shp.Left = 0 + LeftMargin
shp.Top = 0 + TopMargin
I would like to put this shape (QR Code) on specific page on the most left top corner. But sometimes shape jumps to previous page (on bottom) or other location (vertical center).
Can you help me recognize a problem and fix it to locate Shape Object every time top left corner?
Code:
Sub QRCodeGenerator(SOP, BookmarkID, Page, TopMargin, LeftMargin)
Dim doc As Document
Set doc = Application.ActiveDocument
For Each sh In doc.Shapes
If sh.Type = msoOLEControlObject Then
If sh.OLEFormat.ProgID = "STROKESCRIBE.StrokeScribeCtrl.1" Then
sh.Delete
End If
End If
Next
With doc.PageSetup
usable_w = .PageWidth
usable_h = .PageHeight
End With
Dim pg As Range
Set pg = doc.GoTo(wdGoToPage, wdGoToRelative, Page)
Dim shp As Shape
Set shp = doc.Shapes.AddOLEControl(ClassType:="STROKESCRIBE.StrokeScribeCtrl.1", Anchor:=pg)
Dim sMyString As String
sMyString = ActiveDocument.Bookmarks(BookmarkID).Range.Text
sMyString = Replace(sMyString, "FORMTEXT ", "")
shp.LockAspectRatio = msoFalse
shp.Height = InchesToPoints(0.6)
shp.Width = shp.Height
shp.Left = 0 + LeftMargin
shp.Top = 0 + TopMargin ' // usable_h - shp.Height * 3 + TopMargin
Dim ss As StrokeScribe
Set ss = shp.OLEFormat.Object
ss.Alphabet = QRCODE 'StrokeScribe will draw a QR code picture
ss.Text = SOP & ";" & sMyString 'Any text you want to encode in the barcode
ss.QrECL = H 'Changes the default error correction level. This can be omitted
ss.QrMinVersion = 3 'Specifies the minimum barcode size. This can be omitted
ss.FontColor = RGB(0, 0, 0)
' ss.UTF8 = True 'Enable this, if you want to encode national characters for smartphones
If ss.Error Then
MsgBox ss.ErrorDescription
End If
End Sub
Word SHAPE objects must be anchored to a Range. The page location of that Range determines on which page the Shape will display. There's nothing you can do to "lock" a Shape to a particular page.
That said, it is possible to dictate that a Shape always appears in the same location on whichever page the anchoring Range lies.
This is always tricky if you add such a Shape before document editing is finished, because editing can move the anchoring paragraph to a different page. It can help to choose a paragraph as the anchor that's unlikely to move, for example perhaps the first paragraph on the page.
Something I did once, long ago, was write a macro that checks the page locations of Shapes before printing or saving. When inserting and positioning the Shape, I give it a Name that includes the page number. Before printing/saving the macro checks the page number in the Shape name with the page on which the Shape is located. If the two don't match, CUT the Shape and PASTE it to a paragraph on the correct page (it remembers its position settings).
The code sample below demonstrates how to name the Shape, lock the anchor to a specific paragraph and position the Shape flush to the top, left corner of the page.
Sub ShapePosTopLeft()
Dim doc As word.Document
Dim shp As word.Shape
Dim rng As word.Range
Set doc = ActiveDocument
Set rng = doc.GoTo(wdGoToPage, wdGoToRelative, Page)
Set rng = rng.Paragraphs(1).Range
Set shp = doc.Shapes.AddOLEControl(ClassType:="STROKESCRIBE.StrokeScribeCtrl.1", Anchor:=rng)
With shp
.Name = "Shape_Page" & Page
.LockAnchor = True
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Left = 0
.Top = 0
End With
End Sub

Access Shape By Name in Header

My first post so sorry for any errors.
I am trying to replace a image in the header of a document. This will be done a few thousand times.
This line of code:
Set shp = ActiveDocument.Sections(1).Headers.Shapes(strPic)
Causes:
Compile error: Method or data member not found
and
Set shp = ActiveDocument.Shapes("strPic")
Causes:
Run-time error '-2147024809(80070057): The item with the specified name wasn't found.
I have written in multiple ways and cannot get it to assign shp I feel like this is a very simple issue of how I am accessing the header or maybe this whole sub is just wrong. The strPic line before get the name of the shape fine.
Sub imagerepl()
With Selection
' \\ If we selected a InlineShape then convert to Shape
If .Type = wdSelectionInlineShape Then
.InlineShapes(1).ConvertToShape
End If
End With
strPic = Selection.ShapeRange.Name
Set shp = ActiveDocument.Sections(1).Headers.Shapes(strPic)
'Capture properties of exisitng picture such as location and size
With shp
t = .Top
l = .Left
h = .Height
w = .Width
End With
ActiveDocument.StoryRanges(wdPrimaryHeaderStory).ShapeRange(strPic).Delete
Set shp = ActiveDocument.Shapes.AddPicture("C:\Users\tk\Pictures\DFHlogo.png", msoFalse, msoTrue, l, t, w, h)
shp.Name = strPic
shp.ScaleHeight Factor:=1, RelativeToOriginalSize:=msoTrue
shp.ScaleWidth Factor:=1, RelativeToOriginalSize:=msoTrue
End Sub
You can access the header image through the Range.InlineShapes collection. For example, the following routine would delete the first image in the collection and then add new image to the header.
Dim sh As InlineShape
With ThisDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range
' Get the first (possibly only, for you) image in the header...
Set sh = .InlineShapes(1)
' Delete it...
sh.Delete
' Add a new image to the header...
Set sh = .InlineShapes.AddPicture("c:\path\to\my.jpg")
' Set its properties...
sh.Width = 100
sh.Height = 100
...
End With

Finding if a TextBox/Label caption fits in the control

The scenario is trying to adjust font size to get a nice graphic arrangement, or trying to decide where to break a caption/subtitle.
a) In XL VBA is there a way to find out whether a text on a textbox, or caption on a label, still fits the control?
b) Is there a way to know where was the text/caption broken on multiline control?
I gave this a rest, gave it enough back-of-head time (which produces far better results than "burp a non-answer ASAP, for credits"), and...
Function TextWidth(aText As String, Optional aFont As NewFont) As Single
Dim theFont As New NewFont
Dim notSeenTBox As Control
On Error Resume Next 'trap for aFont=Nothing
theFont = aFont 'try assign
If Err.Number Then 'can't use aFont because it's not instantiated/set
theFont.Name = "Tahoma"
theFont.Size = 8
theFont.Bold = False
theFont.Italic = False
End If
On Error GoTo ErrHandler
'make a TextBox, fiddle with autosize et al, retrive control width
Set notSeenTBox = UserForms(0).Controls.Add("Forms.TextBox.1", "notSeen1", False)
notSeenTBox.MultiLine = False
notSeenTBox.AutoSize = True 'the trick
notSeenTBox.Font.Name = theFont.Name
notSeenTBox.SpecialEffect = 0
notSeenTBox.Width = 0 ' otherwise we get an offset (a ""feature"" from MS)
notSeenTBox.Text = aText
TextWidth = notSeenTBox.Width
'done with it, to scrap I say
UserForms(0).Controls.Remove ("notSeen1")
Exit Function
ErrHandler:
TextWidth = -1
MsgBox "TextWidth failed: " + Err.Description
End Function
I feel I'm getting/got close to answer b), but I'll give it a second mind rest... because it works better than stating "impossible" in a flash.
I'm sure there is no way to do this with the ordinary Excel controls on the Forms toolbar, not least because (as I understand it) they are simply drawings and not full Windows controls.
The simplest approach may be to make a slightly conservative estimate of the maximum text length for each control, through a few tests, and use these to manage your line breaks.
This can be achieved by taking advantage of the label or textbox's .AutoSize feature, and looping through font sizes until you reach the one that fits best.
Public Sub ResizeTextToFit(Ctrl As MSForms.Label) 'or TextBox
Const FONT_SHRINKAGE_FACTOR As Single = 0.9 'For more accuracy, use .95 or .99
Dim OrigWidth As Single
Dim OrigHeight As Single
Dim OrigLeft As Single
Dim OrigTop As Single
With Ctrl
If .Caption = "" Then Exit Sub
.AutoSize = False
OrigWidth = .Width
OrigHeight = .Height
OrigLeft = .Left
OrigTop = .Top
Do
.AutoSize = True
If .Width <= OrigWidth And .Height <= OrigHeight Then
Exit Do 'The font is small enough now
.Font.Size = .Font.Size * FONT_SHRINKAGE_FACTOR
.AutoSize = False
Loop
.AutoSize = False
.Width = OrigWidth
.Height = OrigHeight
.Left = OrigLeft
.Top = OrigTop
End With
End Sub