troubleshooting Question

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

Avatar of Luis Diaz
Luis Diaz asked on
Microsoft Office
2 Comments1 Solution136 ViewsLast Modified:
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

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

If you have questions, please contact me. Thank you for your help.
ASKER CERTIFIED SOLUTION
Jamie Garroch (MVP)
PowerPoint Technical Consultant

Our community of experts have been thoroughly vetted for their expertise and industry experience.

Join our community to see this answer!
Unlock 1 Answer and 2 Comments.
Start Free Trial
Learn from the best

Network and collaborate with thousands of CTOs, CISOs, and IT Pros rooting for you and your success.

Andrew Hancock - VMware vExpert
See if this solution works for you by signing up for a 7 day free trial.
Unlock 1 Answer and 2 Comments.
Try for 7 days

”The time we save is the biggest benefit of E-E to our team. What could take multiple guys 2 hours or more each to find is accessed in around 15 minutes on Experts Exchange.

-Mike Kapnisakis, Warner Bros