frmfieldset.frm

金算盘软件代码

VERSION 5.00
Begin VB.Form frmFieldSet 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "报表自定义栏目设置"
   ClientHeight    =   4770
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   6135
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4770
   ScaleWidth      =   6135
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.TextBox txtName 
      Height          =   270
      Left            =   3120
      TabIndex        =   11
      Text            =   "未定义"
      Top             =   2760
      Width           =   1335
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "/"
      Height          =   375
      Index           =   5
      Left            =   5040
      MaskColor       =   &H8000000F&
      TabIndex        =   7
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "*"
      Height          =   375
      Index           =   4
      Left            =   4080
      MaskColor       =   &H8000000F&
      TabIndex        =   6
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "-"
      Height          =   375
      Index           =   3
      Left            =   3120
      MaskColor       =   &H8000000F&
      TabIndex        =   5
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "+"
      Height          =   375
      Index           =   2
      Left            =   2160
      MaskColor       =   &H8000000F&
      TabIndex        =   4
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   ")"
      Height          =   375
      Index           =   1
      Left            =   1200
      MaskColor       =   &H8000000F&
      TabIndex        =   3
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdOperate 
      Caption         =   "("
      Height          =   375
      Index           =   0
      Left            =   240
      MaskColor       =   &H8000000F&
      TabIndex        =   2
      Top             =   2040
      UseMaskColor    =   -1  'True
      Width           =   735
   End
   Begin VB.CommandButton cmdClear 
      Caption         =   "清除公式(&C)"
      Height          =   375
      Left            =   4680
      MaskColor       =   &H8000000F&
      TabIndex        =   15
      Top             =   4200
      UseMaskColor    =   -1  'True
      Width           =   1275
   End
   Begin VB.CommandButton cmdAadjust 
      Caption         =   "检查公式(&A)"
      Height          =   375
      Left            =   4680
      MaskColor       =   &H8000000F&
      TabIndex        =   14
      Top             =   3720
      UseMaskColor    =   -1  'True
      Width           =   1275
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Height          =   375
      Left            =   4680
      Style           =   1  'Graphical
      TabIndex        =   13
      Top             =   3240
      UseMaskColor    =   -1  'True
      Width           =   1275
   End
   Begin VB.CommandButton cmdAffirm 
      Default         =   -1  'True
      Height          =   375
      Left            =   4680
      Style           =   1  'Graphical
      TabIndex        =   12
      Top             =   2760
      UseMaskColor    =   -1  'True
      Width           =   1275
   End
   Begin VB.ListBox lstField 
      Height          =   1860
      Left            =   360
      TabIndex        =   9
      Top             =   2760
      Width           =   2535
   End
   Begin VB.TextBox txtFormula 
      Height          =   1575
      HideSelection   =   0   'False
      Left            =   240
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   360
      Width           =   5655
   End
   Begin VB.Label Label1 
      Caption         =   "公式设置(&S)"
      Height          =   255
      Left            =   240
      TabIndex        =   0
      Top             =   120
      Width           =   1575
   End
   Begin VB.Label LblName 
      Caption         =   "栏目名称(&N)"
      Height          =   255
      Left            =   3120
      TabIndex        =   10
      Top             =   2520
      Width           =   1125
   End
   Begin VB.Label LblField 
      Caption         =   "报表栏目(&R)"
      Height          =   255
      Left            =   360
      TabIndex        =   8
      Top             =   2520
      Width           =   1215
   End
End
Attribute VB_Name = "frmFieldSet"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  报表自定义栏目设置窗体
'  作者：邓强
'  日期：1999.02.01
'
'  引导用户设置自定义栏目
'  SetField(arr,strLabel)                          增加或修改自定义栏目
'         arr 报表字段数组  strLabel 所需数组内容位置 intIndex 修改栏目索引(-1为新增)

Option Explicit

Private WithEvents mclsFormula As DepolandClass   '语法分析
Attribute mclsFormula.VB_VarHelpID = -1
Private mcolName As Collection               '用户说明集合
Private mcolFieldID As Collection            '字段视图ID集合

Private mvarReportID As Long
Private mvarViewID As Long
Private mstrSql As String
Private mstrSelect As String                 '公式SQL
Private mstrFormula As String                '公式存储
Private mstrShow As String                   '公式显示文本
Private mstrFrom As String
Private mstrWhere As String
Private mstrAdd As String                    '附加检测字段
Private mintIndex As Integer
Private mblnOk As Boolean
Private marrFields() As Variant


'数组说明:0 用户说明 1 报表字段ID 2 字段类型 3 字段名称 4 字段公式 5 字段标志 6 字段视图ID
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                   只写属性

Public Property Let ReportID(ByVal vData As Long)
    mvarReportID = vData
End Property

Public Property Let ViewId(ByVal vData As Long)
    mvarViewID = vData
End Property

Public Property Let ReportFrom(ByVal vData As String)
    mstrFrom = vData
