#1
|
|||
|
|||
Finding the graphics and inserting the keyword
Hi,
I am looking for some help in writing the vba macro to find all the figures in the word document and insert a line just above the each graphics in the work document. Sub Macro1() ' ' Macro1 Macro ' ' Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting With Selection.Find .Text = "^g" '.Replacement.Text = "" .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Like in this code it is able to find all the graphics but we dont want to replace the graphics, we want to keep them and add the line. Thanks in advance. |
#2
|
||||
|
||||
When shapes are positioned with text wrapping “Square”, Word inserts their captions into text boxes. In such situations, the caption ordering for multiple shapes anchored to a single paragraph is hard to control because it’s based on the order of the anchors in the document stream (which you can’t see). Captions in textboxes create other problems of their own if you create a Table of Figures; in that case, Word inserts a fully-qualified path into the TOF, which creates problems when the file is saved as PDF (the TOF links back to the original document).
It’s better, IMHO to insert the shapes into the cells of floating tables, as inlineshapes, with the captions in the tables also. The following macro resolves these issue. As coded, the macro processes all shapes & inline shapes, but it could be stripped down to work with just the shapes or even just a selected shape. Either way, the disconnect between the shapes and their captions will be resolved. Whatever positioning applied to the original Shape object will apply to the table also. As coded, the ‘MakeImageTable’ macro limits the inserted InlineShape dimesnsions to 7.5*5.0cm. That code can, of course, be edited/omitted, in which case, so too can the corresponding code that re-sizes the inserted InlineShape to fit. To have the caption row appear above the image, instead of below, change the Rows(1) references to Rows(2), change the Cell(1, 1) references to Cell(2, 1) and change the change the Cell(2, 1) references to Cell(1, 1). Note that, due to the extra space taken up by the caption row, all except for the first of the document's pictures are liable to shift position. Code:
Sub AddImageCaptionTables() Dim iShp As InlineShape, Rng As Range, Tbl As Table Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean With ActiveDocument For i = 1 To .InlineShapes.Count If .InlineShapes(i).Range.Information(wdWithInTable) = False Then PicWdth = .InlineShapes(i).Width Set Rng = .InlineShapes(i).Range With Rng If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString PicWdth = .InlineShapes(1).Width PicHght = .InlineShapes(1).Height .InlineShapes(1).Range.Cut End With BShp = False: VRel = 0: HRel = 0: VPos = 0: HPos = 0 Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos) End If Next While .Shapes.Count > 0 BShp = True With .Shapes(1) PicWdth = .Width PicHght = .Height VRel = .RelativeVerticalPosition HRel = .RelativeHorizontalPosition VPos = .Top HPos = .Left Set iShp = .ConvertToInlineShape End With With iShp Set Rng = .Range .Range.Cut End With Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos) Wend End With End Sub Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _ VRel As Long, HRel As Long, VPos As Single, HPos As Single) Dim Tbl As Table, sngScl As Single, iShp As InlineShape 'Constrain maximum image size If PicWdth > CentimetersToPoints(7.5) Then sngScl = PicWdth / CentimetersToPoints(7.5) PicWdth = PicWdth / sngScl PicHght = PicHght / sngScl End If If PicHght > CentimetersToPoints(5) Then sngScl = PicHght / CentimetersToPoints(5) PicWdth = PicWdth / sngScl PicHght = PicHght / sngScl End If 'Create & format the table Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=2, NumColumns:=1) With Tbl .Borders.Enable = True .Columns.Width = PicWdth .TopPadding = 0 .BottomPadding = 0 .LeftPadding = 0 .RightPadding = 0 .Spacing = 0 .Rows(1).HeightRule = wdRowHeightExactly .Rows(1).Height = PicHght With .Rows .LeftIndent = 0 If BShp = True Then .WrapAroundText = True .HorizontalPosition = HPos .RelativeHorizontalPosition = HRel .VerticalPosition = VPos .RelativeVerticalPosition = VRel .AllowOverlap = False End If End With With .Cell(1, 1).Range With .ParagraphFormat .SpaceBefore = 0 .SpaceAfter = 0 .LeftIndent = 0 .RightIndent = 0 .FirstLineIndent = 0 .KeepWithNext = True End With .Paste ' Resize the inserted InlineShape Set iShp = .InlineShapes(1) With iShp .Width = PicWdth .Height = PicHght End With End With With .Cell(2, 1).Range .Style = "Caption" .End = .End - 1 .InsertAfter vbCr .InsertCaption Label:="Figure", TitleAutoText:=" ", Title:="", _ Position:=wdCaptionPositionBelow, ExcludeLabel:=0 .Paragraphs.First.Range.Characters.Last.Text = vbNullString .Borders(wdBorderLeft).LineStyle = wdLineStyleNone .Borders(wdBorderRight).LineStyle = wdLineStyleNone .Borders(wdBorderTop).LineStyle = wdLineStyleNone End With End With End Sub With ActiveDocument to: With Selection and change: Code:
While .Shapes.Count > 0 With .Shapes(1) Code:
While .ShapeRange.Count > 0 With .ShapeRange(1)
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
#3
|
|||
|
|||
Powerful code but different from my requirment
Hi,
Thank you for putting efforts and helping me out. This code is certainly powerful but my requirement is less than this. and I feel bad that you wrote a big program but it is not direct useful to me. I want my vba program to find all the graphics in the word file and then add a same caption to all the existing graphs; just above the graph. So it is like advance version of find and replace. Find: All the graphics in the existing word file i.e. ^g Replace: Do not delete or modify the graph (keep the original graph) just add a one line (not caption) above all the graphs. Thank you for understanding. |
#4
|
||||
|
||||
Do you really need a macro? Try doing a search and replace with
Find: ^p^g Replace: ^pOne Line^&
__________________
Andrew Lockton Chrysalis Design, Melbourne Australia |
#5
|
|||
|
|||
Perfect, Thank you.
Simplified version, Solved my purpose.
|
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Summarize keyword into word document | simba24d | Word | 3 | 06-10-2016 02:28 PM |
Multiple keyword search in WORD | tvincent8118 | Word VBA | 1 | 06-23-2015 04:45 AM |
VBA find keyword and move to location then add symbol | Jmanville | Word VBA | 3 | 10-22-2014 01:45 AM |
Problem with Inserting Power-Point Graphics into Word | Don83 | Word | 4 | 03-12-2014 02:19 AM |
Find keyword in section & delete section | donaldadams1951 | Word VBA | 5 | 12-03-2013 10:08 AM |