pit263
07-24-2008, 12:33 AM
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
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