We help IT Professionals succeed at work.

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

Luis Diaz
Luis Diaz asked
on
78 Views
Last Modified: 2020-05-06
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.
Comment
Watch Question

PowerPoint Technical Consultant
CERTIFIED EXPERT
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION
Luis DiazIT consultant

Author

Commented:
Tested for 3 applications and the proposal works! Thank you again for your help!

Gain unlimited access to on-demand training courses with an Experts Exchange subscription.

Get Access
Why Experts Exchange?

Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.

Jim Murphy
Programmer at Smart IT Solutions

When asked, what has been your best career decision?

Deciding to stick with EE.

Mohamed Asif
Technical Department Head

Being involved with EE helped me to grow personally and professionally.

Carl Webster
CTP, Sr Infrastructure Consultant
Empower Your Career
Did You Know?

We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE

Ask ANY Question

Connect with Certified Experts to gain insight and support on specific technology challenges including:

  • Troubleshooting
  • Research
  • Professional Opinions
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.