frmmain.frm

本系统是一个报表分析查询系统

 ColsCols = tlMax + 2
 ColsRows = meRptTitle.Count + 2
 '//
 With frmCols
  '//
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  .SetSelectMode 0, 1
  .ShowPageBreak 0
  '//滚动栏信息
  .ShowHScroll 1, 0
  .ShowVScroll 0, 0
  .AllowSizeColInGrid = True
  .AllowSizeRowInGrid = True
  '//页面信息
  .PrintSetPaper 9
  .PrintSetOrient 1
  .PrintSetAlign 1, 1
  .PrintSetMargin 10, 0.5, 10, 0.5
  .WndBkColor = RGB(&HFF, &HFF, &HFF)
  '
  .SetCols ColsCols, 0
  .SetRows ColsRows, 0
  
  '//打印标题
  For iLoop = tlMin To tlMax
   .SetColWidth 1, 100, iLoop + 1, 0
   .SetCellFont iLoop + 1, 1, 0, .FindFontIndex("黑体", 1)
   .SetCellFontSize iLoop + 1, 1, 0, 11
   .SetCellAlign iLoop + 1, 1, 0, 4 + 32
   .SetCellFontStyle iLoop + 1, 1, 0, 2
   .SetCellInput iLoop + 1, 1, 0, 5
   .SetCellString iLoop + 1, 1, 0, vTl(iLoop)
   .SetCellBackColor iLoop + 1, 1, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  Next
  '//初始化字段表
  '//"标题名称|Sql 类型|文本长度|小数位数|标题宽度|对齐方式|显示标志|访问权限|标题描述|权限内码"
  For iLoop = 1 To meRptTitle.Count
   '//显示字段名称
   .SetCellString 1, iLoop + 1, 0, meRptTitle.Item(iLoop).TitleName
   .SetCellInput 1, iLoop + 1, 0, 5
   .SetCellBackColor 1, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)
   
   .SetCellString 2, iLoop + 1, 0, fID2fName(meRptTitle(iLoop).TitleTypeID)
   .SetCellInput 2, iLoop + 1, 0, 5
   .SetCellBackColor 2, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)
   
   '//
   .SetCellDouble 11, iLoop + 1, 0, meRptTitle(iLoop).TitleTypeID
   
   '//输入文本的长度
   .SetCellInput 3, iLoop + 1, 0, 3
   .SetCellDigital 3, iLoop + 1, 0, 0
   
   '//小数位数
   Select Case meRptTitle(iLoop).TitleTypeID
    Case 3, 4, 5, 6, 11, 17, 20, 128, 131, 204
     .SetCellDouble 4, iLoop + 1, 0, 2
     .SetSpinCellEx 4, iLoop + 1, 0, 1, 20, 1, 2
    Case Else
     .SetCellInput 4, iLoop + 1, 0, 5
     .SetCellBackColor 4, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)
   End Select
   
   '//标题宽度
   .SetCellInput 5, iLoop + 1, 0, 3
   .SetCellDouble 5, iLoop + 1, 0, 1200
   .SetCellDigital 5, iLoop + 1, 0, 0
      
   '//对齐方式
   Select Case meRptTitle(iLoop).TitleTypeID
    Case 3, 4, 5, 6, 11, 17, 20, 128, 131, 204
     .SetCellString 6, iLoop + 1, 0, "右对齐"
    Case Else
   End Select
   .SetDroplistCell 6, iLoop + 1, 0, AlignDesc, 4
   
   '//显示标志
   .SetDroplistCell 7, iLoop + 1, 0, ShowSign, 4
   
   '//访问权限
   .SetCellInput 8, iLoop + 1, 0, 5
   .SetCellString 8, iLoop + 1, 0, meObj.BaseInfo.getItemName(8, 1)
   .SetCellBackColor 8, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &H99), 1)
   
   '//设置默认访问
   .SetCellDouble 10, iLoop + 1, 0, 1
  Next
  .SetColHidden 10, 11
  .DrawGridLine 1, 1, ColsCols, ColsRows, 0, 2, -1
 End With
