Promote/demote paragraphs in table

[Toskico]

Hi all,

I'm trying to write code which replicates the alt+shift+up/down keyboard shortcut for textboxes/shapes in a way that works with tables for Powerpoint 2007. So far, I have code which identifies the cell the selected text is in, as well as the index number (within the cell) of the first and last paragraphs selected. I've tried two ways of swapping the text so far, with little success:

using the insert before/after feature for paragraphs (doesn't retain the formatting of the paragraphs being moved)
Creating dummy textboxes and using .Copy/.PasteSpecial (ppPasteDefault) to move the paragraphs being switched to the text boxes and then back into their new spots in the cell. This actually works reasonably well, but for some reason doesn't handle bullets at level three or below (the bullet disappears and the indentation gets messed up). I'm also keen to find a method which doesn't clear the user's clipboard in the process, as this does.

[John Wilson]

These are not much more than doodles but I think the method works (move up in this caee)

Have a play and see if it can be improved


Sub tabler()
Dim otbl As Table
Dim i As Integer
Dim iRow As Integer
Dim strInsert As String
Dim iCol As Integer
Dim otxtR As TextRange2
Dim lngStart As Long
Dim lngEnd As Long
Dim lngNum As Long
On Error GoTo err
Set otbl = ActiveWindow.Selection.ShapeRange(1).Table
For iRow = 1 To otbl.Rows.Count
For iCol = 1 To otbl.Columns.Count
If otbl.Cell(iRow, iCol).Selected Then
lngStart = startPara(otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange, ActiveWindow.Selection.TextRange)
If ActiveWindow.Selection.TextRange.Length = 0 Then
lngEnd = lngStart
Else
lngEnd = endPara(otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange, ActiveWindow.Selection.TextRange)
End If
lngNum = lngEnd - lngStart + 1
If lngStart > 1 Then
otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Paragraphs(lngStart, lngNum).Cut
For i = 1 To lngNum
strInsert = strInsert & vbCrLf
Next
otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange.Paragraphs(lngStart - 1).InsertBefore (strInsert)
Set otxtR = otbl.Cell(iRow, iCol).Shape.TextFrame2.TextRange
otxtR.Paragraphs(lngStart - 1).Select
ActiveWindow.View.Paste
End If
End If
Next iCol
Next iRow
Exit Sub
err:
MsgBox "ERROR " & err.Description
End Sub

Function startPara(otxR As TextRange2, setTR As TextRange)
Dim p As Integer
For p = 1 To otxR.Paragraphs.Count
If otxR.Paragraphs(p).Start + otxR.Paragraphs(p).Length > setTR.Start Then
startPara = p
Exit For
End If
Next
End Function

Function endPara(otxR As TextRange2, setTR As TextRange)
Dim p As Integer
For p = 1 To otxR.Paragraphs.Count
If setTR.Start + setTR.Length <= otxR.Paragraphs(p).Start + otxR.Paragraphs(p).Length Then
endPara = p
Exit For
End If
Next
End Function

[Toskico]

Hey John,

This is definitely a massive improvement on what I was doing, so thanks. The only problem with it is that it adopts the destination formatting (so if the paragraphs being swapped are different sizes, the one being moved up gets changed). Is there a way of doing this which retains source formatting? I've tried using CommandBars.Executemso("PasteSourceFormatting"), but completely without success.

[John Wilson]

PasteSourceFormatting only came in with v. 2010. It will not work in 2007.