filtratefrm.frm

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

VERSION 5.00
Object = "{7802D41A-28B0-43C4-95EA-17B7E32337D1}#1.0#0"; "CellCtrl5.ocx"
Object = "{7DB16ABC-EB77-4367-ABFC-A99311A23C80}#3.0#0"; "Office2007Top.ocx"
Begin VB.Form FiltrateFrm 
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   4080
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4995
   LinkTopic       =   "Form1"
   ScaleHeight     =   4080
   ScaleWidth      =   4995
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin CELL50Lib.Cell frmCell 
      Height          =   2415
      Left            =   120
      TabIndex        =   1
      Top             =   840
      Width           =   4695
      _Version        =   65536
      _ExtentX        =   8281
      _ExtentY        =   4260
      _StockProps     =   0
   End
   Begin Office2007Top.ACPRibbon TBar 
      Height          =   600
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   4995
      _ExtentX        =   8811
      _ExtentY        =   1058
   End
End
Attribute VB_Name = "FiltrateFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private imgPath As String
Private imgStd As StdPicture

Private Sub Form_Load()
 imgPath = App.Path & "\ResLib\"
 Call getProInfo(meRpt.Js_RptCallName)
 Call LoadTBar
 Call LoadCell
End Sub

'//装载工具栏
Private Sub LoadTBar()
 With TBar
  .Left = 0
  .Top = 0
  .Width = Me.ScaleWidth
  .Caption = "过滤"
  Set imgStd = LoadPicture(imgPath & "Find.Ico")
  Set .Picture = imgStd
  .ShowCustomMenu = False
  Set imgStd = LoadPicture(imgPath & "Check.Ico")
  .AddTopButton "001", "确认", imgStd
  Set imgStd = LoadPicture(imgPath & "Exit.Ico")
  .AddTopButton "002", "关闭", imgStd
 End With
End Sub

'//装载单据格式
Private Sub LoadCell()
   '//基本信息
 Dim iLoop As Integer
 With frmCell
  .Left = 0
  .Width = Me.ScaleWidth
  .Top = TBar.Top + TBar.Height
  .Height = Me.ScaleHeight - .Top
  '//扩展信息
  .ShowTopLabel 0, 0
  .ShowSideLabel 0, 0
  .ShowSheetLabel 0, 0
  '//.SetSelectMode 0, 2
  .ShowPageBreak 0
  '//滚动栏信息
  .ShowHScroll 0, 0
  .ShowVScroll 1, 0
  '//页面信息
  .PrintSetPaper 9
  .PrintSetOrient 0
  .PrintSetAlign 1, 1
  .PrintSetMargin 10, 0.5, 10, 0.5
  '//
  .SetRows meRpt.lBill.Count + 1, 0
  .SetCols 5, 0
  '//
  .SetColWidth 1, 80, 1, 0
  .SetColWidth 1, 150, 2, 0
  '//
  For iLoop = 1 To meRpt.lBill.Count
   .SetCellString 1, iLoop, 0, meRpt.lBill.Item(iLoop).Js_Desc
   .SetCellAlign 1, iLoop, 0, 2 + 32
   .SetCellInput 1, iLoop, 0, 5
   .SetCellBackColor 1, iLoop, 0, .FindColorIndex(RGB(&HFF, &HFF, &HCC), 1)
   '//
   .SetCellAlign 2, iLoop, 0, 1 + 32
   Select Case meRpt.lBill.Item(iLoop).Js_FieldControlID
    Case 1 '//字符串
     .SetCellNumType 2, iLoop, 0, 7
    Case 2 '//数值
     .SetCellInput 2, iLoop, 0, 2
     .SetCellNumType 1, iLoop, 0, 2
    Case 3 '//日期
     .SetCellNumType 2, iLoop, 0, 3
     .SetCellDateStyle 2, iLoop, 0, 22
     .SetCellDateTime 2, iLoop, 0, meObj.BaseInfo.getServerDate(1)
    Case Else '// 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 '//控件类型
     .SetCellInput 2, iLoop, 0, 5
     .SetCellBackColor 2, iLoop, 0, .FindColorIndex(RGB(&HFF, &HFF, &H99), 1)
   End Select
   '//
   .SetCellDouble 3, iLoop, 0, meRpt.lBill.Item(iLoop).Js_FieldControlID
   .SetCellDouble 4, iLoop, 0, meRpt.lBill.Item(iLoop).Js_OrderID
  Next
  .SetColHidden 3, 4
 End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
  ExeSign = CmdExeSign