End Sub

Private Sub LoadFind()
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim tlMin As Integer
 Dim tlMax As Integer
 Dim vTl As Variant
 Dim ColsCols As Integer
 Dim ColsRows As Integer
 '//
 vTl = Split(FilStr, "|")
 tlMin = LBound(vTl)
 tlMax = UBound(vTl)
 ColsCols = tlMax + 2
 ColsRows = meColCls.Count + 2
 '//
 With frmFind
  '//
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  .SetSelectMode 0, 1
  .ShowPageBreak 0
  '//滚动栏信息
  .ShowHScroll 0, 0
  .ShowVScroll 0, 0
  .AllowSizeColInGrid = True
  .AllowSizeRowInGrid = True
  '//页面信息
  .PrintSetPaper 9
  .PrintSetOrient 1
  .PrintSetAlign 1, 1
  .PrintSetMargin 10, 0.5, 10, 0.5
  .WndBkColor = RGB(&HFF, &HFF, &HFF)
  '
  .SetCols ColsCols, 0
  .SetRows ColsRows, 0
  
  '//打印标题
  For iLoop = tlMin To tlMax
   .SetColWidth 1, 100, iLoop + 1, 0
   .SetCellFont iLoop + 1, 1, 0, .FindFontIndex("黑体", 1)
   .SetCellFontSize iLoop + 1, 1, 0, 11
   .SetCellAlign iLoop + 1, 1, 0, 4 + 32
   .SetCellFontStyle iLoop + 1, 1, 0, 2
   .SetCellInput iLoop + 1, 1, 0, 5
   .SetCellString iLoop + 1, 1, 0, vTl(iLoop)
   .SetCellBackColor iLoop + 1, 1, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  Next
'  '//初始化字段表
'  '//"标题名称|Sql 名称|Sql 类型|来源类型|来源内码"
  For iLoop = 1 To meColCls.Count
   '//显示字段名称
   .SetCellString 2, iLoop + 1, 0, meColCls.Item(iLoop).pName
   .SetCellInput 2, iLoop + 1, 0, 5
   .SetCellBackColor 2, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)

   .SetCellString 3, iLoop + 1, 0, meColCls.Item(iLoop).pType
   .SetCellInput 3, iLoop + 1, 0, 5
   .SetCellBackColor 3, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)
'
   '//访问权限
   .SetCellInput 4, iLoop + 1, 0, 5
   .SetCellBackColor 4, iLoop + 1, 0, .FindColorIndex(RGB(&HFF, &HFF, &H99), 1)
  Next
  .SetColHidden 5, 5
  .DrawGridLine 1, 1, ColsCols, ColsRows, 0, 2, -1
 End With
End Sub

'//初始化字段控制表
Private Sub LoadRptTitle()
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim ColsCols As Integer
 Dim ColsRows As Integer
 '//
 ColsCols = meRptTitle.Count + 1
 ColsRows = MaxTitleRow + 2
 '//
 With frmRptTitle
  '//
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  .SetSelectMode 0, 1
  .ShowPageBreak 0
  '//滚动栏信息
  .ShowHScroll 1, 0
  .ShowVScroll 0, 0
  .AllowSizeColInGrid = True
  .AllowSizeRowInGrid = True
  '//页面信息
  .PrintSetPaper 9
  .PrintSetOrient 1
  .PrintSetAlign 1, 1
  .PrintSetMargin 10, 0.5, 10, 0.5
  .WndBkColor = RGB(&HFF, &HFF, &HFF)
  '
  .SetCols ColsCols, 0
  .SetRows ColsRows, 0
  
  '//打印标题
  For iLoop = 1 To meRptTitle.Count
   .SetColWidth 1, 100, iLoop, 0
   .SetCellFont iLoop, 1, 0, .FindFontIndex("黑体", 1)
   .SetCellFontSize iLoop, 1, 0, 11
   .SetCellAlign iLoop, 1, 0, 4 + 32
   .SetCellFontStyle iLoop, 1, 0, 2
   .SetCellInput iLoop, 1, 0, 5
   .SetCellString iLoop, 1, 0, meRptTitle.Item(iLoop).TitleName
   .SetCellString iLoop, 2, 0, meRptTitle.Item(iLoop).TitleName '//打印默认值
   .SetCellBackColor iLoop, 1, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  Next
  For iLoop = 1 To ColsRows
   For jLoop = 1 To ColsCols
    .SetCellAlign jLoop, iLoop, 0, 4 + 32
    .SetCellNumType jLoop, iLoop, 0, 7
   Next
  Next
  .DrawGridLine 1, 1, ColsCols, ColsRows, 0, 2, -1
 End With
End Sub

'//处理报表参数表：报表组，访问权限，过滤权限，导出权限，打印权限
Private Sub frmParam_MouseDClick(ByVal col As Long, ByVal row As Long)
 Dim objGlass As Object
 Dim objGetEntry As Object
 Select Case col
  Case 2
   Select Case row
    Case 2
     Set objGlass = CreateObject("SelRptGroup.SelRptGroupCls")
     objGlass.setUserID = meObj.BaseInfo.getUserID
     objGlass.setClassID = meObj.BaseInfo.getClassID
     Call objGlass.mShow(1)
     Set objGetEntry = objGlass.getRptGroup
     If Not IsNull(objGetEntry) Then
      objRpt.Js_GroupID = objGetEntry.Js_GroupID
      objRpt.Js_GroupName = objGetEntry.Js_GroupName
      frmParam.SetCellString col, row, 0, objRpt.Js_GroupName
     End If
    Case 4
     Set objGlass = CreateObject("SelRight.SelRightCls")
     objGlass.setUserID = meObj.BaseInfo.getUserID
     objGlass.setClassID = meObj.BaseInfo.getClassID
     Call objGlass.mShow(1)
     Set objGetEntry = objGlass.getRight
     If Not IsNull(objGetEntry) Then
      objRpt.Js_RightID = objGetEntry.Js_RightID
      objRpt.Js_RightName = objGetEntry.Js_RightName
      frmParam.SetCellString col, row, 0, objRpt.Js_RightName
     End If
    Case 5
     Set objGlass = CreateObject("SelRight.SelRightCls")
     objGlass.setUserID = meObj.BaseInfo.getUserID
     objGlass.setClassID = meObj.BaseInfo.getClassID
     Call objGlass.mShow(1)
     Set objGetEntry = objGlass.getRight
     If Not IsNull(objGetEntry) Then
      objRpt.Js_FiltrateRightID = objGetEntry.Js_RightID
      objRpt.Js_FiltrateRightName = objGetEntry.Js_RightName
      frmParam.SetCellString col, row, 0, objRpt.Js_FiltrateRightName
     End If
    Case 6
     Set objGlass = CreateObject("SelRight.SelRightCls")
     objGlass.setUserID = meObj.BaseInfo.getUserID
     objGlass.setClassID = meObj.BaseInfo.getClassID
     Call objGlass.mShow(1)
     Set objGetEntry = objGlass.getRight
     If Not IsNull(objGetEntry) Then
      objRpt.Js_ExportRightID = objGetEntry.Js_RightID
      objRpt.Js_ExportRightName = objGetEntry.Js_RightName
      frmParam.SetCellString col, row, 0, objRpt.Js_ExportRightName
     End If
    Case 7
     Set objGlass = CreateObject("SelRight.SelRightCls")
     objGlass.setUserID = meObj.BaseInfo.getUserID
     objGlass.setClassID = meObj.BaseInfo.getClassID
     Call objGlass.mShow(1)
     Set objGetEntry = objGlass.getRight
     If Not IsNull(objGetEntry) Then
      objRpt.Js_PrintRightID = objGetEntry.Js_RightID
      objRpt.Js_PrintRightName = objGetEntry.Js_RightName
      frmParam.SetCellString col, row, 0, objRpt.Js_PrintRightName
     End If
    Case 8
     
     Call ReInitTable
     frmPro.Show vbModal
     frmParam.SetCellString col, row, 0, meRpt.ProName
     If Trim(meRpt.ProName) = "" Then Exit Sub
     Call InitCols
   End Select
 End Select
 Set objGetEntry = Nothing
 Set objGlass = Nothing
End Sub

Private Sub frmRptTitle_MenuStart(ByVal col As Long, ByVal row As Long, ByVal Section As Long)
 PopupMenu M_Cell
End Sub

Private Sub M_CellMrg_Click()
 '//合并单元格
 Dim sCol As Long
 Dim sRow As Long
 Dim eCol As Long
 Dim eRow As Long
 '//
 With frmRptTitle
  .GetSelectRange sCol, sRow, eCol, eRow
 '//MsgBox sCol & "::" & sRow & "::" & eCol & "::" & eRow
  .MergeCells sCol, sRow, eCol, eRow
  .SetCellAlign sCol, sRow, 0, 4 + 32
 End With
End Sub

Private Sub M_DisMrg_Click()
 '//合并单元格
 Dim sCol As Long
 Dim sRow As Long
 Dim eCol As Long
 Dim eRow As Long
 '//
 With frmRptTitle
  .GetSelectRange sCol, sRow, eCol, eRow
  .UnmergeCells sCol, sRow, eCol, eRow
 End With
End Sub

Private Sub TBar_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
 Dim MsgInfo As String
 '//
 Select Case Tool.Name
  Case "TBase"
   frmTable.Tab = 0
  Case "TTitle"
   frmTable.Tab = 1
  Case "TFeild"
   frmTable.Tab = 2
  Case "TFilt"
   frmTable.Tab = 3
  Case "TSave"
   If SaveRptData(MsgInfo) = False Then MsgBox MsgInfo, vbCritical + vbOKOnly, meObj.BaseInfo.getMsgInfo Else MsgBox MsgInfo, vbInformation + vbOKOnly, meObj.BaseInfo.getMsgInfo
  Case "TExit"
   Unload Me
 End Select
End Sub

'//保存报表数据
Private Function SaveRptData(ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 '//检测数据
 If IsValidate(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 '//打包报表基本参数
 If SaveParameter(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 '//打包报表页眉页脚
 If SaveGetHeaderFoolter(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 '//打包字段控制
 If SaveGetField(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 '//打包搜索字段数据
 If SaveGetFind(MsgInfo) = False Then
  'SaveRptData = False
  'Exit Function
 End If
 
 '//打包标题数据
 If SaveGetTitle(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 '//保存数据
 If objRpt.Save(MsgInfo) = False Then
  SaveRptData = False
  Exit Function
 End If
 
 MsgInfo = "保存报表数据成功"
 SaveRptData = True
 Exit Function
 
ErrHandle:
 MsgInfo = "保存数据错误：" & Err.Description
 SaveRptData = False
End Function

'//效验数据的正确性
Private Function IsValidate(ByRef MsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim ValStr As String
 Dim iLoop As Integer
 Dim tlMax As Integer
 '======*验证报表参数*======
 '//报表的组属
 With frmParam
  ValStr = .GetCellString2(2, 2, 0)
  If Trim(ValStr) = "" Then
   MsgInfo = "选择报表的组属"
   IsValidate = False
   Exit Function
  End If
  
  ValStr = .GetCellString2(2, 3, 0)
  If Trim(ValStr) = "" Then
   MsgInfo = "输入报表的名称"
   IsValidate = False
   Exit Function
  End If
  
  ValStr = .GetCellString2(2, 4, 0)
  If Trim(ValStr) = "" Then
   MsgInfo = "选择报表的访问权限"
   IsValidate = False
   Exit Function
  End If