I am not sure if this question should be in here cause it involves vb6 code and crystal report or sql query.
I have this record for example group of subjects and grade per student. I will print this record on half paper. I would like to appear each subject with corresponding grades separately in each half size paper. so like math and algebra would be shown on one paper since they belong to same group and english on another paper and so on.
I have group id assigned to each subject.
Its like, they are page 1, its the math and algebra then page 2 its english and so on.
How will i do that?
Last edited by genlight; May 27th, 2017 at 11:02 AM.
I am not sure if this question should be in here cause it involves vb6 code and crystal report or sql query.
A lot of developers prefer to use their own Report-Drawing, to have more control over the Render-OutPut
and not as many dependecies to ship, which often are (e.g. in case of Crystal-Reports) not easy to bundle in an Installer.
Originally Posted by genlight
I have this record for example group of subjects and grade per student. I will print this record on half paper...
...Its like, they are page 1, its the math and algebra then page 2 its english and so on.
How will i do that?
Below is shown, how one can achieve his own OwnerDrawn-Reporting (including a PictureBox-based Preview)
with a small set of only 4 (wrapped) VB6-Drawing-Routines (the Print-Output based on vbPoints-Coordinates).
Here is the set of the just mentioned 4 Helper-Functions, which you can put into a *.bas-Module for global availability.
Code:
Option Explicit
Sub ChangeFontOn(Canvas As Object, FontName, FontSize, Optional ByVal FontBold As Boolean, Optional ByVal FontItalic As Boolean)
Canvas.Font.Name = FontName
Canvas.Font.Size = FontSize
Canvas.Font.Bold = FontBold
Canvas.Font.Italic = FontItalic
End Sub
Sub DrawRectangleOn(Canvas As Object, x, y, dx, dy, Optional ByVal LineColor&, Optional ByVal LineWidth& = 1, Optional ByVal FillColor& = -1)
If LineWidth Then Canvas.DrawWidth = LineWidth
If FillColor <> -1 Then Canvas.Line (Int(x), Int(y))-(Int(x + dx), Int(y + dy)), FillColor, BF
If LineWidth Then Canvas.Line (Int(x), Int(y))-(Int(x + dx), Int(y + dy)), LineColor, B
End Sub
Sub DrawTextOn(Canvas As Object, x, y, dx, dy, ByVal Text$, Optional ByVal Color&, Optional ByVal Align As AlignmentConstants, Optional ByVal VCenter As Boolean = True, Optional ByVal Padding As Long = 3)
Canvas.ForeColor = Color
If VCenter Then Canvas.CurrentY = y + (dy - Canvas.TextHeight("|")) / 2 Else Canvas.CurrentY = y - Padding
Select Case Align
Case vbLeftJustify: Canvas.CurrentX = x + Padding
Case vbCenter: Canvas.CurrentX = x + (dx - Canvas.TextWidth(Trim$(Text))) / 2
Case vbRightJustify: Canvas.CurrentX = x + (dx - Canvas.TextWidth(Trim$(Text))) - Padding
End Select
Canvas.Print Text
End Sub
Sub DrawRsTableOn(Canvas As Object, Rs As Object, xOffs, yOffs, dx, dy, ColWPercArr, HeaderHeight, RowHeight)
Dim i, x, y, ColWidth, PercColor
ChangeFontOn Canvas, "Arial", 10
x = xOffs: y = yOffs
For i = 0 To Rs.Fields.Count - 1 'draw the Header first
ColWidth = ColWPercArr(i) * dx 'calculate the current ColWidth
DrawRectangleOn Canvas, x, y, ColWidth, HeaderHeight, vbBlack, 1, &HBBBBBB
DrawTextOn Canvas, x, y, ColWidth, HeaderHeight, Rs(i).Name, , vbCenter
x = x + ColWidth 'increase the current x about the last ColWidth
Next
y = y + HeaderHeight
Do Until Rs.EOF Or y - yOffs + RowHeight > dy 'now the Table-Body
x = xOffs 'reset to xOffs for the rendering of the next Row
For i = 0 To Rs.Fields.Count - 1 'loop over all Fields in the Rs to render the current Row
ColWidth = ColWPercArr(i) * dx 'calculate the current ColWidth
DrawRectangleOn Canvas, x, y, ColWidth, RowHeight, vbBlack, 1 'the Border-Rect
If InStr(1, Rs(i).Name, "Perc", 1) Then 'a special Handling for Rs-FieldNames which have "Perc" in it
PercColor = Choose(1 + Int(4 * Rs(i).Value - 0.01), vbRed, vbMagenta, vbBlue, vbCyan)
DrawRectangleOn Canvas, x + 2, y + (RowHeight - 4) / 2, Rs(i).Value * (ColWidth - 4), 4, 0, 0, PercColor
Else 'draw normal Text-Content
Select Case VarType(Rs(i).Value)
Case vbNull: 'your choice what is rendered in this case, currently we do nothing
Case vbBoolean: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & IIf(Rs(i).Value, "X", "O"), 0, vbCenter
Case vbString: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & Rs(i).Value, 0, vbLeftJustify
Case Else: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & Rs(i).Value, 0, vbRightJustify
End Select
x = x + ColWidth 'increase the current x about the last ColWidth
End If
Next
y = y + RowHeight 'increase y about the just rendered Row
Rs.MoveNext
Loop
End Sub
With the above Helpers "out of the way" in the *.bas Module, the Form-Code
becomes quite lean and readable.
Into a naked Form, which will only need a Command1 and a Picture1 on it (arranged e.g. like in the ScreenShot below):
Code:
Option Explicit
Private Rs As Object
Private Sub Form_Load()
Me.BackColor = &H888888
Picture1.AutoRedraw = True
Picture1.BackColor = vbWhite
Picture1.BorderStyle = 0
End Sub
Private Sub Command1_Click()
Picture1.Cls
DrawPageOn Picture1, "Maths", "Algebra"
If MsgBox("Print it?", vbYesNo) = vbYes Then
DrawPageOn Printer, "Maths", "Algebra"
Printer.NewPage
DrawPageOn Printer, "Bio-Lectures", "Bio-Lab"
Printer.EndDoc
End If
End Sub
Private Sub DrawPageOn(Canvas As Object, SubjTop As String, Optional SubjBottom As String)
Canvas.ScaleMode = vbPoints
If TypeOf Canvas Is VB.PictureBox Then Canvas.Cls
DrawHalfPage Canvas, SubjTop, GetRsForSubject(SubjTop)
If Len(SubjBottom) Then DrawHalfPage Canvas, SubjBottom, GetRsForSubject(SubjBottom), Canvas.ScaleWidth / 2
End Sub
Sub DrawHalfPage(Canvas As Object, Subject As String, Rs As Object, Optional ByVal xOffs = 0)
'print a separator-line at the top of the bottom-halfpage when needed
If xOffs Then DrawRectangleOn Canvas, xOffs, 10, 0, Canvas.ScaleHeight - 20
'draw the Subject-Text in Arial 12pt, centered, and blue
ChangeFontOn Canvas, "Arial", 12, True, True
DrawTextOn Canvas, xOffs, 20, Canvas.ScaleWidth / 2, 12, Subject, vbBlue, vbCenter
'now the Rs-based TableRendering
Dim ColWPerc: ColWPerc = Array(0.5, 0.15, 0.35) 'define the ColumnWidths of the 3 Rs-Columns i percent
DrawRsTableOn Canvas, Rs, xOffs + 10, 40, Canvas.ScaleWidth / 2 - 20, Canvas.ScaleHeight - 40, ColWPerc, 16, 15
End Sub
'just to simulate a DB-Select which hands out a similar RecordSet
Private Function GetRsForSubject(Subject As String) As Object
Set GetRsForSubject = CreateObject("ADODB.Recordset")
With GetRsForSubject
.Fields.Append "Name", vbString
.Fields.Append "Grade", vbInteger
.Fields.Append "GradePerc", vbDouble
.Open
Dim i As Long, Name, Grade, GradePerc
For i = 1 To 25
.AddNew
!Name = "Sudent " & i
!Grade = 19 + Rnd * 80
!GradePerc = !Grade / 100
Next
.MoveFirst
End With
End Function
A lot of developers prefer to use their own Report-Drawing, to have more control over the Render-OutPut
and not as many dependecies to ship, which often are (e.g. in case of Crystal-Reports) not easy to bundle in an Installer.
Below is shown, how one can achieve his own OwnerDrawn-Reporting (including a PictureBox-based Preview)
with a small set of only 4 (wrapped) VB6-Drawing-Routines (the Print-Output based on vbPoints-Coordinates).
Here is the set of the just mentioned 4 Helper-Functions, which you can put into a *.bas-Module for global availability.
Code:
Option Explicit
Sub ChangeFontOn(Canvas As Object, FontName, FontSize, Optional ByVal FontBold As Boolean, Optional ByVal FontItalic As Boolean)
Canvas.Font.Name = FontName
Canvas.Font.Size = FontSize
Canvas.Font.Bold = FontBold
Canvas.Font.Italic = FontItalic
End Sub
Sub DrawRectangleOn(Canvas As Object, x, y, dx, dy, Optional ByVal LineColor&, Optional ByVal LineWidth& = 1, Optional ByVal FillColor& = -1)
If LineWidth Then Canvas.DrawWidth = LineWidth
If FillColor <> -1 Then Canvas.Line (Int(x), Int(y))-(Int(x + dx), Int(y + dy)), FillColor, BF
If LineWidth Then Canvas.Line (Int(x), Int(y))-(Int(x + dx), Int(y + dy)), LineColor, B
End Sub
Sub DrawTextOn(Canvas As Object, x, y, dx, dy, ByVal Text$, Optional ByVal Color&, Optional ByVal Align As AlignmentConstants, Optional ByVal VCenter As Boolean = True, Optional ByVal Padding As Long = 3)
Canvas.ForeColor = Color
If VCenter Then Canvas.CurrentY = y + (dy - Canvas.TextHeight("|")) / 2 Else Canvas.CurrentY = y - Padding
Select Case Align
Case vbLeftJustify: Canvas.CurrentX = x + Padding
Case vbCenter: Canvas.CurrentX = x + (dx - Canvas.TextWidth(Trim$(Text))) / 2
Case vbRightJustify: Canvas.CurrentX = x + (dx - Canvas.TextWidth(Trim$(Text))) - Padding
End Select
Canvas.Print Text
End Sub
Sub DrawRsTableOn(Canvas As Object, Rs As Object, xOffs, yOffs, dx, dy, ColWPercArr, HeaderHeight, RowHeight)
Dim i, x, y, ColWidth, PercColor
ChangeFontOn Canvas, "Arial", 10
x = xOffs: y = yOffs
For i = 0 To Rs.Fields.Count - 1 'draw the Header first
ColWidth = ColWPercArr(i) * dx 'calculate the current ColWidth
DrawRectangleOn Canvas, x, y, ColWidth, HeaderHeight, vbBlack, 1, &HBBBBBB
DrawTextOn Canvas, x, y, ColWidth, HeaderHeight, Rs(i).Name, , vbCenter
x = x + ColWidth 'increase the current x about the last ColWidth
Next
y = y + HeaderHeight
Do Until Rs.EOF Or y - yOffs + RowHeight > dy 'now the Table-Body
x = xOffs 'reset to xOffs for the rendering of the next Row
For i = 0 To Rs.Fields.Count - 1 'loop over all Fields in the Rs to render the current Row
ColWidth = ColWPercArr(i) * dx 'calculate the current ColWidth
DrawRectangleOn Canvas, x, y, ColWidth, RowHeight, vbBlack, 1 'the Border-Rect
If InStr(1, Rs(i).Name, "Perc", 1) Then 'a special Handling for Rs-FieldNames which have "Perc" in it
PercColor = Choose(1 + Int(4 * Rs(i).Value - 0.01), vbRed, vbMagenta, vbBlue, vbCyan)
DrawRectangleOn Canvas, x + 2, y + (RowHeight - 4) / 2, Rs(i).Value * (ColWidth - 4), 4, 0, 0, PercColor
Else 'draw normal Text-Content
Select Case VarType(Rs(i).Value)
Case vbNull: 'your choice what is rendered in this case, currently we do nothing
Case vbBoolean: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & IIf(Rs(i).Value, "X", "O"), 0, vbCenter
Case vbString: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & Rs(i).Value, 0, vbLeftJustify
Case Else: DrawTextOn Canvas, x, y, ColWidth, RowHeight, "" & Rs(i).Value, 0, vbRightJustify
End Select
x = x + ColWidth 'increase the current x about the last ColWidth
End If
Next
y = y + RowHeight 'increase y about the just rendered Row
Rs.MoveNext
Loop
End Sub
With the above Helpers "out of the way" in the *.bas Module, the Form-Code
becomes quite lean and readable.
Into a naked Form, which will only need a Command1 and a Picture1 on it (arranged e.g. like in the ScreenShot below):
Code:
Option Explicit
Private Rs As Object
Private Sub Form_Load()
Me.BackColor = &H888888
Picture1.AutoRedraw = True
Picture1.BackColor = vbWhite
Picture1.BorderStyle = 0
End Sub
Private Sub Command1_Click()
Picture1.Cls
DrawPageOn Picture1, "Maths", "Algebra"
If MsgBox("Print it?", vbYesNo) = vbYes Then
DrawPageOn Printer, "Maths", "Algebra"
Printer.NewPage
DrawPageOn Printer, "Bio-Lectures", "Bio-Lab"
Printer.EndDoc
End If
End Sub
Private Sub DrawPageOn(Canvas As Object, SubjTop As String, Optional SubjBottom As String)
Canvas.ScaleMode = vbPoints
If TypeOf Canvas Is VB.PictureBox Then Canvas.Cls
DrawHalfPage Canvas, SubjTop, GetRsForSubject(SubjTop)
If Len(SubjBottom) Then DrawHalfPage Canvas, SubjBottom, GetRsForSubject(SubjBottom), Canvas.ScaleWidth / 2
End Sub
Sub DrawHalfPage(Canvas As Object, Subject As String, Rs As Object, Optional ByVal xOffs = 0)
'print a separator-line at the top of the bottom-halfpage when needed
If xOffs Then DrawRectangleOn Canvas, xOffs, 10, 0, Canvas.ScaleHeight - 20
'draw the Subject-Text in Arial 12pt, centered, and blue
ChangeFontOn Canvas, "Arial", 12, True, True
DrawTextOn Canvas, xOffs, 20, Canvas.ScaleWidth / 2, 12, Subject, vbBlue, vbCenter
'now the Rs-based TableRendering
Dim ColWPerc: ColWPerc = Array(0.5, 0.15, 0.35) 'define the ColumnWidths of the 3 Rs-Columns i percent
DrawRsTableOn Canvas, Rs, xOffs + 10, 40, Canvas.ScaleWidth / 2 - 20, Canvas.ScaleHeight - 40, ColWPerc, 16, 15
End Sub
'just to simulate a DB-Select which hands out a similar RecordSet
Private Function GetRsForSubject(Subject As String) As Object
Set GetRsForSubject = CreateObject("ADODB.Recordset")
With GetRsForSubject
.Fields.Append "Name", vbString
.Fields.Append "Grade", vbInteger
.Fields.Append "GradePerc", vbDouble
.Open
Dim i As Long, Name, Grade, GradePerc
For i = 1 To 25
.AddNew
!Name = "Sudent " & i
!Grade = 19 + Rnd * 80
!GradePerc = !Grade / 100
Next
.MoveFirst
End With
End Function
In the VB6 IDE, there is no color-bar in the grid. But after compiling into exe, color-bars appear.
The Color-bars will be created within the Routine 'DrawRsTable' on all Fields
(Field-Names) which contain the snippet 'Perc' by this line here:
Code:
If InStr(1, Rs(i).Name, "Perc", 1) Then 'a special Handling for Rs-FieldNames which have "Perc" in it
Why exactly this branching-instruction fails (in your IDE on a system with a chinese locale)
should be relatively easy to discover when you set a breakpoint there...
On XP:
Whether in the VB6 IDE environment, or after compiling into exe, the grid have color-bars.
On Win10:
In the VB6 IDE, there is no color-bar in the grid. But after compiling into exe, color-bars appear.
After testing, the problem is indeed generated by the following code line:
Code:
If InStr(1, Rs(i).Name, "Perc", 1) Then
I have encountered this type of problem before, I know what the reason is.
In vb6 IDE on Win7, Win8 and Win10 with Chinese locale, the compare method of Instr must be 0 (vbBinaryCompare), can not be 1 (vbTextCompare) or 2 (vbDatabaseCompare).
Function InStr([Start], [String1], [String2], [Compare As VbCompareMethod = vbBinaryCompare])
I modified the following code line, everything was fine:
Code:
If InStr(1, Rs(i).Name, "Perc", 0) Then
or
Code:
If InStr(1, LCase(Rs(i).Name), "perc", 0) Then
Thanks, Olaf.
Last edited by dreammanor; May 29th, 2017 at 08:49 AM.
@Arnoutdv, sorry, I missed the OP's sentence. When Olaf made a good solution, I tested it and raised the problem in the test process, that's it.
In my opinion, answering question is to help others, testing and find problem is to help others too, which can let others and me learn a lot of knowledge.
Of course, if OP is not interested in these issues, then I really disturb him. I will pay attention to this, and try not to ask questions in other's thread. Thanks for your reminder.