📄 frmmain.frm
字号:
ValStr = .GetCellString2(2, 5, 0)
If Trim(ValStr) = "" Then
MsgInfo = "选择报表的过滤权限"
IsValidate = False
Exit Function
End If
ValStr = .GetCellString2(2, 6, 0)
If Trim(ValStr) = "" Then
MsgInfo = "选择报表的导出权限"
IsValidate = False
Exit Function
End If
ValStr = .GetCellString2(2, 7, 0)
If Trim(ValStr) = "" Then
MsgInfo = "选择报表的打印权限"
IsValidate = False
Exit Function
End If
ValStr = .GetCellString2(2, 8, 0)
If Trim(ValStr) = "" Then
MsgInfo = "选择报表的执行程序"
IsValidate = False
Exit Function
End If
End With
'======*验证报表字段*======
With frmCols
tlMax = .GetRows(0)
For iLoop = 2 To tlMax - 1
'//列宽
If .GetCellDouble2(5, iLoop, 0) = 0 Then
frmTable.Tab = 2
MsgInfo = "输入本例的宽度"
IsValidate = False
Exit Function
End If
'//权限
If Trim(.GetCellString2(8, iLoop, 0)) = "" Then
frmTable.Tab = 2
MsgInfo = "选择本字段的访问权限"
IsValidate = False
Exit Function
End If
Next
End With
MsgInfo = "数据输入正确"
IsValidate = True
Exit Function
ErrHandle:
MsgInfo = "错误：" & Err.Description
IsValidate = False
End Function
'//扫描参数表，打包报表其他参数
Private Function SaveParameter(ByRef MsgInfo As String) As Boolean
On Error GoTo ErrHandle
With objRpt
'//报表内码
If .Js_RptID = 0 Then
.Js_RptID = meObj.BaseInfo.getItemID(9)
.Js_GroupID = .Js_GroupID
.Js_RptName = Trim(frmParam.GetCellString2(2, 3, 0))
.Js_RptDesc = Trim(frmParam.GetCellString2(2, 9, 0))
.Js_RptCallName = Trim(frmParam.GetCellString2(2, 8, 0))
.Js_RptWidth = 0 '//保留：
.Js_RptHeight = 0 '//保留
.Js_RightID = .Js_RightID
.Js_FiltrateRightID = .Js_FiltrateRightID
.Js_ExportRightID = .Js_ExportRightID
.Js_PrintRightID = .Js_PrintRightID
.Js_UserID = meObj.BaseInfo.getUserID
.Js_Date = meObj.BaseInfo.getServerDate(1)
.Js_Time = meObj.BaseInfo.getServerDate(2)
Else
.Js_RptID = .Js_RptID
.Js_GroupID = .Js_GroupID
.Js_RptName = Trim(frmParam.GetCellString2(2, 3, 0))
.Js_RptDesc = Trim(frmParam.GetCellString2(2, 9, 0))
.Js_RptCallName = Trim(frmParam.GetCellString2(2, 8, 0))
.Js_RptWidth = 0 '//保留：
.Js_RptHeight = 0 '//保留
.Js_RightID = .Js_RightID
.Js_FiltrateRightID = .Js_FiltrateRightID
.Js_ExportRightID = .Js_ExportRightID
.Js_PrintRightID = .Js_PrintRightID
.Js_UserID = .Js_UserID
.Js_Date = .Js_Date
.Js_Time = .Js_Time
End If
'//MsgBox .Js_RptID & "::" & .Js_GroupID & "::" & .Js_RptName & "::" & .Js_RptDesc & "::" & .Js_RptCallName & "::" & .Js_RptWidth & "::" & .Js_RptHeight & "::" & .Js_RightID & "::" & .Js_FiltrateRightID & "::" & .Js_ExportRightID & "::" & .Js_PrintRightID & "::" & .Js_UserID & "::" & .Js_Date & "::" & .Js_Time
End With
MsgInfo = "打包报表参数成功"
SaveParameter = True
Exit Function
ErrHandle:
MsgInfo = "打包数据错误：" & Err.Description
SaveParameter = True
End Function
'//扫描页眉页脚表，打包页眉页脚数据
Private Function SaveGetHeaderFoolter(ByRef MsgInfo As String) As Boolean
On Error GoTo ErrHandle
Dim iLoop As Integer
Dim jLoop As Integer
Dim FInterID As Long
Dim ValStr As String
Dim FontStVal As Long
Dim entryObj As Object
jLoop = 0
FInterID = 0
If objRpt.hBill.Count > 0 Then
Call objRpt.hRemove
End If
'//处理页眉
For iLoop = 1 To 7
ValStr = Trim(frmHeadFooterText.GetCellString2(1, iLoop, 0))
If ValStr <> "" Then
jLoop = jLoop + 1
Set entryObj = CreateObject("StdRptBase.HeaderFooter")
With entryObj
'//页眉页脚内码
If FInterID = 0 Then
.Js_HeaderFooterID = meObj.BaseInfo.getItemID(5)
FInterID = .Js_HeaderFooterID
Else
FInterID = FInterID + 1
.Js_HeaderFooterID = FInterID
End If
'//关联报表
.Js_RptID = objRpt.Js_RptID
'//页眉页脚类型内码
.Js_hfTypeID = 1 '//页眉
'//内容名称
.Js_hfText = ValStr
'//字段名称
.Js_hfFontName = frmHeadFooterText.GetFontName(frmHeadFooterText.GetCellFont(1, iLoop, 0))
'//字体大小
.Js_hfFontSize = frmHeadFooterText.GetCellFontSize(1, iLoop, 0)
'//字体风格
FontStVal = frmHeadFooterText.GetCellFontStyle(1, iLoop, 0)
Select Case FontStVal
Case 2
.Js_hfFontBold = 1
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 0
Case 4
.Js_hfFontBold = 0
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 0
Case 8
.Js_hfFontBold = 0
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 1
Case 6
.Js_hfFontBold = 1
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 0
Case 10
.Js_hfFontBold = 1
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 1
Case 12
.Js_hfFontBold = 0
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 1
Case 14
.Js_hfFontBold = 1
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 1
End Select
.Js_HeaderFooterOrderID = jLoop
End With
objRpt.hBill.Add entryObj
Set entryObj = Nothing
End If
Next
For iLoop = 9 To 15
ValStr = Trim(frmHeadFooterText.GetCellString2(1, iLoop, 0))
If ValStr <> "" Then
jLoop = jLoop + 1
Set entryObj = CreateObject("StdRptBase.HeaderFooter")
With entryObj
'//页眉页脚内码
If FInterID = 0 Then
.Js_HeaderFooterID = meObj.BaseInfo.getItemID(5)
FInterID = .Js_HeaderFooterID
Else
FInterID = FInterID + 1
.Js_HeaderFooterID = FInterID
End If
'//关联报表
.Js_RptID = objRpt.Js_RptID
'//页眉页脚类型内码
.Js_hfTypeID = 2 '//页脚
'//内容名称
.Js_hfText = ValStr
'//字段名称
.Js_hfFontName = frmHeadFooterText.GetFontName(frmHeadFooterText.GetCellFont(1, iLoop, 0))
'//字体大小
.Js_hfFontSize = frmHeadFooterText.GetCellFontSize(1, iLoop, 0)
'//字体风格
FontStVal = frmHeadFooterText.GetCellFontStyle(1, iLoop, 0)
Select Case FontStVal
Case 2
.Js_hfFontBold = 1
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 0
Case 4
.Js_hfFontBold = 0
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 0
Case 8
.Js_hfFontBold = 0
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 1
Case 6
.Js_hfFontBold = 1
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 0
Case 10
.Js_hfFontBold = 1
.Js_hfFontItalic = 0
.Js_hfFontUnderline = 1
Case 12
.Js_hfFontBold = 0
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 1
Case 14
.Js_hfFontBold = 1
.Js_hfFontItalic = 1
.Js_hfFontUnderline = 1
End Select
.Js_HeaderFooterOrderID = jLoop
End With
objRpt.hBill.Add entryObj
Set entryObj = Nothing
End If
Next
MsgInfo = "打包页眉页脚数据成功"
SaveGetHeaderFoolter = True
Exit Function
ErrHandle:
MsgInfo = "打包页眉页脚数据失败：" & Err.Description
SaveGetHeaderFoolter = False
' For iLoop = 1 To objRpt.hBill.Count
' With objRpt.hBill.Item(iLoop)
' MsgBox .Js_HeaderFooterID & "::" & .Js_RptID & "::" & .Js_hfTypeID & "::" & .Js_hfText & "::" & .Js_hfFontName & "::" & .Js_hfFontSize & "::" & .Js_hfFontBold & "::" & .Js_hfFontItalic & "::" & .Js_hfFontUnderline & "::" & .Js_HeaderFooterOrderID
' End With
' Next
End Function
'//扫描字段控制表，打包数据控制
Private Function SaveGetField(ByRef MsgInfo As String) As Boolean
On Error GoTo ErrHandle
Dim iLoop As Integer
Dim jLoop As Integer
Dim FInterID As Long
Dim tlMin As Integer
Dim tlMax As Integer
Dim ValStr As String
Dim entryObj As Object
If objRpt.fBill.Count > 0 Then
Call objRpt.fRemove
End If
jLoop = 0
tlMin = 2
tlMax = frmCols.GetRows(0) - 1
With frmCols
For iLoop = tlMin To tlMax
jLoop = jLoop + 1
Set entryObj = CreateObject("StdRptBase.FieldControl")
With entryObj
'//计算字段内码
If FInterID = 0 Then
.Js_FieldControlID = meObj.BaseInfo.getItemID(2)
FInterID = .Js_FieldControlID
Else
FInterID = FInterID + 1
.Js_FieldControlID = FInterID
End If
'//报表关联
.Js_RptID = objRpt.Js_RptID
'//字段名称
.Js_FieldName = frmCols.GetCellString2(1, iLoop, 0)
'//保留字段:字段类型码
.Js_FieldDsecID = frmCols.GetCellDouble2(11, iLoop, 0)
'//保留字段
.Js_FieldDsec = ""
'//字段内容长的
.Js_FieldLen = frmCols.GetCellDouble2(3, iLoop, 0)
'//字段宽度
.Js_FieldWidth = frmCols.GetCellDouble2(5, iLoop, 0)
'//字段对齐方式
.Js_FieldAlign = getCellAlign(Trim(frmCols.GetCellString2(6, iLoop, 0)))
'//显示标志
.Js_FieldShowSign = getShowSign(Trim(frmCols.GetCellString2(7, iLoop, 0)))
'//权限内码
.Js_RightID = frmCols.GetCellDouble2(10, iLoop, 0)
'//顺序
.Js_FieldOrderID = jLoop
'//小数位
.Js_FieldOrderSign = frmCols.GetCellDouble2(4, iLoop, 0)
End With
objRpt.fBill.Add entryObj
Set entryObj = Nothing
Next
End With
MsgInfo = "打包字段数据成功"
SaveGetField = True
Exit Function
ErrHandle:
MsgInfo = "打包字段数据错误：" & Err.Description
SaveGetField = False
'//
' For iLoop = 1 To objRpt.fbill.Count
' With objRpt.fbill.Item(iLoop)
' MsgBox .Js_FieldControlID & "::" & .Js_RptID & "::" & .Js_FieldName & "::" & .Js_FieldDsecID & "::" & .Js_FieldDsec & "::" & .Js_FieldLen & "::" & .Js_FieldWidth & "::" & .Js_FieldAlign & "::" & .Js_FieldShowSign & "::" & .Js_RightID & "::" & .Js_FieldOrderID & "::" & .Js_FieldOrderSign
' End With
' Next
End Function
'//扫描过滤条件，打包过滤条件数据
Private Function SaveGetFind(ByRef MsgInfo As String) As Boolean
On Error GoTo ErrHandle
Dim iLoop As Integer
Dim jLoop As Integer
Dim tlMin As Integer
Dim tlMax As Integer
Dim CellValue As String
Dim FInterID As Long
Dim entryObj As Object
If objRpt.lBill.Count > 0 Then
Call objRpt.lRemove
End If
jLoop = 0
tlMin = 2
tlMax = frmFind.GetRows(0) - 1
With frmFind
For iLoop = tlMin To tlMax
CellValue = Trim(.GetCellString2(1, iLoop, 0))
If CellValue <> "" Then
jLoop = iLoop - 1
Set entryObj = CreateObject("StdRptBase.Filt")
With entryObj
'//计算搜索条件内码
If FInterID = 0 Then
.Js_FiltID = meObj.BaseInfo.getItemID(4)
FInterID = .Js_FiltID
Else
FInterID = FInterID + 1
.Js_FiltID = FInterID
End If
'//报表内码
.Js_RptID = objRpt.Js_RptID
'//控件内码
.Js_FieldControlID = frmFind.GetCellDouble2(5, iLoop, 0)
'//保留字段
.Js_LinkSign = 0
'//标题描述
.Js_Desc = CellValue
'//顺序
.Js_OrderID = jLoop
End With
objRpt.lBill.Add entryObj
Set entryObj = Nothing
End If
Next
End With
MsgInfo = "打包搜索条件成功"
SaveGetFind = True
Exit Function
ErrHandle:
MsgInfo = "打包搜索条件错误：" & Err.Description
SaveGetFind = False
' For iLoop = 1 To objRpt.lBill.Count
' MsgBox objRpt.lBill.Item(iLoop).Js_FiltID & "::" & objRpt.lBill.Item(iLoop).Js_Desc & "::" & objRpt.lBill.Item(iLoop).Js_FieldControlID & "::" & objRpt.lBill.Item(iLoop).Js_OrderID
' Next
End Function
'//扫描标题表，打包标题数据
Private Function SaveGetTitle(ByRef MsgInfo As String) As Boolean
On Error GoTo ErrHandle
Dim iLoop As Integer
Dim jLoop As Integer
Dim FInterID As Long
Dim CellRange As Long
Dim entryObj As Object
'//
If objRpt.tBill.Count > 0 Then
Call objRpt.tRemove
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -