home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Programmer'…arterly (Limited Edition) / Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso / code / ch28code / frmmain.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-08-02  |  16.2 KB  |  390 lines
  1. VERSION 4.00
  2. Begin VB.Form frmMain 
  3.    AutoRedraw      =   -1  'True
  4.    BackColor       =   &H00C0C0C0&
  5.    BorderStyle     =   0  'None
  6.    Caption         =   "UseAll Main Window"
  7.    ClientHeight    =   3495
  8.    ClientLeft      =   1140
  9.    ClientTop       =   1560
  10.    ClientWidth     =   7365
  11.    Height          =   3900
  12.    Icon            =   "FRMMAIN.frx":0000
  13.    Left            =   1080
  14.    LinkTopic       =   "Form1"
  15.    ScaleHeight     =   233
  16.    ScaleMode       =   3  'Pixel
  17.    ScaleWidth      =   491
  18.    Top             =   1215
  19.    Width           =   7485
  20.    Begin VB.PictureBox picButton 
  21.       Appearance      =   0  'Flat
  22.       AutoRedraw      =   -1  'True
  23.       BackColor       =   &H00C0C0C0&
  24.       BeginProperty Font 
  25.          name            =   "Arial"
  26.          charset         =   0
  27.          weight          =   700
  28.          size            =   8.25
  29.          underline       =   0   'False
  30.          italic          =   0   'False
  31.          strikethrough   =   0   'False
  32.       EndProperty
  33.       ForeColor       =   &H80000008&
  34.       Height          =   735
  35.       Index           =   0
  36.       Left            =   4725
  37.       ScaleHeight     =   47
  38.       ScaleMode       =   3  'Pixel
  39.       ScaleWidth      =   50
  40.       TabIndex        =   1
  41.       TabStop         =   0   'False
  42.       Top             =   495
  43.       Width           =   780
  44.    End
  45.    Begin VB.Label lblStatus 
  46.       Alignment       =   2  'Center
  47.       BackStyle       =   0  'Transparent
  48.       Caption         =   "Click to update the chart!"
  49.       Height          =   195
  50.       Left            =   4905
  51.       TabIndex        =   5
  52.       Top             =   1485
  53.       UseMnemonic     =   0   'False
  54.       Visible         =   0   'False
  55.       Width           =   1230
  56.    End
  57.    Begin VB.OLE oleExcel 
  58.       BackStyle       =   0  'Transparent
  59.       BorderStyle     =   0  'None
  60.       Class           =   "Excel.Sheet.5"
  61.       Height          =   3345
  62.       Left            =   4875
  63.       OleObjectBlob   =   "FRMMAIN.frx":030A
  64.       SizeMode        =   1  'Stretch
  65.       SourceDoc       =   "d:\book\submit\chpx6\code\qrybugs.xls"
  66.       TabIndex        =   4
  67.       TabStop         =   0   'False
  68.       Top             =   3675
  69.       Width           =   4530
  70.    End
  71.    Begin VB.Label lbl 
  72.       Alignment       =   2  'Center
  73.       BackStyle       =   0  'Transparent
  74.       Caption         =   "Command Console"
  75.       BeginProperty Font 
  76.          name            =   "Times New Roman"
  77.          charset         =   0
  78.          weight          =   700
  79.          size            =   13.5
  80.          underline       =   0   'False
  81.          italic          =   -1  'True
  82.          strikethrough   =   0   'False
  83.       EndProperty
  84.       ForeColor       =   &H0000FFFF&
  85.       Height          =   330
  86.       Left            =   4680
  87.       TabIndex        =   0
  88.       Top             =   180
  89.       Width           =   2175
  90.    End
  91.    Begin MSComDlg.CommonDialog cdlg 
  92.       Left            =   5670
  93.       Top             =   540
  94.       _Version        =   65536
  95.       _ExtentX        =   847
  96.       _ExtentY        =   847
  97.       _StockProps     =   0
  98.       CancelError     =   -1  'True
  99.       DefaultExt      =   "frm"
  100.       DialogTitle     =   "View Code in Word 6.0"
  101.       Filter          =   "VB Code (*.bas, *.cls, *.frm)|*.bas;*.cls;*.frm|All Files (*.*)|*.*"
  102.       FilterIndex     =   1
  103.    End
  104.    Begin VB.OLE olePower 
  105.       BackStyle       =   0  'Transparent
  106.       Class           =   "PowerPoint.Show.7"
  107.       Height          =   3405
  108.       Left            =   180
  109.       OleObjectBlob   =   "FRMMAIN.frx":3922
  110.       SizeMode        =   1  'Stretch
  111.       SourceDoc       =   "d:\book\submit\chpx6\code\useall.ppt"
  112.       TabIndex        =   3
  113.       TabStop         =   0   'False
  114.       Top             =   3615
  115.       Width           =   4455
  116.    End
  117.    Begin VB.OLE oleProject 
  118.       BackStyle       =   0  'Transparent
  119.       BorderStyle     =   0  'None
  120.       Height          =   3255
  121.       Left            =   180
  122.       OleObjectBlob   =   "FRMMAIN.frx":18B3A
  123.       SizeMode        =   1  'Stretch
  124.       SourceDoc       =   "e:\proj\softdev.mpp"
  125.       TabIndex        =   2
  126.       TabStop         =   0   'False
  127.       Top             =   180
  128.       Width           =   4455
  129.    End
  130. Attribute VB_Name = "frmMain"
  131. Attribute VB_Creatable = False
  132. Attribute VB_Exposed = False
  133. '*********************************************************************
  134. ' FRMMAIN.FRM - This is command central where everything begins.
  135. '*********************************************************************
  136. Option Explicit
  137. Public clsR2XL As New clsReportToXL
  138. Public clsPPrint As New clsPrettyPrint
  139. #If Win32 Then
  140. Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As _
  141.     Long, ByVal nIndex As Long) As Long
  142. #Else
  143. Private Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC%, _
  144.     ByVal nIndex%) As Integer
  145. #End If
  146. '*********************************************************************
  147. ' This is a form level conditional compilation constant. It's used to
  148. ' prevent performing certain time consuming tasks during debugging.
  149. '*********************************************************************
  150. #Const DEBUG_MODE = False
  151. '*********************************************************************
  152. ' Position and size all objects on the form.
  153. '*********************************************************************
  154. Private Sub Form_Load()
  155. Dim Quad2 As RECT, Quad4 As RECT, NewQuad As RECT, i%
  156.     '*****************************************************************
  157.     ' Since these are time consuming to display, hide them during
  158.     ' debugging.
  159.     '*****************************************************************
  160.     #If DEBUG_MODE Then
  161.         oleExcel.Visible = False
  162.         olePower.Visible = False
  163.         oleProject.Visible = False
  164.     #End If
  165.     '*****************************************************************
  166.     ' Change Backcolor and Display the splash screen.
  167.     '*****************************************************************
  168.     On Error Resume Next
  169.     picButton(0).BackColor = vb3DFace
  170.     BackColor = vb3DFace
  171.     SplashVisible True
  172.     '*****************************************************************
  173.     ' Size the form to the screen.
  174.     '*****************************************************************
  175.     Move 0, 0, Screen.Width, Screen.Height
  176.     '*****************************************************************
  177.     ' Draw a 3d grid on the form.
  178.     '*****************************************************************
  179.     Draw3DGrid Me, True
  180.     '*****************************************************************
  181.     ' Position a label above the oleExcel control.
  182.     '*****************************************************************
  183.     GetQuad 2, Quad2
  184.     GetQuad 4, Quad4
  185.     With NewQuad
  186.         .rL = Quad2.rL
  187.         .rT = Quad2.rB
  188.         .rR = Quad2.rR
  189.         .rB = Quad4.rT
  190.     End With
  191.     SizeToRectClient lblStatus, NewQuad
  192.     '*****************************************************************
  193.     ' Draw a DkBlue background in Quad2 & position lbl and picButtons.
  194.     '*****************************************************************
  195.     ResizeRect Quad2, -1, -1, False
  196.     DrawRect Me, Quad2, Solid:=True, RectColor:=RGB(0, 0, 64)
  197.     SizeToRectClient lbl, Quad2
  198.     lbl.top = Quad2.rT + 2
  199.     lbl.Height = GetRectHeight(Quad2) * 0.1
  200.     picButton(0).Move lbl.Left + 50, lbl.top + lbl.Height, _
  201.                       lbl.Width - 100, GetRectHeight(Quad2) * 0.2
  202.     '*****************************************************************
  203.     ' Load 3 more buttons 5 pixels apart.
  204.     '*****************************************************************
  205.     For i = 1 To 3
  206.         Load picButton(i): picButton(i).Visible = True
  207.         picButton(i).top = picButton(i - 1).top + _
  208.                            picButton(i - 1).Height + 5
  209.     Next i
  210.     '*****************************************************************
  211.     ' Create the button effect, and label them.
  212.     '*****************************************************************
  213.     picButton(0).Tag = "Create a Bug Report..." & "|ADD_BUGS"
  214.     Handle_MouseUpDown 0, False
  215.     Handle_MouseUpDown 1, False
  216.     Handle_MouseUpDown 2, False
  217.     Handle_MouseUpDown 3, False
  218.     '*****************************************************************
  219.     ' Make sure everything is positioned, then remove the splash form.
  220.     '*****************************************************************
  221.     VerifyControlPositions
  222.     Visible = True
  223.     SplashVisible False
  224. End Sub
  225. '*********************************************************************
  226. ' Resizing OLE Controls can be VERY time consuming, so only do it if
  227. ' they have moved, or if resolution is <> 640x480.
  228. '*********************************************************************
  229. Sub VerifyControlPositions()
  230. Const HORZRES = 8   '  Horizontal width in pixels
  231. Const VERTRES = 10  '  Vertical width in pixels
  232. Dim hRes%, vRes%, Quad1 As RECT, Quad3 As RECT, Quad4 As RECT
  233.     '*****************************************************************
  234.     ' Get the size of the quadrants.
  235.     '*****************************************************************
  236.     GetQuad 1, Quad1
  237.     GetQuad 3, Quad3
  238.     GetQuad 4, Quad4
  239.     '*****************************************************************
  240.     ' Get the screen resolution,
  241.     '*****************************************************************
  242.     hRes = GetDeviceCaps(hDC, HORZRES)
  243.     vRes = GetDeviceCaps(hDC, VERTRES)
  244.     '*****************************************************************
  245.     ' If not 640x480, then resize the OLE controls.
  246.     '*****************************************************************
  247.     If hRes <> 640 Or vRes <> 480 Then
  248.         SizeToRectClient oleProject, Quad1
  249.         SizeToRectClient olePower, Quad3
  250.         SizeToRectClient oleExcel, Quad4
  251.     '*****************************************************************
  252.     ' If ole??? has moved or been resized, then fix it.
  253.     '*****************************************************************
  254.     ElseIf Not EqualToQuadClient(oleProject, Quad1) Then
  255.         SizeToRectClient oleProject, Quad1
  256.     ElseIf Not EqualToQuadClient(olePower, Quad3) Then
  257.         SizeToRectClient olePower, Quad3
  258.         
  259.     ElseIf Not EqualToQuadClient(oleExcel, Quad4) Then
  260.         SizeToRectClient oleExcel, Quad4
  261.     End If
  262.     '*****************************************************************
  263.     ' Process the delays caused by resizing OLE controls.
  264.     '*****************************************************************
  265.     DoEvents
  266. End Sub
  267. '*********************************************************************
  268. ' Make sure there are no orphan forms.
  269. '*********************************************************************
  270. Private Sub Form_Unload(Cancel As Integer)
  271.     Unload frmReturn
  272. End Sub
  273. '*********************************************************************
  274. ' If the mouse is over the form, then hide lblStatus.
  275. '*********************************************************************
  276. Private Sub Form_MouseMove(Button%, Shift%, x As Single, y As Single)
  277.     lblStatus.Visible = False
  278. End Sub
  279. '*********************************************************************
  280. ' Update the chart whenever the user clicks on it.
  281. '*********************************************************************
  282. Private Sub oleExcel_Click()
  283.     UpdateChart
  284. End Sub
  285. '*********************************************************************
  286. ' If the mouse is over the control, then show the label.
  287. '*********************************************************************
  288. Private Sub oleExcel_MouseMove(Button%, Shift%, x As Single, y As Single)
  289.     lblStatus.Visible = True
  290. End Sub
  291. '*********************************************************************
  292. ' Performs the appropriate action for the picButton that was clicked.
  293. '*********************************************************************
  294. Private Sub picButton_Click(Index As Integer)
  295.     '*****************************************************************
  296.     ' Since a Click event only occurs when an object gets a Mouse_Down
  297.     ' AND a Mouse_Up event, all command processing should be here.
  298.     '*****************************************************************
  299.     On Error Resume Next
  300.     Select Case Index
  301.         Case 0
  302.             frmBugs.Show vbModal
  303.         Case 1
  304.             '*********************************************************
  305.             ' Display frmReturn by calling its Display method, instead
  306.             ' of using the Show method. This allows frmReturn to know
  307.             ' which form is requesting that frmReturn is displayed.
  308.             ' This is important because frmReturn needs to know which
  309.             ' form it should activate when it is unloaded.
  310.             '*********************************************************
  311.             frmReturn.Display Me
  312.             clsR2XL.ReportToExcel App.Path & "\bugs.mdb"
  313.         Case 2
  314.             '*********************************************************
  315.             ' Display a common file open dialog.
  316.             '*********************************************************
  317.             cdlg.FLAGS = cdlOFNFileMustExist + cdlOFNHideReadOnly + _
  318.                          cdlOFNPathMustExist
  319.             cdlg.ShowOpen
  320.             If Err <> cdlCancel Then
  321.                 frmReturn.Display Me
  322.                 clsPPrint.PrettyPrint cdlg.FileName
  323.             End If
  324.         Case 3
  325.             Unload Me
  326.     End Select
  327. End Sub
  328. '*********************************************************************
  329. ' This method is called by frmReturn after frmMain has been made
  330. ' visible. This method is used to destroy references to any OLE
  331. ' Automation objects.
  332. '*********************************************************************
  333. Public Sub DestroyObject()
  334.     Set clsPPrint = Nothing
  335.     Set clsR2XL = Nothing
  336. End Sub
  337. '*********************************************************************
  338. ' These two events simulate the button clicking effect.
  339. '*********************************************************************
  340. Private Sub picButton_MouseDown(Index%, Button%, Shift%, x!, y!)
  341.     Handle_MouseUpDown Index, True
  342. End Sub
  343. Private Sub picButton_MouseUp(Index%, Button%, Shift%, x!, y!)
  344.     Handle_MouseUpDown Index, False
  345. End Sub
  346. '*********************************************************************
  347. ' A single Procedure is used so that the code only appears in one
  348. ' place. This prevents errors from duplicate code.
  349. '*********************************************************************
  350. Private Sub Handle_MouseUpDown(Index%, bState As Boolean)
  351.     '*****************************************************************
  352.     ' Here's where all of buttons are drawn. Any changes here will
  353.     ' affect all other procedures which operate on picButtons.
  354.     '*****************************************************************
  355.     Select Case Index
  356.         Case 0
  357.             DrawButton picButton(Index), IsDown:=bState, _
  358.                                         IsResource:=True
  359.         Case 1
  360.             DrawButton picButton(1), IsDown:=bState, _
  361.                         sCaption:="Bug Summary in Excel...", _
  362.                         sIcon:="VIEW_BUGS", _
  363.                         IsResource:=True
  364.         Case 2
  365.             DrawButton picButton(2), IsDown:=bState, _
  366.                         sCaption:="View Code in Word...", _
  367.                         sIcon:="VIEW_CODE", _
  368.                         IsResource:=True
  369.         Case 3
  370.             DrawButton picButton(3), IsDown:=bState, _
  371.                         sCaption:="Exit Application...", _
  372.                         sIcon:="EXIT", _
  373.                         IsResource:=True
  374.     End Select
  375. End Sub
  376. Private Sub UpdateChart()
  377. Dim BugDBase As New GenericDB, retArray() As String
  378.     BugDBase.OpenDB App.Path & "\bugs.mdb"
  379.     BugDBase.CreateRecordSet "qryBugsByProduct"
  380.     BugDBase.GetArrayData "BugCount", retArray()
  381.     oleExcel.DoVerb 0
  382.     With oleExcel.object.Parent.Parent.ActiveWorkbook
  383.         .Sheets("Bugs").Range("B2").FormulaR1C1 = retArray(0)
  384.         .Sheets("Bugs").Range("B3").FormulaR1C1 = retArray(1)
  385.         .Sheets("Bugs").Range("B4").FormulaR1C1 = retArray(2)
  386.     End With
  387.     oleExcel.Close
  388.     Set BugDBase = Nothing
  389. End Sub
  390.