imports System.Windows.Forms
Imports System.IO
imports System.Drawing
imports system.Drawing.Printing
Imports System.Runtime.Serialization.Formatters.soap
Public Class nbfBrowseRep
private pvDataSourceList as New DataSourceList
private pvBFInfo as new nbfBrowseFormInfo
private pvDBC as nbfDB.HDBC
private pvAppPath as String = ""
private pvTemplateName as String = ""
private CtlSaveName as string = ""
private PageCountDone as Boolean = false
private PrintPageCount as Integer = 0
private CurrentPrintPage as integer = 0
private ColGap as Single = 5
dim dblLineWidth as Single = 5
private pvCurrentDate as Date
private pvDefaultLineWidth as Integer = 2
private SvIndx as integer = 0
Public Event PrintComplete()
'ODBC DataTypes
Const SQL_CHAR = 1
Const SQL_NUMERIC = 2
Const SQL_DECIMAL = 3
Const SQL_INTEGER = 4
Const SQL_SMALLINT = 5
Const SQL_FLOAT = 6
Const SQL_REAL = 7
Const SQL_DOUBLE = 8
Const SQL_VARCHAR = 12
Const SQL_DATE = 9
Const SQL_TIME = 10
Const SQL_TIMESTAMP = 11
Const SQL_LONGVARCHAR = -1
Const SQL_BINARY = -2
Const SQL_VARBINARY = -3
Const SQL_LONGVARBINARY = -4
Const SQL_BIGINT = -5
Const SQL_TINYINT = -6
Const SQL_BIT = -7
Public Sub FreeConnections
dim ds as nbfDB.nbfResultSet
dim dsi as dataSourceInfo
For Each dsi in DataSourceList
if not dsi.ds is nothing then
dsi.ds.Dispose
dsi.ds = nothing
End If
Next
do while DataSourceList.count > 0
DataSourceList.RemoveAt(0)
Loop
if not pvDBc is nothing then
pvDBC.logoff
pvDbc.Dispose
pvDBc = nothing
end if
End Sub
Public Sub New(Byref idb as nbfDB.HDBC, ip as string, itn as string)
MyBase.New()
pvDBC = idb
pvAppPath = ip
pvTemplateName = itn
LoadCtlInfo
End Sub
Public Property CurrentDate as Date
Get
if pvCurrentDate = nothing then
return now
else
return pvCurrentDate
End If
End Get
Set
pvCurrentDate = Value
End Set
End Property
Friend Property DataSourceList as DataSourceList
Get
Return pvDataSourceList
End Get
Set
pvDataSourceList = Value
End Set
End Property
public Property BFInfo as nbfBrowseFormInfo
Get
Return pvBFInfo
End Get
Set
pvBFInfo = Value
End Set
End Property
Friend Property DBC as nbfDB.HDBC
Get
Return pvDBC
End Get
Set
pvDBC = Value
End Set
End Property
public Property AppPath as String
Get
Return pvAppPath
End Get
Set
pvAppPath = Value
End Set
End Property
public Property TemplateName as String
Get
Return pvTemplateName
End Get
Set
pvTemplateName = Value
End Set
End Property
Public Sub SetParamValue(byval ParamNumber as Integer,byval ParamValue as String)
dim p as nbfRepParam
for each p in pvBfInfo.RepParams
if p.ParamNumber = ParamNumber then
p.ParamCurrentValue = ParamValue
End If
Next
End Sub
sub LoadCtlInfo()
dim svpath as string
svpath = pvAppPath & "\BRLYT"
If Dir(svpath, FileAttribute.Directory) = "" Then
MkDir(svpath)
End If
CtlSaveName = svpath & "\" & pvTemplateName & "." & "SQS"
try
'pvBFInfo = new nbfBrowseFormInfo
If File.Exists(CtlSaveName) Then
Dim myFileStream As Stream = File.OpenRead(CtlSaveName)
try
'Dim deserializer As New BinaryFormatter()
Dim deserializer As New SoapFormatter()
pvBFInfo = CType(deserializer.Deserialize(myFileStream), nbfBrowseFormInfo)
catch ex2 as exception
msgbox(ex2.message)
finally
myFileStream.Close()
end try
end if
dim bc as nbfSQLBrowseCtrl
'ensure unique sequential names
dim rs as nbfSQLRepSection
dim ss as nbfSqlSource
For each ss in pvBFInfo.SQLSources
ss.ResetValidation
Next
for each bc in pvBFInfo.SQLBrowseCtrls
bc.Name = pvBFINfo.GetCtrlName()
For each ss in bc.SQLSources
ss.ResetValidation
Next
SetCtrlNames(bc)
Next
catch ex as Exception
msgbox(ex.Message)
end try
End Sub
Sub SetCtrlNames(bc as nbfSqlBrowseCtrl)
dim rs as nbfSQLRepSection
dim ss as nbfSqlSource
dim sbc as nbfSqlBrowseCtrl
for each rs in bc.RepSections
For each sbc in rs.SectionCtrls
sbc.Name = pvBFInfo.GetCtrlName
For each ss in bc.SQLSources
ss.ResetValidation
Next
SetCtrlNames(sbc)
Next
Next
End Sub
Sub ReSetPrintStat(bc as nbfSqlBrowseCtrl)
dim rs as nbfSQLRepSection
dim sbc as nbfSqlBrowseCtrl
for each rs in bc.RepSections
For each sbc in rs.SectionCtrls
sbc.PrintReqMorePages = false
sbc.NextRecordPos = 1
sbc.LastRecordTot = 0
sbc.NextSectReq = "C1"
sbc.NextSectNo = 0
sbc.RecPrinted = 0
sbc.GrowthOffset = 0
ReSetPrintStat(sbc)
Next
Next
End Sub
friend Function GetSqS(byval cn as String) as nbfSqlSource
try
dim bc as nbfSqlBrowseCtrl
dim sqs as nbfSqlSOurce
for each bc in pvBFInfo.SQLBrowseCtrls
if bc.Name = cn then
if bc.SQLSource<> "" then
for each sqs in pvBFInfo.SQLSources
if sqs.BrowseTableName = bc.SQLSource then
return sqs
End If
Next
End If
End If
Next
return nothing
catch
return nothing
end try
End Function
friend Function GetSqSFromName(byval dsn as String) as nbfSqlSource
try
dsn = trim(ucase(dsn))
if dsn = ""
return nothing
End If
dim bc as nbfSQLBrowseCtrl
dim ss as nbfSqlSource
For Each ss in pvBFInfo.SQLSources
if trim(ucase(ss.BrowseTableName)) = dsn then
return ss
End If
Next
For Each bc in pvBFInfo.SQLBrowseCtrls
ss = RetCtrlSource(bc,dsn)
if not ss is nothing then
return ss
End If
Next
return nothing
catch
return nothing
end try
End Function
private Function RetCtrlSource(bc as nbfSQLBrowseCtrl,byval SourceName as String) as nbfSqlSource
dim rs as nbfSQLRepSection
dim bc2 as nbfSQLBrowseCtrl
dim ss as nbfSqlSource
For Each ss in bc.SQLSources
if ucase(trim(ss.BrowseTableName)) = ucase(trim(SourceName)) then
return ss
End If
Next
For each rs in bc.RepSections
For Each bc2 in rs.SectionCtrls
For Each ss in bc2.SQLSources
if ucase(trim(ss.BrowseTableName)) = ucase(trim(SourceName)) then
return ss
End If
Next
Next
Next
return nothing
End Function
Public Sub Save(Optional byval SaveName as String = "")
try
dim svpath as string
if SaveName <> "" then
svpath = pvAppPath & "\BRLYT"
If Dir(svpath, FileAttribute.Directory) = "" Then
MkDir(svpath)
End If
CtlSaveName = svpath & "\" & SaveName & "." & "SQS"
End If
dim tCtlSaveName as String = pvAppPath & "tpltmp.tmp"
if tCtlSaveName <> "" then
'SaveCtlSettings
'pvBFInfo.Size = me.Size
'pvBFInfo.Location = me.Location
If File.Exists(tCtlSaveName) Then
File.Delete(tCtlSaveName)
End If
Dim CtlFileStream As Stream = File.Create(tCtlSaveName)
'Dim serializer As New BinaryFormatter()
Dim serializer As New SoapFormatter()
serializer.Serialize(CtlFileStream, pvBFInfo)
CtlFileStream.Close()
if SaveName <> "" then
CtlSaveName = SaveName
End If
If File.Exists(CtlSaveName) Then
File.Delete(CtlSaveName)
End If
Rename(tCTlSaveName,CTlSaveName)
End If
catch ex as Exception
msgbox(ex.Message)
end try
End Sub
Private Function GetColInfoFromName(cc as nbfSqlColInfos,cn as string) as nbfSqlColInfo
dim ci as nbfSqlColInfo
for each ci in cc
if ci.Colname = cn then
return ci
End If
Next
return nothing
End Function
Friend Function OLD_RepSubParams(pinstr as String, ss as nbfSqlSource) as String
try
pinstr = RepParams(pinstr)
'ParamCurrentValue
'ParamDefaultValue
dim pstr as string = ""
dim fpos as Integer = -1
dim spos as Integer = -1
dim rp as nbfRepParam
dim Ststr as string = ""
dim pfnd as boolean = false
dim rv as string = ""
do
pfnd = false
spos = instr(pinstr,"{{")
if spos > 0 then
fpos = instr(pinstr,"}}")
if fpos > 0 and fpos > (spos + 2) then
pstr = trim(mid(pinstr,spos + 2,(fpos - (spos + 2))))
if pstr.Length > 1 then
if ucase(mid(pstr,1,1)) = "C" then
pstr = mid(pstr,2,pstr.Length - 1)
if isnumeric(pstr) then
rv = ss.SqlColInfos.Item(cint(pstr) - 1).CurrentValue
if rv = "" then
select case ss.SqlColInfos.Item(cint(pstr) - 1).ColType
case "T"
'Empty string OK
case "D"
rv = "31-dec-2000"
case else
rv = 1
End Select
End If
if spos > 1 then
Ststr = mid(pinstr,1,spos - 1)
else
Ststr = ""
end if
pinstr = Ststr & rv & mid(pinstr,fpos + 2,pinstr.Length - fpos + 1)
pfnd = true
End If
End If
End If
End If
end if
loop while pfnd
return pinstr
catch
return ""
end try
end function
Friend Function RepParams(pinstr as String, optional byval dtf as String = "",Optional ByVal ParentSce as String = "") as String
try
'ParamCurrentValue
'ParamDefaultValue
dim pstr as string = ""
dim fpos as Integer = 0
dim spos as Integer = 0
dim bpos as integer = 0
dim rp as nbfRepParam
dim Ststr as string = ""
dim pfnd as boolean = false
dim ss as nbfSqlSource
dim rv as string = ""
dim SceName as String = ""
dim PrQt as Boolean = false
do
pfnd = false
spos = instr(pinstr,"<<")
if spos > 0 then
fpos = instr(pinstr,">>")
if fpos > 0 and fpos > (spos + 2) then
pstr = mid(pinstr,spos + 2,(fpos - (spos + 2)))
rp = getParam(pstr)
if not rp is nothing
Ststr = ""
if spos > 1 then
Ststr = mid(pinstr,1,spos - 1)
end if
pinstr = Ststr & GetParamValue(rp) & mid(pinstr,fpos + 2,pinstr.Length - fpos + 1)
pfnd = true
End If
End If
end if
loop while pfnd
do
pfnd = false
spos = instr(pinstr,"{{PG}}")
if spos > 0 then
pfnd = true
pinstr = rep_string(pinstr,"{{PG}}",cstr(CurrentPrintPage))
end if
spos = instr(pinstr,"{{TPG}}")
if spos > 0 then
pfnd = true
pinstr = rep_string(pinstr,"{{TPG}}",cstr(PrintPageCount))
end if
spos = instr(pinstr,"{{CDT}}")
if spos > 0 then
pfnd = true
if dtf <> "" then
pinstr = rep_string(pinstr,"{{CDT}}",format(CurrentDate,dtf))
else
pinstr = rep_string(pinstr,"{{CDT}}",format(CurrentDate,"dd MMMM yyyy"))
end if
end if
spos = instr(pinstr,"{{SDT}}")
if spos > 0 then
pfnd = true
if dtf <> "" then
pinstr = rep_string(pinstr,"{{SDT}}",format(now,dtf))
else
pinstr = rep_string(pinstr,"{{SDT}}",format(now,"dd MMMM yyyy"))
end if
end if
loop while pfnd
'
' Change to allow inserted SQL Parent Later
'
'
do
pfnd = false
spos = instr(pinstr,"{{")
if spos > 0 then
fpos = instr(pinstr,"}}")
if fpos > 0 and fpos > (spos + 2) then
pstr = trim(mid(pinstr,spos + 2,(fpos - (spos + 2))))
if pstr.Length > 1 then
'
' Could auto add quotes, but not needed in labels etc
'
'PrQt = False
'if spos > 1 then
' if mid(pinstr,spos - 1,1) = "'" then
PrQt = true
' End If
'End If
bpos = instr(pstr,":")
if bpos > 1 and bpos < pstr.Length then
SceName = left(pstr,bpos - 1)
pstr = right(pstr,pstr.Length - bpos)
else
SceName = ParentSce
End If
if SceName <> "" and ucase(mid(pstr,1,1)) = "C" then
pstr = mid(pstr,2,pstr.Length - 1)
if isnumeric(pstr) then
ss = GetSQSFromName(SceName)
if not ss is nothing then
rv = GetSqlValue(SceName,cint(pstr))
if rv = "" then
select case ss.SqlColInfos.Item(cint(pstr) - 1).ColType
case "T"
'Empty string OK
if not PrQt then
rv = "''"
End If
case "D"
rv = "31-dec-2000"
case else
rv = 1
End Select
else
select case ss.SqlColInfos.Item(cint(pstr) - 1).ColType
case "T"
if not PrQt then
rv = fnds(rv)
End If
End Select
end if
else
rv = ""
end if
if spos > 1 then
Ststr = mid(pinstr,1,spos - 1)
else
Ststr = ""
end if
pinstr = Ststr & rv & mid(pinstr,fpos + 2,pinstr.Length - fpos + 1)
pfnd = true
End If
End If
End If
End If
end if
loop while pfnd
return pinstr
catch
return ""
end try
End Function
Private Function GetParam(pstr as string) as nbfRepParam
try
dim rp as nbfRepParam
if isnumeric(pstr) then
for each rp in pvBFInfo.RepParams
if rp.ParamNumber = cint(pstr) then
return rp
End If
Next
else
for each rp in pvBFInfo.RepParams
if trim(ucase(rp.ParamName)) = trim(ucase(pstr)) then
return rp
End If
Next
End If
return nothing
catch
return nothing
end try
End Function
private function GetParamValue(rp as nbfRepParam) as string
try
dim pv as String
if rp.ParamCurrentValue = "" then
pv = rp.ParamDefaultValue
else
pv = rp.ParamCurrentValue
End If
if ucase(Trim(rp.ParamType)) = "DATE" then
GetParamValue = pvdbc.fdate(cdate(pv))
elseif ucase(Trim(rp.ParamType)) = "TEXT" then
GetParamValue = fnds(pv)
else
GetParamValue = pv
End If
Catch ex As Exception
return ""
End Try
end function
public shared Function fnds(ByVal istr As String) As String
istr = Trim(istr)
If istr = "" Then
fnds = "NULL"
Else
fnds = "'" & Trim(rep_quote(istr)) & "'"
End If
End Function
shared Function rep_quote(ByVal rs As String) As String
Dim spos As Short
Dim dpos As Short
Dim Start As Object
Start = InStr(rs, "'")
Do While Start > 0
dpos = InStr(Start + 1, rs, "'")
If Not (dpos = Start + 1) Then
rs = Mid(rs, 1, Start) & "'" & Mid(rs, Start + 1, Len(rs))
End If
spos = Start + 2
Start = InStr(spos, rs, "'")
Loop
rep_quote = rs
End Function
Friend Function GetSqlValue(byval SqlSourceName as String, byval ColumnNumber as Integer) as String
Try
dim SqlSce as nbfSqlSource
SqlSce = GetSqSFromName(SqlSourceName)
if SqlSce.SQLValidated then
return SqlSce.SqlColInfos.Item(ColumnNumber - 1).CurrentValue
else
if ValidateSqlSource(SqlSce) then
return SqlSce.SqlColInfos.Item(ColumnNumber - 1).CurrentValue
else
return ""
End If
end if
catch
return ""
end try
End Function
Friend Function GetSqlValueOld(byval SqlSourceName as String, byval ColumnNumber as Integer) as String
Try
dim SqlSce as nbfSqlSource
dim dq as nbfDB.NbfResultSet
dim dsi as datasourceinfo
dim ci as nbfSqlColInfo
dim cval as string = ""
dim dsn as string = ""
dim clnum as integer = 0
dim ResetSource as Boolean = false
dim dsfnd as Boolean = false
dsn = SqlSourceName
clnum = ColumnNumber
for each dsi in DataSourceList
if dsi.DataSourceName = dsn
dsfnd = true
ResetSource = false
if dsi.ds is nothing then
ResetSource = True
else
if dsi.ds.EOF and not dsi.NoRows then
dsi.ds.Dispose
dsi.ds = nothing
ResetSource = True
End If
end if
if ResetSource then
SqlSce = GetSqSFromName(dsn)
if SqlSce is nothing then
return ""
else
if dq is nothing then
return ""
End If
dsi.ds = dq
dsi.NoRows = false
exit for
end if
End If
if dsi.NoRows then
cval = ""
else
if dsi.ds.BOF then
if dsi.ds.Fetch() then
cval = dsi.ds.fetchstring(clnum)
else
cval = ""
dsi.NoRows = true
End If
elseif dsi.ds.EOF then
cval = ""
else
cval = dsi.ds.fetchstring(clnum)
End If
End If
exit for
End If
Next
if not dsfnd then
SqlSce = GetSqSFromName(dsn)
if not SqlSce is nothing then
if not ValidateSqlSource(SqlSce)
return ""
End If
dsi = new datasourceinfo
dsi.DataSourceName = SqlSce.BrowseTableName
dsi.ds = dq
if dsi.ds.Fetch() then
cval = dsi.ds.fetchstring(clnum)
else
cval = ""
dsi.NoRows = true
End If
DataSourceList.Add(dsi)
end if
end if
return cval
catch
Return ""
end try
End Function
Public Sub AddDataSource(sqs as nbfSqlSource,rs as nbfdb.nbfResultSet,byval NoRows as boolean)
dim dsi as New DataSourceInfo
dsi.DataSourceName = sqs.BrowseTableName
dsi.ds = rs
dsi.NoRows = NoRows
DataSourceList.Add(dsi)
End Sub
Public Sub RemoveDataSource(byval DsName as string)
Try
dim dsi as datasourceinfo
for each dsi in DataSourceList
if dsi.DataSourceName = dsname then
if not dsi.ds is nothing then
dsi.ds.Dispose
End If
DataSourceList.Remove(dsi)
exit Sub
End If
next dsi
catch
'no action
end try
End Sub
friend function ValidSqlSourceOld(byref rp as nbfSqlSource) as nbfDB.NbfResultSet
ValidSqlSourceOld = ValidSqlSourceExOld(rp,Nothing)
End Function
friend function ValidSqlSourceExOld(byref rp as nbfSqlSource,hs as nbfSqlSource) as nbfDB.NbfResultSet
Try
dim sql as String
'if hs is nothing then
sql = RepParams(rp.SQL)
'else
' sql = RepSubParams(rp.SQL,hs)
'end if
dim rs as nbfDB.NbfResultSet
rs = pvDBC.CreateNbfResultSetNoErr(sql)
if rs is nothing then
return nothing
End If
if rp.SQLvalidated and rs.nocols = rp.SqlColInfos.Count then
return rs
else
do while rp.SqlColInfos.Count > 0
rp.SqlColInfos.RemoveAt(0)
Loop
End If
dim c_scale as integer
dim d_wid as integer = 50
dim r_wid as integer = 50
dim i_wid as integer = 50
dim c_wid as Integer = 50
dim Cnt as Integer
dim ci as New nbfSqlColInfo
For Cnt = 1 to rs.nocols
ci = New nbfSqlColInfo
ci.ColPosition = Cnt
ci.ColName = rs.ColumnName(cnt)
ci.ColHeader = ci.ColName
ci.RepCanGrow = false
select case rs.ColumnDatatype(cnt)
case SQL_DATE,SQL_TIMESTAMP
ci.ColWidth = d_wid
ci.ColType = "D"
ci.ColJust = "L"
ci.RepOverRun = true
ci.RepCanGrow = false
case SQL_DECIMAL,SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC
ci.RepOverRun = true
ci.RepCanGrow = false
if rs.ColumnScale(cnt) > 0 then
ci.ColWidth = r_wid
ci.ColType = "M"
ci.ColJust = "R"
ci.RepSubTotals = True
ci.RepTotals = True
ci.RepGrandTotals = True
else
ci.ColWidth = i_wid
ci.ColType = "N"
ci.ColJust = "R"
ci.RepSubTotals = false
end if
case SQL_SMALLINT, SQL_INTEGER
ci.RepOverRun = true
ci.RepCanGrow = false
ci.ColWidth = i_wid
ci.ColType = "I"
ci.ColJust = "R"
ci.RepSubTotals = false
case else
'c_wid = rs.ColumnScale(cnt)
'if c_wid > 2000
' c_wid = 2000
'else
' c_wid = 2000
'End If
ci.RepCanGrow = true
ci.RepOverRun = false
ci.ColWidth = c_wid
ci.ColType = "T"
ci.ColJust = "L"
ci.RepSubTotals = false
end select
ci.ColHeadJust = ci.ColJust
rp.SqlColInfos.Add(ci)
rp.validate
Next
return rs
catch ex as exception
msgbox(ex.Message)
return nothing
end try
End function
friend function ValidateSqlSource(byref rp as nbfSqlSource, optional Byval NoDrill as Boolean = false) as boolean
Try
dim sql as String
rp.ResetValidation
'if hs is nothing then
sql = RepParams(rp.SQL,"",rp.ParentSource)
'else
' sql = RepSubParams(rp.SQL,hs)
'end if
RemoveDataSource(rp.BrowseTableName)
dim rs as nbfDB.NbfResultSet
rs = pvDBC.CreateNbfResultSetNoErr(sql)
if rs is nothing then
return false
End If
'if rp.SQLvalidated and rs.nocols = rp.SqlColInfos.Count then
' return rs
'else
Dim Cnt As Integer
Dim resetcols As Boolean = False
If rs.nocols <> rp.SqlColInfos.count Then
resetcols = True
Else
For Cnt = 1 To rs.nocols
If rp.SqlColInfos.Item(Cnt - 1).ColName <> rs.ColumnName(Cnt) Then
resetcols = True
Exit For
End If
Next
End If
If resetcols Then
Do While rp.SqlColInfos.count > 0
rp.SqlColInfos.RemoveAt(0)
Loop
'End If
Dim c_scale As Integer
Dim d_wid As Integer = 50
Dim r_wid As Integer = 50
Dim i_wid As Integer = 50
Dim c_wid As Integer = 50
Dim ci As New nbfSqlColInfo
For Cnt = 1 To rs.nocols
ci = New nbfSqlColInfo
ci.ColPosition = Cnt
ci.ColName = rs.ColumnName(Cnt)
ci.ColHeader = ci.ColName
ci.RepCanGrow = False
Select Case rs.ColumnDatatype(Cnt)
Case SQL_DATE, SQL_TIMESTAMP
ci.ColWidth = d_wid
ci.ColType = "D"
ci.ColJust = "L"
ci.RepOverRun = True
ci.RepCanGrow = False
Case SQL_DECIMAL, SQL_FLOAT, SQL_DOUBLE, SQL_NUMERIC
ci.RepOverRun = True
ci.RepCanGrow = False
If rs.ColumnScale(Cnt) > 0 Then
ci.ColWidth = r_wid
ci.ColType = "M"
ci.ColJust = "R"
ci.RepSubTotals = True
ci.RepTotals = True
ci.RepGrandTotals = True
Else
ci.ColWidth = i_wid
ci.ColType = "N"
ci.ColJust = "R"
ci.RepSubTotals = False
End If
Case SQL_SMALLINT, SQL_INTEGER
ci.RepOverRun = True
ci.RepCanGrow = False
ci.ColWidth = i_wid
ci.ColType = "I"
ci.ColJust = "R"
ci.RepSubTotals = False
Case Else
'c_wid = rs.ColumnScale(cnt)
'if c_wid > 2000
' c_wid = 2000
'else
' c_wid = 2000
'End If
ci.RepCanGrow = True
ci.RepOverRun = False
ci.ColWidth = c_wid
ci.ColType = "T"
ci.ColJust = "L"
ci.RepSubTotals = False
End Select
ci.ColHeadJust = ci.ColJust
rp.SqlColInfos.Add(ci)
Next
End If
If rs.fetch() Then
'rp.AdvanceRow()
GetNextFldVals(rs, rp.SqlColInfos)
rp.NextRowFound = True
BufferDownRows(rp, rs)
AddDataSource(rp, rs, False)
Else
rp.AdvanceRow(True)
AddDataSource(rp, rs, False)
'dim SubSS as nbfSqlSource
'dim bc as nbfSQLBrowseCtrl
'For Each SubSS in pvBFInfo.SQLSources
' if SubSS.ParentSource = rp.BrowseTableName and SubSS.BrowseTableName <> rp.BrowseTableName then
' ValidateSqlSource(SubSS)
' End If
'Next
'For Each bc in pvBFInfo.SQLBrowseCtrls
' ValidateSubSources(bc,rp.BrowseTableName)
'Next
End If
rp.Validate()
Return True
Catch ex As Exception
msgbox(ex.Message)
return nothing
end try
End function
private Sub ValidateSubSources(bc as nbfSQLBrowseCtrl,ParentSce as String)
dim bc2 as nbfSQLBrowseCtrl
dim rsn as nbfSQLRepSection
dim SubSS as nbfSqlSource
for each rsn in bc.RepSections
For Each bc2 in rsn.SectionCtrls
SubSS = GetSqsFromName(bc2.SQLSource)
if not SubSS is nothing
if SubSS.ParentSource = ParentSce and SubSS.BrowseTableName <> ParentSce then
ValidateSqlSource(SubSS)
End If
ValidateSubSources(bc2,ParentSce)
end if
Next
Next
End Sub
Private Function GetRSFromName(byval dsn as String) as nbfDB.NbfResultSet
dim dsi as datasourceinfo
for each dsi in DataSourceList
if trim(ucase(dsi.DataSourceName)) = trim(ucase(dsn))
return dsi.ds
End If
Next
return nothing
End Function
private Sub GetPrintSettings()
Dim PDLG As New PrintDialog()
Try
pdlg.PrinterSettings = new PrinterSettings
pdlg.PrinterSettings.PrinterName = pvBFInfo.PrinterName
if pvBFInfo.PrinterOrientation = "L" then
pdlg.PrinterSettings.DefaultPageSettings.Landscape = True
else
pdlg.PrinterSettings.DefaultPageSettings.Landscape = false
end if
pdlg.PrinterSettings.Copies = pvBFInfo.PrinterCopies
Dim result As DialogResult = PDLG.ShowDialog()
If not (result = DialogResult.OK) Then
exit sub
End If
pvBFInfo.PrinterName = pdlg.PrinterSettings.PrinterName
pvBFInfo.PrinterCopies = pdlg.PrinterSettings.Copies
'if pdlg.PrinterSettings.DefaultPageSettings.Landscape then
' pvBFInfo.PrinterOrientation = "L"
'else
' pvBFInfo.PrinterOrientation = "P"
'End If
catch ex as Exception
msgbox(ex.Message)
end try
End Sub
private Sub PrintSettings(ByVal sender As System.Object, ByVal e As System.EventArgs)
GetPrintSettings
End Sub
Public Sub PrintForm()
Dim PDLG As New PrintDialog()
dim ps as New PrinterSettings
Dim PD as New system.Drawing.Printing.PrintDocument
dim PrinterName as String
Try
if pvBFInfo.PrinterName = "" then
GetPrintSettings
End If
AddHandler PD.PrintPage, AddressOf DoPrint
ps.PrinterName = pvBFInfo.PrinterName
ps.Copies = pvBFInfo.PrinterCopies
PD.PrinterSettings.PrinterName = pvBFInfo.PrinterName
PD.PrinterSettings.Copies = pvBFInfo.PrinterCopies
if pvBFInfo.PageSize.Width > pvBFInfo.PageSize.Height then
ps.DefaultPageSettings.Landscape = true
PD.DefaultPageSettings.Landscape = true
else
ps.DefaultPageSettings.Landscape = false
PD.DefaultPageSettings.Landscape = false
End If
PD.Print
catch ex as Exception
msgbox(ex.Message)
RaiseEvent PrintComplete
end try
End Sub
Private Sub DoPrint(sender As Object, ev As PrintPageEventArgs)
Try
dim bc as nbfSQLBrowseCtrl
dim sqs as nbfSqlSource
dim ci as nbfSqlColInfo
dim NumPages as Integer = 0
dim ThisPages as Integer = 0
Dim pi As New PrintInfo
pi.PageBounds = RectangleF.op_Implicit(ev.PageBounds)
pi.Graphics = ev.Graphics
'First Calc Pages
if not PageCountDone then
CountPages(pi)
if PrintPageCount <= 0 then
exit sub
End If
end if
'Now Print
'RaiseEvent PrintComplete
'exit Sub
CurrentPrintPage += 1
dim mpgflag as Boolean = false
mpgflag = PrintPage(pi)
if mpgflag = true then
ev.HasMorePages = True
else
PageCountDone = false
PrintPageCount = 0
CurrentPrintPage = 0
RaiseEvent PrintComplete
End If
catch ex as Exception
msgbox(ex.Message)
end try
End Sub
Function PrintPage(byref pi as PrintInfo) as Boolean
dim mpg as Boolean = false
dim mpgflag as Boolean = false
dim bc as nbfSQLBrowseCtrl
dim ThisPages as Integer = 0
'First do Grid controls to count totals
for each bc in pvBFInfo.SQLBrowseCtrls
bc.GrowthOffset = 0
Select Case bc.CtlType
Case "Grid", "Report"
if CurrentPrintPage = 1 or (bc.FlowThrough and bc.PrintReqMorePages) or bc.PrintWhenBlank then
ThisPages = PrintRepPage(mpg,bc,true,pi,PrintPageCount,pvBFINfo.FormSize)
end if
End Select
if mpg then
mpgflag = true
End If
Next
for each bc in pvBFInfo.SQLBrowseCtrls
Select Case bc.CtlType
case "Grid","Report","Amalgum"
'no action
case else
PrintBrowseCtrl(bc,pi,pvBFInfo.FormSize,true,False,False,"")
End Select
Next
for each bc in pvBFInfo.SQLBrowseCtrls
Select Case bc.CtlType
case "Amalgum"
PrintBrowseCtrl(bc,pi,pvBFInfo.FormSize,true,False,False,"")
End Select
Next
return mpgflag
End Function
Public Sub PrintOnForm()
PageCountDone = false
PrintPageCount = 0
CurrentPrintPage = 0
dim [of] as Form
dim pi as PrintInfo
dim sz as Size
dim r as Rectangle
[of] = New Form
pi = New PrintInfo
[of].AutoScale = false
[of].Size = pvBfinfo.size
[of].AutoScroll = True
sz = new size
sz.Width = pvBfinfo.FormSize.Width
sz.Height = pvBfinfo.FormSize.Height
[of].AutoScrollMinSize = sz
[of].BackColor= system.Drawing.Color.WhiteSmoke
pi.Graphics = [of].CreateGraphics
r = new rectangle
r.Width = sz.Width
r.Height = sz.Height
pi.PageBounds = RectangleF.op_Implicit(r)
CountPages(pi)
if PrintPageCount <= 0 then
exit sub
End If
CurrentPrintPage += 1
[of].Show
do while PrintPage(pi)
exit sub
CurrentPrintPage += 1
[of] = New Form
pi = New PrintInfo
[of] = New Form
pi = New PrintInfo
[of].AutoScale = false
[of].Size = pvBfinfo.size
[of].AutoScroll = True
sz = new size
sz.Width = pvBfinfo.PageSize.Width
sz.Height = pvBfinfo.PageSize.Height
[of].AutoScrollMinSize = sz
pi.Graphics = [of].CreateGraphics
r = new rectangle
r.Width = sz.Width
r.Height = sz.Height
pi.PageBounds = RectangleF.op_Implicit(r)
Loop
End Sub
Public Sub ResetSqlSources()
Dim bc As nbfSQLBrowseCtrl
Dim sqs As nbfSqlSource
Dim ci As nbfSqlColInfo
For Each sqs In pvBFInfo.SQLSources
For Each ci In sqs.SqlColInfos
ci.FinalGrandTotal = 0
Next
sqs.TotSet = False
Next
For Each bc In pvBFInfo.SQLBrowseCtrls
bc.PrintReqMorePages = False
bc.NextRecordPos = 1
bc.LastRecordTot = 0
bc.NextSectReq = "C1"
bc.NextSectNo = 0
bc.GrowthOffset = 0
bc.RecPrinted = 0
ReSetPrintStat(bc)
Next
End Sub
Private Sub CountPages(ByVal pi As PrintInfo)
Dim bc As nbfSQLBrowseCtrl
Dim sqs As nbfSqlSource
Dim ci As nbfSqlColInfo
Dim NumPages As Integer = 0
Dim ThisPages As Integer = 0
ResetSqlSources()
For Each bc In pvBFInfo.SQLBrowseCtrls
Select Case bc.CtlType
Case "Grid", "Report"
If bc.FlowThrough Then
ThisPages = PrintRepCount(bc, pi)
If ThisPages > NumPages Then
NumPages = ThisPages
End If
End If
End Select
Next
'Reset result sets
For Each bc In pvBFInfo.SQLBrowseCtrls
bc.PrintReqMorePages = False
bc.NextRecordPos = 1
bc.LastRecordTot = 0
bc.NextSectReq = "C1"
bc.NextSectNo = 0
bc.GrowthOffset = 0
bc.RecPrinted = 0
ReSetPrintStat(bc)
Next
For Each sqs In pvBFInfo.SQLSources
If Not sqs.TotSet Then
SetSqsTots(sqs)
Else
For Each ci In sqs.SqlColInfos
ci.RunningGrandTotal = 0
ci.RunningSubTotal = 0
ci.RunningTotal = 0
ci.RunningGrandTotal = 0
Next
End If
Next
PageCountDone = True
PrintPageCount = NumPages
End Sub
Function PrintBrowseCtrl(ByRef bc As nbfSQLBrowseCtrl, ByVal ev As PrintInfo, ByVal SourceSize As Size, ByVal DrawPage As Boolean, ByVal TryForSize As Boolean, ByVal UseVal As Boolean, ByVal SetVal As String, Optional ByVal Dest As String = "P") As Boolean
Try
If bc.CtlType = "Grid" Then
Return False
End If
Dim PageFlag As String
If CurrentPrintPage = PrintPageCount Then
PageFlag = "L"
If CurrentPrintPage > 1 Then
If bc.ShowOnPages = "F" Then
Return True
End If
Else
If bc.ShowOnPages = "I" Then
Return True
End If
End If
ElseIf CurrentPrintPage > 1 Then
PageFlag = "I"
If bc.ShowOnPages = "F" Or bc.ShowOnPages = "L" Then
Return True
End If
Else
PageFlag = "F"
If bc.ShowOnPages = "I" Or bc.ShowOnPages = "L" Then
Return True
End If
End If
Dim sqs As nbfSqlSource
Dim sqsFound As Boolean = False
Dim ci As nbfSqlColInfo
Dim ccnt As Integer = 0
Dim brush = New SolidBrush(System.Drawing.Color.Black)
Dim DBrush = New SolidBrush(System.Drawing.Color.Honeydew)
Dim rF As RectangleF
Dim ft As Font
'bc.BackColor
'bc.ForeColor
Dim Pen As New Pen(System.Drawing.Color.Black, bc.LineWidth)
Dim leftMargin As Single = ev.PageBounds.Left 'ev.MarginBounds.Left
Dim topMargin As Single = ev.PageBounds.Top 'ev.MarginBounds.Top
Dim PageHeight As Single = ev.PageBounds.Height 'ev.MarginBounds.Height
Dim PageWidth As Single = ev.PageBounds.Width 'ev.MarginBounds.Width
Dim CtlWidth As Single
Dim CtlHeight As Single
Dim StartYPos As Single = topMargin + CSng(bc.Top * PageHeight / SourceSize.Height) + bc.GrowthOffset
Dim StartXPos As Single = leftMargin + CSng(bc.Left * PageWidth / SourceSize.Width)
CtlWidth = CSng(bc.Width * PageWidth / SourceSize.Width)
CtlHeight = CSng(bc.Height * PageHeight / SourceSize.Height)
'dim grect as new rectangle(csng(StartXPos),csng(StartYPos),CtlWidth,CtlHeight)
If bc.FontInfo Is Nothing Then
bc.FontInfo = GetDefRepFont(True, 8)
ElseIf bc.FontInfo.FontName = "" Or bc.FontInfo.FontSize = 0 Then
bc.FontInfo = GetDefRepFont(True, 8)
End If
ft = GetRepFont(bc.FontInfo, Dest)
If bc.MultiLine = False Then
Select Case bc.CtlType
Case "Field", "Label", "Total", "Amalgum"
CtlHeight = ft.Height
End Select
End If
bc.StretchHeight = CtlHeight
Dim EndYPos As Single = StartYPos + CtlHeight
Dim EndXPos As Single = StartXPos + CtlWidth
If TryForSize = False And DrawPage = False Then
Return True
End If
If Not ((bc.CtlType = "Field" Or bc.CtlType = "Label") And bc.MultiLine) Then
If TryForSize Then
If EndYPos > (topMargin + PageHeight) Then
Debug.WriteLine("Control doesn't fit")
Return False
Else
If Not DrawPage Then
'no further action needed
Return True
End If
End If
End If
End If
'debug.WriteLine("Unit " & ft.Unit.ToString)
'debug.WriteLine("Height " & ft.Height.ToString)
'debug.WriteLine("Size " & ft.Size.ToString)
If bc.SQLSource <> "" Then
For Each sqs In pvBFInfo.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
sqsFound = True
Exit For
End If
Next sqs
End If
If Dest = "D" Then
If Not (bc.CtlType = "Line" Or bc.CtlType = "Box") Then
ev.Graphics.FillRectangle(DBrush, StartXPos, StartYPos, CtlWidth, ft.Height)
End If
End If
Select Case bc.CtlType
Case "Line"
ev.Graphics.DrawLine(Pen, StartXPos, StartYPos, EndXPos, EndYPos)
Case "Box"
ev.Graphics.DrawRectangle(Pen, StartXPos, StartYPos, CtlWidth, CtlHeight)
Case "Field", "Label", "Total", "Image", "Amalgum"
Dim cval As String
If bc.AlignWithCol > 0 Then
If sqsFound Then
ccnt = 0
For Each ci In sqs.SqlColInfos
ccnt += 1
If ccnt = bc.AlignWithCol Then
StartXPos = ci.LeftPos
CtlWidth = ci.PrintWidth
EndXPos = ci.LeftPos + ci.PrintWidth + ColGap
Exit For
End If
Next
End If
End If
Select Case bc.CtlType
Case "Field", "Label", "Total", "Amalgum"
If UseVal Then
cval = SetVal
Else
Select Case bc.CtlType
Case "Field"
cval = GetSqlValue(bc.SQLSource, bc.SQLColNumber)
Case "Label"
Select Case PageFlag
Case "F"
cval = bc.FirstPageText
Case "I"
cval = bc.PriorPageText
Case Else
cval = bc.Text
End Select
Case "Total"
If sqsFound Then
ccnt = 0
For Each ci In sqs.SqlColInfos
ccnt += 1
If ccnt = bc.SQLColNumber Then
cval = FormatTot(ci, ci.RunningGrandTotal)
End If
Next
End If
Case "Amalgum"
Dim si As nbfSubTotItem
Dim av As Decimal = 0
For Each si In bc.SubTotList
Dim ss As nbfSqlSource
For Each ss In pvBFInfo.SQLSources
If ss.BrowseTableName = si.SQLSource Then
ccnt = 0
For Each ci In ss.SqlColInfos
ccnt += 1
If ccnt = si.SQLColNumber Then
av = av + ci.RunningGrandTotal
Exit For
End If
Next
Exit For
End If
Next
Next
If Not ci Is Nothing Then
cval = FormatTot(ci, av)
Else
cval = Format(av, "#,##0.00")
End If
End Select
End If
cval = RepParams(cval, bc.DateFormat)
Dim sf As New StringFormat
If Not bc.MultiLine Then
sf.FormatFlags = sf.FormatFlags Or StringFormatFlags.NoWrap
End If
If Not bc.CliptoBorders Then
sf.FormatFlags = sf.FormatFlags Or StringFormatFlags.NoClip
sf.Trimming = StringTrimming.None
Else
sf.Trimming = StringTrimming.EllipsisCharacter
End If
Select Case bc.TextAlign
Case ContentAlignment.TopRight, ContentAlignment.MiddleRight, ContentAlignment.BottomRight
sf.Alignment = StringAlignment.Far
Case ContentAlignment.BottomCenter, ContentAlignment.MiddleCenter, ContentAlignment.TopCenter
sf.Alignment = StringAlignment.Center
Case Else
sf.Alignment = StringAlignment.Near
End Select
rF = New RectangleF(StartXPos, StartYPos, CtlWidth, CtlHeight)
If bc.MultiLine Then
Dim szf As New SizeF
szf.Height = CtlHeight
szf.Width = CtlWidth
szf = ev.Graphics.MeasureString(cval, ft, szf, sf)
CtlHeight = szf.Height
EndYPos = StartYPos + CtlHeight
bc.StretchHeight = CtlHeight
If TryForSize Then
If EndYPos > (topMargin + PageHeight) Then
Return False
Else
If Not DrawPage Then
Return True
End If
End If
End If
End If
ev.Graphics.DrawString(cval, ft, brush, rF, sf)
Case "Image"
If bc.SourceType = "N" Then
cval = GetSqlValue(bc.SQLSource, bc.SQLColNumber)
ElseIf bc.SourceType = "F" Then
cval = bc.SourceFile
End If
If InStr(cval, "\") = 0 Then
cval = pvAppPath & "\" & cval
End If
Dim Img As Image
Img = Image.FromFile(cval)
rF = New RectangleF(StartXPos, StartYPos, CtlWidth, CtlHeight)
If Img.PhysicalDimension.Height <> 0 And Img.PhysicalDimension.Width <> 0 Then
If bc.MaintainAspectRatio Then
If bc.StretchDimension = "W" Then
rF.Width = CSng((CtlHeight * Img.PhysicalDimension.Width) / Img.PhysicalDimension.Height)
Else
Dim nw As Single = CSng((CtlHeight * Img.PhysicalDimension.Width) / Img.PhysicalDimension.Height)
If nw <= rF.Width Then
rF.Width = nw
Else
rF.Height = CSng((CtlWidth * Img.PhysicalDimension.Height) / Img.PhysicalDimension.Height)
End If
End If
End If
End If
ev.Graphics.DrawImage(Img, rF)
End Select
If bc.RepTopBorder Then
ev.Graphics.DrawLine(Pen, StartXPos, StartYPos, EndXPos, StartYPos)
End If
If bc.RepBottomBorder Or bc.RepUnderline Or bc.RepDoubleUnderline Then
ev.Graphics.DrawLine(Pen, StartXPos, EndYPos, EndXPos, EndYPos)
End If
If bc.RepDoubleUnderline Then
ev.Graphics.DrawLine(Pen, StartXPos, EndYPos + dblLineWidth, EndXPos, EndYPos + dblLineWidth)
End If
If bc.RepRightBorder Then
ev.Graphics.DrawLine(Pen, EndXPos, StartYPos, EndXPos, EndYPos)
End If
If bc.RepLeftBorder Then
ev.Graphics.DrawLine(Pen, StartXPos, StartYPos, StartXPos, EndYPos)
End If
End Select
Return True
Catch ex As Exception
MsgBox("ex.Message")
Return False
End Try
End Function
Private Function PrintRepCount(ByVal bc As nbfSQLBrowseCtrl, ByVal pi As PrintInfo) As Integer
Try
Dim PgCount As Integer = 0
Dim MorePages As Boolean
If Not PrintRepPage(MorePages, bc, False, pi, 0, pvBFInfo.FormSize) Then
Return 0
End If
If bc.NextRecordPos <= 1 And bc.NextSectNo = 0 Then
MsgBox("Not enough room for first record")
Return 0
End If
PgCount += 1
Do While MorePages = True
If Not PrintRepPage(MorePages, bc, False, pi, 0, pvBFInfo.FormSize) Then
Return 0
End If
PgCount += 1
Loop
Return PgCount
Catch ex As Exception
MsgBox(ex.Message)
Return 0
End Try
End Function
Public Function PrintSubRep(ByRef bc As nbfSQLBrowseCtrl, ByVal pi As PrintInfo, ByVal SourceSize As Size, Optional ByVal Dest As String = "P") As Boolean
Dim MorePages As Boolean = False
Dim DrawPage As Boolean = True
Dim NoPages As Integer = 1
bc.NextRecordPos = 1
bc.LastRecordTot = 0
bc.NextSectReq = "C1"
bc.NextSectNo = 0
Return PrintRepPage(MorePages, bc, DrawPage, pi, NoPages, SourceSize, Dest)
End Function
Private Function PrintRepPage(ByRef MorePages As Boolean, ByRef bc As nbfSQLBrowseCtrl, ByVal DrawPage As Boolean, ByRef ev As PrintInfo, ByVal NoPages As Integer, ByVal SourceSize As Size, Optional ByVal Dest As String = "P") As Boolean
Dim rslt As Boolean = False
Select Case bc.CtlType
Case "Report"
rslt = PrintSubRepPage(MorePages, bc, DrawPage, ev, NoPages, SourceSize, Dest)
bc.PrintReqMorePages = MorePages
Case Else
rslt = PrintListPage(MorePages, bc, DrawPage, ev, NoPages, SourceSize, Dest)
bc.PrintReqMorePages = MorePages
End Select
Return rslt
End Function
Private Function PrintListPage(ByRef MorePages As Boolean, ByRef bc As nbfSQLBrowseCtrl, ByVal DrawPage As Boolean, ByRef ev As PrintInfo, ByVal NoPages As Integer, ByVal SourceSize As Size, Optional ByVal Dest As String = "P") As Boolean
Try
Dim sqs As nbfSqlSource
Dim ci As nbfSqlColInfo
Dim brush = New SolidBrush(System.Drawing.Color.Black)
Dim Pen As New Pen(System.Drawing.Color.Black)
Dim dq As nbfDB.NbfResultSet
Dim cnt As Integer
Dim CalcPages As Integer = 1
'bc.FlowThrough = true
If bc.SubItem Then
If bc.ParentCtrl.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In bc.ParentCtrl.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
Else
If pvBFInfo.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In pvBFInfo.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
End If
If Not sqs.BrowseTableName = bc.SQLSource Then
MsgBox("Unable to find SQL Source")
Return False
End If
Dim leftMargin As Single = ev.PageBounds.Left 'ev.MarginBounds.Left
Dim topMargin As Single = ev.PageBounds.Top 'ev.MarginBounds.Top
Dim PageHeight As Single = ev.PageBounds.Height 'ev.MarginBounds.Height
Dim PageWidth As Single = ev.PageBounds.Width 'ev.MarginBounds.Width
Dim StartYPos As Single = topMargin + CSng(bc.Top * PageHeight / SourceSize.Height) + bc.GrowthOffset
Dim StartXPos As Single = leftMargin + CSng(bc.Left * PageWidth / SourceSize.Width)
Dim HeadBorder As Single = 0
sqs.RepPageWidth = CSng(bc.Width * PageWidth / SourceSize.Width)
sqs.RepPageLength = CSng(bc.Height * PageHeight / SourceSize.Height)
'Dim sqs.RepPageWidth as Single = csng(bc.Width * PageWidth/ pvBFInfo.FormSize.Width)
'Dim RepHeight as Single = csng(bc.Height * PageHeight/ pvBFInfo.FormSize.Height)
Dim grect As New Rectangle(CSng(StartXPos), CSng(StartYPos), CSng(sqs.RepPageWidth), CSng(sqs.RepPageLength))
Dim EndYPos As Single = StartYPos + sqs.RepPageLength
Dim EndXPos As Single = StartXPos + sqs.RepPageWidth
If bc.CanGrow Then
EndYPos = topMargin + PageHeight
End If
Dim WidTot As Integer = 0
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
For Each ci In sqs.SqlColInfos
WidTot += ci.ColWidth
Next
Dim clpos As Single = StartXPos
Dim curr_y As Single = StartYPos
CheckSqlSourceFontInfo(sqs)
Dim hft As Font
hft = GetRepFont(sqs.RepColHeadFont)
Dim ft As Font
Dim FontHt As Single
ft = GetRepFont(sqs.RepNormalFont)
FontHt = ft.GetHeight(ev.Graphics)
Dim c1_ft As Font
Dim c1_FontHt As Single
c1_ft = GetRepFont(sqs.RepBreak1HeadFont)
c1_FontHt = c1_ft.GetHeight(ev.Graphics)
Dim c2_ft As Font
Dim c2_FontHt As Single
c2_ft = GetRepFont(sqs.RepBreak2HeadFont)
c2_FontHt = c2_ft.GetHeight(ev.Graphics)
Dim rf As New RectangleF
Dim szf As SizeF
Dim sf As StringFormat
Dim HdHt As Single = 0
Dim SubTotals As Boolean = False
For Each ci In sqs.SqlColInfos
If ci.RepSubTotals Then
SubTotals = True
End If
sf = GetStrFormat(ci, True)
ci.PrintWidth = CSng((ci.ColWidth * sqs.RepPageWidth) / WidTot) - ColGap
ci.LeftPos = clpos
clpos = clpos + ci.PrintWidth + ColGap
If sqs.BrowseColHeaders Then
szf.Height = EndYPos - curr_y
szf.Width = ci.PrintWidth
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
szf = ev.Graphics.MeasureString(ci.ColHeader, hft, szf, sf)
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
If szf.Height > HdHt Then
HdHt = szf.Height
End If
End If
Next
If HdHt > (EndYPos - curr_y) Then
bc.StretchHeight = curr_y - StartYPos
'If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder)
MorePages = True
Return True
End If
If bc.PrintReqMorePages = False and bc.NextRecordPos = 1 then
For Each ci In sqs.SqlColInfos
ci.RunningGrandTotal = 0
ci.RunningSubTotal = 0
ci.RunningTotal = 0
ci.RunningGrandTotal = 0
Next
If bc.SubItem and sqs.BrowseColHeaders then
if (HdHt + CSng(FontHt / 2) + c1_FontHt) > (EndYPos - curr_y) Then
MorePages = True
Return True
End If
end if
End If
If sqs.BrowseColHeaders Then
curr_y += (HdHt + CSng(FontHt / 2))
End If
HeadBorder = curr_y
If Not sqs.SQLValidated Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
SetSubSources(bc, sqs)
ElseIf sqs.RowsFetched > bc.NextRecordPos Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
SetSubSources(bc, sqs)
'for each rs in bc.RepSections
' For Each sbc in rs.SectionCtrls
' SubSS = GetSqsFromName(sbc.SQLSource)
' if not SubSS is nothing then
' ValidateSqlSource(subSS)
' End If
' Next
'Next
ElseIf bc.NextRecordPos = 1 And Not bc.PrintReqMorePages Then
SetSubSources(bc, sqs)
End If
If sqs.RowsFetched < bc.NextRecordPos Then
Do While sqs.RowsFetched < bc.NextRecordPos
If Not sqs.CurrentRowFound Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage and bc.PrintWhenBlank Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.Dispose
'End If
sqs.TotSet = True
MorePages = False
Return True
End If
BufferDownRows(sqs)
Loop
SetSubSources(bc, sqs)
End If
'sqs.NextRowFound = False
'sqs.CurrentRowFound = False
'sqs.PriorRowFound = False
'if bc.SubItem then
' dq = ValidSqlSourceEx(sqs,bc.DrivingSqlSource)
'else
' dq = GetDbQuery(bc.SQLSource)
' if bc.NextRecordPos > 1 then
' if dq.rowsFetched > bc.NextRecordPos - 1 then
' dq = GetDbQuery(bc.SQLSource,true)
' End If
' else
' if dq.rowsFetched > bc.NextRecordPos then
' dq = GetDbQuery(bc.SQLSource,true)
' End If
' end if
'End If
'if dq is nothing then
' return false
'End If
'if bc.NextRecordPos > 1 then
' 'set up prior row data
' Do while dq.rowsFetched < (bc.NextRecordPos - 1)
' If not dq.fetch() then
' sqs.TotSet = true
' bc.StretchHeight = curr_y - StartYPos
' if DrawPage then DrawGridBorder(bc,sqs,ev,pen,StartXPos,StartYPos,EndXPos,EndYPos,HeadBorder)
' MorePages = False
' return true
' End If
' Loop
' GetNextFldVals(dq,sqs.SqlColInfos)
' sqs.NextRowFound = true
' BufferDownRows(dq,sqs)
'else
' Do while dq.rowsFetched < bc.NextRecordPos
' if not dq.fetch() then
' sqs.TotSet = true
' bc.StretchHeight = curr_y - StartYPos
' if DrawPage then DrawGridBorder(bc,sqs,ev,pen,StartXPos,StartYPos,EndXPos,EndYPos,HeadBorder)
' MorePages = False
' return true
' end if
' Loop
' GetNextFldVals(dq,sqs.SqlColInfos)
' sqs.NextRowFound = true
'end if
'BufferDownRows(sqs)
Dim Cat1Code As String = ""
Dim Cat2Code As String = ""
Dim NxtCat1Code As String = ""
Dim NxtCat2Code As String = ""
Dim PrvCat1Code As String = ""
Dim PrvCat2Code As String = ""
Dim Cat1Head As String = ""
Dim Cat2Head As String = ""
Dim Cat1Req As Boolean = False
Dim Cat2Req As Boolean = False
Dim SubReq As Boolean = False
Dim TotReq As Boolean = False
Dim GrandReq As Boolean = False
Dim SpaceReq As Single = 0
Dim RSpaceReq As Single = 0
Dim HeadSpace As Single = 0
Dim orig_y As Single
Dim hsm As Boolean = False
Dim lpos As Single = sqs.SqlColInfos.Item(0).LeftPos
Dim hwid As Single = 0
Dim hht As Single = 0
Dim cval As Decimal
dim RecPrinted as Boolean = false
Dim SubHeadDone As Boolean
Dim SubHeadTxt As String = ""
Do While sqs.CurrentRowFound
Cat1Req = False
Cat2Req = False
SubReq = False
TotReq = False
GrandReq = False
SpaceReq = 0
RSpaceReq = 0
HeadSpace = 0
orig_y = curr_y
If sqs.RepBreak1Cols > 0 Then
Cat1Code = GetCatCode(sqs, 1)
NxtCat1Code = GetCatCode(sqs, 1, True)
End If
If sqs.RepBreak2Cols > 0 Then
Cat2Code = GetCatCode(sqs, 2)
NxtCat2Code = GetCatCode(sqs, 2, True)
End If
If (sqs.RepBreak1Cols > 0 And sqs.PriorRowFound = False) Or Cat1Code <> PrvCat1Code Then
Cat1Head = GetCatHead(sqs, 1)
Cat2Head = GetCatHead(sqs, 2)
If bc.NextSectReq = "C1" Then
Cat1Req = True
Cat2Req = True
HeadSpace = (c1_FontHt + c2_FontHt)
ElseIf bc.NextSectReq = "C2" Then
Cat2Req = True
HeadSpace = c2_FontHt
End If
SpaceReq += HeadSpace
ElseIf sqs.RepBreak2Cols > 0 And Cat2Code <> PrvCat2Code Then
Cat2Head = GetCatHead(sqs, 2)
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Then
Cat2Req = True
HeadSpace = c2_FontHt
SpaceReq += HeadSpace
End If
End If
If SubTotals And sqs.RepNoTotals = False Then
If sqs.NextRowFound = False Then
If sqs.RepShowGrandTotals Then
GrandReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Or bc.NextSectReq = "T" Then
If sqs.RepShowTotals Then
TotReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
End If
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Then
If sqs.RepShowSubTotals Then
SubReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
End If
ElseIf Cat1Code <> NxtCat1Code Then
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Or bc.NextSectReq = "T" Then
If sqs.RepShowTotals Then
TotReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
End If
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Then
If sqs.RepShowSubTotals Then
SubReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
End If
ElseIf Cat2Code <> NxtCat2Code Then
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Then
If sqs.RepShowSubTotals Then
SubReq = True
SpaceReq += CSng(FontHt * 1.5)
End If
End If
End If
End If
HdHt = 0
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Then
For Each ci In sqs.SqlColInfos
sf = GetStrFormat(ci)
szf.Height = EndYPos - curr_y - HeadSpace
szf.Width = ci.PrintWidth
szf = ev.Graphics.MeasureString(ci.CurrentValue, ft, szf, sf)
If szf.Height > HdHt Then
HdHt = szf.Height
End If
Next
End If
SpaceReq += HdHt
If SpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage and (RecPrinted or bc.PrintWhenBlank) Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
MorePages = True
Return True
End If
End If
RSpaceReq = SpaceReq
'Space OK so print
If DrawPage Then
If Cat1Req Then
'Print CAT 1
RecPrinted = true
hwid = EndXPos - lpos
hht = EndYPos - curr_y
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
rf = New RectangleF(lpos, curr_y, hwid, hht)
ev.Graphics.DrawString(Cat1Head, c1_ft, brush, rf, sf)
curr_y += c1_FontHt
RSpaceReq -= c1_FontHt
If RSpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
bc.NextSectReq = "C2"
MorePages = True
Return True
End If
End If
End If
If Cat2Req Then
'Print CAT 2
RecPrinted = true
hwid = EndXPos - lpos
hht = EndYPos - curr_y
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
rf = New RectangleF(lpos, curr_y, hwid, hht)
ev.Graphics.DrawString(Cat2Head, c2_ft, brush, rf, sf)
curr_y += c2_FontHt
RSpaceReq -= c2_FontHt
If RSpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
bc.NextSectReq = "B"
MorePages = True
Return True
End If
End If
End If
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Then
HdHt = 0
RecPrinted = true
For Each ci In sqs.SqlColInfos
sf = GetStrFormat(ci)
szf.Height = EndYPos - curr_y - HeadSpace
szf.Width = ci.PrintWidth
If True Then 'ci.RepCanGrow then
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
szf = ev.Graphics.MeasureString(ci.CurrentValue, ft, szf, sf)
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
rf = New RectangleF(ci.LeftPos, curr_y, ci.PrintWidth, szf.Height)
ev.Graphics.DrawString(ci.CurrentValue, ft, brush, rf, sf)
Select Case ci.ColType
Case "T", "D"
'no totals poss
Case Else
If Cat1Req Then
ci.RunningTotal = 0
ElseIf Cat2Req Then
ci.RunningSubTotal = 0
End If
If IsNumeric(ci.CurrentValue) Then
'debug.WriteLine("Row " & cstr(bc.NextRecordPos) & " col " & cstr(ci.ColPosition))
cval = CDec(ci.CurrentValue)
ci.RunningGrandTotal = ci.RunningGrandTotal + cval
ci.RunningTotal = ci.RunningTotal + cval
ci.RunningSubTotal = ci.RunningSubTotal + cval
End If
End Select
If szf.Height > HdHt Then
HdHt = szf.Height
End If
Else
If FontHt > HdHt Then
HdHt = FontHt
End If
ev.Graphics.DrawString(ci.CurrentValue, ft, brush, ci.LeftPos, curr_y)
End If
Next
curr_y += HdHt
RSpaceReq -= HdHt
If RSpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
bc.NextSectReq = "ST"
MorePages = True
Return True
End If
End If
End If
If SubReq Then
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Then
SubHeadDone = False
For Each ci In sqs.SqlColInfos
If ci.RepSubTotals Then
RecPrinted = true
If Not SubHeadDone Then
SubHeadDone = True
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
sf.Alignment = StringAlignment.Far
rf = New RectangleF(StartXPos, curr_y, ci.LeftPos - StartXPos, CSng(FontHt * 1.5))
If sqs.UseFieldSubValue Then
SubHeadTxt = Cat2Code
ElseIf sqs.RepSubDes <> "" Then
SubHeadTxt = sqs.RepSubDes
Else
SubHeadTxt = "Sub Total"
End If
ev.Graphics.DrawString(SubHeadTxt, ft, brush, rf, sf)
End If
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y, ci.LeftPos + ci.PrintWidth, curr_y)
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
If ci.ColJust = "R" Then
sf.Alignment = StringAlignment.Far
ElseIf ci.ColJust = "C" Then
sf.Alignment = StringAlignment.Center
Else
sf.Alignment = StringAlignment.Near
End If
rf = New RectangleF(ci.LeftPos, curr_y, ci.PrintWidth, CSng(FontHt * 1.5))
ev.Graphics.DrawString(FormatTot(ci, ci.RunningSubTotal), ft, brush, rf, sf)
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y + CSng(FontHt * 1.25), ci.LeftPos + ci.PrintWidth, curr_y + CSng(FontHt * 1.25))
End If
Next
End If
curr_y += CSng(FontHt * 1.5)
RSpaceReq -= CSng(FontHt * 1.5)
If RSpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
bc.NextSectReq = "T"
MorePages = True
Return True
End If
End If
End If
If TotReq Then
If bc.NextSectReq = "C1" Or bc.NextSectReq = "C2" Or bc.NextSectReq = "B" Or bc.NextSectReq = "ST" Or bc.NextSectReq = "T" Then
SubHeadDone = False
For Each ci In sqs.SqlColInfos
If ci.RepTotals Then
RecPrinted = true
If Not SubHeadDone Then
SubHeadDone = True
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
sf.Alignment = StringAlignment.Far
rf = New RectangleF(StartXPos, curr_y, ci.LeftPos - StartXPos, CSng(FontHt * 1.5))
If sqs.UseFieldSubValue Then
SubHeadTxt = Cat1Code
ElseIf sqs.RepSubDes <> "" Then
SubHeadTxt = sqs.RepTotDes
Else
SubHeadTxt = "Total"
End If
ev.Graphics.DrawString(SubHeadTxt, ft, brush, rf, sf)
End If
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y, ci.LeftPos + ci.PrintWidth, curr_y)
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
If ci.ColJust = "R" Then
sf.Alignment = StringAlignment.Far
ElseIf ci.ColJust = "C" Then
sf.Alignment = StringAlignment.Center
Else
sf.Alignment = StringAlignment.Near
End If
rf = New RectangleF(ci.LeftPos, curr_y, ci.PrintWidth, CSng(FontHt * 1.5))
ev.Graphics.DrawString(FormatTot(ci, ci.RunningTotal), ft, brush, rf, sf)
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y + CSng(FontHt * 1.25), ci.LeftPos + ci.PrintWidth, curr_y + CSng(FontHt * 1.25))
End If
Next
curr_y += CSng(FontHt * 1.5)
RSpaceReq -= CSng(FontHt * 1.5)
If RSpaceReq > (EndYPos - curr_y) Then
'out of space
If curr_y > StartYPos Then
bc.StretchHeight = curr_y - StartYPos
If DrawPage Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
bc.NextSectReq = "GT"
MorePages = True
Return True
End If
End If
End If
End If
If GrandReq Then
SubHeadDone = False
For Each ci In sqs.SqlColInfos
If ci.RepGrandTotals Then
RecPrinted = true
If Not SubHeadDone Then
SubHeadDone = True
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
sf.Alignment = StringAlignment.Far
rf = New RectangleF(StartXPos, curr_y, ci.LeftPos - StartXPos, CSng(FontHt * 1.5))
SubHeadTxt = "Grand Total"
ev.Graphics.DrawString(SubHeadTxt, ft, brush, rf, sf)
End If
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y, ci.LeftPos + ci.PrintWidth, curr_y)
sf = New StringFormat
sf.FormatFlags = StringFormatFlags.NoWrap
If ci.ColJust = "R" Then
sf.Alignment = StringAlignment.Far
ElseIf ci.ColJust = "C" Then
sf.Alignment = StringAlignment.Center
Else
sf.Alignment = StringAlignment.Near
End If
rf = New RectangleF(ci.LeftPos, curr_y, ci.PrintWidth, CSng(FontHt * 1.5))
ev.Graphics.DrawString(FormatTot(ci, ci.RunningGrandTotal), ft, brush, rf, sf)
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y + CSng(FontHt * 1.25), ci.LeftPos + ci.PrintWidth, curr_y + CSng(FontHt * 1.25))
ev.Graphics.DrawLine(Pen, ci.LeftPos, curr_y + CSng(FontHt * 1.35), ci.LeftPos + ci.PrintWidth, curr_y + CSng(FontHt * 1.35))
End If
Next
curr_y += CSng(FontHt * 1.5)
End If
'dim stpos as Decimal = round(curr_y,4)
If System.Math.Round(curr_y, 4) <> System.Math.Round((orig_y + SpaceReq), 4) Then
If Not hsm Then
'Msgbox("Space Req Mis Match")
'debug.WriteLine("Mis Match curr_y" & cstr(curr_y))
'debug.WriteLine("Mis Match round curr_y" & cstr(math.Round(curr_y,4)))
'debug.WriteLine("Mis Match orig_y" & cstr(orig_y))
'debug.WriteLine("Mis Match Space Req" & cstr(SpaceReq))
'debug.WriteLine("Mis Match round Round orig_y + SpaceReq" & cstr(system.Math.Round((orig_y + SpaceReq),4)))
hsm = True
Else
'debug.WriteLine("Space Req Mis Match")
'debug.WriteLine("Mis Match curr_y" & cstr(curr_y))
'debug.WriteLine("Mis Match round curr_y" & cstr(math.Round(curr_y,4)))
'debug.WriteLine("Mis Match orig_y" & cstr(orig_y))
'debug.WriteLine("Mis Match Space Req" & cstr(SpaceReq))
'debug.WriteLine("Mis Match round Round orig_y + SpaceReq" & cstr(system.Math.Round((orig_y + SpaceReq),4)))
End If
End If
curr_y = orig_y + SpaceReq
Else
'calculate Grand totals
For Each ci In sqs.SqlColInfos
Select Case ci.ColType
Case "T", "D"
'no totals poss
Case Else
If IsNumeric(ci.CurrentValue) Then
cval = CDec(ci.CurrentValue)
ci.FinalGrandTotal += cval
End If
End Select
Next
curr_y = orig_y + SpaceReq
End If
bc.NextRecordPos += 1
bc.NextSectReq = "C1"
BufferDownRows(sqs)
SetSubSources(bc, sqs)
Loop
bc.StretchHeight = curr_y - StartYPos
If DrawPage and (RecPrinted or bc.PrintWhenBlank) Then DrawGridBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos, HeadBorder,hft)
sqs.TotSet = True
MorePages = False
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
Private Sub DrawGridBorder(ByRef bc As nbfSQLBrowseCtrl, ByRef sqs As nbfSqlSource, ByRef ev As PrintInfo, ByVal pen As Pen, ByVal StartXPos As Single, ByVal StartYPos As Single, ByVal EndXPos As Single, ByVal EndYPos As Single, ByVal HeadBorder As Single,Byval ft as Font)
Try
Dim ci As nbfSqlColInfo
Dim cnt As Integer
Dim brush = New SolidBrush(System.Drawing.Color.Black)
Dim rf As New RectangleF
Dim szf As SizeF
Dim sf As StringFormat
If bc.CanGrow Then
EndYPos = StartYPos + bc.StretchHeight
End If
If sqs.BrowseColHeaders Then
For Each ci In sqs.SqlColInfos
sf = GetStrFormat(ci, True)
szf.Height = EndYPos - StartYPos
szf.Width = ci.PrintWidth
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
'szf = ev.Graphics.MeasureString(ci.ColHeader, ft, szf, sf)
'debug.WriteLine("wid " & cstr(szf.Width) & " Ht " & cstr(szf.Height))
'If szf.Height > HdHt Then
'HdHt = szf.Height
'End If
rf = New RectangleF(ci.LeftPos, StartYPos, ci.PrintWidth, szf.Height)
ev.Graphics.DrawString(ci.ColHeader, ft, brush, rf, sf)
Next
End If
If sqs.TopBorderLine Then
ev.Graphics.DrawLine(pen, StartXPos, StartYPos, EndXPos, StartYPos)
End If
If sqs.LeftBorderLine Then
ev.Graphics.DrawLine(pen, StartXPos, StartYPos, StartXPos, EndYPos)
End If
If sqs.RightBorderLine Then
ev.Graphics.DrawLine(pen, EndXPos, StartYPos, EndXPos, EndYPos)
End If
If sqs.BottomBorderLine Then
ev.Graphics.DrawLine(pen, StartXPos, EndYPos, EndXPos, EndYPos)
End If
If sqs.HeaderBorderLine Then
ev.Graphics.DrawLine(pen, StartXPos, HeadBorder, EndXPos, HeadBorder)
ElseIf sqs.HeaderUnderline Then
For Each ci In sqs.SqlColInfos
ev.Graphics.DrawLine(pen, ci.LeftPos, HeadBorder, ci.LeftPos + ci.PrintWidth, HeadBorder)
Next
End If
If sqs.ColumnLines Then
If sqs.SqlColInfos.count > 1 Then
For cnt = 1 To sqs.SqlColInfos.count - 1
If sqs.VertLinesToTop Then
ev.Graphics.DrawLine(pen, sqs.SqlColInfos.Item(cnt).LeftPos, StartYPos, sqs.SqlColInfos.Item(cnt).LeftPos, EndYPos)
Else
ev.Graphics.DrawLine(pen, sqs.SqlColInfos.Item(cnt).LeftPos, HeadBorder, sqs.SqlColInfos.Item(cnt).LeftPos, EndYPos)
End If
Next
End If
Else
cnt = 0
For Each ci In sqs.SqlColInfos
If cnt > 0 Then
If sqs.VertLinesToTop Then
ev.Graphics.DrawLine(pen, ci.LeftPos, StartYPos, ci.LeftPos, EndYPos)
Else
ev.Graphics.DrawLine(pen, ci.LeftPos, HeadBorder, ci.LeftPos, EndYPos)
End If
End If
cnt += 1
Next
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub DrawRepBorder(ByVal bc As nbfSQLBrowseCtrl, ByRef sqs As nbfSqlSource, ByRef ev As PrintInfo, ByVal pen As Pen, ByVal StartXPos As Single, ByVal StartYPos As Single, ByVal EndXPos As Single, ByVal EndYPos As Single)
If bc.CanGrow Then
EndYPos = StartYPos + bc.StretchHeight
End If
If bc.RepTopBorder Then
ev.Graphics.DrawLine(pen, StartXPos, StartYPos, EndXPos, StartYPos)
End If
If bc.RepLeftBorder Then
ev.Graphics.DrawLine(pen, StartXPos, StartYPos, StartXPos, EndYPos)
End If
If bc.RepRightBorder Then
ev.Graphics.DrawLine(pen, EndXPos, StartYPos, EndXPos, EndYPos)
End If
If bc.RepBottomBorder Or bc.RepUnderline Or bc.RepDoubleUnderline Then
ev.Graphics.DrawLine(pen, StartXPos, EndYPos, EndXPos, EndYPos)
End If
If bc.RepDoubleUnderline Then
ev.Graphics.DrawLine(pen, StartXPos, EndYPos + dblLineWidth, EndXPos, EndYPos + dblLineWidth)
End If
End Sub
Private Function OLD_PrintSubRepPage(ByRef MorePages As Boolean, ByRef bc As nbfSQLBrowseCtrl, ByVal DrawPage As Boolean, ByRef ev As PrintInfo, ByVal NoPages As Integer, ByVal SourceSize As Size, Optional ByVal Dest As String = "P") As Boolean
Try
Dim sqs As nbfSqlSource
Dim ci As nbfSqlColInfo
Dim brush = New SolidBrush(System.Drawing.Color.Black)
Dim Pen As New Pen(System.Drawing.Color.Black)
Dim dq As nbfDB.NbfResultSet
Dim cnt As Integer
Dim CheckMorePages As Boolean = False
Dim CalcPages As Integer = 1
If bc.SubItem Then
If bc.ParentCtrl.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In bc.ParentCtrl.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
Else
If pvBFInfo.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In pvBFInfo.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
End If
If Not sqs.BrowseTableName = bc.SQLSource Then
MsgBox("Unable to find SQL Source")
Return False
End If
Dim leftMargin As Single = ev.PageBounds.Left 'ev.MarginBounds.Left
Dim topMargin As Single = ev.PageBounds.Top 'ev.MarginBounds.Top
Dim PageHeight As Single = ev.PageBounds.Height 'ev.MarginBounds.Height
Dim PageWidth As Single = ev.PageBounds.Width 'ev.MarginBounds.Width
Dim StartYPos As Single = topMargin + CSng(bc.Top * PageHeight / SourceSize.Height) + bc.GrowthOffset
Dim StartXPos As Single = leftMargin + CSng(bc.Left * PageWidth / SourceSize.Width)
sqs.RepPageWidth = CSng(bc.Width * PageWidth / SourceSize.Width)
sqs.RepPageLength = CSng(bc.Height * PageHeight / SourceSize.Height)
'Dim sqs.RepPageWidth as Single = csng(bc.Width * PageWidth/ pvBFInfo.FormSize.Width)
'Dim RepHeight as Single = csng(bc.Height * PageHeight/ pvBFInfo.FormSize.Height)
Dim grect As New Rectangle(CSng(StartXPos), CSng(StartYPos), CSng(sqs.RepPageWidth), CSng(sqs.RepPageLength))
Dim EndYPos As Single = StartYPos + sqs.RepPageLength
Dim EndXPos As Single = StartXPos + sqs.RepPageWidth
Dim WidTot As Integer = 0
Dim ftSize As Single = 0
Dim ftReq As Boolean = False
Dim ftSec As nbfSQLRepSection
Dim ftStart As Single = 0
Dim rs As nbfSQLRepSection
Dim st As nbfSqlSecTot
If bc.CanGrow Then
EndYPos = topMargin + PageHeight
End If
For Each rs In bc.RepSections
If rs.SectionType = "P" And rs.SectionHead = False Then
rs.PrintRequired = False
If rs.SectionCtrls.count > 0 Then
ftReq = True
ftSec = rs
ftSec.PrintHeight = CSng(ftSec.SectionHeight * PageHeight / SourceSize.Height)
ftSize = ftSec.PrintHeight
ftStart = EndYPos - ftSize
For Each st In ftSec.SectionTotals
st.RunningTotal = 0
Next
End If
Exit For
End If
Next
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
Dim clpos As Single = StartXPos
Dim curr_y As Single = StartYPos
Dim rf As New RectangleF
Dim szf As SizeF
Dim sf As StringFormat
Dim HdHt As Single = 0
Dim sbc As nbfSQLBrowseCtrl
Dim SubSS As nbfSqlSource
If Not sqs.SQLValidated Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
For Each rs In bc.RepSections
For Each sbc In rs.SectionCtrls
SubSS = GetSqSFromName(sbc.SQLSource)
If Not SubSS Is Nothing Then
ValidateSqlSource(SubSS)
End If
Next
Next
ElseIf sqs.RowsFetched > bc.NextRecordPos Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
For Each rs In bc.RepSections
For Each sbc In rs.SectionCtrls
SubSS = GetSqSFromName(sbc.SQLSource)
If Not SubSS Is Nothing Then
ValidateSqlSource(SubSS)
End If
Next
Next
End If
Do While sqs.RowsFetched < bc.NextRecordPos
If Not sqs.CurrentRowFound Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.Dispose
'End If
sqs.TotSet = True
bc.NextSectNo = 0
MorePages = False
Return True
End If
BufferDownRows(sqs)
For Each rs In bc.RepSections
For Each sbc In rs.SectionCtrls
SubSS = GetSqSFromName(sbc.SQLSource)
If Not SubSS Is Nothing Then
ValidateSqlSource(SubSS)
End If
Next
Next
Loop
If bc.NextRecordPos = 1 And bc.NextSectNo = 0 Then
For Each rs In bc.RepSections
Do While rs.SectionTotals.count > 0
rs.SectionTotals.RemoveAt(0)
Loop
For cnt = 1 To sqs.SqlColInfos.count
st = New nbfSqlSecTot
st.RunningTotal = 0
rs.SectionTotals.Add(st)
Next
Next
End If
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
'case "CASTLE","CROWN","BL/SUPERPRO","18","24","CL/SIM760/DB/8"
Dim Cat1Code As String = ""
Dim Cat2Code As String = ""
Dim NxtCat1Code As String = ""
Dim NxtCat2Code As String = ""
Dim PrvCat1Code As String = ""
Dim PrvCat2Code As String = ""
Dim Cat1Head As String = ""
Dim Cat2Head As String = ""
Dim Cat1Req As Boolean = False
Dim Cat2Req As Boolean = False
Dim SubReq As Boolean = False
Dim TotReq As Boolean = False
Dim GrandReq As Boolean = False
Dim PageReq As Boolean = True
Dim SpaceReq As Single = 0
Dim RSpaceReq As Single = 0
Dim HeadSpace As Single = 0
Dim orig_y As Single
Dim hsm As Boolean = False
Dim lpos As Single = sqs.SqlColInfos.Item(0).LeftPos
Dim hwid As Single = 0
Dim hht As Single = 0
Dim cval As Decimal
Dim SubHeadDone As Boolean
Dim SubHeadTxt As String = ""
Dim frs As nbfSQLRepSection
Dim BrkCol As nbfBreakColumn
Dim CRVal As String = ""
Dim PRVal As String = ""
Dim NRVal As String = ""
Dim sbc2 As nbfSQLBrowseCtrl
Dim FollHeadReq As Boolean = False
Dim FollTotReq As Boolean = False
Dim pi As New PrintInfo
Dim ssz As New Size
Dim pirc As New Rectangle
Dim SectStart As Integer = 0
Dim clnum As Integer = 0
Dim cgo As Single = 0
Dim olpt As Single = 0 ' original section lowest point
Dim clpt As Single = 0 ' original section lowest point
Dim mxlpt As Single = 0 ' original section lowest point
Dim sbfr As Single = 0
Dim DownGrowth As Boolean = False
Dim UpGrowth As Boolean = False
Dim GrowthAmt As Single = 0
Dim DownGrowthAmt As Single = 0
Dim UpGrowthAmt As Single = 0
Dim CeilingAmt As Single = 0
Dim ft As Font
Do While sqs.CurrentRowFound
Cat1Req = False
Cat2Req = False
SubReq = False
TotReq = False
GrandReq = False
SpaceReq = 0
RSpaceReq = 0
HeadSpace = 0
orig_y = curr_y
FollHeadReq = False
FollTotReq = False
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
For Each rs In bc.RepSections
rs.PrintRequired = False
Next rs
For Each rs In bc.RepSections
Select Case rs.SectionType
Case "H"
'header req ?
If sqs.PriorRowFound = False Then
'first row - so rep head
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
FollHeadReq = True
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
End If
'tot req ?
For Each frs In bc.RepSections
If frs.SectionType = "H" And frs.SectionHead = False Then
If sqs.NextRowFound = False Then
'last row - so rep tots
frs.PrintRequired = True
frs.PrintHeight = CSng(frs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += frs.PrintHeight
FollTotReq = True
End If
End If
Next
Case "P"
If PageReq And rs.SectionHead Then
PageReq = False
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
End If
Case "S"
If rs.SectionNumber >= bc.NextSectNo Then
'header req ?
If sqs.SqlColInfos.Item(0).CurrentValue = "MM" Then
Debug.WriteLine(rs.SectionName & " " & rs.BreakDes)
Debug.WriteLine("MM Line")
End If
If FollHeadReq Then
rs.PrintRequired = True
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
Else
For Each BrkCol In rs.BreakColumns
CRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).CurrentValue
PRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).PreviousValue
If Trim(UCase(CRVal)) <> Trim(UCase(PRVal)) Then
'New Section
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
SpaceReq += rs.PrintHeight
FollHeadReq = True
End If
Next
End If
End If
'tot req ?
For Each frs In bc.RepSections
If frs.SectionType = rs.SectionType And frs.SectionIndex = rs.SectionIndex And frs.SectionHead = False And frs.SectionNumber >= bc.NextSectNo Then
If FollTotReq Or sqs.NextRowFound = False Then
frs.PrintRequired = True
Else
For Each BrkCol In rs.BreakColumns
CRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).CurrentValue
NRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).NextValue
If Trim(UCase(CRVal)) <> Trim(UCase(NRVal)) Then
'New Section
frs.PrintRequired = True
Exit For
End If
Next
End If
If frs.PrintRequired Then
frs.PrintHeight = CSng(frs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += frs.PrintHeight
FollTotReq = True
End If
End If
Next
Case "B"
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
Select Case sqs.SqlColInfos.Item(0).CurrentValue
Case "CASTLE", "CROWN", "BL/SUPERPRO", "18", "24", "CL/SIM760/DB/8"
Debug.WriteLine(rs.SectionName & " " & rs.BreakDes)
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
End Select
If rs.SectionNumber >= bc.NextSectNo Then
Dim testMorePages As Boolean = False
Dim testNoPages As Integer = 0
rs.PrintRequired = True
olpt = 0
clpt = 0
mxlpt = 0
'for each st in rs.SectionTotals
' st.RunningTotal = 0
'Next
If rs.CanGrow Then
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue)
If sqs.SqlColInfos.Item(0).CurrentValue = "CROWN" Then
Debug.WriteLine("CROWN")
End If
For Each sbc In rs.SectionCtrls
sbc.GrowthOffset = 0
sbc.StretchHeight = CSng(sbc.Height * PageHeight / SourceSize.Height)
If (sbc.Top + sbc.Height) > olpt Then
olpt = (sbc.Top + sbc.Height)
End If
'sbc.NextRecordPos = 1
'sbc.LastRecordTot = 0
'sbc.NextSectNo = 0
Next
sbfr = rs.SectionHeight - olpt
olpt = 0
For Each sbc In rs.SectionCtrls
If sbc.RecPrinted < sqs.RowsFetched Then
DownGrowth = False
UpGrowth = False
DownGrowthAmt = 0
UpGrowthAmt = 0
CeilingAmt = 0
SubSS = GetSqSFromName(sbc.SQLSource)
If Not SubSS Is Nothing Then
If True Then
If Not SubSS.SQLValidated Then
ValidateSqlSource(SubSS)
End If
Else
If Trim(UCase(SubSS.ParentSource)) = Trim(UCase(bc.SQLSource)) Then
'reset child SQL Sources
Debug.WriteLine(sbc.SQLSource)
ValidateSqlSource(SubSS)
End If
End If
If sqs.SqlColInfos.Item(0).CurrentValue = "CROWN" And sbc.CtlType = "Report" Then
Debug.WriteLine("CROWN Line")
End If
End If
For Each sbc2 In rs.SectionCtrls
If sbc2 Is sbc Then
Exit For
End If
If (sbc.Left + sbc.Width) >= sbc2.Left And sbc.Left <= (sbc2.Left + sbc2.Width) Then
'if csng((sbc2.Top + sbc2.Height) * PageHeight/SourceSize.Height) > CeilingAmt then
' CeilingAmt = csng((sbc2.Top + sbc2.Height) * PageHeight/SourceSize.Height)
'end if
If sbc2.RecPrinted < sqs.RowsFetched Then
If CSng(sbc2.Top * PageHeight / SourceSize.Height) + sbc2.StretchHeight > CeilingAmt Then
CeilingAmt = CSng(sbc2.Top * PageHeight / SourceSize.Height) + sbc2.StretchHeight
End If
Else
sbc2.StretchHeight = 0
End If
If sbc2.GrowthOffset <> 0 Or (sbc2.StretchHeight <> CSng(sbc2.Height * PageHeight / SourceSize.Height)) Then
GrowthAmt = sbc2.GrowthOffset + (sbc2.StretchHeight - (sbc2.Height * PageHeight / SourceSize.Height))
If GrowthAmt > 0 Then
DownGrowth = True
If GrowthAmt > DownGrowthAmt Then
DownGrowthAmt = GrowthAmt
End If
ElseIf GrowthAmt < 0 Then
UpGrowth = True
GrowthAmt = (-1) * GrowthAmt
If GrowthAmt > UpGrowthAmt Then
UpGrowthAmt = GrowthAmt
End If
End If
End If
End If
Next
If DownGrowth Then
sbc.GrowthOffset = DownGrowthAmt
ElseIf UpGrowth Then
If CSng(sbc.Top * PageHeight / SourceSize.Height) - CeilingAmt > UpGrowthAmt Then
sbc.GrowthOffset = CSng((-1) * UpGrowthAmt)
Else
sbc.GrowthOffset = CSng((-1) * ((sbc.Top * PageHeight / SourceSize.Height) - CeilingAmt))
End If
End If
If sbc.CanGrow Then
Select Case sbc.CtlType
Case "Grid"
PrintListPage(testMorePages, sbc, False, ev, testNoPages, SourceSize)
Case "Report"
PrintSubRepPage(testMorePages, sbc, False, ev, testNoPages, SourceSize)
If sqs.SqlColInfos.Item(0).CurrentValue = "CASTLE" Then
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue)
End If
Case "Field" '"Label"
If sbc.SQLSource = bc.SQLSource Then
CRVal = sqs.SqlColInfos.Item(sbc.SQLColNumber - 1).CurrentValue
Else
CRVal = GetSqlValue(sbc.SQLSource, sbc.SQLColNumber)
End If
sf = GetStrFormat(sqs.SqlColInfos.Item(sbc.SQLColNumber - 1))
szf.Height = ev.PageBounds.Height
szf.Width = sbc.Width * PageWidth / SourceSize.Width
ft = GetRepFont(sbc.FontInfo)
szf = ev.Graphics.MeasureString(CRVal, ft, szf, sf)
sbc.StretchHeight = szf.Height '* SourceSize.Height/PageHeight
End Select
End If
If (sbc.Top + sbc.Height) * PageHeight / SourceSize.Height > olpt Then
olpt = (sbc.Top + sbc.Height) * PageHeight / SourceSize.Height
End If
If ((sbc.Top * PageHeight) / SourceSize.Height) + sbc.StretchHeight + sbc.GrowthOffset > clpt Then
clpt = ((sbc.Top * PageHeight) / SourceSize.Height) + sbc.StretchHeight + sbc.GrowthOffset
End If
If clpt > mxlpt Then
mxlpt = clpt
End If
End If
Next
'
' calculate new row space req here
'
rs.PrintHeight = mxlpt + (sbfr * PageHeight / SourceSize.Height)
'rs.PrintHeight = csng(rs.SectionHeight * PageHeight/ SourceSize.Height)
'rs.PrintHeight += (clpt - olpt)
SpaceReq += rs.PrintHeight
Else
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
End If
'only do 'Outgoing' sections
End If
Exit For
End Select
Next
If sqs.RowsFetched > bc.LastRecordTot Then
For Each rs In bc.RepSections
For cnt = 0 To sqs.SqlColInfos.count - 1
rs.SectionTotals.Item(cnt).RunningTotal += sqs.SqlColInfos.Item(cnt).CurrentNumberValue
If rs.SectionType = "S" Then
Debug.WriteLine(rs.Description & " " & CStr(cnt) & " " & CStr(rs.SectionTotals.Item(cnt).RunningTotal))
End If
Next
Next
bc.LastRecordTot = sqs.RowsFetched
End If
If SpaceReq > (EndYPos - curr_y - ftSize) Then
'out of space
If (curr_y > StartYPos) And curr_y > ((EndYPos - StartYPos - ftSize) * 0.75) Then
'if false then 'curr_y > StartYPos and bc.FlowThrough then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.Dispose
'End If
bc.NextSectNo = 0
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
End If
RSpaceReq = SpaceReq
SectStart = 0
Dim FollowOnPage As Boolean = False
For Each rs In bc.RepSections
If True Then
If rs.PrintRequired Then
If (curr_y > (EndYPos - ftSize)) Or (rs.CanGrow = False And (CSng(rs.SectionHeight * PageHeight / SourceSize.Height) > (EndYPos - curr_y - ftSize))) Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
'PrintSection(rs,sqs,ev,bc,curr_y,PageWidth,PageHeight,SourceSize,ftSize,DrawPage,CheckMorePages,Dest)
If CheckMorePages Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
SectStart += CInt(((rs.SectionHeight * PageHeight) / SourceSize.Height))
curr_y += rs.PrintHeight 'csng(rs.SectionHeight * PageHeight/ SourceSize.Height)
End If
Else
If rs.PrintRequired Then
If CSng(rs.SectionHeight * PageHeight / SourceSize.Height) > (EndYPos - curr_y - ftSize) Then
'if bc.SubItem then
' dq.dispose
'End If
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If Not bc.FlowThrough Then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
If DrawPage Then
'PrintSection(rs,sqs,ev,bc,curr_y,PageWidth,PageHeight,SourceSize,ftSize,DrawPage,CheckMorePages,Dest)
End If
If CheckMorePages Then
FollowOnPage = True
End If
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
SectStart += CInt(((rs.SectionHeight * PageHeight) / SourceSize.Height))
curr_y += rs.PrintHeight 'csng(rs.SectionHeight * PageHeight/ SourceSize.Height)
End If
End If
Next
bc.NextRecordPos += 1
bc.NextSectNo = 0
BufferDownRows(sqs)
Loop
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
'if DrawPage then PrintSection(ftSec,sqs,ev,bc,ftStart,PageWidth,PageHeight,SourceSize,0,DrawPage,CheckMorePages,Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.dispose
'End If
bc.NextSectNo = 0
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
sqs.TotSet = True
MorePages = False
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
Sub SetSubSources(ByRef bc As nbfSQLBrowseCtrl, ByVal sqs As nbfSqlSource)
Dim rs As nbfSQLRepSection
Dim sbc As nbfSQLBrowseCtrl
Dim SubSS As nbfSqlSource
For Each SubSS In pvBFInfo.SQLSources
If Trim(UCase(SubSS.ParentSource)) = sqs.BrowseTableName Then
ValidateSqlSource(SubSS)
RestCtrlSets(SubSS.BrowseTableName)
End If
Next
For Each sbc In pvBFInfo.SQLBrowseCtrls
SetSubSce(sbc, sqs.BrowseTableName)
Next
End Sub
Private Sub RestCtrlSets(ByVal SqlSceName As String)
Dim bc As nbfSQLBrowseCtrl
Dim rs As nbfSQLRepSection
For Each bc In pvBFInfo.SQLBrowseCtrls
If bc.SQLSource = SqlSceName Then
bc.NextRecordPos = 1
bc.RecPrinted = 0
End If
SetSubCtrlSets(bc, SqlSceName)
Next
End Sub
Private Sub SetSubCtrlSets(ByVal bc As nbfSQLBrowseCtrl, ByVal SqlSceName As String)
Dim sbc As nbfSQLBrowseCtrl
Dim rs As nbfSQLRepSection
For Each rs In bc.RepSections
For Each sbc In rs.SectionCtrls
If sbc.SQLSource = SqlSceName Then
sbc.NextRecordPos = 1
sbc.RecPrinted = 0
End If
SetSubCtrlSets(sbc, SqlSceName)
Next
Next
End Sub
Private Sub SetSubSce(ByVal bc As nbfSQLBrowseCtrl, ByVal ParentSourceName As String)
Dim rs As nbfSQLRepSection
Dim bc2 As nbfSQLBrowseCtrl
Dim ss As nbfSqlSource
For Each ss In bc.SQLSources
If UCase(Trim(ss.ParentSource)) = UCase(Trim(ParentSourceName)) Then
ValidateSqlSource(ss)
RestCtrlSets(ss.BrowseTableName)
End If
Next
For Each rs In bc.RepSections
For Each bc2 In rs.SectionCtrls
For Each ss In bc2.SQLSources
If UCase(Trim(ss.ParentSource)) = UCase(Trim(ParentSourceName)) Then
ValidateSqlSource(ss)
RestCtrlSets(ss.BrowseTableName)
End If
Next
SetSubSce(bc2, ParentSourceName)
Next
Next
End Sub
Private Function PrintSubRepPage(ByRef MorePages As Boolean, ByRef bc As nbfSQLBrowseCtrl, ByVal DrawPage As Boolean, ByRef ev As PrintInfo, ByVal NoPages As Integer, ByVal SourceSize As Size, Optional ByVal Dest As String = "P") As Boolean
Try
Dim sqs As nbfSqlSource
Dim ci As nbfSqlColInfo
Dim brush = New SolidBrush(System.Drawing.Color.Black)
Dim Pen As New Pen(System.Drawing.Color.Black)
Dim dq As nbfDB.NbfResultSet
Dim cnt As Integer
Dim CheckMorePages As Boolean = False
Dim CalcPages As Integer = 1
Dim SubPi As New PrintInfo
Dim SubPir As New RectangleF
Dim SubSze As New Size
Dim ftSubPi As New PrintInfo
Dim ftSubPir As New RectangleF
Dim ftSubSze As New Size
If bc.SubItem Then
If bc.ParentCtrl.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In bc.ParentCtrl.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
Else
If pvBFInfo.SQLSources.count <= 0 Then
MsgBox("No Sql Sources")
Return False
End If
For Each sqs In pvBFInfo.SQLSources
If sqs.BrowseTableName = bc.SQLSource Then
Exit For
End If
Next
End If
If Not sqs.BrowseTableName = bc.SQLSource Then
MsgBox("Unable to find SQL Source")
Return False
End If
Dim leftMargin As Single = ev.PageBounds.Left 'ev.MarginBounds.Left
Dim topMargin As Single = ev.PageBounds.Top 'ev.MarginBounds.Top
Dim PageHeight As Single = ev.PageBounds.Height 'ev.MarginBounds.Height
Dim PageWidth As Single = ev.PageBounds.Width 'ev.MarginBounds.Width
Dim StartYPos As Single = topMargin + CSng(bc.Top * PageHeight / SourceSize.Height) + bc.GrowthOffset
Dim StartXPos As Single = leftMargin + CSng(bc.Left * PageWidth / SourceSize.Width)
sqs.RepPageWidth = CSng(bc.Width * PageWidth / SourceSize.Width)
sqs.RepPageLength = CSng(bc.Height * PageHeight / SourceSize.Height)
'Dim sqs.RepPageWidth as Single = csng(bc.Width * PageWidth/ pvBFInfo.FormSize.Width)
'Dim RepHeight as Single = csng(bc.Height * PageHeight/ pvBFInfo.FormSize.Height)
Dim grect As New Rectangle(CSng(StartXPos), CSng(StartYPos), CSng(sqs.RepPageWidth), CSng(sqs.RepPageLength))
Dim EndYPos As Single = StartYPos + sqs.RepPageLength
Dim EndXPos As Single = StartXPos + sqs.RepPageWidth
Dim WidTot As Integer = 0
Dim ftSize As Single = 0
Dim ftReq As Boolean = False
Dim ftSec As nbfSQLRepSection
Dim ftCtrlSize As Single = 0
Dim ftStart As Single = 0
Dim rs As nbfSQLRepSection
Dim st As nbfSqlSecTot
If bc.CanGrow Then
EndYPos = topMargin + PageHeight
End If
For Each rs In bc.RepSections
If rs.SectionType = "P" And rs.SectionHead = False Then
rs.PrintRequired = False
If rs.SectionCtrls.count > 0 Then
ftReq = True
ftSec = rs
ftCtrlSize = ftSec.SectionHeight
ftSec.PrintHeight = CSng(ftCtrlSize * PageHeight / SourceSize.Height)
ftSize = ftSec.PrintHeight
ftStart = EndYPos - ftSize
For Each st In ftSec.SectionTotals
st.RunningTotal = 0
Next
End If
Exit For
End If
Next
If ftReq Then
ftSubPir.X = StartXPos
ftSubPir.Y = ftStart
ftSubPir.Width = EndXPos - StartXPos
ftSubPir.Height = ftSize
ftSubPi.PageBounds = ftSubPir
ftSubPi.Graphics = ev.Graphics
ftSubSze.Width = bc.Width
ftSubSze.Height = ftCtrlSize
End If
Dim clpos As Single = StartXPos
Dim curr_y As Single = StartYPos
Dim rf As New RectangleF
Dim szf As SizeF
Dim sf As StringFormat
Dim HdHt As Single = 0
Dim sbc As nbfSQLBrowseCtrl
Dim SubSS As nbfSqlSource
If Not sqs.SQLValidated Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
SetSubSources(bc, sqs)
'for each rs in bc.RepSections
' For Each sbc in rs.SectionCtrls
' SubSS = GetSqsFromName(sbc.SQLSource)
' if not SubSS is nothing then
' ValidateSqlSource(subSS)
' End If
' Next
'Next
ElseIf sqs.RowsFetched > bc.NextRecordPos Then
ValidateSqlSource(sqs)
If Not sqs.SQLValidated Then
Return False
End If
If sqs.SqlColInfos.count <= 0 Then
MsgBox("No Columns in Datasource")
Return False
End If
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
SetSubSources(bc, sqs)
'for each rs in bc.RepSections
' For Each sbc in rs.SectionCtrls
' SubSS = GetSqsFromName(sbc.SQLSource)
' if not SubSS is nothing then
' ValidateSqlSource(subSS)
' End If
' Next
'Next
ElseIf bc.NextRecordPos = 1 And Not bc.PrintReqMorePages Then
SetSubSources(bc, sqs)
End If
'If sqs.SqlColInfos.Item(0).CurrentValue = "CUEFACT" Then
If bc.SQLSource = "HSINV" Then
Debug.WriteLine("HSINV")
End If
If sqs.RowsFetched < bc.NextRecordPos Then
Do While sqs.RowsFetched < bc.NextRecordPos
If Not sqs.CurrentRowFound Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.Dispose
'End If
sqs.TotSet = True
bc.NextSectNo = 0
MorePages = False
Return True
End If
BufferDownRows(sqs)
Loop
SetSubSources(bc, sqs)
'for each rs in bc.RepSections
' For Each sbc in rs.SectionCtrls
' SubSS = GetSqsFromName(sbc.SQLSource)
' if not SubSS is nothing then
' ValidateSqlSource(subSS)
' End If
' Next
'Next
End If
If bc.NextRecordPos = 1 And bc.NextSectNo = 0 Then
For Each rs In bc.RepSections
Do While rs.SectionTotals.count > 0
rs.SectionTotals.RemoveAt(0)
Loop
For cnt = 1 To sqs.SqlColInfos.count
st = New nbfSqlSecTot
st.RunningTotal = 0
rs.SectionTotals.Add(st)
Next
Next
End If
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
'case "CASTLE","CROWN","BL/SUPERPRO","18","24","CL/SIM760/DB/8"
Dim Cat1Code As String = ""
Dim Cat2Code As String = ""
Dim NxtCat1Code As String = ""
Dim NxtCat2Code As String = ""
Dim PrvCat1Code As String = ""
Dim PrvCat2Code As String = ""
Dim Cat1Head As String = ""
Dim Cat2Head As String = ""
Dim Cat1Req As Boolean = False
Dim Cat2Req As Boolean = False
Dim SubReq As Boolean = False
Dim TotReq As Boolean = False
Dim GrandReq As Boolean = False
Dim PageReq As Boolean = True
Dim SpaceReq As Single = 0
Dim RSpaceReq As Single = 0
Dim HeadSpace As Single = 0
Dim orig_y As Single
Dim hsm As Boolean = False
Dim lpos As Single = sqs.SqlColInfos.Item(0).LeftPos
Dim hwid As Single = 0
Dim hht As Single = 0
Dim cval As Decimal
Dim SubHeadDone As Boolean
Dim SubHeadTxt As String = ""
Dim frs As nbfSQLRepSection
Dim BrkCol As nbfBreakColumn
Dim CRVal As String = ""
Dim PRVal As String = ""
Dim NRVal As String = ""
Dim sbc2 As nbfSQLBrowseCtrl
Dim FollHeadReq As Boolean = False
Dim FollTotReq As Boolean = False
Dim pi As New PrintInfo
Dim ssz As New Size
Dim pirc As New Rectangle
Dim SectStart As Integer = 0
Dim clnum As Integer = 0
Dim cgo As Single = 0
Dim olpt As Single = 0 ' original section lowest point
Dim clpt As Single = 0 ' original section lowest point
Dim mxlpt As Single = 0 ' original section lowest point
Dim sbfr As Single = 0
Dim DownGrowth As Boolean = False
Dim UpGrowth As Boolean = False
Dim GrowthAmt As Single = 0
Dim DownGrowthAmt As Single = 0
Dim UpGrowthAmt As Single = 0
Dim CeilingAmt As Single = 0
Dim ft As Font
Do While sqs.CurrentRowFound
Cat1Req = False
Cat2Req = False
SubReq = False
TotReq = False
GrandReq = False
SpaceReq = 0
RSpaceReq = 0
HeadSpace = 0
orig_y = curr_y
FollHeadReq = False
FollTotReq = False
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & " Line")
If sqs.SqlColInfos.Item(0).CurrentValue = "CUEFACT" Then
Debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue & "CF")
End If
For Each rs In bc.RepSections
rs.PrintRequired = False
Next rs
For Each rs In bc.RepSections
Select Case rs.SectionType
Case "H"
'header req ?
If sqs.PriorRowFound = False Then
if not rs.suppress
'first row - so rep head
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
end if
FollHeadReq = True
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
End If
'tot req ?
For Each frs In bc.RepSections
If frs.SectionType = "H" And frs.SectionHead = False Then
If sqs.NextRowFound = False Then
if not frs.suppress
'last row - so rep tots
frs.PrintRequired = True
frs.PrintHeight = CSng(frs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += frs.PrintHeight
end if
FollTotReq = True
End If
End If
Next
Case "P"
If PageReq And rs.SectionHead Then
PageReq = False
if not rs.suppress
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
end if
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
End If
Case "S"
If rs.SectionNumber >= bc.NextSectNo Then
'header req ?
If sqs.SqlColInfos.Item(0).CurrentValue = "MM" Then
Debug.WriteLine(rs.SectionName & " " & rs.BreakDes)
Debug.WriteLine("MM Line")
End If
If FollHeadReq Then
if not rs.suppress
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
end if
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
Else
For Each BrkCol In rs.BreakColumns
CRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).CurrentValue
PRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).PreviousValue
If Trim(UCase(CRVal)) <> Trim(UCase(PRVal)) Then
'New Section
if not rs.suppress
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
end if
For Each st In rs.SectionTotals
st.RunningTotal = 0
Next
FollHeadReq = True
End If
Next
End If
End If
'tot req ?
For Each frs In bc.RepSections
If frs.SectionType = rs.SectionType And frs.SectionIndex = rs.SectionIndex And frs.SectionHead = False And frs.SectionNumber >= bc.NextSectNo Then
If FollTotReq Or sqs.NextRowFound = False Then
frs.PrintRequired = True
Else
For Each BrkCol In rs.BreakColumns
CRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).CurrentValue
NRVal = sqs.SqlColInfos.Item(BrkCol.ColumnNumber - 1).NextValue
If Trim(UCase(CRVal)) <> Trim(UCase(NRVal)) Then
'New Section
frs.PrintRequired = True
Exit For
End If
Next
End If
If frs.PrintRequired Then
if frs.suppress then
frs.PrintRequired = false
else
frs.PrintHeight = CSng(frs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += frs.PrintHeight
End If
FollTotReq = True
End If
End If
Next
Case "B"
If rs.SectionNumber >= bc.NextSectNo Then
if not rs.Suppress then
rs.PrintRequired = True
rs.PrintHeight = CSng(rs.SectionHeight * PageHeight / SourceSize.Height)
SpaceReq += rs.PrintHeight
end if
End If
'only do 'Outgoing' sections
Exit For
End Select
Next
If sqs.RowsFetched > bc.LastRecordTot Then
For Each rs In bc.RepSections
For cnt = 0 To sqs.SqlColInfos.count - 1
rs.SectionTotals.Item(cnt).RunningTotal += sqs.SqlColInfos.Item(cnt).CurrentNumberValue
If rs.SectionType = "S" Then
Debug.WriteLine(rs.Description & " " & CStr(cnt) & " " & CStr(rs.SectionTotals.Item(cnt).RunningTotal))
End If
Next
Next
bc.LastRecordTot = sqs.RowsFetched
End If
If true Then
If SpaceReq > (EndYPos - curr_y - ftSize) Then
'out of space
If (curr_y > StartYPos) And curr_y > ((EndYPos - StartYPos - ftSize) * 0.75) Then
'if false then 'curr_y > StartYPos and bc.FlowThrough then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.Dispose
'End If
bc.NextSectNo = 0
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
End If
End If
For Each rs In bc.RepSections
If rs.PrintRequired Then
If ((curr_y > StartYPos) and rs.PageBreakBefore) _
or (curr_y > (EndYPos - ftSize)) Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
End If
SubPir.X = StartXPos
SubPir.Y = curr_y
SubPir.Width = EndXPos - StartXPos
SubPir.Height = EndYPos - curr_y - ftSize
SubPi.PageBounds = SubPir
SubPi.Graphics = ev.Graphics
SubSze.Width = CSng(SourceSize.Width * SubPir.Width / PageWidth)
SubSze.Height = CSng(SourceSize.Height * SubPir.Height / PageHeight)
PrintSection(rs, sqs, SubPi, SubSze, bc, DrawPage, CheckMorePages, Dest)
If CheckMorePages Then
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then
PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
End If
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber
MorePages = True
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
Return True
Else
For Each sbc In rs.SectionCtrls
'If sbc.SQLSource = "" Then
sbc.RecPrinted = 0
'End If
Next
End If
curr_y += rs.PrintHeight
if rs.PageBreakAfter then
dim LastSectionInGroup as Boolean = true
dim rs2 as nbfSQLRepSection
for each rs2 in bc.RepSections
if rs2.SectionNumber > rs.SectionNumber then
LastSectionInGroup = false
End If
Next
if LastSectionInGroup then
if sqs.NextRowFound then
bc.NextRecordPos += 1
bc.NextSectNo = 0
BufferDownRows(sqs)
SetSubSources(bc, sqs)
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then
PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
End If
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
MorePages = True
Return True
else
'will end anyway
end if
else
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then
PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
End If
Else
bc.StretchHeight = curr_y - StartYPos
End If
If False Then 'not bc.FlowThrough then
Do While sqs.CurrentRowFound
BufferDownRows(sqs)
Loop
sqs.TotSet = True
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
bc.NextSectNo = rs.SectionNumber + 1
MorePages = True
Return True
end if
end if
Else
For Each sbc In rs.SectionCtrls
'If sbc.SQLSource = "" Then
sbc.RecPrinted = 0
'End If
Next
End If
Next
bc.NextRecordPos += 1
bc.NextSectNo = 0
BufferDownRows(sqs)
SetSubSources(bc, sqs)
Loop
If ftReq Then
bc.StretchHeight = EndYPos - StartYPos
If DrawPage Then PrintSection(ftSec, sqs, ftSubPi, ftSubSze, bc, DrawPage, CheckMorePages, Dest)
Else
bc.StretchHeight = curr_y - StartYPos
End If
If DrawPage Then DrawRepBorder(bc, sqs, ev, Pen, StartXPos, StartYPos, EndXPos, EndYPos)
'if bc.SubItem then
' dq.dispose
'End If
bc.NextSectNo = 0
'msgbox("Page " & cstr(CurrentPrintPage) & " End Row" & cstr(sqs.rowsfetched) & " Next sec " & cstr(bc.NextSectNo))
sqs.TotSet = True
MorePages = False
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
Private Sub OLDPrintSection(ByRef rs As nbfSQLRepSection, ByRef sqs As nbfSqlSource, ByRef ev As PrintInfo, ByRef bc As nbfSQLBrowseCtrl, ByVal curr_y As Single, ByVal PageWidth As Single, ByVal PageHeight As Single, ByVal SourceSize As Size, ByVal FtSize As Single, ByVal DrawPage As Boolean, ByRef MorePages As Boolean, Optional ByVal Dest As String = "P")
Try
Dim pirc As New RectangleF
Dim pi As New PrintInfo
Dim sbc As nbfSQLBrowseCtrl
Dim SubSS As nbfSqlSource
Dim CRVal As String = ""
Dim CheckPages As Boolean = False
pirc.X = ev.PageBounds.X + CInt((bc.Left * PageWidth) / SourceSize.Width)
pirc.Y = CInt(curr_y) 'ev.PageBounds.Y + cint((bc.Top * PageWidth)/SourceSize.Width) + SectStart
pirc.Height = ev.PageBounds.Height - FtSize
pirc.Width = ev.PageBounds.Width
pi.PageBounds = pirc
pi.Graphics = ev.Graphics
MorePages = False
For Each sbc In rs.SectionCtrls
Select Case sbc.CtlType
Case "Report"
SubSS = GetSqSFromName(sbc.SQLSource)
If Trim(UCase(SubSS.ParentSource)) = Trim(UCase(bc.SQLSource)) Then
'reset child SQL Sources
If (Dest = "D" Or Dest = "M") Or Not sbc.PrintReqMorePages Then
ValidateSqlSource(SubSS)
End If
End If
If Dest = "D" Then
Dest = "M"
End If
PrintRepPage(CheckPages, sbc, DrawPage, pi, 0, SourceSize, Dest)
If Not CheckPages Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Case "Grid"
SubSS = GetSqSFromName(sbc.SQLSource)
If Trim(UCase(SubSS.ParentSource)) = Trim(UCase(bc.SQLSource)) Then
'reset child SQL Sources
'if not sbc.PrintReqMorePages then
ValidateSqlSource(SubSS)
'end if
End If
If Dest = "D" Then
Dest = "M"
End If
PrintSubRep(sbc, pi, SourceSize, Dest)
sbc.RecPrinted = sqs.RowsFetched
Case Else
'no action first pass
End Select
Next
For Each sbc In rs.SectionCtrls
Select Case sbc.CtlType
Case "Total"
If sbc.SQLSource = bc.SQLSource Then
CRVal = FormatTot(sqs.SqlColInfos.Item(sbc.SQLColNumber - 1), rs.SectionTotals.Item(sbc.SQLColNumber - 1).RunningTotal)
If PrintBrowseCtrl(sbc, pi, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Else
If PrintBrowseCtrl(sbc, pi, SourceSize, DrawPage, True, False, "", Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
End If
Case "Amalgum"
Dim si As nbfSubTotItem
Dim av As Decimal = 0
Dim ss As nbfSqlSource
Dim ccnt As Integer
Dim ci As nbfSqlColInfo
For Each si In sbc.SubTotList
If si.SQLSource = bc.SQLSource Then
av += rs.SectionTotals.Item(si.SQLColNumber - 1).RunningTotal
Else
For Each ss In pvBFInfo.SQLSources
If ss.BrowseTableName = si.SQLSource Then
ccnt = 0
For Each ci In ss.SqlColInfos
ccnt += 1
If ccnt = si.SQLColNumber Then
If IsNumeric(ci.CurrentValue) Then
av += CDec(ci.CurrentValue)
Exit For
End If
End If
Next
Exit For
End If
Next
End If
Next
If Not ci Is Nothing Then
CRVal = FormatTot(ci, av)
Else
CRVal = Format(av, "#,##0.00")
End If
If PrintBrowseCtrl(sbc, pi, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Case Else
If sbc.SQLSource = bc.SQLSource Then
CRVal = sqs.SqlColInfos.Item(sbc.SQLColNumber - 1).CurrentValue
If PrintBrowseCtrl(sbc, pi, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Else
If PrintBrowseCtrl(sbc, pi, SourceSize, DrawPage, True, False, "", Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
End If
End Select
Next
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub PrintSection(ByRef rs As nbfSQLRepSection, ByRef sqs As nbfSqlSource, ByRef ev As PrintInfo, ByVal SourceSize As Size, ByRef bc As nbfSQLBrowseCtrl, ByVal DrawPage As Boolean, ByRef MorePages As Boolean, Optional ByVal Dest As String = "P")
Try
Dim sbc As nbfSQLBrowseCtrl
Dim SubSS As nbfSqlSource
Dim CRVal As String = ""
Dim CheckPages As Boolean = False
MorePages = False
Dim testMorePages As Boolean = False
Dim testNoPages As Integer = 0
Dim olpt As Single = 0 ' original section lowest point
Dim clpt As Single = 0 ' original section lowest point
Dim mxlpt As Single = 0 ' original section lowest point
Dim sbfr As Single = 0
Dim DownGrowth As Boolean = False
Dim UpGrowth As Boolean = False
Dim GrowthAmt As Single = 0
Dim DownGrowthAmt As Single = 0
Dim UpGrowthAmt As Single = 0
Dim CeilingAmt As Single = 0
Dim sbc2 As nbfSQLBrowseCtrl
olpt = 0
clpt = 0
mxlpt = 0
If Dest = "D" Then
Dest = "M"
End If
'debug.WriteLine(sqs.SqlColInfos.Item(0).CurrentValue)
'if sqs.SqlColInfos.Item(0).CurrentValue = "CROWN" then
' debug.WriteLine("CROWN")
'End If
Dim tpbuf As Single = 999999999
Dim tpprbuf As Single = 999999999
For Each sbc In rs.SectionCtrls
If sbc.Top < tpbuf Then
tpbuf = sbc.Top
End If
If sbc.RecPrinted < sqs.RowsFetched Or rs.SectionType = "P" Then
If sbc.Top < tpprbuf Then
tpprbuf = sbc.Top
End If
End If
sbc.GrowthOffset = 0
sbc.StretchHeight = CSng(sbc.Height * ev.PageBounds.Height / SourceSize.Height)
If (sbc.Top + sbc.Height) > olpt Then
olpt = (sbc.Top + sbc.Height)
End If
'sbc.NextRecordPos = 1
'sbc.LastRecordTot = 0
'sbc.NextSectNo = 0
Next
sbfr = rs.SectionHeight - olpt
olpt = 0
If tpbuf < tpprbuf And tpbuf <> 999999999 And tpprbuf <> 999999999 Then
For Each sbc In rs.SectionCtrls
If sbc.RecPrinted < sqs.RowsFetched Or rs.SectionType = "P" Then
sbc.GrowthOffset = tpbuf - tpprbuf
End If
Next
End If
For Each sbc In rs.SectionCtrls
If sbc.RecPrinted < sqs.RowsFetched Or rs.SectionType = "P" Then
DownGrowth = False
UpGrowth = False
DownGrowthAmt = 0
UpGrowthAmt = 0
CeilingAmt = 0
SubSS = GetSqSFromName(sbc.SQLSource)
If Not SubSS Is Nothing Then
If Not SubSS.SQLValidated Then
ValidateSqlSource(SubSS)
End If
End If
For Each sbc2 In rs.SectionCtrls
If sbc2 Is sbc Then
Exit For
End If
If (sbc.Left + sbc.Width) >= sbc2.Left And sbc.Left <= (sbc2.Left + sbc2.Width) Then
If sbc2.RecPrinted <= sqs.RowsFetched Or rs.SectionType = "P" Then
If CSng(sbc2.Top * ev.PageBounds.Height / SourceSize.Height) + sbc2.StretchHeight > CeilingAmt Then
CeilingAmt = CSng(sbc2.Top * ev.PageBounds.Height / SourceSize.Height) + sbc2.StretchHeight
End If
Else
sbc2.StretchHeight = 0
End If
If sbc2.GrowthOffset <> 0 Or (sbc2.StretchHeight <> CSng(sbc2.Height * ev.PageBounds.Height / SourceSize.Height)) Then
GrowthAmt = sbc2.GrowthOffset + (sbc2.StretchHeight - (sbc2.Height * ev.PageBounds.Height / SourceSize.Height))
If GrowthAmt > 0 Then
DownGrowth = True
If GrowthAmt > DownGrowthAmt Then
DownGrowthAmt = GrowthAmt
End If
ElseIf GrowthAmt < 0 Then
UpGrowth = True
GrowthAmt = (-1) * GrowthAmt
If GrowthAmt > UpGrowthAmt Then
UpGrowthAmt = GrowthAmt
End If
End If
End If
End If
Next
If DownGrowth Then
sbc.GrowthOffset = DownGrowthAmt
ElseIf UpGrowth Then
If CSng(sbc.Top * ev.PageBounds.Height / SourceSize.Height) - CeilingAmt > UpGrowthAmt Then
sbc.GrowthOffset = CSng((-1) * UpGrowthAmt)
Else
sbc.GrowthOffset = CSng((-1) * ((sbc.Top * ev.PageBounds.Height / SourceSize.Height) - CeilingAmt))
End If
End If
Select Case sbc.CtlType
Case "Grid", "Report"
PrintRepPage(CheckPages, sbc, DrawPage, ev, testNoPages, SourceSize, Dest)
If Not CheckPages Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
'Case "Report"
' PrintSubRepPage(CheckPages, sbc, DrawPage, ev, testNoPages, SourceSize, Dest)
' If Not CheckPages Then
' sbc.RecPrinted = sqs.RowsFetched
' Else
' MorePages = True
' End If
Case "Total"
If sbc.SQLSource = bc.SQLSource Then
CRVal = FormatTot(sqs.SqlColInfos.Item(sbc.SQLColNumber - 1), rs.SectionTotals.Item(sbc.SQLColNumber - 1).RunningTotal)
If PrintBrowseCtrl(sbc, ev, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Else
If PrintBrowseCtrl(sbc, ev, SourceSize, DrawPage, True, False, "", Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
End If
Case "Amalgum"
Dim si As nbfSubTotItem
Dim av As Decimal = 0
Dim ss As nbfSqlSource
Dim ccnt As Integer
Dim ci As nbfSqlColInfo
For Each si In sbc.SubTotList
If si.SQLSource = bc.SQLSource Then
av += rs.SectionTotals.Item(si.SQLColNumber - 1).RunningTotal
Else
For Each ss In pvBFInfo.SQLSources
If ss.BrowseTableName = si.SQLSource Then
ccnt = 0
For Each ci In ss.SqlColInfos
ccnt += 1
If ccnt = si.SQLColNumber Then
If IsNumeric(ci.CurrentValue) Then
av += CDec(ci.CurrentValue)
Exit For
End If
End If
Next
Exit For
End If
Next
End If
Next
If Not ci Is Nothing Then
CRVal = FormatTot(ci, av)
Else
CRVal = Format(av, "#,##0.00")
End If
If PrintBrowseCtrl(sbc, ev, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Case Else
If sbc.SQLSource = bc.SQLSource Then
CRVal = sqs.SqlColInfos.Item(sbc.SQLColNumber - 1).CurrentValue
If PrintBrowseCtrl(sbc, ev, SourceSize, DrawPage, True, True, CRVal, Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
Else
If PrintBrowseCtrl(sbc, ev, SourceSize, DrawPage, True, False, "", Dest) Then
sbc.RecPrinted = sqs.RowsFetched
Else
MorePages = True
End If
End If
End Select
If (sbc.Top + sbc.Height) * ev.PageBounds.Height / SourceSize.Height > olpt Then
olpt = (sbc.Top + sbc.Height) * ev.PageBounds.Height / SourceSize.Height
End If
If ((sbc.Top * ev.PageBounds.Height) / SourceSize.Height) + sbc.StretchHeight + sbc.GrowthOffset > clpt Then
clpt = ((sbc.Top * ev.PageBounds.Height) / SourceSize.Height) + sbc.StretchHeight + sbc.GrowthOffset
End If
If clpt > mxlpt Then
mxlpt = clpt
End If
End If
Next
rs.PrintHeight = mxlpt + (sbfr * ev.PageBounds.Height / SourceSize.Height)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Function GetTotSect(ByVal bc As nbfSQLBrowseCtrl, ByVal hs As nbfSQLRepSection) As nbfSQLRepSection
Dim frs As nbfSQLRepSection
For Each frs In bc.RepSections
If frs.SectionIndex = hs.SectionIndex And frs.SectionHead = False Then
Return frs
End If
Next
Return Nothing
End Function
Public Function CheckSqlSourceExists(ByVal SourceName As String) As Boolean
Dim bc As nbfSQLBrowseCtrl
Dim ss As nbfSqlSource
If Trim(SourceName) = "" Then
MsgBox("Blank SQL Source Name")
Return True
End If
For Each ss In pvBFInfo.SQLSources
If ss.BrowseTableName = UCase(Trim(SourceName)) Then
Return True
End If
Next
For Each bc In pvBFInfo.SQLBrowseCtrls
If CheckCtrlSources(bc, SourceName) Then
Return True
End If
Next
Return False
End Function
Private Function CheckCtrlSources(ByVal bc As nbfSQLBrowseCtrl, ByVal SourceName As String) As Boolean
Dim rs As nbfSQLRepSection
Dim bc2 As nbfSQLBrowseCtrl
Dim ss As nbfSqlSource
For Each ss In bc.SQLSources
If ss.BrowseTableName = UCase(Trim(SourceName)) Then
Return True
End If
Next
For Each rs In bc.RepSections
For Each bc2 In rs.SectionCtrls
If CheckCtrlSources(bc2, SourceName) Then
Return True
End If
Next
Next
Return False
End Function
Friend Function CreateDTFromSqlSource(ByRef sqlsce As nbfSqlSource) As DataTable
Try
Dim dt As DataTable
dt = pvDBC.CreateBrowseDataTable(sqlsce.BrowseTableName, RepParams(sqlsce.SQL))
TotDataTableRows(sqlsce, dt)
Return dt
Catch ex As Exception
Return Nothing
End Try
End Function
Private Sub TotDataTableRows(ByRef sq As nbfSqlSource, ByVal dt As DataTable)
Dim myRow As DataRow
Dim myCol As DataColumn
Dim ci As nbfSqlColInfo
For Each ci In sq.SqlColInfos
ci.RunningGrandTotal = 0
Next
For Each myRow In dt.Rows
For Each myCol In dt.Columns
If myCol.DataType Is System.Type.GetType("System.Int32") _
Or myCol.DataType Is System.Type.GetType("System.Decimal") _
Then
For Each ci In sq.SqlColInfos
If ci.ColName = myCol.ColumnName Then
ci.RunningGrandTotal = ci.RunningGrandTotal + CDec(myRow.Item(myCol))
End If
Next
End If
Next myCol
Next myRow
End Sub
Private Sub SetSqsTots(ByRef sqs As nbfSqlSource)
' only called for calculating totals for non grid based result sets
Try
Dim ci As nbfSqlColInfo
Dim MoreResults As Boolean
If ValidateSqlSource(sqs) Then
Do While sqs.CurrentRowFound
For Each ci In sqs.SqlColInfos
Select Case ci.ColType
Case "T", "D"
'no totals poss
Case Else
ci.FinalGrandTotal += CDec(ci.CurrentValue)
ci.RunningGrandTotal = ci.FinalGrandTotal
End Select
Next
BufferDownRows(sqs)
Loop
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Function GetCatHead(ByVal sqs As nbfSqlSource, ByVal CatLev As Integer) As String
Try
Dim CatHead As String = ""
Dim cnt As Integer = 0
Dim scnt As Integer = 0
Dim ecnt As Integer = 0
Dim ColStr As String = ""
Dim ColVal As String = ""
Select Case CatLev
Case 1
scnt = 0
If sqs.RepBreak1Cols > 0 Then
ecnt = sqs.RepBreak1Cols - 1
Else
Return ""
End If
Case 2
scnt = sqs.RepBreak1Cols
If sqs.RepBreak2Cols > 0 Then
ecnt = sqs.RepBreak1Cols + sqs.RepBreak2Cols - 1
Else
Return ""
End If
End Select
CatHead = ""
For cnt = scnt To ecnt
If sqs.SqlColInfos.Item(cnt).ColHeader <> "" Then
ColStr = ": "
Else
ColStr = ""
End If
If sqs.SqlColInfos.Item(cnt).CurrentValue = "" Then
If ColStr = ": " Then
ColVal = "NONE"
Else
ColVal = ""
End If
Else
ColVal = sqs.SqlColInfos.Item(cnt).CurrentValue
End If
CatHead = CatHead & sqs.SqlColInfos.Item(cnt).ColHeader & ColStr & ColVal
Next
Return CatHead
Catch ex As Exception
MsgBox(ex.Message)
Return ""
End Try
End Function
Private Function GetCatCode(ByVal sqs As nbfSqlSource, ByVal CatLev As Integer, Optional ByVal Nxt As Boolean = False) As String
Try
Dim CatCode As String = ""
Dim cnt As Integer = 0
Dim scnt As Integer = 0
Dim ecnt As Integer = 0
Select Case CatLev
Case 1
scnt = 0
If sqs.RepBreak1Cols > 0 Then
ecnt = sqs.RepBreak1Cols - 1
Else
Return ""
End If
Case 2
scnt = sqs.RepBreak1Cols
If sqs.RepBreak2Cols > 0 Then
ecnt = sqs.RepBreak1Cols + sqs.RepBreak2Cols - 1
Else
Return ""
End If
End Select
CatCode = ""
If Nxt Then
For cnt = scnt To ecnt
If CatCode = "" Then
CatCode = CatCode & sqs.SqlColInfos.Item(cnt).NextValue
Else
CatCode = Trim(CatCode) & " " & sqs.SqlColInfos.Item(cnt).NextValue
End If
Next
Else
For cnt = scnt To ecnt
If CatCode = "" Then
CatCode = CatCode & sqs.SqlColInfos.Item(cnt).CurrentValue
Else
CatCode = Trim(CatCode) & " " & sqs.SqlColInfos.Item(cnt).CurrentValue
End If
Next
End If
Return CatCode
Catch ex As Exception
MsgBox(ex.Message)
Return ""
End Try
End Function
Private Function BufferDownRows(ByRef sqs As nbfSqlSource, Optional ByVal dq As nbfDB.NbfResultSet = Nothing)
Try
Dim cnt As Integer
If sqs.CurrentRowFound Then
sqs.PriorRowFound = True
For cnt = 0 To sqs.SqlColInfos.count - 1
sqs.SqlColInfos.Item(cnt).PreviousValue = sqs.SqlColInfos.Item(cnt).CurrentValue
sqs.SqlColInfos.Item(cnt).PreviousNumberValue = sqs.SqlColInfos.Item(cnt).CurrentNumberValue
sqs.SqlColInfos.Item(cnt).PreviousDateValue = sqs.SqlColInfos.Item(cnt).CurrentDateValue
Next
Else
sqs.PriorRowFound = False
End If
If sqs.NextRowFound Then
sqs.CurrentRowFound = True
For cnt = 0 To sqs.SqlColInfos.count - 1
sqs.SqlColInfos.Item(cnt).CurrentValue = sqs.SqlColInfos.Item(cnt).NextValue
sqs.SqlColInfos.Item(cnt).CurrentNumberValue = sqs.SqlColInfos.Item(cnt).NextNumberValue
sqs.SqlColInfos.Item(cnt).CurrentDateValue = sqs.SqlColInfos.Item(cnt).NextDateValue
Next
sqs.AdvanceRow()
Else
sqs.CurrentRowFound = False
sqs.AdvanceRow(True)
End If
If dq Is Nothing Then
dq = GetRSFromName(sqs.BrowseTableName)
End If
If Not dq Is Nothing Then
Debug.WriteLine(CStr(dq.rowsFetched))
If dq.fetch() Then
sqs.NextRowFound = True
GetNextFldVals(dq, sqs.SqlColInfos)
Else
sqs.NextRowFound = False
End If
End If
'dim SubSS as nbfSqlSource
'dim bc as nbfSQLBrowseCtrl
'For Each SubSS in pvBFInfo.SQLSources
' if SubSS.ParentSource = sqs.BrowseTableName and SubSS.BrowseTableName <> sqs.BrowseTableName then
' ValidateSqlSource(SubSS)
' End If
'Next
'For Each bc in pvBFInfo.SQLBrowseCtrls
' ValidateSubSources(bc,sqs.BrowseTableName)
'Next
Catch
sqs.NextRowFound = False
End Try
End Function
Private Function FormatTot(ByVal ci As nbfSqlColInfo, ByVal ctot As Decimal) As String
Dim fmtStr As String = ""
With ci
Select Case .ColType
Case "I"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Return Format(ctot, fmtStr)
Else
Return CStr(Fix(ctot))
End If
Case "Z"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
Return Format(ctot, fmtStr)
Case "X"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Return Format(ctot, fmtStr)
Else
Return Format(ctot)
End If
Case "M"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
If ctot = 0 Then
Return ""
Else
Return Format(ctot, fmtStr)
End If
Case "N"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
If ctot = 0 Then
Return ""
Else
Return Format(Fix(ctot), fmtStr)
End If
Case Else
Return CStr(ctot)
End Select
End With
End Function
Private Function GetNextFldVals(ByVal ds As nbfDB.NbfResultSet, ByVal cis As nbfSqlColInfos)
Try
Dim cnt As Integer = 0
Dim RetVal As Double
Dim fmtStr As String
Dim dtVal As Date
Dim nbVal As Double
For cnt = 1 To ds.nocols
With cis.Item(cnt - 1)
Select Case .ColType
Case "D"
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "dd-MMM-yyyy"
End If
dtVal = ds.FetchDate(cnt)
.NextDateValue = dtVal
.NextValue = Format(dtVal, fmtStr)
Case "I"
nbVal = ds.FetchDouble(cnt)
.NextNumberValue = nbVal
If .ColFormat <> "" Then
fmtStr = .ColFormat
.NextValue = Format(nbVal, fmtStr)
Else
.NextValue = CStr(Fix(nbVal))
End If
Case "Z"
nbVal = ds.FetchDouble(cnt)
.NextNumberValue = nbVal
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
.NextValue = Format(nbVal, fmtStr)
Case "X"
nbVal = ds.FetchDouble(cnt)
.NextNumberValue = nbVal
If .ColFormat <> "" Then
fmtStr = .ColFormat
.NextValue = Format(nbVal, fmtStr)
Else
.NextValue = CStr(nbVal)
End If
Case "M"
nbVal = ds.FetchDouble(cnt)
.NextNumberValue = nbVal
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
RetVal = nbVal
If RetVal = 0 Then
.NextValue = ""
Else
.NextValue = Format(RetVal, fmtStr)
End If
Case "N"
nbVal = ds.FetchDouble(cnt)
.NextNumberValue = nbVal
If .ColFormat <> "" Then
fmtStr = .ColFormat
Else
fmtStr = "#,##0.00"
End If
RetVal = Fix(nbVal)
If RetVal = 0 Then
.NextValue = ""
Else
.NextValue = Format(RetVal, fmtStr)
End If
Case Else
.NextValue = ds.FetchString(cnt)
End Select
End With
Next
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Function
Function GetRepFont(ByRef fi As FontInfo, Optional ByVal Dest As String = "P") As Font
Dim tf As Font
Dim PtHt As Decimal ' Page Height in points
Dim PixelsPerPoint As Decimal
Dim FontSizeInPixels As Decimal
Dim fntHt As Decimal
If Dest = "D" Or Dest = "M" Then
Dim gu As System.Drawing.GraphicsUnit
Dim pc As System.Drawing.Printing.PrinterUnitConvert
PtHt = (pc.Convert(pvBFInfo.PageSize.Height * 10, PrinterUnit.TenthsOfAMillimeter, PrinterUnit.ThousandthsOfAnInch) / 1000) * 72
PixelsPerPoint = pvBFInfo.FormSize.Height / PtHt
fntHt = fi.FontSize * PixelsPerPoint
Else
fntHt = fi.FontSize
End If
tf = New System.Drawing.Font(fi.FontName, fntHt)
If fi.Bold Then
tf = New System.Drawing.Font(tf, FontStyle.Bold)
End If
If fi.Italic Then
tf = New System.Drawing.Font(tf, FontStyle.Italic)
End If
If fi.Underlined Then
tf = New System.Drawing.Font(tf, FontStyle.Underline)
End If
If fi.StrikeOut Then
tf = New System.Drawing.Font(tf, FontStyle.Strikeout)
End If
Return tf
End Function
Friend Function GetDefRepFont(ByVal Serifed As Boolean, ByVal FntSize As Integer, Optional ByVal It As Boolean = False, Optional ByVal bld As Boolean = False) As FontInfo
Dim tf As Font
Dim fn As String
Dim fnt As New FontInfo
Dim DefFontFamily As System.Drawing.FontFamily
If FntSize = 0 Then
FntSize = 8
End If
If Serifed Then
tf = New System.Drawing.Font(DefFontFamily.GenericSerif, FntSize)
Else
tf = New System.Drawing.Font(DefFontFamily.GenericSansSerif, FntSize)
End If
fn = tf.Name
tf = New System.Drawing.Font(fn, FntSize)
fnt.FontName = tf.Name
fnt.FontSize = tf.Size
If tf.Bold Then
fnt.Bold = True
Else
fnt.Bold = False
End If
If tf.Italic Then
fnt.Italic = True
Else
fnt.Italic = False
End If
If tf.Underline Then
fnt.Underlined = True
Else
fnt.Underlined = False
End If
Return fnt
'with sqs
' if .RepMainHeadFont is nothing then
' .RepMainHeadFont = new System.Drawing.Font(deffontfamily.GenericSerif,12)
' end if
' if .RepSubHeadFont is nothing then
' .RepSubHeadFont = new System.Drawing.Font(deffontfamily.GenericSansSerif,11)
' end if
' if .RepBreak1HeadFont is nothing then
' .RepBreak1HeadFont = new System.Drawing.Font(deffontfamily.GenericSansSerif,10)
' end if
' if .RepBreak2HeadFont is nothing then
' .RepBreak2HeadFont = new System.Drawing.Font(deffontfamily.GenericSansSerif,9)
' end if
' if .RepNormalFont is nothing then
' .RepNormalFont = new System.Drawing.Font(deffontfamily.GenericSerif,8)
' end if
' if .RepItalicFont is nothing then
' .RepItalicFont = new System.Drawing.Font(deffontfamily.GenericSerif,8)
' .RepItalicFont = new System.Drawing.Font(.RepItalicFont,Drawing.FontStyle.Italic)
' End If
' if .RepBoldFont is nothing then
' .RepBoldFont = new System.Drawing.Font(deffontfamily.GenericSerif,8)
' .RepBoldFont = new System.Drawing.Font(.RepBoldFont,Drawing.FontStyle.Bold)
' End If
'End With
End Function
Friend Sub CheckSqlSourceFonts()
Dim sqs As nbfSqlSource
For Each sqs In pvBFInfo.SQLSources
CheckSqlSourceFontInfo(sqs)
Next
End Sub
Sub CheckSqlSourceFontInfo(ByVal sqs As nbfSqlSource)
With sqs
If .RepMainHeadFont Is Nothing Then
.RepMainHeadFont = GetDefRepFont(True, 12)
Else
If .RepMainHeadFont.FontName = "" Or .RepMainHeadFont.FontSize = 0 Then
.RepMainHeadFont = GetDefRepFont(True, 12)
End If
End If
If .RepColHeadFont Is Nothing Then
.RepColHeadFont = GetDefRepFont(True, 8)
Else
If .RepColHeadFont.FontName = "" Or .RepColHeadFont.FontSize = 0 Then
.RepColHeadFont = GetDefRepFont(True, 8)
End If
End If
If .RepSubHeadFont Is Nothing Then
.RepSubHeadFont = GetDefRepFont(False, 11)
Else
If .RepSubHeadFont.FontName = "" Or .RepSubHeadFont.FontSize = 0 Then
.RepSubHeadFont = GetDefRepFont(False, 11)
End If
End If
If .RepBreak1HeadFont Is Nothing Then
.RepBreak1HeadFont = GetDefRepFont(False, 10)
Else
If .RepBreak1HeadFont.FontName = "" Or .RepBreak1HeadFont.FontSize = 0 Then
.RepBreak1HeadFont = GetDefRepFont(False, 10)
End If
End If
If .RepBreak2HeadFont Is Nothing Then
.RepBreak2HeadFont = GetDefRepFont(False, 9)
Else
If .RepBreak2HeadFont.FontName = "" Or .RepBreak2HeadFont.FontSize = 0 Then
.RepBreak2HeadFont = GetDefRepFont(False, 9)
End If
End If
If .RepNormalFont Is Nothing Then
.RepNormalFont = GetDefRepFont(True, 8)
Else
If .RepNormalFont.FontName = "" Or .RepNormalFont.FontSize = 0 Then
.RepNormalFont = GetDefRepFont(True, 8)
End If
End If
If .RepItalicFont Is Nothing Then
.RepItalicFont = GetDefRepFont(False, 8, True)
Else
If .RepItalicFont.FontName = "" Or .RepItalicFont.FontSize = 0 Then
.RepItalicFont = GetDefRepFont(True, 8, True)
End If
End If
If .RepBoldFont Is Nothing Then
.RepBoldFont = GetDefRepFont(False, 8, False, True)
Else
If .RepBoldFont.FontName = "" Or .RepBoldFont.FontSize = 0 Then
.RepBoldFont = GetDefRepFont(True, 8, False, True)
End If
End If
End With
End Sub
Private Function GetStrFormat(ByVal ci As nbfSqlColInfo, Optional ByVal ColHead As Boolean = False) As StringFormat
Dim sf As New StringFormat
sf.LineAlignment = StringAlignment.Near
sf.FormatFlags = StringFormatFlags.NoClip
If ColHead Then
Select Case ci.ColHeadJust
Case "R"
sf.Alignment = StringAlignment.Far
Case "C"
sf.Alignment = StringAlignment.Center
Case Else
sf.Alignment = StringAlignment.Near
End Select
Else
Select Case ci.ColJust
Case "R"
sf.Alignment = StringAlignment.Far
Case "C"
sf.Alignment = StringAlignment.Center
Case Else
sf.Alignment = StringAlignment.Near
End Select
If Not ci.RepCanGrow Then
sf.FormatFlags = sf.FormatFlags Or StringFormatFlags.NoWrap
If ci.RepOverRun Then
sf.Trimming = StringTrimming.None
Else
sf.Trimming = StringTrimming.EllipsisCharacter
End If
End If
End If
Return sf
End Function
Private Function rep_string(ByVal bstr As String, ByVal dchr As String, ByVal rchr As String, Optional ByRef txtcomp As Boolean = False) As String
Dim cp As Short
Dim Start As Object
Dim spos As Short
Dim retv As String ' Declare variables.
If txtcomp Then
cp = 1
Else
cp = 0
End If
Start = InStr(1, bstr, dchr, cp) ' Find where "fox" begins.
While Not Start = 0 'InStr(spos%, rs, "'") = 0
bstr = Mid(bstr, 1, Start - 1) & rchr & Mid(bstr, Start + Len(dchr), Len(bstr))
spos = Start + Len(rchr)
Start = InStr(spos, bstr, dchr, cp)
End While
rep_string = bstr
End Function
Protected Overrides Sub Finalize()
MyBase.Finalize()
FreeConnections()
End Sub
End Class
Public Class PrintInfo
Private pvPageBounds As RectangleF
private pvGraphics as Graphics
Public Property PageBounds() As RectangleF
Get
Return pvPageBounds
End Get
Set(ByVal Value As RectangleF)
pvPageBounds = Value
End Set
End Property
Public Property Graphics() As Graphics
Get
Return pvGraphics
End Get
Set(ByVal Value As Graphics)
pvGraphics = Value
End Set
End Property
End Class
Submit an article or tip