count shapes

[pit263]

I am trying to figure out how to tell vba to count all the shapes in a document. Afterwards i would like it to select the last (furthest to the right) shape and depending on what page it is, print that many pages.

If anyone could help me here, i would really appreciate it. I know it can't be to complicated but i just don't get it.

Thanks so much
Peter

 

[Anthony047]

Hi macropod,
it is not clear to how Peter's worksheet is organized and why he is relying on this method to determine the pages to be printed.
Your message forced me to re-read Peter's messages, and realize he was willing to check the horizontal position of a shape.
At this point the approach could be:
-locate the Row & Column of the "last" shape
-use HPageBreaks to determine the last row to be printed
-use this in conjunction with the shape column to determine and set a PrintArea.
That should work whichever is the printing priority of the user.
I shall try this later today.

Bye.


Anthony047 (GMT+1)

 

[Anthony047]

This is my latest development on the subject.
It prints by horizontal priority. It is the sum up of different works, the code is far from optimized.

Sub GetLastShape_3()
'get the rightmost shape, then print up to that page
'
Dim oShp As Shape
Dim ShLast As Single, XBShape As Single, XTShape As Single
Dim YBShape As Single, YTShape As Single
Dim ShName As String
Dim PB As HPageBreak, HB As VPageBreak
Dim NextPRow As Single, PCount As Single, NextPCol As Single
'
ActiveWindow.View = xlNormalView
ActiveSheet.PageSetup.PrintArea = ""
  For Each oShp In ActiveSheet.Shapes
'MsgBox oShp.Name
   If oShp.BottomRightCell.Column > ShLast Then
   ShLast = oShp.BottomRightCell.Column: ShName = oShp.Name
  End If
  Next oShp
'  MsgBox "Last is " & ShName
ActiveSheet.Shapes(ShName).Select
XBShape = ActiveSheet.Shapes(ShName).BottomRightCell.Column
YBShape = ActiveSheet.Shapes(ShName).BottomRightCell.Row
'
'Identify the page num.
'By vertical pagebreaks
Range("A1").Select
ActiveWindow.View = xlPageBreakPreview
For Each PB In ActiveSheet.HPageBreaks
PB.Location.Select
NextPRow = ActiveCell.Row
PCount = PCount + 1
If NextPRow >= YBShape Then
 NextPRow = NextPRow - 1: Exit For
 End If
Next PB
ActiveWindow.View = xlNormalView

'Identify the page num.
'By horizontal pagebreaks
Range("A1").Select
ActiveWindow.View = xlPageBreakPreview
For Each HB In ActiveSheet.VPageBreaks
HB.Location.Select
NextPCol = ActiveCell.Column
PCount = PCount + 1
If NextPCol >= XBShape Then
 NextPCol = NextPCol - 1: Exit For
 End If
Next HB
ActiveWindow.View = xlNormalView


Range("A1", Cells(NextPRow, NextPCol)).Name = "PrArea"
ActiveSheet.PageSetup.PrintArea = "PrArea"
ActiveSheet.PageSetup.Order = xlOverThenDown   'Horiz priority

'print pages
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True

End Sub

Bye.




Anthony047 (GMT+1)

 

[macropod]

Hi folks,

I was thinking of something more like this:

Sub PrintToLastShape()
Dim oShp As Shape
Dim oldPrintHighLeft As String
'Dim oldPrintLowRight As String
Dim i As Integer
Dim j As Integer
Dim x As Integer
Dim y As Integer
i = 1
j = 1
x = 0
y = 0
Application.ScreenUpdating = False
With ActiveSheet
  If .PageSetup.PrintArea = "" Then
    oldPrintHighLeft = .Cells(1, 1).Address
    'oldPrintLowRight = .Cells(1, 1).Address
  Else
    oldPrintHighLeft = Split(.PageSetup.PrintArea, ":")(0)
    'oldPrintLowRight = Split(.PageSetup.PrintArea, ":")(1)
  End If
  For Each oShp In .Shapes
    If oShp.BottomRightCell.Row >= i Then i = oShp.BottomRightCell.Row
    If oShp.BottomRightCell.Column >= j Then j = oShp.BottomRightCell.Column
  Next
  .PageSetup.PrintArea = .Range(oldPrintHighLeft, .Cells(i, j)).Address
  x = .VPageBreaks.Count
  y = .HPageBreaks.Count
  Do While .VPageBreaks.Count = x
    j = j + 1
    .PageSetup.PrintArea = .Range(oldPrintHighLeft, .Cells(i, j)).Address
  Loop
  Do While .HPageBreaks.Count = y
    i = i + 1
    .PageSetup.PrintArea = .Range(oldPrintHighLeft, .Cells(i, j)).Address
  Loop
  .PageSetup.PrintArea = .Range(oldPrintHighLeft, .Cells(i - 1, j - 1)).Address
  .PrintOut
  '.PageSetup.PrintArea = .Range(oldPrintHighLeft, oldPrintLowRight).Address
End With
Application.ScreenUpdating = True
End Sub

In this particular version, I'm not giving either the rows or the columns precedence.

More importantly, however, the code takes the print area bound by the original specification for the upper left and the row & column for the bottom right shape(s) and extends the print area to the right and down so that it fills the whole of the pages around the edge of the print range. This is important, so as to ensure the background shading covers the whole page, whilst at the same time preventing reliance on the print order from causing extra shaded blocks of cells to be printed before the 'last' page is reached.

I've also inserted enough extra code (commented out) so that the original print area can be restored, if required.

Cheers

[MS MVP - Word]