printarea with rectangles

[pit263]

Hey,
Currently i am trying to create a program. It is supposed to be a template for creating business processes.
The program should be used for showing the document flow inside of companies.
The information is going to be written in rectangles.
I have almost all the necessary stuff figured out.
One thing remains very difficult to me though
I would like to tell VBA that when a button is being pushed, it is supposed to count all the rectangles and dependent on where the last one is, set the number of pages to be printed.
Hope you could understand my problem and are able to help me.
Here is what i have so far:

Public xDep As Integer
Public i As Integer
Public y As String
Public extradept As Integer
Public k As Integer

Sub setenvironment()
On Error Resume Next

Sheets(2).Select


y = InputBox("processheadline")

If y = "" Then

MsgBox "no headline"

Exit Sub

Else

If IsNumeric(y) Then

Sheets(2).PageSetup.LeftHeader = "&""verdana,bold""&16" + " " + CStr(y) + ""

Else

Sheets(2).PageSetup.LeftHeader = "&""verdana,bold""&16" + CStr(y) + ""

End If

End If

With Sheets(2).PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = "$A:$A"

End With

Sheets(2).PageSetup.PrintArea = ""

With Sheets(2).PageSetup
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = "&F"
.CenterFooter = "Page&P/&N"
.RightFooter = "Printed on:&D;&T"
.LeftMargin = Application.InchesToPoints(0.590551181102362)
.RightMargin = Application.InchesToPoints(0.590551181102362)
.TopMargin = Application.InchesToPoints(0.78740157480315)
.BottomMargin = Application.InchesToPoints(0.590551181102362)
.HeaderMargin = Application.InchesToPoints(0.393700787401575)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 69
.PrintErrors = xlPrintErrorsDisplayed
End With
xDep = InputBox("number of departments?")

If Not IsNumeric(xDep) Or xDep < 1 Then

MsgBox "no departments"

Exit Sub

Else

For i = 1 To xDep

Rows(i * 2).Activate
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

Selection.RowHeight = 67

Range(Cells(i * 2, 1), Cells(i * 2, 1)).Select
Selection.Interior.ColorIndex = 16

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Next i

End If

' adding rectangle
Sheets(2).Shapes.AddShape(msoShapeRectangle, 75#, 15.25, 87#, 65.75).Select

With Selection
.Placement = xlMove
.PrintObject = True
End With


Selection.Characters.Text = ""

With Selection.Font
.Name = "Verdana"
.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

Selection.Font.Bold = True

With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.ReadingOrder = xlContext
.Orientation = xlHorizontal
.AutoSize = False
.AddIndent = False
End With

' adding connector
Sheets(2).Shapes.AddConnector(msoConnectorElbow, 195#, 84#, 108.75, 30.75 _
).Select
Selection.ShapeRange.Line.EndArrowheadStyle = msoArrowheadTriangle
With Selection
.Placement = xlMove
.PrintObject = True
End With

' changing fonttype of all cells to verdana
Cells.Select
With Selection.Font
.Name = "Verdana"
.Size = 10
.Strikethrough = False
.Superscript = True
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With

Cells.HorizontalAlignment = xlCenter
Cells.VerticalAlignment = xlCenter

' adjusting column "A"
Columns("A:A").ColumnWidth = 4.5
Columns("A:A").Font.Bold = True
Columns("A:A").WrapText = True
Rows("1:1").RowHeight = 0

With Sheets(2)
For intY = 1 To xDep

For intX = 1 To 25

.Cells(intY * 2, intX * 7).FormulaR1C1 = "=R" + CStr(intY * 2) + "C1"
.Cells(intY * 2, intX * 7).Font.ColorIndex = 16

Next

Next

End With

End Sub

Sub add_more_departments()
Sheets(2).Select

extradept = InputBox("number of new departments?")

If Not IsNumeric(extradept) Or extradept < 1 Then

MsgBox "no further departments"

Exit Sub

Else

For k = 1 To extradept

Rows(xDep * 2 + 2 * k).Activate
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With

Selection.RowHeight = 69

Range(Cells(xDep * 2 + 2 * k, 1), Cells(xDep * 2 + 2 * k, 1)).Select
Selection.Interior.ColorIndex = 16


With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 90
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With

Next

End If

xDep = extradept + xDep

With Sheets(2)

For addY = 1 To xDep

For addX = 1 To 25

.Cells(addY * 2, addX * 7).FormulaR1C1 = "=R" + CStr(addY * 2) + "C1"
.Cells(addY * 2, addX * 7).Font.ColorIndex = 16

Next

Next

End With

End Sub

Sub Change_process_headline()
Sheets(2).Select

m = InputBox("new processheadline")

If m = "" Then

MsgBox "no headline"

Exit Sub

Else

If IsNumeric(m) Then

Sheets(2).PageSetup.LeftHeader = "&""verdana,bold""&16" + " " + CStr(m) + ""

Else

Sheets(2).PageSetup.LeftHeader = "&""verdana,bold""&16" + CStr(m) + ""

End If

End If

End Sub

Sub Reset_watermarks()

Sheets(2).Select

Columns("B:FS").Select
Selection.ClearContents

With Sheets(2)

For intY = 1 To xDep

For intX = 1 To 25

.Cells(intY * 2, intX * 7).FormulaR1C1 = "=R" + CStr(intY * 2) + "C1"
.Cells(intY * 2, intX * 7).Font.ColorIndex = 16

Next

Next

End With

End Sub

Sub Printbutton()
Sheets(2).Select



End Sub

[Bob Phillips]

What is this supposed to do? ALl I get is a few grey lines, a single box, some formulae that point to empty cells, and a single arrow. Not very informative.

[pit263]

sorry about that.
those grey lines are supposed to be the departments that you need to show your process.
in column A you are supposed to type in the dept name.
the one box and one arrow are already shown because they have special features. You are supposed to copy and paste as many as you need in order to create your process.
my problem is that if you would want to print the process, excel always wants to print 10 or something pages. Most of the time that is not the amount that you need.
also it is very confusing if it says on the bottom of a page (for example) page 5/10, so you expect 5 more pages but the fifth is already the last one.
Therefore, i would like to create some kind of mechanism that tells excel to look at how many rectangles there are and thus know how many pages it has to print.
Hope i could help making my problem a bit more clear.
Thanks for the help

[Bob Phillips]

I get 9 pages, and all 9 print because the formulae extend all the way across the columns to IV.

[pit263]

yes, that is my problem.
What i would like to do is tell excel to ignore those watermarks and say that the printarea depends on the rectangles instead

[Bob Phillips]

They are not watermarks, they are coloured cells with formula in every 7th cell until column FS. That is why it is printing upto column FS.

[pit263]

yeah, i know. I was just calling them watermarks since that was what similar things in visio were called.
What i am trying to do, though, is telling excel to ignore those and instead look at the rectangles to figure out how many pages should be printed