frmquota.frm

金算盘软件代码

Private Sub LstHeaded_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeySpace Then Exit Sub
    If LstHeaded.SelCount <> 1 Then Exit Sub
    cmdHeadArrow_Click 1
End Sub

Private Sub LstReport_Click()
    Dim intLoc As Integer
    Dim strSel As String
    If lstReport.ListIndex <> -1 Then lstReport.ToolTipText = GetNoXString(lstReport.list(lstReport.ListIndex), 1, Space(100))
    If lstReport.SelCount <> 1 Then
        txtList.Text = ""
        txtList.Enabled = False
        LblList.Enabled = False
    Else
        strSel = lstReport.list(lstReport.ListIndex)
        txtList.Text = StringOut(strSel, Space(100))
        txtList.Enabled = True
        LblList.Enabled = True
    End If
    CmdEnabled lstReport, cmdArrow(2), cmdArrow(3)
    LstClick lstReport, cmdUpDown(0), cmdUpDown(1)
End Sub

Private Sub LstReport_DblClick()
    If lstReport.SelCount <> 1 Then Exit Sub
    cmdArrow_Click 2
End Sub

Private Sub LstReport_KeyPress(KeyAscii As Integer)
    If KeyAscii <> vbKeySpace Then Exit Sub
    If lstReport.SelCount <> 1 Then Exit Sub
    cmdArrow_Click 2
End Sub

Private Sub sstQuota_Click(PreviousTab As Integer)
    Dim intCount As Integer
    If Not mblnInited Then Exit Sub
    intCount = sstQuota.Tab
    InitQuota intCount
    Select Case intCount
    Case 0, 1, 3
      picWizard.ZOrder 0
      CmdReset.Visible = False
    Case 2
      picWizard.ZOrder 1
      CmdReset.Visible = True
    End Select
    Select Case PreviousTab
    Case 0
        If mblnChanged Then
            mblnIsInited(1) = False
            mstrQuotaField = cboQuota.Text
            mstrQuotaStandard = cboStandard.Text
            InitQuota 1
            mblnChanged = False
        End If
    Case 1, 2, 3
    End Select
    IsComplete
    CmdISEnabled sstQuota.Tab
    SetTabValid sstQuota.Tab
End Sub

Private Sub txtList_Change()
    Dim strSel As String
    Dim strTail As String
    Dim blnIsSame As Boolean
    Dim intLoc As Integer
     
    If lstReport.ListIndex = -1 Or Trim(txtList.Text) = "" Then Exit Sub
    If mblnIsInited(1) Then
        strSel = lstReport.list(lstReport.ListIndex)
        blnIsSame = FindSameField(txtList.Text, lstReport.ListIndex)
        If blnIsSame Then
            Utility.ShowMsg Me.hwnd, "已有名称'" & txtList.Text & "'了,请重新命名!", vbOKOnly + vbInformation, App.title
            txtList.Text = StringOut(strSel, Space(100))
        End If
    End If
    If StrLen(Trim(txtList.Text)) > 30 Then
       Utility.ShowMsg Me.hwnd, "项目名称太长了,请重新命名!", vbOKOnly + vbInformation, App.title
       txtList.Text = strLeft(txtList.Text, 30)
    Else
       strTail = lstReport.list(lstReport.ListIndex)
       MeFind strSel, intLoc
       marrFields(intLoc, 0) = Trim(txtList.Text) & Space(100) & intLoc
       lstReport.list(lstReport.ListIndex) = marrFields(intLoc, 0)
    End If
End Sub


Private Sub txtList_LostFocus()
 
  Dim strSel As String
  Dim blnErr As Boolean
    If Me.ActiveControl Is cmdCancel Then Exit Sub
    If sstQuota.Tab <> 1 Then Exit Sub
    If Trim(txtList.Text) = "" Then
        strSel = lstReport.list(lstReport.ListIndex)
        txtList.Text = StringOut(strSel, Space(100))
    End If
    blnErr = NameIsErr(txtList.Text, strSel)
    If blnErr Then
        Utility.ShowMsg Me.hwnd, "列名不能有非法字符:'" & strSel & "'!", vbOKOnly + vbInformation, App.title
        sstQuota.Tab = 1
        txtList.SetFocus
        Exit Sub
    End If
    
End Sub


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'         以下为自定义过程

'设置向导按钮的可用性
Private Sub CmdISEnabled(intIndex As Integer)
    Select Case intIndex
    Case 0
      CmdPrevious.Enabled = False
      cmdNext.Enabled = True
'      cmdComplete.Enabled = False
    Case 1, 2
      cmdNext.Enabled = True
      CmdPrevious.Enabled = True
    Case 3
      cmdNext.Enabled = False
      CmdPrevious.Enabled = True
    End Select
End Sub

'查找同名项目
Private Function FindSameField(strName As String, intIndex As Integer) As Boolean
Dim intCount As Integer
Dim strTemp As String
    
    intCount = 0
    Do While intCount < LstDataField.ListCount
        If intCount <> intIndex Then
            strTemp = LstDataField.list(intCount)
            strTemp = StringOut(strTemp, Space(100))
            If strTemp = strName Then
                FindSameField = True
                Exit Function
            End If
        End If
        intCount = intCount + 1
    Loop
    intCount = 0
    Do While intCount < lstReport.ListCount
        If intCount <> intIndex Then
            strTemp = lstReport.list(intCount)
            strTemp = StringOut(strTemp, Space(100))
            If strTemp = strName Then
                FindSameField = True
                Exit Function
            End If
        End If
        intCount = intCount + 1
    Loop
    FindSameField = False
End Function

'完成按钮是否有效
Private Sub IsComplete()
  If Trim(txtName.Text) = "" Or lstReport.ListCount = 0 Or sstQuota.Tab = 0 Then
      cmdComplete.Enabled = False
  Else
      cmdComplete.Enabled = True
  End If
End Sub

'初始化向导
Private Function InitQuota(intTab As Integer) As Boolean
   Dim intCount As Integer, intColumn As Integer, intLoc As Integer
   Dim strItem As String, strSql As String
   Dim strTemp As String, strRep As String
   Dim rstData As rdoResultset
   Dim strCondVersion As String
     
     
     If mblnIsInited(intTab) = True Then
        mblnInited = True
        Exit Function
     End If
     Select Case intTab
     Case 2
        mclsFilter.ShowFilter Me, mclsQuota.ReportID, 2, 64, , "日期"
        CmdReset.Visible = True
        mblnIsInited(2) = True
     Case 0
        cboCond.Clear
        cboCond.AddItem "不显示"
        cboCond.AddItem "表头显示"
        cboCond.AddItem "表尾显示"
        mbytOldCondShow = mclsQuota.CondShow
        cboCond.Text = cboCond.list(mbytOldCondShow)
        txtName.Text = mclsQuota.ReportName
        Me.Caption = mclsQuota.ReportName
        '初始化配款标准
        If mstrSalaryList = "" Then
            strSql = "Select lngSalaryListID,strSalaryListName From SalaryList Where lngSalaryListID= (Select Max(lngSalaryListID) From SalaryList Where To_Date('" & Format(gclsBase.BaseDate, "YYYY-MM-DD") & "','YYYY-MM-DD')<=To_Date(strDate,'YYYY-MM-DD'))"
            Set rstData = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If Not rstData.EOF Then
                mstrSalaryList = rstData!strSalaryListName & Space(100) & rstData!lngSalaryListID
            End If
        End If
        cboSalary.Clear
        strSql = "Select lngSalaryListID,strSalaryListName From SalaryList"
        Set rstData = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If rstData.EOF Then
            InitQuota = False
            mblnInited = True
            Exit Function
        Else
            Do Until rstData.EOF
                strTemp = rstData!strSalaryListName & Space(100) & rstData!lngSalaryListID
                cboSalary.AddItem strTemp
                If strTemp = mstrSalaryList Then
                    cboSalary.Text = mstrSalaryList
                End If
                rstData.MoveNext
            Loop
        End If
        If cboSalary.Text = "" Then
            cboSalary.Text = cboSalary.list(0)
            mstrSalaryList = cboSalary.list(0)
            'Utility.ShowMsg Me.hwnd, "上次所选工资表已被删除！", vbOKOnly + vbInformation, App.title
        End If
        cboQuota.Clear
        strSql = "Select ViewField.strViewFieldDesc,ViewField.lngViewFieldID,ViewField.strFieldName FROM SalaryField,ViewField " _
                 & " Where SalaryField.lngViewFieldID = ViewField.lngViewFieldID" _
                 & " And ViewField.lngViewid=63 And SalaryField.lngSalaryListID=" & Val(GetNoXString(cboSalary.Text, 2, Space(100))) _
                 & " And Upper(ViewField.strFieldType)='DOUBLE' And ViewField.lngViewFieldID NOT IN (13219,13221,18660)"
        Set rstData = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        Do Until rstData.EOF
            strTemp = rstData!strViewFieldDesc & Space(100) & rstData!lngViewFieldID & Space(100) & rstData!strFieldName
            cboQuota.AddItem strTemp
            If strTemp = mstrQuotaField Then
                cboQuota.Text = mstrQuotaField
            End If
            rstData.MoveNext
        Loop
        If cboQuota.Text = "" Then
            cboQuota.Text = cboQuota.list(0)
            mstrQuotaField = cboQuota.list(0)
        End If
        If CLng(GetNoXString(mstrQuotaField, 2, Space(100))) = mlngDeductFieldID Then
            mblnDeductItem = True
        Else
            mblnDeductItem = False
        End If
        cboStandard.Clear
        cboStandard.AddItem "部门"
        cboStandard.AddItem "职员"

        If mstrQuotaStandard = "" Then
            mstrQuotaStandard = cboStandard.list(0)
        End If
        cboStandard.Text = mstrQuotaStandard
        GetDeduct
        
        With mclsQuota
            ReDim marrFields(.Columns - 1, 12)
            For intCount = 0 To .Columns - 1
                marrFields(intCount, 0) = .ColumnDesc(intCount) & Space(100) & CStr(intCount)
                marrFields(intCount, 1) = .ColumnID(intCount)
                marrFields(intCount, 2) = .FieldName(intCount)
                marrFields(intCount, 3) = .FieldType(intCount)
                marrFields(intCount, 4) = .FieldSize(intCount)
                marrFields(intCount, 5) = .ColumnFieldDesc(intCount)
                marrFields(intCount, 6) = .ColumnWidth(intCount)
                marrFields(intCount, 7) = .ColumnStyle(intCount)
                marrFields(intCount, 8) = ConverDeduct(.ColumnFieldDesc(intCount))
                marrFields(intCount, 9) = .ColumnFieldHead(intCount)
                marrFields(intCount, 10) = .FieldFixed(intCount)
                marrFields(intCount, 11) = .ColumnChoosed(intCount)
                marrFields(intCount, 12) = .CodeName(intCount)
            Next intCount
       End With
       
        mblnIsInited(0) = True
        
      Case 1
        
        '对报表列表初始化(已选项目)
        LstDataField.Clear
        lstReport.Clear
        If mblnFirstOpen Then     '重选配款项目
            For intColumn = 0 To UBound(marrFields)
                If marrFields(intColumn, 9) = 0 Then
                    If marrFields(intColumn, 5) = "人数" Then
                        If cboStandard.Text = "部门" Then
                            lstReport.AddItem marrFields(intColumn, 0)
                        End If
                    ElseIf Left(marrFields(intColumn, 5), 2) = Left(cboStandard.Text, 2) Or marrFields(intColumn, 5) = "配款项目" Then
                        lstReport.AddItem marrFields(intColumn, 0)
                    ElseIf UCase(marrFields(intColumn, 3)) = "INTEGER" Then
                        If mblnDeductItem Then     '扣零项目
                            If marrFields(intColumn, 8) >= mintDeductField Then
                                lstReport.AddItem marrFields(intColumn, 0)
                            End If
                        Else                       '一般项目
                            lstReport.AddItem marrFields(intColumn, 0)
                        End If
                    End If
                End If
            Next intColumn
        Else       '加载窗体前
            With mclsQuota
                For intColumn = 0 To .ChoosedColumns - 1
                    intLoc = .ChoosedLoc(intColumn)
                    lstReport.AddItem marrFields(intLoc, 0)
                Next intColumn
                
                For intColumn = 0 To UBound(marrFields)
                    If marrFields(intColumn, 9) = 0 And marrFields(intColumn, 11) = False Then
                        If marrFields(intColumn, 5) = "人数" Then
                            If cboStandard.Text = "部门" Then
                                LstDataField.AddItem marrFields(intColumn, 0)
                            End If
                        ElseIf Left(marrFields(intColumn, 5), 2) = Left(cboStandard.Text, 2) Or marrFields(intColumn, 5) = "配款项目" Then
                            LstDataField.AddItem marrFields(intColumn, 0)
                        ElseIf UCase(marrFields(intColumn, 3)) = "INTEGER" Then
                            If mblnDeductItem Then     '扣零项目
                                If marrFields(intColumn, 8) > mintDeductField Then
                                    LstDataField.AddItem marrFields(intColumn, 0)
                                End If
                            Else                       '一般项目
                                LstDataField.AddItem marrFields(intColumn, 0)
                            End If
                        End If
                    End If
                Next intColumn
            End With
        End If
        
        txtList.Enabled = False
        LblList.Enabled = False
        LstClick lstReport, cmdUpDown(0), cmdUpDown(1)
        CmdEnabled LstDataField, cmdArrow(0), cmdArrow(1)
        CmdEnabled lstReport, cmdArrow(2), cmdArrow(3)
        IsComplete
        mblnIsInited(1) = True
     Case 3
        '初始化表头栏目
        cboCode.Clear
        cboCode.AddItem "只显示编码"
        cboCode.AddItem "编码+名称"
        cboCode.AddItem "编码+全称"
        cboCode.Text = cboCode.list(1)
        For intCount = 0 To UBound(marrFields)
            If marrFields(intCount, 9) = 1 Or marrFields(intCount, 9) = 2 Then
                lstHead.AddItem marrFields(intCount, 0)
            End If
        Next intCount
        For intCount = 0 To mclsQuota.ListColumns - 1
            intLoc = 0
             Do While intLoc < lstHead.ListCount
                strItem = lstHead.list(intLoc)
                intColumn = mclsQuota.ColumnListLoc(intCount)
                 If mclsQuota.ColumnDesc(intColumn) = StringOut(strItem, Space(100)) Then
                     lstHead.Selected(intLoc) = True