End Sub

Private Sub frmCell_MouseDClick(ByVal col As Long, ByVal row As Long)
 '//判断登录类型
 Dim lgID As String
 Dim AxID As Long
 Dim mGLView As Object
 Dim retcol As Object
 lgID = meObj.BaseInfo.getLoginID
 AxID = frmCell.GetCellDouble2(3, row, 0)
 Select Case lgID
  Case "1"  '//系统
   Select Case AxID
    Case 4 '//系统用户
     Set mGLView = CreateObject("SelUser.SelUserCls")
     mGLView.setUserID = meObj.BaseInfo.getUserID
     mGLView.setClassID = meObj.BaseInfo.getClassID
     Call mGLView.mShow(1)
     Set retcol = mGLView.getUser
     If Not IsNull(retcol) Then
      frmCell.SetCellString col, row, 0, retcol.Js_UserName
     End If
    Case Else
     Exit Sub
   End Select
  Case "2"  '//金蝶
   Select Case AxID
    Case 1
     Exit Sub
    Case 2
     Exit Sub
    Case 3
     Exit Sub
    Case 4 '//系统用户
     Set mGLView = CreateObject("SelUser.SelUserCls")
     mGLView.setUserID = meObj.BaseInfo.getUserID
     mGLView.setClassID = meObj.BaseInfo.getClassID
     Call mGLView.mShow(1)
     Set retcol = mGLView.getUser
     If Not IsNull(retcol) Then
      frmCell.SetCellString col, row, 0, retcol.Js_UserName
     End If
    Case 5, 6, 7, 8, 9, 10, 11, 12, 13, 14
     Set mGLView = CreateObject("EBCGLView.GLView")
     Set retcol = mGLView.ItemLookup(getDataSrID(AxID))
     If retcol.ReturnOK Then
      frmCell.SetCellString col, row, 0, retcol.ReturnObject.Number
     End If
    Case 15
     Set mGLView = CreateObject("EBCGLView.GLView")
     Set retcol = mGLView.ItemLookup(getDataSrID(AxID))
     If retcol.ReturnOK Then
      frmCell.SetCellString col, row, 0, retcol.ReturnObject.Name
     End If
    Case Else
     Set mGLView = CreateObject("EBCGLView.GLView")
     Set retcol = mGLView.ItemLookup(getDataSrID(AxID))
     If retcol.ReturnOK Then
      frmCell.SetCellString col, row, 0, retcol.ReturnObject.Number
     End If
   End Select
 End Select
 Set retcol = Nothing
 Set mGLView = Nothing
End Sub

'//获取搜索表格数据
Private Sub getCellData(ByRef oName As String, ByRef oVal As String, ByVal iOrder As Long)
 Dim iLoop As Integer
 Dim iMax As Integer
 iMax = frmCell.GetRows(0) - 1
 oName = ""
 oVal = ""
 For iLoop = 1 To iMax
  If iOrder = frmCell.GetCellDouble2(4, iLoop, 0) Then
   oName = Trim(frmCell.GetCellString2(1, iLoop, 0))
   oVal = Trim(frmCell.GetCellString2(2, iLoop, 0))
   Exit Sub
  End If
 Next
End Sub

