📄 frmmain.frm

📁 本系统是一个报表分析查询系统
💻 FRM
📖 第 1 页 / 共 5 页
字号:
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Rpt_Feild.Ico"), &HC0C0C0
  .ToolTipText = "报表字段设置"
 End With
 '//
 Set Tool = Band.Tools.Add(4, "TFilt")
 With Tool
  .Caption = "过滤"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Find.Ico"), &HC0C0C0
  .ToolTipText = "报表过滤条件"
 End With
 '//
 Set Tool = Band.Tools.Add(5, "SplitOne")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(6, "TSave")
 With Tool
  .Caption = "保存"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Save.Ico"), &HC0C0C0
  .ToolTipText = "保存报表"
 End With
 '//
 Set Tool = Band.Tools.Add(8, "SplitTwo")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(9, "TExit")
 With Tool
  .Caption = "退出"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "Exit.Ico"), &HC0C0C0
  .ToolTipText = "退出报表管理"
 End With
 TBar.RecalcLayout
 TBar.Refresh
End Sub

'//
Private Sub LoadSBar()
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//添加用户图标
 Set Tool = SBar.Tools.Add(1, "UserImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "User.Ico")
  .Style = ddSIcon
 End With
 '//添加用户名称
 Set Tool = SBar.Tools.Add(2, "UserName")
 With Tool
  .Height = SBar.Height
  .Alignment = ddALeftCenter
  .Caption = meObj.BaseInfo.getItemName(12, meObj.BaseInfo.getUserID)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//添加主信息
 Set Tool = SBar.Tools.Add(3, "MainMsg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = "准备就绪"
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.5
 End With
 '//添加时间图形
 Set Tool = SBar.Tools.Add(4, "DateImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "Timer.Ico")
  .Style = ddSIcon
 End With
 '//添加时间值
 Set Tool = SBar.Tools.Add(5, "DateVal")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = meObj.BaseInfo.getServerDate(1)
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//
 Set Tool = SBar.Tools.Add(6, "Inst")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSInsert
 End With
 Set Band = SBar.Bands.Add("TSBar"): Band.Type = ddBTStatusBar
 With Band.Tools
  .Insert .Count, SBar.Tools("UserImg")
  .Insert .Count, SBar.Tools("UserName")
  .Insert .Count, SBar.Tools("MainMsg")
  .Insert .Count, SBar.Tools("DateImg")
  .Insert .Count, SBar.Tools("DateVal")
  .Insert .Count, SBar.Tools("Inst")
 End With
 SBar.RecalcLayout
 SBar.Refresh
End Sub

Private Sub LoadRptParam()
 Dim iLoop As Integer
 Dim RowHeight As Long
 With frmParam
  '//
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  '.SetSelectMode 0, 2
  .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 3, 0
  .SetRows 10, 0
  '//
  .SetCellFont 1, 1, 0, .FindFontIndex("黑体", 1)
  .SetCellFontSize 1, 1, 0, 11
  .SetCellAlign 1, 1, 0, 4 + 32
  .SetCellFontStyle 1, 1, 0, 2
  .SetCellInput 1, 1, 0, 5
  '//
  .SetCellString 1, 1, 0, "项目名称"
  .SetCellFont 2, 1, 0, .FindFontIndex("黑体", 1)
  .SetCellFontSize 2, 1, 0, 11
  .SetCellAlign 2, 1, 0, 4 + 32
  .SetCellFontStyle 2, 1, 0, 2
  .SetCellInput 2, 1, 0, 5
  .SetCellBackColor 1, 1, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  '//
  .SetCellString 2, 1, 0, "项目数据"
  .SetColWidth 0, .Width * 0.04, 1, 0
  .SetColWidth 0, .Width * 0.11, 2, 0
  .SetCellBackColor 2, 1, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  '//显示上级分组
  .SetCellString 1, 2, 0, "报表组属："
  .SetCellAlign 1, 2, 0, 2 + 32
  .SetCellInput 1, 2, 0, 5
  .SetCellFontStyle 1, 2, 0, 2
  .SetCellInput 2, 2, 0, 5
  .SetCellBackColor 2, 2, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 2, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  objRpt.Js_GroupID = 1
  objRpt.Js_GroupName = meObj.BaseInfo.getItemName(10, 1)
  .SetCellString 2, 2, 0, objRpt.Js_GroupName

  .SetCellString 1, 3, 0, "报表名称："
  .SetCellAlign 1, 3, 0, 2 + 32
  .SetCellInput 1, 3, 0, 5
  .SetCellFontStyle 1, 3, 0, 2
  .SetCellBackColor 1, 3, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)

  .SetCellString 1, 4, 0, "访问权限："
  .SetCellAlign 1, 4, 0, 2 + 8
  .SetCellInput 1, 4, 0, 5
  .SetCellFontStyle 1, 4, 0, 2
  .SetCellInput 2, 4, 0, 5
  .SetCellBackColor 2, 4, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 4, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  objRpt.Js_RightID = 1
  objRpt.Js_RightName = meObj.BaseInfo.getItemName(8, 1)
  .SetCellString 2, 4, 0, objRpt.Js_RightName

  .SetCellString 1, 5, 0, "过滤权限："
  .SetCellAlign 1, 5, 0, 2 + 32
  .SetCellInput 1, 5, 0, 5
  .SetCellFontStyle 1, 5, 0, 2
  .SetCellInput 2, 5, 0, 5
  .SetCellBackColor 2, 5, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 5, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  objRpt.Js_FiltrateRightID = 1
  objRpt.Js_FiltrateRightName = meObj.BaseInfo.getItemName(8, 1)
  .SetCellString 2, 5, 0, objRpt.Js_FiltrateRightName

  .SetCellString 1, 6, 0, "导出权限："
  .SetCellAlign 1, 6, 0, 2 + 32
  .SetCellInput 1, 6, 0, 5
  .SetCellFontStyle 1, 6, 0, 2
  .SetCellInput 2, 6, 0, 5
  .SetCellBackColor 2, 6, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 6, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  objRpt.Js_ExportRightID = 1
  objRpt.Js_ExportRightName = meObj.BaseInfo.getItemName(8, 1)
  .SetCellString 2, 6, 0, objRpt.Js_ExportRightName

  .SetCellString 1, 7, 0, "打印权限："
  .SetCellAlign 1, 7, 0, 2 + 8
  .SetCellInput 1, 7, 0, 5
  .SetCellFontStyle 1, 7, 0, 2
  .SetCellInput 2, 7, 0, 5
  .SetCellBackColor 2, 7, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 7, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  objRpt.Js_PrintRightID = 1
  objRpt.Js_PrintRightName = meObj.BaseInfo.getItemName(8, 1)
  .SetCellString 2, 7, 0, objRpt.Js_PrintRightName

  .SetCellString 1, 8, 0, "报表程序："
  .SetCellAlign 1, 8, 0, 2 + 32
  .SetCellInput 1, 8, 0, 5
  .SetCellFontStyle 1, 8, 0, 2
  '//.SetDroplistCell 2, 8, 0, getProcList(), 4
  '//.SetCellBackColor 1, 8, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  .SetCellInput 2, 8, 0, 5
  .SetCellBackColor 2, 8, 0, .FindColorIndex(RGB(&HFF, &HFF, &HFF), 1)
  .SetCellBackColor 1, 8, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  

  .SetCellString 1, 9, 0, "报表描述："
  .SetCellAlign 1, 9, 0, 2 + 8
  .SetCellInput 1, 9, 0, 5
  .SetCellFontStyle 1, 9, 0, 2
  .SetCellTextStyle 2, 9, 0, 2
  .SetCellAlign 2, 9, 0, 1 + 8
  .SetCellBackColor 1, 9, 0, .FindColorIndex(RGB(&HED, &HF5, &HFE), 1)
  .SetRowHeight 1, .GetRowHeight(1, 2, 0) * 20, 9, 0
  
  For iLoop = 2 To 9
   .SetCellNumType 2, iLoop, 0, 7
  Next
  .MoveToCell 2, 2
 End With
End Sub

Private Sub LoadHeadFooter()
 Dim iLoop As Integer
 With frmHeadFooterText
  '//
  .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 2, 0
  .SetRows 16, 0
  .SetColWidth 1, 900, 1, 0
  '//
  For iLoop = 1 To 20
   .SetCellNumType 2, iLoop, 0, 7
  Next
  .ProtectSheet 0, "9681161488"
 End With
End Sub

Private Sub Form_Load()
 Call formInit
 Call LoadTBar
 Call LoadSBar
 Call LoadRptParam
 Call LoadHeadFooter
 frmTable.Tab = 0
 frmHfAdd.Enabled = False
 '//
 If eRptID > 0 Then
  Call loadData
 End If
 '//
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Set ImgStd = Nothing
  Set objRpt = Nothing
End Sub

Private Sub frmCols_MouseDClick(ByVal col As Long, ByVal row As Long)
 Select Case col
  Case 8
    Dim objGlass As Object
    Dim objGetEntry As Object
    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
     frmCols.SetCellDouble 10, row, 0, objGetEntry.Js_RightID
     frmCols.SetCellString col, row, 0, objGetEntry.Js_RightName
    End If
    Set objGetEntry = Nothing
    Set objGlass = Nothing
 End Select
End Sub

Private Sub frmFind_MouseDClick(ByVal col As Long, ByVal row As Long)
 If col = 4 Then
  frmType.Show vbModal
  frmFind.SetCellString 4, row, 0, meRpt.FieldName
  frmFind.SetCellDouble 5, row, 0, meRpt.FieldID
 End If
End Sub

Private Sub frmFooterContent_Change()
 meRpt.hOper.Text = frmFooterContent.Text
 meRpt.hOper.Header = False
 meRpt.hOper.Footer = True
 frmHfAdd.Enabled = True
End Sub

Private Sub frmHeadContent_Change()
 meRpt.hOper.Text = frmHeadContent.Text
 meRpt.hOper.Header = True
 meRpt.hOper.Footer = False
 frmHfAdd.Enabled = True
End Sub

Private Sub frmHeadFooterText_MouseLClick(ByVal col As Long, ByVal row As Long, ByVal updn As Long)
 meRpt.hOper.SelRow = row
 If row < 8 Then
  frmHeadContent.Text = frmHeadFooterText.GetCellString2(1, row, 0)
 Else
  frmFooterContent.Text = frmHeadFooterText.GetCellString2(1, row, 0)
 End If
End Sub

Private Sub frmHfAdd_Click()
 Call getHfRow
 frmHeadFooterText.SetCellString 1, meRpt.hOper.CurRow, 0, meRpt.hOper.Text
 frmHfAdd.Enabled = False
End Sub

Private Sub frmHfDel_Click()
 frmHeadFooterText.SetCellString 1, meRpt.hOper.SelRow, 0, ""
End Sub

Private Sub frmHfFont_Click()
 '//打开字体对话框
 frmFontDiag.Flags = cdlCFBoth
 frmFontDiag.ShowFont
 With frmFontDiag
  meFont.Name = .FontName
  meFont.Size = .FontSize
  If .FontBold = True Then meFont.Bold = 2 Else meFont.Bold = 0
  If .FontItalic = True Then meFont.Italic = 4 Else meFont.Italic = 0
  If .FontStrikethru = True Then meFont.Strikethru = 16 Else meFont.Strikethru = 0
  If .FontUnderline = True Then meFont.Underline = 8 Else meFont.Underline = 0
 End With
 With frmHeadFooterText
  .SetCellFontSize 1, meRpt.hOper.SelRow, 0, meFont.Size
  .SetCellFontStyle 1, meRpt.hOper.SelRow, 0, meFont.Bold + meFont.Italic + meFont.Strikethru + meFont.Underline
  .SetCellFont 1, meRpt.hOper.SelRow, 0, .FindFontIndex(meFont.Name, 1)
  .SetRowHeight 1, .GetRowBestHeight(meRpt.hOper.SelRow), meRpt.hOper.SelRow, 0
 End With
End Sub

Private Sub InitCols()
 Dim iLoop As Integer
 Dim ProName As String
 If meColCls.Count > 0 Then
  For iLoop = meColCls.Count To 1 Step -1
   meColCls.Remove iLoop
  Next
 End If
 ProName = Trim(frmParam.GetCellString(2, 8, 0))
 Call getProInfo(ProName)
 Call getColsInfo(ProName)
 Call LoadCols
 Call LoadFind
 Call LoadRptTitle
End Sub

'//初始化字段控制表
Private Sub LoadCols()
 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(TitleStr, "|")
 tlMin = LBound(vTl)
 tlMax = UBound(vTl)
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -