InlineShape marco problam

[Chris Joyce]

I've almost got this one working ( even if its not neat ) but I can't seem
to work out one small problam .

The aim is to locate all InlineShapes, split the table cell they are in and
move them to the new cell .

I've got it working but it seems to act on the forst image twice ! ,
if I select anything after the first image then run the macro everything is
ok !

I can't seem to work out why ?

maybe there is a better way to do the same action.

Chris


Sub SplitCellsWithImg()

' Find All InlineImages and split the cell
' then move the Inline to the new cell

Dim oILS As InlineShape
Dim oRg As Range

For Each oILS In ActiveDocument.InlineShapes

Selection.Find.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

Selection.Cells.Split NumRows:=1, NumColumns:=2,
MergeBeforeSplit:=False
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.MoveRight unit:=wdCharacter, Count:=11
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=1

Selection.Find.ClearFormatting
With Selection.Find
.Text = "^g"
.Replacement.Text = ""
.Forward = False
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Cut
Selection.MoveRight unit:=wdCell
Selection.Paste
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone

Next oILS

End Sub

 

[Andra]

a sligthly better version, I suppose:

Sub aSplitCellsWithImg2()
' Find All InlineImages and split the cell
' then move the Inline to the new cell
On Error GoTo ErrProc

c = ActiveDocument.InlineShapes.Count
For i = 1 To c
Selection.Find.ClearFormatting
With Selection.Find
.Text = "^g"
.Forward = True
.Wrap = wdFindContinue
.Format = False
End With
Selection.Find.Execute
If Selection.Information(wdWithInTable) Then
Selection.Cells.Split NumRows:=1, NumColumns:=2,
MergeBeforeSplit:=False
Selection.MoveLeft Unit:=wdCell
Selection.Cut
Selection.MoveRight Unit:=wdCell
Selection.Paste
Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
End If
Next i

Exit Sub
ErrProc:
MsgBox Err.Description, vbExclamation, "Error " & Err.Number
End Sub



Chris Joyce wrote

 

[Jean-Guy Marcil]

Bonjour,

Dans son message, < Chris Joyce > écrivait :
In this message, < Chris Joyce > wrote:

|| I've almost got this one working ( even if its not neat ) but I can't
seem
|| to work out one small problam .
||
|| The aim is to locate all InlineShapes, split the table cell they are in
and
|| move them to the new cell .
||
|| I've got it working but it seems to act on the forst image twice ! ,
|| if I select anything after the first image then run the macro everything
is
|| ok !
||
|| I can't seem to work out why ?
||
|| maybe there is a better way to do the same action.
||
|| Chris
||
||
|| Sub SplitCellsWithImg()
||
|| ' Find All InlineImages and split the cell
|| ' then move the Inline to the new cell
||
|| Dim oILS As InlineShape
|| Dim oRg As Range
||
|| For Each oILS In ActiveDocument.InlineShapes
||
|| Selection.Find.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
||
|| Selection.Cells.Split NumRows:=1, NumColumns:=2,
|| MergeBeforeSplit:=False
|| Selection.MoveLeft unit:=wdCharacter, Count:=1
|| Selection.MoveRight unit:=wdCharacter, Count:=11
|| Selection.MoveLeft unit:=wdCharacter, Count:=1
|| Selection.MoveRight unit:=wdCharacter, Count:=1
|| Selection.MoveLeft unit:=wdCharacter, Count:=1
||
|| Selection.Find.ClearFormatting
|| With Selection.Find
|| .Text = "^g"
|| .Replacement.Text = ""
|| .Forward = False
|| .Wrap = wdFindContinue
|| .Format = False
|| .MatchCase = False
|| .MatchWholeWord = False
|| .MatchWildcards = False
|| .MatchSoundsLike = False
|| .MatchAllWordForms = False
|| End With
|| Selection.Find.Execute
|| Selection.Cut
|| Selection.MoveRight unit:=wdCell
|| Selection.Paste
|| Selection.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
||
|| Next oILS
||
|| End Sub

One of the problem is that the line
|| For Each oILS In ActiveDocument.InlineShapes
is not reliable when you start moving/copying/pasting stuff around. A shape
can be grabbed twice... or you could end up in an infinite loop.

Also, since you are using a For/Next, why are you using a Find/Replace?

Try this:

'_______________________________________
Sub SplitCellsWithImg()

' Find All InlineImages that are in a table
' and split the cell
' then move the Inline to the new cell

Dim oILS As InlineShape
Dim oRg As Range
Dim i As Long

Application.ScreenUpdating = False

Set oRg = Selection.Range

For i = ActiveDocument.InlineShapes.Count To 1 Step -1
Set oILS = ActiveDocument.InlineShapes(i)
oILS.Select
With Selection
If .Information(wdWithInTable) Then
.Cells.Split NumRows:=1, NumColumns:=2, MergeBeforeSplit:=False
.Cut
.MoveRight unit:=wdCell
.Paste
.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
End If
End With
Next i

oRg.Select

Application.ScreenRefresh
Application.ScreenUpdating = True

End Sub
'_______________________________________

--
Salut!
_______________________________________
Jean-Guy Marcil - Word MVP
(e-mail address removed)
Word MVP site: http://www.word.mvps.org