End Property
Public Property Let ReportWhere(ByVal vData As String)
    If vData = "" Then
        mstrWhere = " Where 2<1"
    Else
        mstrWhere = " Where 2<1 And " & vData
    End If
End Property

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                   公共过程

'设置自定义栏目
Public Function SetField(arr() As Variant, ByVal strLabel As String, intIndex As Integer) As Boolean
Dim intCount As Integer, intLoc As Integer
Dim intLabel As Integer
Dim strSel As String, strSql As String
Dim edtErrReturn As ErrDealType

    On Error GoTo ErrHandle
    
    Set mclsFormula = New DepolandClass
    Set mcolFieldID = New Collection
    Set mcolName = New Collection

    mintIndex = intIndex
    ReDim marrFields(UBound(arr, 1), 6)
    For intCount = 0 To UBound(arr, 1)
        For intLoc = 0 To 6
            intLabel = GetNoXString(strLabel, intLoc + 1, ",")
            marrFields(intCount, intLoc) = arr(intCount, intLabel)
        Next intLoc
    Next intCount
    
    lstField.Clear
    intLoc = -1
    For intCount = 0 To UBound(marrFields)
        If StandardReport.IsNumType(marrFields(intCount, 2)) And marrFields(intCount, 6) > 0 And marrFields(intCount, 5) = 0 Then
            lstField.AddItem marrFields(intCount, 0)
            strSql = marrFields(intCount, 0)
            strSel = StringOut(strSql, Space(100))
            intLoc = Val(strSql)
            mcolName.Add intLoc, strSel
            mcolFieldID.Add intLoc, CStr(marrFields(intCount, 6))
        End If
    Next intCount
    If intLoc = -1 Then
        Utility.ShowMsg Me.hWnd, "此报表不能新增项目!", vbOKOnly + vbInformation, App.title
        Unload Me
        Exit Function
    End If
    mstrAdd = marrFields(mcolFieldID.Item(1), 3)
    If intIndex = -1 Then
    '新增
        txtFormula.Text = ""
        mstrSelect = ""
    Else
    '修改
        strSel = marrFields(intIndex, 4)
        FormulaToText strSel, strSql
        txtFormula.Text = strSql
        mstrSelect = ""
        txtName.Text = GetNoXString(marrFields(intIndex, 0), 1, Space(100))
        txtName.Enabled = False
        LblName.Enabled = False
    End If
    mblnOk = False
    
    Me.Show vbModal
    If mblnOk Then
        For intLoc = 0 To 6
            intLabel = GetNoXString(strLabel, intLoc + 1, ",")
            arr(mintIndex, intLabel) = marrFields(mintIndex, intLoc)
        Next intLoc
        intIndex = mintIndex
    End If
    Set mcolName = Nothing
    SetField = mblnOk
    Exit Function
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Utility.ShowMsg Me.hWnd, "未知错误!", vbCritical + vbOKOnly, App.title
         Unload Me
    End If
End Function

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'                                   窗体事件
Private Sub cmdAadjust_Click()
Dim strSql As String, strQryName As String
Dim intCount As Integer
Dim blnQuery As Boolean
Dim qdfTemp As rdoQuery

    On Error GoTo ErrHandle
    If StrLen(Trim(txtFormula.Text)) > 1000 Then
        Utility.ShowMsg Me.hWnd, "公式太复杂,请重新定义公式!", vbCritical + vbOKOnly, App.title
        Exit Sub
    End If
    If mclsFormula.ExprParse(Trim(txtFormula.Text)) Then
        TextToFormula
        EditSql strSql
        gclsBase.BaseDB.OpenResultset strSql, rdOpenStatic
        cmdAffirm.Enabled = True
    Else
        GoTo ErrHandle
    End If
    Exit Sub
ErrHandle:
    Utility.ShowMsg Me.hWnd, "公式无效,请重新定义公式!", vbCritical + vbOKOnly, App.title
    cmdAffirm.Enabled = False
End Sub

Private Sub cmdAffirm_Click()
Dim intCount As Integer
Dim lngFieldID As Long
Dim blnOK As Boolean
Dim strSql As String
Dim rstField As rdoResultset
    
    '检查重名
    If Trim(txtName.Text) = "" Then
        Utility.ShowMsg Me.hWnd, "请为自定义栏目命名!", vbOKOnly + vbInformation, App.title
        txtName.SetFocus
        Exit Sub
    ElseIf StrLen(Trim(txtName.Text)) > 30 Then
        Utility.ShowMsg Me.hWnd, "自定义栏目名称太长!", vbOKOnly + vbInformation, App.title
        txtName.Text = strLeft(txtName.Text, 30)
        txtName.SetFocus
        Exit Sub
    ElseIf CheckName Then
        Utility.ShowMsg Me.hWnd, "已有名称'" & Trim(txtName.Text) & "'了,请重新命名!", vbOKOnly + vbInformation, App.title
        txtName.SetFocus