Microsoft Office Forums

Go Back   Microsoft Office Forums > >

 
 
Thread Tools Display Modes
Prev Previous Post   Next Post Next
  #5  
Old 07-08-2014, 06:17 PM
excelledsoftware excelledsoftware is offline Get the TEXT of Clicked Shape Windows 7 64bit Get the TEXT of Clicked Shape Office 2003
IT Specialist
 
Join Date: Jan 2012
Location: Utah
Posts: 455
excelledsoftware will become famous soon enough
Default

I took a look at this myself. The issue is just like Bob said. The application.caller is pulling the first shape it can. Your code works flawlessly when the shapes have different names. I started thinking why it would be necessary to have the shapes all have the same name and then it occurred to me. (I am assuming here) It is very easy to duplicate a shape in Excel by clicking and dragging with control or just copying and pasting. It is really annoying to have to go and rename all the shapes. So based off of this assumption I believe it would be helpful for you to have a way to name all of the shapes with a unique but similar name all at once. I wrote 2 procedures for you that will do this. The first renames every shape followed by a number. So if you decided to name the shapes "Default" the first shape would be Default1 then Default2 etc.

The 2nd procedure will name only the selected shapes. This one is a little more detailed since it needs to check if the name has already been taken otherwise there is no point.

Here are the 2 procedures let me know if this helps.

Code:
Sub NameAllTheShapes()
  'Names all of the shapes a set name with a unique number
  Dim shp As Shape
  Dim NewName As String
  Dim x As Integer
  
    NewName = InputBox("What is the new name for the shapes")
    If NewName = "" Then Exit Sub
    
    x = 1
  
    For Each shp In ActiveSheet.Shapes
      shp.Name = NewName & x
      x = x + 1
    Next shp
  
End Sub

Sub NameSelectedShapes()
  'Names all selected shapes
  Dim shp As Shape
  Dim SR As Variant
  Dim CheckShape(0 To 300) As String
  Dim NewName As String
  Dim x As Integer, y As Integer, TotShapes As Integer
    On Error Resume Next
    Set SR = Selection.ShapeRange
    If SR Is Nothing Then
      MsgBox "No shapes selected"
      End
    End If
    On Error GoTo 0 'Enable Errors again
    
  
    NewName = InputBox("What is the new name for the shapes")
    If NewName = "" Then Exit Sub
    y = 0
    x = 1
    
    
    For Each shp In ActiveSheet.Shapes
      CheckShape(y) = shp.Name
      y = y + 1
    Next shp
    TotShapes = y - 2
    
    
    
    'Check if the name is in use
      For Each shp In Selection.ShapeRange
        For y = 0 To TotShapes
          If CheckShape(y) = NewName & x Then
            MsgBox ("The group name " & NewName & " is already in use." _
            & vbLf & "Program ending")
            End
          End If
        Next y
        x = x + 1
      Next shp
      x = 1
            
      For Each shp In Selection.ShapeRange
        shp.Name = NewName & x
        x = x + 1
      Next shp

    
End Sub
Reply With Quote
 



Similar Threads
Thread Thread Starter Forum Replies Last Post
Copied shape/text box pastes as an image in Word spectator Word 0 06-04-2014 08:45 AM
Get the TEXT of Clicked Shape how to paste text as shape bsapaka Excel 1 05-01-2014 06:53 AM
Shape+text issue when saving to PDF HMS Word 1 07-12-2013 04:43 PM
Get the TEXT of Clicked Shape autofit text to shape (msoShapeRectangle) viuf PowerPoint 2 02-20-2012 02:11 PM
Get the TEXT of Clicked Shape Adding text to auto shape and rotating Hot Mumma Word 1 06-14-2011 05:15 PM

Other Forums: Access Forums

All times are GMT -7. The time now is 05:56 PM.


Powered by vBulletin® Version 3.8.11
Copyright ©2000 - 2025, vBulletin Solutions Inc.
Search Engine Optimisation provided by DragonByte SEO (Lite) - vBulletin Mods & Addons Copyright © 2025 DragonByte Technologies Ltd.
MSOfficeForums.com is not affiliated with Microsoft