VERSION 4.00 Begin VB.Form frmProgress Appearance = 0 'Flat BackColor = &H00C0C0C0& BorderStyle = 3 'Fixed Dialog ClientHeight = 4455 ClientLeft = -30 ClientTop = 1530 ClientWidth = 6480 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 4860 Left = -90 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 4455 ScaleWidth = 6480 Top = 1185 Width = 6600 Begin Threed.SSPanel pnlStndoc Height = 3390 Left = 180 TabIndex = 7 Top = 180 Width = 1950 _Version = 65536 _ExtentX = 3440 _ExtentY = 5980 _StockProps = 15 ForeColor = -2147483640 BackColor = 8421376 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BevelOuter = 1 Begin VB.Image imgStndoc Appearance = 0 'Flat Height = 3360 Left = 0 Picture = "PROGRESS.frx":0000 Top = 0 Width = 1920 End End Begin VB.CommandButton cmdCancel Appearance = 0 'Flat BackColor = &H80000005& Caption = "Cancel" BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 5160 TabIndex = 6 Top = 3960 Width = 1155 End Begin VB.CommandButton cmdNext Appearance = 0 'Flat BackColor = &H80000005& Caption = "Next >" Default = -1 'True Enabled = 0 'False BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 3840 TabIndex = 0 Top = 3960 Width = 1155 End Begin VB.CommandButton cmdBack Appearance = 0 'Flat BackColor = &H80000005& Caption = "< &Back" Enabled = 0 'False BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2700 TabIndex = 5 Top = 3960 Width = 1155 End Begin Threed.SSPanel Panel3D1 Height = 375 Left = 2220 TabIndex = 4 Top = 3000 Width = 4215 _Version = 65536 _ExtentX = 7435 _ExtentY = 661 _StockProps = 15 Caption = "Panel3D1" ForeColor = 4210752 BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty BevelOuter = 1 FloodType = 1 End Begin VB.Line Line2 BorderColor = &H00FFFFFF& X1 = 180 X2 = 6300 Y1 = 3795 Y2 = 3795 End Begin VB.Label Label3 Appearance = 0 'Flat BackColor = &H80000005& BackStyle = 0 'Transparent BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 255 Left = 2220 TabIndex = 3 Top = 2520 Width = 4215 End Begin VB.Label Label2 Appearance = 0 'Flat BackColor = &H80000005& BackStyle = 0 'Transparent BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00000000& Height = 255 Left = 2220 TabIndex = 2 Top = 2160 Width = 4215 End Begin VB.Label Label1 Appearance = 0 'Flat BackColor = &H80000005& BackStyle = 0 'Transparent Caption = "Creating report..." BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H80000008& Height = 255 Left = 2220 TabIndex = 1 Top = 240 Width = 4215 End Attribute VB_Name = "frmProgress" Attribute VB_Creatable = False Attribute VB_Exposed = False Option Explicit Private Sub Cancel_Click() End End Sub Private Sub cmdCancel_Click() g_appVisio.ScreenUpdating = True End End Sub Private Sub DrawCreate() Dim stencil As Visio.Document ' stencil document Dim Page As Visio.Page Dim shape As Visio.shape Dim master As Visio.master Dim masters As Visio.masters Dim label As Visio.master Dim text As Visio.master Dim inst As Visio.shape ' instance Dim xLeft Dim yTop Dim xRight Dim yBottom Dim row Dim col Dim pageNumber Dim masterIndex Dim stencilName Dim pageName Dim stat ' Get stencil ' Set stencil = g_appVisio.Documents(gDoc.Filename) If stencil.Title = "" Then stencilName = stencil.Name Else stencilName = stencil.Title End If stat = DrawYield(stencilName, STR_BACKGROUND, "") ProgressGauge (5) ' Compute page count ' Set masters = stencil.masters gDoc.masters = masters.Count gDoc.PageCount = gDoc.masters \ gGrid.masters If (gDoc.masters Mod gGrid.masters) > 0 Then gDoc.PageCount = gDoc.PageCount + 1 End If ' Draw header on background page ' If gDoc.Header = True Then xLeft = gPage.LeftMargin xRight = gPage.pageWidth - gPage.RightMargin yTop = gPage.pageHeight - gPage.TopMargin yBottom = yTop - gPage.Header / 6 Set shape = gPageBack.DrawRectangle(xLeft, yTop, xRight, yBottom) shape.FillStyle = "Black fill" yTop = yBottom yBottom = gPage.pageHeight - gPage.TopMargin - gPage.Header Set shape = gPageBack.DrawRectangle(xLeft, yTop, xRight, yBottom) shape.style = "_Header" shape.text = stencilName End If stat = DrawYield("", "", "") ProgressGauge (10) ' Draw left footer on background page. ' The left footer includes the line at the bottom of the page. ' If gDoc.Footer = True Then xLeft = gPage.LeftMargin xRight = gPage.pageWidth - gPage.RightMargin yBottom = gPage.BottomMargin yTop = yBottom + gPage.Footer Set shape = gPageBack.DrawLine(xLeft, yTop, xRight, yTop) shape.style = "_FootLeft" shape.text = UCase(gDoc.Filename) End If stat = DrawYield("", "", "") ProgressGauge (15) ' Create property masters ' If gDoc.properties = True Then ' Create text master ' xRight = gGrid.ColWidth - gPage.LabelWidth Set shape = gPageBack.DrawRectangle(0, 0, xRight, 0) shape.style = "_PropText" shape.text = "Name:" & Chr(10) & Chr(10) & "Prompt:" ' Drop text master into local stencil ' Set text = gDocDraw.Drop(shape, 0, 0) ' Create label master ' shape.Cells("Width").Formula = gPage.LabelWidth shape.style = "_PropLabel" ' Drop label master into local stencil ' Set label = gDocDraw.Drop(shape, 0, 0) shape.Delete End If stat = DrawYield("", "", "") ProgressGauge (20) ' Draw grid ' If gDoc.gridlines = True Then ' Draw vertical gridlines ' For col = 0 To gGrid.cols - 2 xLeft = gGridArray(0, col).Right xRight = xLeft yTop = gGridArray(gGrid.rows - 1, col).Top yBottom = gGridArray(0, col).Bottom Set shape = gPageBack.DrawLine(xLeft, yTop, xRight, yBottom) shape.style = "_Gridline" Next ' Draw horizontal gridlines ' For row = 0 To gGrid.rows - 2 xLeft = gGridArray(row, 0).left xRight = gGridArray(row, gGrid.cols - 1).Right yBottom = gGridArray(row, 0).Top yTop = yBottom Set shape = gPageBack.DrawLine(xLeft, yTop, xRight, yBottom) shape.style = "_Gridline" Next End If stat = DrawYield("", "", "") ProgressGauge (25) ' Instance each master in stencil ' masterIndex = 1 For pageNumber = 1 To gDoc.PageCount pageName = "Page " & pageNumber & " of " & gDoc.PageCount stat = DrawYield("", pageName, "") ' Create new page and set its background ' Set Page = gDocDraw.Pages.Add Page.Name = pageName Page.Background = False Page.BackPageFromName = gPageBack ' Draw right footer on page ' If gDoc.Footer = True Then xLeft = gPage.pageWidth / 2 xRight = gPage.pageWidth - gPage.RightMargin yTop = gPage.BottomMargin + gPage.Footer Set shape = Page.DrawLine(xLeft, yTop, xRight, yTop) shape.style = "_FootRight" shape.text = Page.Name End If ' Drop each master on page ' For row = gGrid.rows - 1 To 0 Step -1 For col = 0 To gGrid.cols - 1 If masterIndex > masters.Count Then GoTo fexit End If ' Drop master in the center of the grid ' Set master = masters(masterIndex) stat = DrawYield("", "", master.Name) If gDoc.properties = True Then ' Drop property label ' xLeft = gGridArray(row, col).left + gPage.LabelWidth / 2 yTop = gGridArray(row, col).Top Set shape = Page.Drop(label, xLeft, yTop) ' Drop property text ' xLeft = gGridArray(row, col).left + gPage.LabelWidth + (gGrid.ColWidth - gPage.LabelWidth) / 2 yTop = gGridArray(row, col).Top Set shape = Page.Drop(text, xLeft, yTop) shape.text = master.Name & Chr(10) & Chr(10) & master.Prompt End If 'If master is empty, skip it If master.Shapes.Count > 0 Then xLeft = gGridArray(row, col).left + gGrid.ColWidth / 2 yTop = gGridArray(row, col).Top - gGrid.RowHeight / 2 ' Set the alertresponse so that the custom properties ' dialog doesn't stop us g_appVisio.AlertResponse = 1 Set inst = Page.Drop(master, xLeft, yTop) g_appVisio.AlertResponse = 0 ' Fit in grid ' If gDoc.resize = True Then ' Group the shape if not already a group ' If inst.Type <> 2 Then inst.Group 'Set inst = gWinDraw.Selection.Item(1) If g_appVisio.Version < 2.1 Then Set inst = gWinDraw.Selection.Item(1) Else Set inst = inst.Parent End If End If GridFit row, col, inst ' Resize the shape to fit in grid GridPos row, col, inst ' Reposition the shape End If End If ProgressGauge (25 + masterIndex / masters.Count * 75) masterIndex = masterIndex + 1 Next Next Next fexit: SetScreenUpdating (True) g_appVisio.ActiveWindow.DeselectAll g_appVisio.ActiveWindow.PageFromName = gDocDraw.Pages.Item(1) 'go to first page End End Sub Private Function DrawYield(ByVal stencil As String, ByVal Page As String, ByVal master As String) If stencil <> "" Then label1.Caption = "Stencil: " & stencil End If If Page <> "" Then label2.Caption = "Page: " & Page End If If master <> "" Then label3.Caption = "Master: " & master End If DoEvents End Function Private Sub Form_Load() ' Initialize the form. ' formInit frmProgress ' Center the picture imgStndoc.Top = pnlStndoc.Height / 2 - imgStndoc.Height / 2 imgStndoc.left = pnlStndoc.Width / 2 - imgStndoc.Width / 2 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) End End Sub Private Sub Form_Resize() DoEvents 'Turn off screen updating SetScreenUpdating (False) 'Turn off screen updating DrawCreate End Sub ' Resize shape to fit in grid Private Sub GridFit(row, col, shape As Visio.shape) Dim shapeWidth As Visio.Cell ' cell object Dim shapeHeight As Visio.Cell ' cell object Dim gridWidth Dim gridHeight Dim LabelHeight Dim aspectRatio ' General computations ' Set shapeWidth = shape.Cells("Width") Set shapeHeight = shape.Cells("Height") LabelHeight = 0 If gDoc.properties = True Then LabelHeight = gPage.LabelHeight End If gridWidth = gGrid.ColWidth - 2 * gPage.GridMargin gridHeight = gGrid.RowHeight - LabelHeight - 2 * gPage.GridMargin ' Is the shape too big for the grid ' If shapeWidth <= gridWidth And shapeHeight <= gridHeight Then Exit Sub ' nothing to do End If ' Resize shape to fit in grid ' aspectRatio = 1 If shapeHeight <> 0 Then aspectRatio = shapeWidth / shapeHeight End If ' Adjust height ' If shapeHeight > gridHeight Then shapeHeight.FormulaForce = gridHeight If shapeWidth > 0 Then shapeWidth.FormulaForce = aspectRatio * gridHeight End If End If ' Adjust width ' If shapeWidth > gridWidth Then shapeWidth.FormulaForce = gridWidth If shapeHeight > 0 Then shapeHeight.FormulaForce = gridWidth / aspectRatio End If End If End Sub ' Position shape in grid Private Sub GridPos(row, col, shape As Visio.shape) Dim X Dim Y X = gGridArray(row, col).left + gGrid.ColWidth / 2 Y = gGridArray(row, col).Bottom + gGrid.RowHeight / 2 If gDoc.properties = True Then Y = Y - gPage.LabelHeight / 2 End If shape.SetCenter X, Y End Sub Private Sub ProgressGauge(ByVal percent As Integer) Dim X As Single Dim Y As Single Dim t As String ' Set coordinates for the right end of the rectangle ' that displays the progress bar. ' 'y = Picture1.ScaleHeight 'x = percent * Picture1.ScaleWidth / 100 ' Draw the rectangle ' 'Picture1.Line (0, 0)-(x, y), QBColor(1), BF 'Picture1.Line (x, 0)-(Picture1.ScaleWidth, y), QBColor(7), BF ' Center and draw the text ' 't = percent & "%" 'Picture1.CurrentY = (Picture1.ScaleHeight - Picture1.TextHeight(t)) / 2 'Picture1.CurrentX = (Picture1.ScaleWidth - Picture1.TextWidth(t)) / 2 Panel3D1.FloodPercent = percent If percent > 45 Then 'Picture1.ForeColor = QBColor(1) Panel3D1.ForeColor = &HFFFFFF 'Else 'Picture1.ForeColor = RGB(255, 255, 255) End If 'Picture1.Print t End Sub Private Sub SetScreenUpdating(bUpdate As Integer) If g_appVisio.Version < 2.1 Then Exit Sub Else g_appVisio.ScreenUpdating = bUpdate End If End Sub