'//获取条件
Private Sub getSearchSql()
 Dim iLoop As Integer
 Dim jLoop As Integer
 Dim fName As String
 Dim fVal As String
 Dim fndObj As RptFilter
 Dim tempVal As String
 Dim StrParam As String
 Dim VParam As Variant
 Dim StrItem As String
 '//
 If meFilter.Count > 0 Then
  For iLoop = meFilter.Count To 1 Step -1
   meFilter.Remove iLoop
  Next
 End If
 '//
 If meColCls.Count > 0 Then
  StrParam = meObj.BaseInfo.getDefalut(meRpt.Js_RptCallName)
  VParam = Split(StrParam, "|")
  
  Crp.ExecSql = "exec " & meRpt.Js_RptCallName & " "
  For iLoop = 1 To meColCls.Count
   StrItem = VParam(iLoop - 1)
   StrItem = Replace(StrItem, "'", "")
   StrItem = Replace(StrItem, ",", "")
   Call getCellData(fName, fVal, iLoop)
   '//MsgBox fName & "::" & fVal
   If Trim(fVal) <> "" Then
    Set fndObj = New RptFilter
    With fndObj
     .OrderID = iLoop
     .Title = fName
     .ValStr = fVal
    End With
    meFilter.Add fndObj
    Set fndObj = Nothing
    '//
    If Trim(fVal) <> "" Then
     Select Case meColCls.Item(iLoop).pType
      Case "int", "decimal", "money", "numeric", "real", "smallint", "smallmoney", "tinyint", "varbinary", "bigint", "binary", "bit", "float"
       Crp.ExecSql = Crp.ExecSql & " " & Trim(fVal) & ","
      Case "nvarchar", "varchar", "char", "datetime", "nchar", "sql_variant"
       Crp.ExecSql = Crp.ExecSql & " '" & Trim(fVal) & "',"
     End Select
    Else
     Select Case meColCls.Item(iLoop).pType
      Case "int", "decimal", "money", "numeric", "real", "smallint", "smallmoney", "tinyint", "varbinary", "bigint", "binary", "bit", "float"
       If StrItem = "" Then
        Crp.ExecSql = Crp.ExecSql & " " & 0 & ","
       Else
        Crp.ExecSql = Crp.ExecSql & " " & Trim(StrItem) & ","
       End If
      Case "nvarchar", "varchar", "char", "datetime", "nchar", "sql_variant"
       Crp.ExecSql = Crp.ExecSql & " '" & Trim(StrItem) & "',"
     End Select
    End If
   Else
     Select Case meColCls.Item(iLoop).pType
      Case "int", "decimal", "money", "numeric", "real", "smallint", "smallmoney", "tinyint", "varbinary", "bigint", "binary", "bit", "float"
       If StrItem = "" Then
        Crp.ExecSql = Crp.ExecSql & " " & 0 & ","
       Else
        Crp.ExecSql = Crp.ExecSql & " " & Trim(StrItem) & ","
       End If
      Case "nvarchar", "varchar", "char", "datetime", "nchar", "sql_variant"
       Crp.ExecSql = Crp.ExecSql & " '" & Trim(StrItem) & "',"
     End Select
   End If
  Next
  
 End If
 If Trim(Crp.ExecSql) <> "" Then Crp.ExecSql = Left(Crp.ExecSql, Len(Crp.ExecSql) - 1)
 '//处理页眉数据
 If meRpt.hBill.Count > 0 Then
  For iLoop = 1 To meRpt.hBill.Count
   tempVal = meRpt.hBill.Item(iLoop).Js_hfText
   If meFilter.Count > 0 Then
    For jLoop = 1 To meFilter.Count
     tempVal = Replace(tempVal, "^S" & meFilter.Item(jLoop).OrderID, meFilter.Item(jLoop).Title & meFilter.Item(jLoop).ValStr, , vbTextCompare)
     meRpt.hBill.Item(iLoop).Js_hfText = tempVal
    Next
   End If
  Next
 End If
End Sub

Private Sub TBar_MenuClick(ByVal ID As String, ByVal Caption As String)
  Select Case ID
  Case "001"
   Call getSearchSql
   CmdExeSign = True
   Unload Me
  Case "002"
   CmdExeSign = False
   Unload Me
 End Select
End Sub