home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / rptgen / rptmain.bas < prev   
Encoding:
BASIC Source File  |  1995-05-09  |  15.8 KB  |  492 lines
  1.  
  2. Function RptCreate (rtitle$, numcols%, textcols%, nrows%, thinbars%, thickbars%, tit1$, tit2$, foot1$, foot2$)
  3. '   function to create a new report
  4. '   Graham Hobson   (72506,3410)    Created: 24th September, 1991
  5. '
  6. ' Parameters:
  7. '   rtitle$ is the caption for the report form
  8. '   numcols is the number of numeric columns
  9. '   textcols is the number of text columns
  10. '   nrows is the maximum number of rows for the report (may be larger than one page)
  11. '   thinbars number (n) says to draw a thin line on the printed report every n rows
  12. '           use zero if you don't want any thinbars
  13. '   thickbars, ditto but with a thicker line
  14. '   tit1 is the main title
  15. '   tit2 is the secondary title
  16. '   foot1 is the first footnote
  17. '   foot2 is the second footnote
  18.  
  19. On Error GoTo memerror
  20. ncols% = numcols% + textcols%
  21. If ncols% < 1 Then MsgBox "Error: there must be one or more columns", 16, "RptCreate"
  22. ReDim RptCol(1 To ncols%) As RptCol_Type
  23. If numcols% > 0 Then ReDim RptNumData(1 To numcols%, 1 To nrows%) As Single
  24. If textcols% > 0 Then ReDim RptTextData(1 To textcols%, 1 To nrows%) As String
  25. ReDim RptSortTop(10) As Integer
  26. ReDim RptSortBottom(10) As Integer
  27.  
  28. RptForm.Show
  29. RptForm.caption = rtitle$
  30. RptForm.Refresh
  31.  
  32. rpt.name = rtitle$
  33. rpt.headerheight = 600
  34. rpt.defrowheight = 225
  35.  
  36. rpt.thinbars = thinbars%
  37. rpt.thickbars = thickbars%
  38. If rpt.thinbars = 0 Then rpt.thinbars = 9999
  39. If rpt.thickbars = 0 Then rpt.thickbars = 9999
  40.  
  41. RptForm.LAB_title1.caption = tit1$
  42. RptForm.LAB_title2.caption = tit2$
  43. RptForm.LAB_footnote1.caption = foot1$
  44. RptForm.LAB_footnote2.caption = foot2$
  45.  
  46. rpt.cols = ncols%
  47. rpt.numcols = numcols%
  48. rpt.textcols = textcols%
  49. rpt.rows = nrows%
  50.  
  51. ' work out number of rows per page
  52. rpt.rowsperpage = (Printer.height - 1750 - 2000 - rpt.headerheight) / (rpt.defrowheight + 15)
  53. rpt.pages = (rpt.rows \ rpt.rowsperpage) + 1
  54.  
  55. RptForm.grid1.cols = rpt.cols
  56. RptForm.grid1.rows = rpt.rowsperpage + 1
  57.  
  58. rpt.currentnumcol = 0
  59. rpt.currenttextcol = 0
  60. RptCreate = 0
  61. Exit Function
  62.  
  63. memerror:
  64. MsgBox "Error: report too large!", 16, "RptCreate"
  65. RptCreate = -1
  66.  
  67. End Function
  68.  
  69.  
  70. Sub RptDefineColumn (Rhnd%, colno%, ctype$, ctitle$, cwidth%, calign%, cfmt$, bar%)
  71. ' routine to create a new column
  72. '   Rhnd is a report handle (not currently used)
  73. '   colno is the column number (from 1 to max)
  74. '   ctype is the datatype: A for text and 9 for numeric
  75. '   ctitle is the column title
  76. '   cwidth is the default width in twips
  77. '   calign is the alignment: 0 = left, 1 = centred, 2 = right
  78. '   cfmt is a standard VB format string used to format each cell value
  79. '   bar is a flag indicating if a vertical bar should be drawn on the printed report
  80. '       0 (FALSE) = no, -1 (TRUE) = yes
  81.  
  82. If colno% < 1 Or colno% > rpt.cols Then MsgBox "invalid column number", 16, "RptDefineColumn"
  83.  
  84. RptCol(colno%).fmt = cfmt$
  85. RptCol(colno%).bar = bar%
  86. RptCol(colno%).datatype = ctype$
  87. RptCol(colno%).ctitle = ctitle$
  88. RptCol(colno%).cwidth = cwidth%
  89. RptCol(colno%).calign = calign%
  90.  
  91. ' set pointer to data column
  92. If ctype$ = "9" Then
  93.     If rpt.currentnumcol < rpt.numcols Then
  94.         rpt.currentnumcol = rpt.currentnumcol + 1
  95.         RptCol(colno%).ptr = rpt.currentnumcol
  96.     Else
  97.         MsgBox "too many numeric columns", 16, "RptDefineColumn"
  98.     End If
  99. ElseIf ctype$ = "A" Then
  100.     If rpt.currenttextcol < rpt.textcols Then
  101.         rpt.currenttextcol = rpt.currenttextcol + 1
  102.         RptCol(colno%).ptr = rpt.currenttextcol
  103.     Else
  104.         MsgBox "too many text columns", 16, "RptDefineColumn"
  105.     End If
  106. Else
  107.     MsgBox "Invalid datatype", 16, "RptDefineColumn"
  108. End If
  109.  
  110. If cwidth% <= 0 Then MsgBox "invalid column width", 16, "RptDefineColumn"
  111.  
  112. RptForm.grid1.col = colno% - 1
  113. RptForm.grid1.row = 0
  114. RptForm.grid1.text = ctitle$
  115. RptForm.grid1.colwidth = cwidth%
  116. RptForm.grid1.rowheight = rpt.headerheight
  117. RptForm.grid1.colalignment = calign%
  118.  
  119. ' set sort menu item
  120. If colno% > 1 Then Load RptForm.MSort(colno%)
  121. RptForm.MSort(colno%).caption = "&" + Format$(colno%) + "." + ctitle$
  122. End Sub
  123.  
  124. Sub RptDelete (Rhnd%)
  125. Unload RptForm
  126. End Sub
  127.  
  128. Sub RptNewPage (Rhnd%, page%)
  129. ' procedure to display specified page of a report
  130. ' report handle is ignored currently
  131. If page% > rpt.pages Or page% < 1 Then MsgBox "invalid page number", 16, "RptNewPage"
  132.  
  133. Screen.MousePointer = 11
  134. '-----------
  135. ' clear grid control
  136.     x% = RptForm.grid1.col
  137.     y% = RptForm.grid1.row
  138.     RptForm.grid1.Selstartrow = 1
  139.     RptForm.grid1.SelStartcol = 0
  140.     RptForm.grid1.Selendrow = RptForm.grid1.rows - 1
  141.     RptForm.grid1.Selendcol = RptForm.grid1.cols - 1
  142.     RptForm.grid1.clip = ""
  143.     RptForm.grid1.Selstartrow = 1
  144.     RptForm.grid1.SelStartcol = 1
  145.     RptForm.grid1.Selendrow = 1
  146.     RptForm.grid1.Selendcol = 1
  147. '-----------
  148.  
  149. rpt.page = page%    ' set current page number
  150. RptForm.caption = RTrim$(rpt.name) + " - (Page " + Format$(rpt.page) + " of " + Format$(rpt.pages) + ")"
  151.  
  152. ' populate grid with data for current page
  153. For y% = ((page% - 1) * rpt.rowsperpage) + 1 To (page% * rpt.rowsperpage)
  154.     If y% > rpt.rows Then Exit For
  155.     For x% = 1 To rpt.cols
  156.         RptForm.grid1.row = y% Mod rpt.rowsperpage
  157.         If RptForm.grid1.row = 0 Then RptForm.grid1.row = rpt.rowsperpage
  158.         RptForm.grid1.col = x% - 1
  159.         
  160.         If RptCol(x%).datatype = "9" Then
  161.             RptForm.grid1.text = Format$(RptNumData(RptCol(x%).ptr, y%), RTrim$(RptCol(x%).fmt) + " ")
  162.         Else
  163.             RptForm.grid1.text = RptTextData(RptCol(x%).ptr, y%)
  164.         End If
  165.     Next
  166. Next
  167.  
  168. RptForm.Refresh
  169. Screen.MousePointer = 0
  170. End Sub
  171.  
  172. Sub RptPrint (Rhnd%)
  173. ' prints current report page.  Report handle is currently ignored
  174.  
  175. Screen.MousePointer = 11
  176. RptForm.TXT_status.visible = -1
  177. RptForm.TXT_status.text = "Printing page " + Format$(rpt.page) + " of " + Format$(rpt.pages)
  178.  
  179. Printer.fontname = Printer.fonts(3)     ' universe on an HP laserjet
  180.  
  181. '--------------------------------------------------------
  182. ' get max width and height of grid by looping thru columns and rows
  183. '--------------------------------------------------------
  184. maxwidth% = 0
  185. maxheight% = rpt.headerheight + 15
  186. For y% = 1 To rpt.rowsperpage
  187.     RptForm.grid1.row = y%
  188.     If RptForm.grid1.text = "" Then Exit For
  189.     maxheight% = maxheight% + rpt.defrowheight + 15
  190. Next
  191. For x% = 0 To rpt.cols - 1
  192.     RptForm.grid1.col = x%
  193.     maxwidth% = maxwidth% + RptForm.grid1.colwidth + 15
  194. Next
  195.  
  196. '----------------------------
  197. ' date and pagenumber
  198. '----------------------------
  199. Printer.fontsize = 9
  200. Printer.currentx = 550
  201. Printer.currenty = 380
  202. Printer.Print Format$(Now, "dd mmmm, yyyy");
  203. Printer.currentx = Printer.width - Printer.TextWidth("Page " + Format$(rpt.page)) - 1300
  204. Printer.Print "Page " + Format$(rpt.page)
  205.  
  206. '----------------------------
  207. ' main title
  208. '----------------------------
  209. Printer.fontbold = -1
  210. Printer.fontsize = 16
  211. Printer.currentx = ((Printer.width - Printer.TextWidth(RptForm.LAB_title1.caption)) / 2) - 400
  212. Printer.currenty = 620
  213. Printer.Print RptForm.LAB_title1.caption
  214.  
  215. '----------------------------
  216. ' second title
  217. '----------------------------
  218. Printer.fontbold = 0
  219. Printer.fontsize = 12
  220. Printer.currentx = ((Printer.width - Printer.TextWidth(RptForm.LAB_title2.caption)) / 2) - 400
  221. Printer.currenty = 1100
  222. Printer.Print RptForm.LAB_title2.caption
  223.  
  224. '----------------------------
  225. ' footnotes
  226. '----------------------------
  227. Printer.fontbold = 0
  228. Printer.fontsize = 9
  229. Printer.currentx = 550
  230. Printer.currenty = Printer.height - 1600
  231. Printer.Print RptForm.LAB_footnote1.caption
  232. Printer.currentx = 550
  233. Printer.currenty = Printer.height - 1200
  234. Printer.Print RptForm.LAB_footnote2.caption
  235.  
  236. ' draw grid
  237. Printer.fontsize = 8.25
  238.  
  239. If (Printer.width - maxwidth%) > 800 Then
  240.     orgx% = ((Printer.width - maxwidth%) / 2) - 400     ' centred report
  241. Else
  242.     orgx% = 400     ' won't fit so left justified
  243. End If
  244. orgy% = 1750
  245.  
  246. '--------------------------------------------------------
  247. ' draw outline of report table with shadows
  248. '--------------------------------------------------------
  249. Printer.currentx = orgx%
  250. Printer.currenty = orgy%
  251. Printer.drawwidth = 3
  252. Printer.Line -(maxwidth% + orgx%, maxheight% + orgy%), , B
  253. Printer.drawwidth = 1
  254. Printer.Line (maxwidth% + orgx%, orgy% + 35)-(maxwidth% + orgx% + 35, orgy% + maxheight% + 35), , BF
  255. Printer.Line (orgx% + 35, maxheight% + orgy%)-(maxwidth% + orgx% + 35, maxheight% + orgy% + 35), , BF
  256.  
  257. Printer.fontbold = -1
  258.  
  259. '------------------------------------------------
  260. ' draw column separator lines and column headings
  261. '------------------------------------------------
  262. xpos% = orgx%
  263. RptForm.grid1.row = 0
  264. For col% = 1 To rpt.cols
  265.     RptForm.grid1.col = col% - 1
  266.     xpos% = xpos% + RptForm.grid1.colwidth + 15
  267.     If RptCol(col%).bar Then
  268.         Printer.Line (xpos%, orgy%)-(xpos%, orgy% + maxheight%)
  269.     End If
  270.     RptPrintColHead (RptForm.grid1.text), (RptForm.grid1.colwidth), (rpt.headerheight), xpos% - RptForm.grid1.colwidth - 15, orgy%
  271. Next
  272.  
  273. '------------------------------------------------
  274. ' draw horizontal lines and data
  275. '------------------------------------------------
  276. Printer.fontbold = 0
  277. ypos% = orgy% + rpt.headerheight + 15
  278. Printer.drawwidth = 3
  279. Printer.Line (orgx%, ypos%)-(maxwidth% + orgx%, ypos%)
  280.  
  281. For y% = 1 To rpt.rowsperpage
  282.     RptForm.grid1.col = 0
  283.     RptForm.grid1.row = y%
  284.     If RptForm.grid1.text = "" Then Exit For
  285.     ypos% = ypos% + rpt.defrowheight + 15
  286.     If (y% Mod rpt.thickbars = 0) Then
  287.         Printer.drawwidth = 3
  288.         Printer.Line (orgx%, ypos%)-(maxwidth% + orgx%, ypos%)
  289.     ElseIf (y% Mod rpt.thinbars = 0) Then
  290.         If y% = 0 Then
  291.             Printer.drawwidth = 3
  292.         Else
  293.             Printer.drawwidth = 1
  294.         End If
  295.         Printer.Line (orgx%, ypos%)-(maxwidth% + orgx%, ypos%)
  296.     End If
  297.     Printer.currenty = ypos% - rpt.defrowheight + 30
  298.  
  299.     '-------------------------------
  300.     ' print data items across row
  301.     '-------------------------------
  302.     If y% > 0 And RptForm.grid1.text <> "" Then
  303.         Printer.currentx = orgx% + 15
  304.         For x% = 0 To rpt.cols - 1
  305.             RptForm.grid1.col = x%
  306.             startcolpos% = Printer.currentx
  307.             RptPrintCellText (RptForm.grid1.text), startcolpos%, (RptForm.grid1.colwidth), (RptForm.grid1.colalignment)
  308.             Printer.currentx = startcolpos% + RptForm.grid1.colwidth + 15
  309.         Next
  310.     End If
  311. Next
  312.  
  313. Printer.NewPage
  314. RptForm.TXT_status.visible = 0
  315. Screen.MousePointer = 0
  316. End Sub
  317.  
  318. Sub RptPrintAll (Rhnd%)
  319. ' routine to print all pages for current report
  320.  
  321. For n% = 1 To rpt.pages
  322.     RptNewPage Rhnd%, n%
  323.     RptPrint Rhnd%
  324. Next
  325.  
  326. Printer.EndDoc
  327. End Sub
  328.  
  329. Sub RptPrintCellText (ctext$, cstart%, cwidth%, align%)
  330. ' routine to print as much text as will fit into a cell
  331.  
  332. If Printer.TextWidth(ctext$) >= cwidth% Then
  333.     For n% = 1 To Len(ctext$)
  334.         If Printer.currentx < cstart% + cwidth% - 30 Then
  335.             Printer.Print Mid$(ctext$, n%, 1);
  336.         End If
  337.     Next
  338. Else
  339.     Select Case align%
  340.         Case 0  ' left
  341.             Printer.currentx = Printer.currentx + 15
  342.         Case 1  ' centred
  343.             Printer.currentx = Printer.currentx + (cwidth% - Printer.TextWidth(ctext$)) / 2
  344.         Case 2  ' right
  345.             Printer.currentx = Printer.currentx + cwidth% - Printer.TextWidth(ctext$)
  346.     End Select
  347.     Printer.Print ctext$;
  348. End If
  349.  
  350. End Sub
  351.  
  352. Sub RptPrintColHead (chead$, cwidth%, rheight%, xstart%, ystart%)
  353. ' this subroutine prints cell text over several lines whilst trying not to split words
  354.  
  355. Printer.currentx = xstart%
  356. Printer.currenty = ystart% + 30
  357.  
  358. Do
  359.     ' while there is space left to display text
  360.     ' get next word
  361.     chead$ = LTrim$(RTrim$(chead$))
  362.     i% = InStr(chead$, " ")
  363.     If i% = 0 Then
  364.         word$ = " " + chead$
  365.         chead$ = ""
  366.     Else
  367.         word$ = " " + Left$(chead$, i% - 1)
  368.         chead$ = Mid$(chead$, i% + 1)
  369.     End If
  370.  
  371.     ' check if space left to write this on current line
  372.     If Printer.currentx + Printer.TextWidth(word$) < xstart% + cwidth% Then
  373.         Printer.Print word$;
  374.     Else
  375.         If Printer.currentx > xstart% Then
  376.             Printer.currenty = Printer.currenty + Printer.TextHeight(word$)
  377.             Printer.currentx = xstart%
  378.         End If
  379.         RptPrintCellText word$, xtart%, cwidth%, 0
  380.     End If
  381.  
  382. Loop Until Printer.currenty >= ystart% + rheight% Or chead$ = ""
  383.  
  384. End Sub
  385.  
  386. Sub RptSetText (Rhnd%, colno%, rowno%, tvalue$)
  387. ' assigns a text value to a cell in the report
  388.  
  389. If colno% < 1 Or colno% > rpt.cols Then MsgBox "invalid column number", 16, "RptSetText"
  390. If rowno% < 1 Or rowno% > rpt.rows Then MsgBox "invalid row number", 16, "RptSetText"
  391. If RptCol(colno%).datatype <> "A" Then MsgBox "not a valid text column", 16, "RptSetText"
  392.  
  393. RptTextData(RptCol(colno%).ptr, rowno%) = tvalue$
  394. End Sub
  395.  
  396. Sub RptSetValue (Rhnd%, colno%, rowno%, value!)
  397. ' routine to assign a numeric value to a report cell
  398.  
  399. If colno% < 1 Or colno% > rpt.cols Then MsgBox "invalid column number", 16, "RptSetValue"
  400. If rowno% < 1 Or rowno% > rpt.rows Then MsgBox "invalid row number", 16, "RptSetValue"
  401. If RptCol(colno%).datatype <> "9" Then MsgBox "not a valid numeric column", 16, "RptSetValue"
  402.  
  403. RptNumData(RptCol(colno%).ptr, rowno%) = value!
  404. End Sub
  405.  
  406. Sub RptSort (colno%)
  407. ' routine to sort report on any single column: text or numeric
  408. ' The sorting algorithm is based upon that in VBSORT.BAS so the credit
  409. ' must go to Nelson Ford (71355,470)
  410.  
  411. If colno% < 1 Or colno% > rpt.cols Then MsgBox "invalid column number", 16, "RptSort"
  412.  
  413. Screen.MousePointer = 1
  414. RptForm.TXT_status.visible = -1
  415. RptForm.TXT_status.text = "sorting by " + RptCol(colno%).ctitle
  416.  
  417. col% = RptCol(colno%).ptr
  418. typ$ = RptCol(colno%).datatype
  419. ply% = 1
  420. RptSortBottom(1) = 1
  421. RptSortTop(1) = rpt.rows
  422.  
  423. While ply% > 0
  424.     If RptSortBottom(ply%) >= RptSortTop(ply%) Then
  425.         ply% = ply% - 1
  426.     Else
  427.         i% = RptSortBottom(ply%) - 1
  428.         j% = RptSortTop(ply%)
  429.         If typ$ = "9" Then
  430.             ptn! = RptNumData(col%, j%)
  431.         Else
  432.             t$ = RptTextData(col%, j%)
  433.         End If
  434.         While i% < j%
  435.             i% = i% + 1
  436.             j% = j% - 1
  437.             If typ$ = "9" Then
  438.                 While RptNumData(col%, i%) < ptn!: i% = i% + 1: Wend
  439.                 While RptNumData(col%, j%) > ptn! And j% > i%: j% = j% - 1: Wend
  440.             Else
  441.                 While RptTextData(col%, i%) < t$: i% = i% + 1: Wend
  442.                 While RptTextData(col%, j%) > t$ And j% > i%: j% = j% - 1: Wend
  443.             End If
  444.             If i% < j% Then
  445.                 RptSwap i%, j%
  446.             End If
  447.         Wend
  448.         j% = RptSortTop(ply%)
  449.         Select Case typ$
  450.             Case "9"
  451.                 If i% <> j% And RptNumData(col%, i%) > RptNumData(col%, j%) Then
  452.                     RptSwap i%, j%
  453.                 End If
  454.             Case Else
  455.                 If i% <> j% And RptTextData(col%, i%) > RptTextData(col%, j%) Then
  456.                     RptSwap i%, j%
  457.                 End If
  458.         End Select
  459.         If i% - RptSortBottom(ply%) < RptSortTop(ply%) - i% Then
  460.             RptSortBottom(ply% + 1) = RptSortBottom(ply%)
  461.             RptSortTop(ply% + 1) = i% - 1
  462.             RptSortBottom(ply%) = i% + 1
  463.         Else
  464.             RptSortTop(ply% + 1) = RptSortTop(ply%)
  465.             RptSortBottom(ply% + 1) = i% + 1
  466.             RptSortTop(ply%) = i% - 1
  467.         End If
  468.         ply% = ply% + 1
  469.     End If
  470. Wend
  471. Screen.MousePointer = 0
  472. RptForm.TXT_status.visible = 0
  473. End Sub
  474.  
  475. Sub RptSwap (i%, j%)
  476. ' swaps all of the column values for two specified rows
  477.  
  478.     ' swap numeric columns
  479.     For n% = 1 To rpt.numcols
  480.         x! = RptNumData(n%, i%)
  481.         RptNumData(n%, i%) = RptNumData(n%, j%)
  482.         RptNumData(n%, j%) = x!
  483.     Next
  484.     ' swap text columns
  485.     For n% = 1 To rpt.textcols
  486.         t$ = RptTextData(n%, i%)
  487.         RptTextData(n%, i%) = RptTextData(n%, j%)
  488.         RptTextData(n%, j%) = t$
  489.     Next
  490. End Sub
  491.  
  492.