frmreportsum.frm

金算盘软件代码

Private Sub cmdArrow_Click(Index As Integer)  '查询项目
Dim intCount As Integer, intLoc As Integer
Dim blnFix As Boolean
Dim strSel As String
    Select Case Index
    Case 0        '右移选择项目
        For intCount = 0 To LstData.ListCount - 1
            If LstData.Selected(intCount) = True Then
                strSel = LstData.list(intCount)
                MeFind strSel, intLoc
                marrFields(intLoc, 2) = 1
            End If
        Next intCount
        SendField LstData, LstReport(2), False
        CmdEnabled LstData, cmdArrow(0), cmdArrow(1)
        CmdEnabled LstReport(2), cmdArrow(2), cmdArrow(3)
    Case 1        '右全移选择项目
        For intCount = 0 To LstData.ListCount - 1
             strSel = LstData.list(intCount)
             MeFind strSel, intLoc
             marrFields(intLoc, 2) = 1
        Next intCount
        SendField LstData, LstReport(2), True
        CmdEnabled LstData, cmdArrow(0), cmdArrow(1)
        CmdEnabled LstReport(2), cmdArrow(2), cmdArrow(3)
    Case 2        '左移选择项目
        blnFix = False
        For intCount = 0 To LstReport(2).ListCount - 1
            If LstReport(2).Selected(intCount) = True Then
                strSel = LstReport(2).list(intCount)
                MeFind strSel, intLoc
                If marrFields(intLoc, 8) = True Then
                    LstReport(2).Selected(intCount) = False
                    blnFix = True
                Else
                    marrFields(intLoc, 3) = 0
                    marrFields(intLoc, 2) = 0
                End If
            End If
        Next intCount
        SendField LstReport(2), LstData, False
        CmdEnabled LstData, cmdArrow(0), cmdArrow(1)
        CmdEnabled LstReport(2), cmdArrow(2), cmdArrow(3)
        If LstReport(2).ListCount = 0 Then
            txtList.Text = ""
            txtList.Enabled = False
            LblList.Enabled = False
        End If
        If blnFix Then
            Utility.ShowMsg Me.hWnd, "固定项目必选!", vbOKOnly + vbInformation, App.title
        End If
    Case 3        '左全移选择项目
        blnFix = False
        For intCount = 0 To LstReport(2).ListCount - 1
            strSel = LstReport(2).list(intCount)
            MeFind strSel, intLoc
            If marrFields(intLoc, 8) = True Then
                LstReport(2).Selected(intCount) = False
                blnFix = True
            Else
                LstReport(2).Selected(intCount) = True
                marrFields(intLoc, 3) = 0
                marrFields(intLoc, 2) = 0
            End If
        Next intCount
        SendField LstReport(2), LstData, False
        CmdEnabled LstData, cmdArrow(0), cmdArrow(1)
        CmdEnabled LstReport(2), cmdArrow(2), cmdArrow(3)
        If LstReport(2).ListCount = 0 Then
            txtList.Text = ""
            txtList.Enabled = False
            LblList.Enabled = False
        End If
'        If blnFix Then
'            Utility.ShowMsg Me.hwnd, "固定项目必选!", vbOKOnly + vbInformation, App.title
'        End If
    End Select
    '判断按钮可用性
    If LstData.ListCount = 0 Then
        cmdField(1).Enabled = False
        cmdField(2).Enabled = False
    End If
    LstClick LstReport(2), cmdUpDown(0), cmdUpDown(1)
    '项目已改变
    mblnFieldChanged = True
End Sub
Private Sub CmdCancel_Click()
    If mblnDelCustom Then
        GetSumWizard
        mblnMeOK = True
    Else
        mblnMeOK = False
    End If
    mblnDelCustom = False
    Unload Me
End Sub

Private Sub cmdComplete_Click()
Dim blnIsSave As Boolean, blnHaveData As Boolean
Dim intCount As Integer, intLoc As Integer
Dim strTemp As String
'    Select Case mclsSum.ViewId
'    Case 593, 595, 596
        blnHaveData = False
        For intCount = 0 To LstReport(2).ListCount - 1
            strTemp = LstReport(2).list(intCount)
            MeFind strTemp, intLoc
            blnHaveData = IIf(marrFields(intLoc, 1) = 0, False, True)
            If blnHaveData Then
                Exit For
            End If
        Next intCount
        If Not blnHaveData Then
            Utility.ShowMsg Me.hWnd, "必须选一个预设项目!", vbOKOnly + vbInformation, App.title
            Exit Sub
        End If
'    Case Else
'    End Select
    mblnMeOK = True
    mblnDelCustom = False
'    If Not mblnInited(2) Then InitStandard 2
'    If Not mblnInited(3) Then InitStandard 3
    GetSumWizard          '得到汇总报表向导设置
    Unload Me
End Sub

Private Sub cmdField_Click(Index As Integer)
Dim strLabel As String
Dim blnSet As Boolean
Dim intIndex As Integer
Dim intCount As Integer, intLoc As Integer
Dim strSel As String, strSQL As String, strTemp As String
Dim frmCustom As New frmFieldSet
'说明:0 用户说明 1 报表字段ID 2 字段类型 3 字段名称 4 字段公式 5 字段标志 6 字段视图ID
    strLabel = "0,13,4,10,12,7,1"
    frmCustom.ReportID = mclsSum.ReportID
    frmCustom.ViewId = mclsSum.ViewId
    frmCustom.ReportFrom = mclsSum.FROM
    frmCustom.ReportWhere = mclsSum.ViewCond
        
    Select Case Index
    Case 0       '新增
        intIndex = -1
        blnSet = frmCustom.SetField(marrFields, strLabel, intIndex)
        If blnSet Then
            mclsSum.CustomFields = mclsSum.CustomFields + 1
            mclsSum.ColumnDesc(intIndex) = GetNoXString(marrFields(intIndex, 0), 1, Space(100))
            mclsSum.FormulaToSql marrFields(intIndex, 12), strTemp
            marrFields(intIndex, 10) = strTemp
            mclsSum.ColumnFieldName(intIndex) = strTemp
            mclsSum.ColumnFieldType(intIndex) = "Double"
            mclsSum.CustomFormula(intIndex) = marrFields(intIndex, 12)
            mclsSum.ReportFieldID(intIndex) = marrFields(intIndex, 13)
            LstData.AddItem marrFields(intIndex, 0)
            LstData.Selected(LstData.NewIndex) = True
            mblnFieldChanged = True
        End If
    Case 1       '修改
        strSel = LstData.list(LstData.ListIndex)
        MeFind strSel, intIndex
        blnSet = frmCustom.SetField(marrFields, strLabel, intIndex)
        If blnSet Then
            mclsSum.FormulaToSql marrFields(intIndex, 12), strTemp
            marrFields(intIndex, 10) = strTemp
            mclsSum.ColumnFieldName(intIndex) = strTemp
            mclsSum.CustomFormula(intIndex) = marrFields(intIndex, 12)
            mblnFieldChanged = True
        End If
    Case 2      '删除
        intCount = Utility.ShowMsg(Me.hWnd, "你确定要做永久性的删除吗?", vbQuestion + vbYesNo, App.title)
        If intCount = 6 Then
            strSel = LstData.list(LstData.ListIndex)
            MeFind strSel, intLoc
            strSQL = "Delete  From ReportField Where lngReportFieldID=" & marrFields(intLoc, 13) _
                   & " And lngReportID=" & mclsSum.ReportID
            blnSet = gclsBase.ExecSQL(strSQL)
            If Not blnSet Then
                Utility.ShowMsg Me.hWnd, "删除失败,请稍后重新操作!", vbInformation + vbOKOnly, App.title
                Exit Sub
            End If
            
            mclsSum.ColumnFieldName(intLoc) = ""
            mclsSum.ReportFieldID(intLoc) = 0
            mclsSum.CustomFormula(intLoc) = ""
            mclsSum.ColumnDesc(intLoc) = ""
            marrFields(intLoc, 12) = ""
            marrFields(intLoc, 10) = ""
            marrFields(intLoc, 0) = ""
            If mclsSum.ColumnChoosed(intLoc) Then
                mblnDelCustom = True
                cmdCancel.Enabled = False
            End If
            mclsSum.CustomFields = mclsSum.CustomFields - 1
            intLoc = LstData.ListIndex
            LstData.RemoveItem intLoc
            If LstData.ListCount > 0 Then
                If intLoc > 0 Then
                    LstData.Selected(intLoc - 1) = True
                Else
                    LstData.Selected(0) = True
                End If
            End If
            mblnFieldChanged = True
        End If
    End Select
    Set frmCustom = Nothing
    LstData_Click
End Sub

Private Sub cmdHeadArrow_Click(Index As Integer)
Dim intLoc As Integer
Dim strSel As String
    If Index = 0 Then        '右移表头项目
      If LstHeaded.ListCount >= 9 Then
         Utility.ShowMsg Me.hWnd, "不能再加表头项目了!", vbOKOnly + vbInformation, App.title
         Exit Sub
      End If
      SendField LstHead, LstHeaded, False
      CmdEnabled LstHeaded, cmdHeadArrow(1)
      CmdEnabled LstHead, cmdHeadArrow(0)
    ElseIf Index = 1 Then     '左移表头项目
      If LstHeaded.SelCount = 1 Then
        MeFind LstHeaded.list(LstHeaded.ListIndex), intLoc
        marrFields(intLoc, 15) = 2
      End If
      SendField LstHeaded, LstHead, False
      CmdEnabled LstHeaded, cmdHeadArrow(1)
      CmdEnabled LstHead, cmdHeadArrow(0)
      If LstHeaded.SelCount = 1 Then
            cboCode.Enabled = True
            LblCode.Enabled = True
      Else
            cboCode.Enabled = False
            LblCode.Enabled = False
      End If
    End If
    mblnHeadChanged = True
End Sub

Private Sub cmdHeadUpDown_Click(Index As Integer)
    '上下移动表头项目
    StandardReport.FieldUpdown LstHeaded, Index
End Sub

Private Sub cmdNext_Click()
Dim intTab As Integer
    intTab = sstWizard.Tab + 1
    Do While sstWizard.TabVisible(intTab) = False
        intTab = intTab + 1
    Loop
    sstWizard.Tab = intTab
End Sub

Private Sub cmdPrevious_Click()
Dim intTab As Integer
    intTab = sstWizard.Tab - 1
    Do While sstWizard.TabVisible(intTab) = False
        intTab = intTab - 1
    Loop
    sstWizard.Tab = intTab
End Sub

Private Sub cmdMeSortArrow_Click(Index As Integer)
Dim intLoc As Integer
Dim strSel As String
    If Index = 0 Then        '右移排序项目
      If LstMeSort.ListCount >= 5 Then
         Utility.ShowMsg Me.hWnd, "不能再加排序项目了!", vbOKOnly + vbInformation, App.title
         Exit Sub
      End If
      strSel = LstReport(1).list(LstReport(1).ListIndex)
      MeFind strSel, intLoc       '寻找选中项目在数组arrFields里的位置
      If marrFields(intLoc, 7) = 4 Then
        Utility.ShowMsg Me.hWnd, "此项目不能作为排序项目!", vbOKOnly + vbInformation, App.title
        Exit Sub
      End If
      SendField LstReport(1), LstMeSort, False
      CmdEnabled LstMeSort, cmdMeSortArrow(1)
      CmdEnabled LstReport(1), cmdMeSortArrow(0)
    ElseIf Index = 1 Then     '左移排序项目
      SendField LstMeSort, LstReport(1), False
      CmdEnabled LstMeSort, cmdMeSortArrow(1)
      CmdEnabled LstReport(1), cmdMeSortArrow(0)
      '清除排序方式
      strSel = LstReport(1).list(LstReport(1).NewIndex)
      MeFind strSel, intLoc
      marrFields(intLoc, 5) = ""
      '判断按钮可用性
      If LstMeSort.SelCount = 1 Then
        cboSort.Enabled = True
        LblSort.Enabled = True
      Else
        cboSort.Enabled = False
        LblSort.Enabled = False
      End If
    End If
End Sub

Private Sub cmdMeSortUp_Click(Index As Integer)
    '上下移动排序项目
    StandardReport.FieldUpdown LstMeSort, Index
End Sub

'选择工资报表
Private Sub cmdSalaryArrow_Click(Index As Integer)
    Select Case Index
    Case 0        '右移选择项目
        SendField lstSalaryChoose, lstSalaryChoosed, False
        CmdEnabled lstSalaryChoose, cmdSalaryArrow(0), cmdSalaryArrow(1)
        CmdEnabled lstSalaryChoosed, cmdSalaryArrow(2), cmdSalaryArrow(3)
    Case 1        '右全移选择项目
        SendField lstSalaryChoose, lstSalaryChoosed, True
        CmdEnabled lstSalaryChoose, cmdSalaryArrow(0), cmdSalaryArrow(1)
        CmdEnabled lstSalaryChoosed, cmdSalaryArrow(2), cmdSalaryArrow(3)
    Case 2        '左移选择项目
        SendField lstSalaryChoosed, lstSalaryChoose, False
        CmdEnabled lstSalaryChoose, cmdSalaryArrow(0), cmdSalaryArrow(1)
        CmdEnabled lstSalaryChoosed, cmdSalaryArrow(2), cmdSalaryArrow(3)
    Case 3        '左全移选择项目
        SendField lstSalaryChoosed, lstSalaryChoose, True
        CmdEnabled lstSalaryChoose, cmdSalaryArrow(0), cmdSalaryArrow(1)
        CmdEnabled lstSalaryChoosed, cmdSalaryArrow(2), cmdSalaryArrow(3)
    End Select
End Sub

Private Sub cmdSumArrow_Click(Index As Integer)
Dim intLoc As Integer
Dim strSel As String
    If Index = 0 Then        '右移汇总项目
        strSel = LstReport(0).list(LstReport(0).ListIndex)
        MeFind strSel, intLoc       '寻找选中项目在数组arrFields里的位置
        If Not StandardReport.IsNumType(marrFields(intLoc, 4)) Then
            Utility.ShowMsg Me.hWnd, "此项目不能作为汇总项目!", vbOKOnly + vbInformation, App.title
            Exit Sub
        End If
        SendField LstReport(0), LstSum, False
        CmdEnabled LstSum, cmdSumArrow(1)
        CmdEnabled LstReport(0), cmdSumArrow(0)
    ElseIf Index = 1 Then     '左移排序项目
        SendField LstSum, LstReport(0), False
        CmdEnabled LstSum, cmdSumArrow(1)
        CmdEnabled LstReport(0), cmdSumArrow(0)
    End If
End Sub

Private Sub cmdUpDown_Click(Index As Integer)
    '