问题
The command ActiveDocument.Pages(1).Shapes.Range.Select doesnot seem to work in word 2010. (It used to work in word 2003).
I need to select all the shapes on a specified page (say page 1), then delete the first shape and last shape on each page of a 300 page word document.
Any help on how to do this will be of great help.
Regards
Firaq pasto
回答1:
UPDATE1 - Removed (only works on inline shapes)
UPDATE2 - Removed (only works on inline shapes)
UPDATE3 - Removed (Delete using the Shape's Name not necessary the right Shape as they can all be the same)
UPDATE4 - Check and Delete using Shape's ID.
To delete the top and bottom shapes of all the pages (be it inline with text or floating). Code below checks for the real Top Left (TL) corner and Bottom Right (BR) corner of the shape when you select it. E.G. The Block Arc here is the considered the Bottom shape instead of the Left Bracket.
If only the TL is of concern, then remove the lines x2 = x1 + ... and y2 = y1 + ... and replace all y2 with y1, x2 with x1 in the if end if blocks.
Sub DeleteAllTopBottomShapes()
On Error Resume Next
Dim aShapeTopID() As Variant ' ID of shape to delete with min vertical location
Dim aShapeBottomID() As Variant ' ID of shape to delete with max vertical location
Dim aShapeMinX() As Variant ' position of shape (min horizontal location)
Dim aShapeMinY() As Variant ' position of shape (min vertical location)
Dim aShapeMaxX() As Variant ' position of shape (max horizontal location)
Dim aShapeMaxY() As Variant ' position of shape (max vertical location)
Dim x1 As Single, y1 As Single ' x and y-axis values (top left corner of shape)
Dim x2 As Single, y2 As Single ' x and y-axis values (bottom right corner of shape)
Dim i As Long, n As Long ' counters
Dim oSh As Shape
'Application.ScreenUpdating = False
' Prepare arrays
n = ActiveDocument.ComputeStatistics(wdStatisticPages) - 1
ReDim aShapeTopID(n)
ReDim aShapeBottomID(n)
ReDim aShapeMinX(n)
ReDim aShapeMinY(n)
ReDim aShapeMaxX(n)
ReDim aShapeMaxY(n)
' Preset the minimum axis values to max according to the pagesetup
For i = 0 To n
aShapeMinX(i) = ActiveDocument.PageSetup.PageHeight
aShapeMinY(i) = ActiveDocument.PageSetup.PageWidth
Next
' Search for the top and bottom shapes
For Each oSh In ActiveDocument.Shapes
With oSh.Anchor
i = .Information(wdActiveEndAdjustedPageNumber) - 1
x1 = .Information(wdHorizontalPositionRelativeToPage) + oSh.Left
y1 = .Information(wdVerticalPositionRelativeToPage) + oSh.Top
x2 = x1 + oSh.Width
y2 = y1 + oSh.Height
End With
Application.StatusBar = "Checking Shape """ & oSh.Name & """ (ID: " & oSh.ID & ") on Page " & i + 1 & " TL:(" & x1 & ", " & y1 & ") BR:(" & x2 & ", " & y2 & ")"
Debug.Print "Pg." & i + 1 & vbTab & "(ID:" & oSh.ID & ") """ & oSh.Name & """" & vbTab & "TL:(" & x1 & ", " & y1 & ") BR:(" & x2 & ", " & y2 & ")"
' Check for Top Left corner of the Shape
If y1 < aShapeMinY(i) Then
aShapeMinY(i) = y1
aShapeMinX(i) = x1
aShapeTopID(i) = oSh.ID
ElseIf y1 = aShapeMinY(i) Then
If x1 < aShapeMinX(i) Then
aShapeMinX(i) = x1
aShapeTopID(i) = oSh.ID
End If
End If
' Check for Bottom Right corner of the Shape
If y2 > aShapeMaxY(i) Then
aShapeMaxY(i) = y2
aShapeMaxX(i) = x2
aShapeBottomID(i) = oSh.ID
ElseIf y2 = aShapeMaxY(i) Then
If x2 > aShapeMaxX(i) Then
aShapeMaxX(i) = x2
aShapeBottomID(i) = oSh.ID
End If
End If
Next
Debug.Print
' Delete the Top and Bottom shapes
For i = 0 To n
If Not IsEmpty(aShapeTopID(i)) Then
For Each oSh In ActiveDocument.Shapes
If oSh.ID = aShapeTopID(i) Then
Application.StatusBar = "Deleting Top shape """ & oSh.Name & """ (ID: " & aShapeTopID(i) & ") on page " & i + 1
Debug.Print "Deleting Top shape """ & oSh.Name & """ (ID: " & aShapeTopID(i) & ") on page " & i + 1
oSh.Delete
Exit For
End If
Next
End If
If Not IsEmpty(aShapeBottomID(i)) Then
For Each oSh In ActiveDocument.Shapes
If oSh.ID = aShapeBottomID(i) Then
Application.StatusBar = "Deleting Bottom shape """ & oSh.Name & """ (ID: " & aShapeBottomID(i) & ") on page " & i + 1
Debug.Print "Deleting Bottom shape """ & oSh.Name & """ (ID: " & aShapeBottomID(i) & ") on page " & i + 1
oSh.Delete
Exit For
End If
Next
End If
Next
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
I checked that the ID does not change when a Shape is added or Deleted.
Screenshot of test doc (wicked it so all "Lightning Bolts" are the Top and Bottom):
After executed once (all the "Lightning Bolt" shapes are deleted):
After 2nd execute (the Explosion Shape is still there but position is out of the page's dimension - this is what floating shapes do, its actual position is relative to the Anchor):
回答2:
This gets a little dirty as I have to change/restore relative positioning/sizing in order to get absolute page positioning. Also, changing shapes mess up enumeration, so must refer shapes by names:
Sub DeleteEveryPageTopAndBottomShape()
Dim p As Page, r As Rectangle, s As Shape
Dim rvp As WdRelativeVerticalPosition, rvs As WdRelativeVerticalSize
Dim top_s As String, bottom_s As String
For Each p In ThisDocument.ActiveWindow.ActivePane.Pages
top_s = vbNullString
bottom_s = vbNullString
For Each r In p.Rectangles
If r.RectangleType = wdShapeRectangle Then
For Each s In p.Rectangles(1).Range.ShapeRange
rvp = s.RelativeVerticalPosition
s.RelativeVerticalPosition = wdRelativeVerticalPositionPage
s.RelativeVerticalSize = wdRelativeVerticalSizePage
If Len(top_s) Then
If s.Top < ThisDocument.Shapes(top_s).Top Then top_s = s.Name
Else
top_s = s.Name
End If
If Len(bottom_s) Then
If s.Top + s.Height > ThisDocument.Shapes(bottom_s).Top + ThisDocument.Shapes(bottom_s).Height Then bottom_s = s.Name
Else
bottom_s = s.Name
End If
s.RelativeVerticalPosition = rvp
s.RelativeVerticalSize = rvs
Next
End If
Next
Debug.Print "..."
If Len(top_s) Then ThisDocument.Shapes(top_s).Delete
If bottom_s <> top_s Then ThisDocument.Shapes(bottom_s).Delete
Next
End Sub
回答3:
This has already been answered by PatricK, but after looking at some more information I wanted to also post my solution, for future reference.
Another way to do this follows this outline:
- For each page, if there are more than 2 shapes,
- find the top-most and bottom-most shape coordinates
- delete any shapes that don't match these coordinates
Executing the code would look similar to the following, thanks to an answer from this question:
Public Sub delete_firstlast()
'---------find the first and last shape on each page, make bold-----------
Dim pg As Page
Dim shp As Variant
Dim shp_count As Long, maxt As Long, maxb As Long
Dim del_index As Long
'for each page
For Each pg In ActiveDocument.Windows(1).Panes(1).Pages
'find the number of shapes
shp_count = 0
For Each shp In pg.Rectangles
If shp.RectangleType = wdShapeRectangle Then shp_count = shp_count + 1
Next
'if there are more than 2 shapes on a page, there
'are shapes to be made bold
If shp_count > 2 Then
'prime the maxt and maxb for comparison
'by setting to the first shape
For Each shp In pg.Rectangles
If shp.RectangleType = wdShapeRectangle Then
maxt = shp.Top
maxb = maxt
Exit For
End If
Next
'set maxt and maxb
For Each shp In pg.Rectangles
'make sure a selectable shape type is being considered
If shp.RectangleType = wdShapeRectangle Then
If shp.Top < maxt Then maxt = shp.Top
If shp.Top > maxb Then maxb = shp.Top
End If
Next
'Delete the top and bottom shapes
For del_index = pg.Rectangles.Count To 1 Step -1
If pg.Rectangles(del_index).RectangleType = wdShapeRectangle Then
Set shp = pg.Rectangles(del_index)
If shp.Top = maxt Or shp.Top = maxb Then
pg.Rectangles(del_index).Range.ShapeRange.Delete
Else
shp.Range.ShapeRange.Line.Weight = 2
End If
End If
Next
End If
'go to next page
Next
End Sub
回答4:
This should do what you want. It deletes the shape with the highest top on the page and the shape with the lowest bottom from each page. It's a very naive implementation, because I'm not familiar with Word, but given that my earlier code worked for you, there's a reasonable chance this will do what you want.
Sub removeTopAndBottomMostShapesFromActiveDocument()
Dim shape As shape
Dim topShape As shape
Dim bottomShape As shape
Dim pageNum
For pageNum = 1 To ActiveWindow.Panes(1).Pages.Count
Dim highestPoint, lowestPoint
highestPoint = 999999
lowestPoint = -999999
Set topShape = Nothing
Set bottomShape = Nothing
Dim sr As ShapeRange
Set sr = ActiveWindow.Panes(1).Pages(pageNum).Rectangles.Item(1).Range.ShapeRange
sr.Select
For Each shape In sr
If shape.Top < highestPoint Then
Set topShape = shape
highestPoint = shape.Top
End If
If shape.Top + shape.Height > lowestPoint Then
Set bottomShape = shape
lowestPoint = shape.Top + shape.Height
End If
Next
If Not topShape Is Nothing Then
topShape.Delete
End If
If Not bottomShape Is Nothing Then
bottomShape.Delete
End If
Next
End Sub
来源：https://stackoverflow.com/questions/18710959/ms-word-2010-macro-how-to-select-all-shapes-on-a-specific-page