Avatar of Luis Diaz
Luis Diaz asked on

MS office VBA: delete text of selected shapes (cross app compatibility)

Hello experts,

Following procedure allows me to delete text of selected shapes:
Sub Del_Text_Selected_Shapes()
  Dim oSR As ShapeRange
  Dim oShp As Shape
  
  
  MsgBox "To add modular approach", vbCritical: Exit Sub
  On Error Resume Next
  
  
  With ActiveWindow.Selection
    If .HasChildShapeRange Then
      Set oSR = ActiveWindow.Selection.ChildShapeRange
    Else
      Set oSR = ActiveWindow.Selection.ShapeRange
    End If
  End With
  
  If oSR Is Nothing Then MsgBox "Unable to proceed as shapes haven't been selected.": Exit Sub
  
  For Each oShp In oSR
    Select Case oShp.Type
      Case msoGroup
        Dim oGrpItem As Shape
        For Each oGrpItem In oShp.GroupItems
          If oGrpItem.HasTextFrame Then oGrpItem.TextFrame.DeleteText
        Next
      Case msoTable
        Dim lCol As Long, lRow As Long
        With oShp.Table
          For lCol = 1 To .Rows.Count
            For lRow = 1 To .Columns.Count
              With .Cell(lRow, lCol).Shape.TextFrame
                If .HasText Then .DeleteText
              End With
            Next
          Next
        End With
      Case Else
        If oShp.HasTextFrame Then oShp.TextFrame.DeleteText
    End Select
  Next
End Sub

Open in new window


I need to use this procedure for Word and Excel.
Possible to have a cross app compatibility?

I put an example of previous procedures that used modular approach:

Public Sub Swap_Shapes()
  Dim oApp As Object  ' Excel, PowerPoint or Word application
  Dim sngTop As Single
  Dim sngLeft As Single
  Dim oSR As ShapeRange
  
  On Error Resume Next

  Set oApp = Application
  
  With ActiveWindow.Selection
    Select Case oApp.Name
      Case "Microsoft PowerPoint"
        If .HasChildShapeRange Then
          Set oSR = .ChildShapeRange
        Else
          Set oSR = .ShapeRange
        End If
      Case "Microsoft Excel"
        Set oSR = .ShapeRange
      Case "Microsoft Word"
        If .ShapeRange(1).Type = msoCanvas Then
          Set oSR = .ChildShapeRange
        Else
          Set oSR = .ShapeRange
        End If
    End Select
  End With
  
  If oSR Is Nothing Then MsgBox "Unable to proceed as shapes haven't been selected.": Exit Sub
  If oSR.Count <> 2 Then MsgBox "You must select two shapes.": Exit Sub
  
  With oSR
    sngTop = .Item(1).Top
    sngLeft = .Item(1).Left
    .Item(1).Top = .Item(2).Top
    .Item(1).Left = .Item(2).Left
    .Item(2).Top = sngTop
    .Item(2).Left = sngLeft
  End With
End Sub

Open in new window


If you have questions, please contact me. Thank you for your help.
Microsoft Office

Avatar of undefined
Last Comment
Luis Diaz

8/22/2022 - Mon
ASKER CERTIFIED SOLUTION
Jamie Garroch (MVP)

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
ASKER
Luis Diaz

Tested for 3 applications and the proposal works! Thank you again for your help!
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy