frmquota.frm

金算盘软件代码

                     cmdHeadArrow_Click 0
                     Exit Do    '退出intLoc循环
                 End If
                 intLoc = intLoc + 1
             Loop
         Next intCount
        '清除已选项
        intCount = 0
        Do While intCount < lstHead.ListCount
           lstHead.Selected(intCount) = False
           intCount = intCount + 1
        Loop
        intCount = 0
        Do While intCount < LstHeaded.ListCount
           LstHeaded.Selected(intCount) = False
           intCount = intCount + 1
        Loop
        cboCode.Enabled = False
        LblCode.Enabled = False
        mblnIsInited(3) = True
     End Select
     mblnInited = True
     InitQuota = True
 End Function
Private Sub txtName_Change()
    If Trim(txtName.Text) = "" Then
       Utility.ShowMsg Me.hwnd, "报表名称不能为空!", vbOKOnly + vbInformation, App.title
       cmdComplete.Enabled = False
       Exit Sub
    End If
End Sub

Private Sub txtName_LostFocus()
    If Me.ActiveControl Is cmdCancel Then Exit Sub
    '检测报表名称是否有效
    If StrLen(txtName.Text) > 40 Then
       Utility.ShowMsg Me.hwnd, "报表名称太长了,请重新命名!", vbOKOnly + vbInformation, App.title
       txtName.Text = strLeft(txtName.Text, 40)
       sstQuota.Tab = 0
       txtName.SetFocus
    End If
    IsComplete
End Sub



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       以下是与类相关的过程与函数
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Sub loadResPic()
Dim picRes As IPictureDisp
    Set picRes = Utility.GetFormResPicture(1019, vbResBitmap)
    cmdUpDown(0).Picture = picRes
    cmdHeadUpDown(0).Picture = picRes
    Set picRes = Utility.GetFormResPicture(1020, vbResBitmap)
    cmdUpDown(1).Picture = picRes
    cmdHeadUpDown(1).Picture = picRes
    cmdCancel.Picture = Utility.GetFormResPicture(1002, vbResBitmap)
    CmdPrevious.Picture = Utility.GetFormResPicture(1005, vbResBitmap)
    cmdNext.Picture = Utility.GetFormResPicture(1006, vbResBitmap)
    cmdComplete.Picture = Utility.GetFormResPicture(1016, vbResBitmap)
    CmdReset.Picture = Utility.GetFormResPicture(1021, vbResBitmap)
    picWizard.Picture = Utility.GetFormResPicture(140, vbResBitmap)
End Sub
Private Sub UnloadResPic()
    Utility.RemoveFormResPicture 1019
    Utility.RemoveFormResPicture 1020
    Utility.RemoveFormResPicture 1002
    Utility.RemoveFormResPicture 1005
    Utility.RemoveFormResPicture 1006
    Utility.RemoveFormResPicture 1016
    Utility.RemoveFormResPicture 1021
    Utility.RemoveFormResPicture 140
    Utility.RemoveFormResPicture 139
    cmdUpDown(0).Picture = Nothing
    cmdUpDown(1).Picture = Nothing
    cmdCancel.Picture = Nothing
    CmdPrevious.Picture = Nothing
    cmdNext.Picture = Nothing
    cmdComplete.Picture = Nothing
    picWizard.Picture = Nothing
End Sub
'初始化向导
Public Function SetQuota(clsQuotaSet As QuotaSet, clsFormCond As FormCond, Optional blnIsNew As Boolean = False) As Boolean
Dim intCount As Integer
Dim edtErrReturn As ErrDealType
    On Error GoTo ErrHandle
    
   mblnMeOK = False
   mblnInited = False
   mblnFormShow = False
   mblnFirstOpen = blnIsNew
   loadResPic
   Set mclsQuota = clsQuotaSet
   Set mclsFilter = clsFormCond
   
   For intCount = 0 To 3
      mblnIsInited(intCount) = False
   Next intCount
   '设置条件钩子
   Set mclsHook = New Hook
   mclsHook.SetHook MsgFilter.hwnd
   mstrSalaryList = mclsQuota.SalaryList
   mstrQuotaField = mclsQuota.SalField
   mstrQuotaStandard = mclsQuota.Standard
   If InitQuota(0) = False Then
        Utility.ShowMsg Me.hwnd, "还没有发放工资,不能打开向导!", vbInformation + vbOKOnly, App.title
        Exit Function
   End If
   sstQuota.Tab = 0
   InitQuota 1
   InitQuota 3
   SetTabValid 0
   mblnHeadChanged = False
   mblnFirstOpen = True
   mblnFormShow = True
   Me.Show vbModal
   SetQuota = mblnMeOK
   Exit Function
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Function
'把各种改变的条件写进类里
Private Sub GetQuotaWizard()
Dim intCount As Integer, intLoc As Integer, intHead As Integer, intCondLoc As Integer
Dim strTemp As String, strSel As String

    intHead = LstHeaded.ListCount
    If cboCond.ListIndex = 1 Then
         intHead = intHead + 1
         intCondLoc = 1
    Else
         intCondLoc = 0
    End If
    
    With mclsQuota
      .ReportName = txtName.Text
      .ChoosedColumns = lstReport.ListCount
      .ListColumns = LstHeaded.ListCount
      .SalaryList = cboSalary.Text
      .SalField = cboQuota.Text
      .Standard = cboStandard.Text
      intCount = cboCond.ListIndex
      .CondShow = intCount
      If mbytOldCondShow <> intCount Then
            .CondAlign = 1
            mblnHeadChanged = True
      End If
      For intCount = 0 To .Columns - 1
          strSel = marrFields(intCount, 0)
          .ColumnDesc(intCount) = StringOut(strSel, Space(100))
          .ColumnChoosed(intCount) = 0
          .ColumnStyle(intCount) = 0
      Next intCount
      '得到表头项目
        For intCount = 0 To LstHeaded.ListCount - 1
             MeFind LstHeaded.list(intCount), intLoc
             strTemp = marrFields(intLoc, 0)
             .ColumnListID(intCount) = marrFields(intLoc, 1)
             .ColumnListLoc(intCount) = intLoc
             .ColumnStyle(intLoc) = 6
             .CodeName(intLoc) = marrFields(intLoc, 12)
             If mblnHeadChanged Then
                .ColumnAlign(intLoc) = StandardReport.GetAddFCAlign(intHead, intCount + intCondLoc + 1, False)
                .ColumnHeight(intLoc) = 15 * Screen.TwipsPerPixelY
                .ColumnWidth(intLoc) = -1
                .ColumnTop(intLoc) = 100
                .ColumnLeft(intLoc) = 100
             End If
         Next intCount
       For intCount = 0 To lstReport.ListCount - 1
          strTemp = lstReport.list(intCount)
          MeFind strTemp, intLoc
         .ColumnChoosed(intLoc) = 1
         .ChoosedID(intCount) = marrFields(intLoc, 1)
       Next
    End With
End Sub
'在指定字符串里寻找数字
Private Sub MeFind(ByVal strSel As String, intLoc As Integer)
    Dim strTemp As String
    strTemp = Trim(GetNoXString(strSel, 2, Space(100)))
    intLoc = IIf(strTemp = "", 0, CInt(strTemp))
End Sub
'转换扣零标准
Private Function ConverDeduct(ByVal strName As String) As Integer
    Select Case strName
    Case "百元"
        ConverDeduct = 10000
    Case "五十元"
        ConverDeduct = 5000
    Case "十元"
        ConverDeduct = 1000
    Case "五元"
        ConverDeduct = 500
    Case "两元"
        ConverDeduct = 200
    Case "一元"
        ConverDeduct = 100
    Case "五角"
        ConverDeduct = 50
    Case "两角"
        ConverDeduct = 20
    Case "一角"
        ConverDeduct = 10
    Case "五分"
        ConverDeduct = 5
    Case "两分"
        ConverDeduct = 2
    Case "一分"
        ConverDeduct = 1
    Case Else
    End Select
End Function
'得到扣零标准
Private Sub GetDeduct()
    Dim strSql As String, strTemp As String
    Dim rstDeduct As rdoResultset
    Dim lngSalaryListID As Long
    
    strTemp = cboSalary.Text
    strTemp = GetNoXString(strTemp, 2, Space(100))
    
    strSql = "SELECT * FROM SalaryList WHERE lngSalaryListID =" & CLng(Val(strTemp))
    Set rstDeduct = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If rstDeduct.EOF Then
    Else
        mintDeductField = rstDeduct!dblDeductLevel * 100
        mlngDeductFieldID = rstDeduct!lngDeductFieldID
    End If
    If mintDeductField = 0 Then
        mintDeductField = 1
    End If
    mintDeductList = 1
    Set rstDeduct = Nothing
End Sub

'列表选中项目，对上下按钮的影响
Private Sub LstClick(Lst As ListBox, _
        cmdUp As CommandButton, cmdDown As CommandButton)
    Dim intCount As Integer
    If Lst.SelCount = 1 And Lst.ListCount > 1 Then
        For intCount = 0 To Lst.ListCount - 1
         If Lst.Selected(intCount) = True Then Exit For
        Next intCount
        cmdUp.Enabled = IIf(intCount = 0, False, True)
        cmdDown.Enabled = IIf(intCount = Lst.ListCount - 1, False, True)
    Else
        cmdUp.Enabled = False
        cmdDown.Enabled = False
    End If
End Sub
'设置TAB的有效性
Private Sub SetTabValid(ByVal intTab As Integer)
Dim x As Control
Dim intMin As Integer, intMax As Integer
    On Error Resume Next
    Select Case intTab
    Case 0
        intMin = 2
        intMax = 13
    Case 1
        intMin = 14
        intMax = 25
    Case 2
        intMin = 26
        intMax = 43
    Case 3
        intMin = 44
        intMax = 53
    End Select
    For Each x In Me.Controls
        If x.TabIndex >= intMin And x.TabIndex < intMax Then
            x.TabStop = True
        ElseIf x.TabIndex >= 54 Then
            x.TabStop = True
        Else
            x.TabStop = False
        End If
    Next
    sstQuota.TabStop = True
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
'筛选条件设置
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'响应钩子消息
Private Sub mclsHook_OnMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long, bCancel As Long)
  If Msg = WM_KEYUP Then
      If wParam = vbKeyUp Or wParam = vbKeyDown Then
          mclsFilter.MsgFilter_click Me
      End If
  End If
End Sub

'以下对应为条件控件过程

Private Sub CmdReset_Click()
      mclsFilter.CmdReset_Click Me
End Sub

Private Sub dateone_lostfocus()
    If sstQuota.Tab <> 2 Then Exit Sub
     mclsFilter.dateone_lostfocus Me
End Sub

Private Sub ReferText1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
     mclsFilter.ReferText1_MouseDown Me, Button, Shift, x, y
End Sub
Private Sub ReferText1_KeyPress(KeyAscii As Integer)
    mclsFilter.ReferText1_KeyPress Me, KeyAscii
End Sub
Private Sub ReferText2_KeyPress(KeyAscii As Integer)
    mclsFilter.ReferText2_KeyPress Me, KeyAscii
End Sub

Private Sub ReferText2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    mclsFilter.ReferText2_MouseDown Me, Button, Shift, x, y
End Sub
Private Sub ReferText2_ItemNotExist()
    mclsFilter.blnNotExist = True
End Sub
Private Sub tvwFilter_Collapse(ByVal Node As msComctlLib.Node)
    mclsFilter.tvwFilter_Collapse Me, Node
End Sub
Private Sub tvwFilter_Expand(ByVal Node As msComctlLib.Node)
    mclsFilter.tvwFilter_Expand Me, Node
End Sub

Private Sub tvwFilter_nodeClick(ByVal Node As msComctlLib.Node)
    mclsFilter.tvwFilter_nodeClick Me, Node
End Sub

Private Sub MsgFilter_click()
    mclsFilter.MsgFilter_click Me
End Sub

Private Sub refertext1_Choose()
    mclsFilter.refertext1_Choose Me
End Sub

Private Sub TxtFrom_KeyDown(KeyCode As Integer, Shift As Integer)
    If sstQuota.Tab <> 2 Then Exit Sub
    mclsFilter.TxtFrom_KeyDown Me, KeyCode, Shift
End Sub
Private Sub txtfrom_LostFocus()
    If sstQuota.Tab <> 2 Then Exit Sub
    mclsFilter.txtfrom_LostFocus Me
End Sub
         

Private Sub refertext2_Choose()
    mclsFilter.ref