quotaset.cls

金算盘软件代码

            intChoosed = intChoosed + 1
        End If
        If mvarFieldHead(intCount) = 2 And mvarColumnStyle(intCount) = 6 Then
            mvarListID(intList) = mvarColumnID(intCount)
            mvarListLoc(intList) = intCount
            intList = intList + 1
        End If
    Next intCount
    Set rstReport = Nothing
    On Error GoTo 0
End Sub

'得到配款记录SQL
Public Sub SetSQL()
Dim intCount As Integer, intLoc As Integer
Dim strTemp As String
    SetGroup
    EditQuotaField
    strTemp = ""
    For intCount = 0 To mvarChoosedColumns - 1
        intLoc = mvarChoosedLoc(intCount)
        If strTemp = "" Then
            strTemp = mvarFieldName(intLoc) & " As """ & mvarColumnDesc(intLoc) & """"
        Else
            strTemp = strTemp & "," & mvarFieldName(intLoc) & " As """ & mvarColumnDesc(intLoc) & """"
        End If
    Next intCount
    mstrSelect = "SELECT " & strTemp
End Sub
Private Sub SetGroup()
Dim strName As String
    strName = GetNoXString(mvarSalField, 3, Space(100))
    If strName = "" Then
        strName = "0"
    End If
    mstrIncome = strName
    mstrHaving = " Having Sum(" & strName & ")>0"
    Select Case mvarStandard
    Case "职员"
        mstrGroup = " GROUP BY strEmployeeCode,strEmployeeName"
    Case "部门"
        mstrGroup = " GROUP BY strDepartmentCode,strDepartmentName"
    Case "职员类别"
        mstrGroup = " GROUP BY strEmployeeTypeCode,strEmployeeTypeName"
    End Select
End Sub


'保存类到数据库
Public Function SaveTable(Optional blnSaveAs As Boolean = False) As Boolean
    On Error GoTo clsErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    
    If blnSaveAs Then
        AddReport
        mvarReportPrep = 2
    Else
        EditUpdate
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveTable = True
    Exit Function
clsErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
    SaveTable = False
End Function
'按用户ID重新保存一份标准表
Private Sub AddReport()
  Dim rstReport As rdoResultset
  Dim strSql As String
  Dim lngReportID As Long
   
'    On Error GoTo ErrHandle
'    If mvarSaveErr Then Exit Sub
'    gclsBase.BaseDB.BeginTrans
    
    '关闭表触发器
    strSql = "Alter Table Report Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
    mvarPrintSetID = StandardReport.GetPrintSetupID(10, mvarReportID)
    strSql = "Select * from Report"
    Set rstReport = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstReport
       .AddNew
          lngReportID = BillPublic.GetNewID("Report")
          !lngViewId = mvarViewID
          !bytGroup = mvarGroupNo
          !strReportName = mvarReportName
          !lngOperatorID = gclsBase.OperatorID
          !bytPrep = 2
          !bytWizard = 10
          !lngParentId = mvarParentID
          !lngPrintSetupID = mvarPrintSetID
          !intLevel = mvarLevel
          !strDate = Format(gclsBase.BaseDate, "YYYY-MM-DD")
          !blnIsDetail = 1
          !strExtraCond = IIf(mvarReportCond = "", " ", mvarReportCond)
          !lngReportID = lngReportID
       .Update
    End With
    
    '打开表触发器
    strSql = "Alter Table Report Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
'    gclsBase.BaseDB.CommitTrans
    
    Set rstReport = Nothing
    CopyReportField (lngReportID)
    mvarReportID = lngReportID
    EditUpdate
'    Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Set rstReport = Nothing
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub

'复制所有报表字段
Private Sub CopyReportField(ByVal lngReportID As Long)
  Dim strSql As String
  Dim rstSource As rdoResultset, rstDesc As rdoResultset
  Dim lngFieldID As Long
  Dim fldReportField As rdoColumn
     
'     On Error GoTo ErrHandle
'     If mvarSaveErr Then Exit Sub
'     gclsBase.BaseDB.BeginTrans
     
     strSql = "Select * from ReportField Where lngReportId=" & mvarReportID
     Set rstSource = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
     
     strSql = "Select * from ReportField Where lngReportId=" & lngReportID
     Set rstDesc = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
     
     '关闭表触发器
    strSql = "Alter Table ReportField Disable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
    
     With rstSource
         Do While Not .EOF
            rstDesc.AddNew
            For Each fldReportField In .rdoColumns
                If UCase(fldReportField.Name) = UCase("lngReportId") Then
                    rstDesc!lngReportID = lngReportID
                Else
                     If UCase(fldReportField.Name) <> UCase("lngReportFieldId") Then
                         rstDesc.rdoColumns(fldReportField.Name).Value = fldReportField.Value
                     Else
                         lngFieldID = BillPublic.GetNewID("reportField")
                         rstDesc.rdoColumns(fldReportField.Name).Value = lngFieldID
                     End If
                End If
            Next
            rstDesc.Update
            .MoveNext
         Loop
     End With
     '打开表触发器
    strSql = "Alter Table ReportField Enable All Triggers"
    gclsBase.BaseDB.Execute (strSql)
'     gclsBase.BaseDB.CommitTrans
     Set rstSource = Nothing
     Set rstDesc = Nothing
'     Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Set rstSource = Nothing
'    Set rstDesc = Nothing
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub

'更新用户自定义标准表的修改
Private Sub EditUpdate()
  Dim strSql As String
  Dim intCount As Integer, intLoc As Integer
'  Dim rstTemp As rdoResultset
  
'  On Error GoTo ErrHandle
'  If mvarSaveErr Then Exit Sub
'  gclsBase.BaseDB.BeginTrans
  
  '更新报表
  strSql = "UPDATE Report Set " _
            & "intTitleWidth=" & mvarTitleWidth & ",intTitleHeight=" & mvarTitleHeight & ",intTitleTop=" & mvarTitleTop & ",intTitleLeft=" & mvarTitleLeft & ",intTitleAlign=" & mvarTitleAlign _
            & ",intCondWidth=" & mvarCondWidth & ",intCondHeight=" & mvarCondHeight & ",intCondTop=" & mvarCondTop & ",intCondLeft=" & mvarCondLeft & ",intCondAlign=" & mvarCondAlign & ",bytCondShow=" & mvarCondShow _
            & ",strReportName='" & mvarReportName & "',bytVersion=" & mvarVersion _
            & ",intGridTop=" & mvarGridTop _
            & ",strSalaryID='" & mvarSalaryList & "',strSalaryFieldID='" & mvarSalField & "$" & mvarStandard & "'" _
            & " WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
    
  '初始化报表字段
  strSql = "UPDATE ReportField Set blnIsChoosed=0,bytReportFieldType=0" & _
            ",bytCodeShow=2,lngReportFieldNO=0  WHERE lngReportID =" & mvarReportID
  gclsBase.ExecSQL strSql
  
  '更新报表已选字段
  For intLoc = 0 To mvarChoosedColumns - 1
      intCount = mvarChoosedLoc(intLoc)
      strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
            & "',bytReportFieldType=" & mvarColumnStyle(intCount) _
            & ",lngReportFieldNO=" & intLoc + 1 & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
            & ",blnIsChoosed=1 " _
            & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
      gclsBase.ExecSQL strSql
  Next intLoc
  '更新报表列表框字段
  For intLoc = 0 To mvarListColumns - 1
      intCount = mvarListLoc(intLoc)
      strSql = "UPDATE ReportField Set strReportFieldDesc='" & mvarColumnDesc(intCount) _
            & "',bytReportFieldType=" & mvarColumnStyle(intCount) & ",bytCodeShow=" & mvarCodeName(intCount) _
            & ",lngReportFieldNO=" & intLoc + mvarChoosedColumns + 1 & ",lngDisplayWidth=" & mvarColumnWidth(intCount) _
            & ",lngDisplayHeight=" & mvarColumnHeight(intCount) & ",lngDisplayTop=" & mvarColumnTop(intCount) _
            & ",lngDisplayLeft=" & mvarColumnLeft(intCount) & ",intAlign=" & mvarColumnAlign(intCount) _
            & " Where lngReportId= " & mvarReportID & " And lngViewFieldId=" & mvarColumnID(intCount)
      gclsBase.ExecSQL strSql
  Next intLoc
'  gclsBase.BaseDB.CommitTrans
'  Exit Sub
'
'ErrHandle:
'    gclsBase.BaseDB.RollBacktrans
'    Utility.ShowMsg frmMain.hwnd, Err.Description, vbCritical + vbOKOnly, App.title
'    mvarSaveErr = True
End Sub
'显示向导窗口
Public Function ShowWizard(Optional ByVal lngReportID As Long, Optional lngParentId As Long, _
       Optional intParentLevel As Integer, Optional clsWizardFormCond As FormCond, _
       Optional blnIsNew As Boolean = True) As Boolean
   Dim clsFormCond As FormCond
   '准备工作
    If mvarReportID = 0 Then
        GetReportSet lngReportID
    End If
    If mvarParentID = 0 Then
        mvarParentID = lngParentId
        mvarLevel = intParentLevel
    End If
    If clsWizardFormCond Is Nothing Then
        Set clsFormCond = New FormCond
    Else
        Set clsFormCond = clsWizardFormCond
    End If
    '显示向导窗口
    ShowWizard = frmQuota.SetQuota(Me, clsFormCond, blnIsNew)

    If ShowWizard And blnIsNew Then
       '由向导新生成了一张帐表(还未存到数据库)
        Report.ShowQuota 0, 0, Me, clsFormCond
    End If
End Function
'配款处理
Private Sub EditQuotaField()
Dim strTemp As String
Dim arrQuota(13) As Boolean
Dim arrLoc(13) As Integer
Dim intCount As Integer, intLoc As Integer
    
    For intCount = 0 To mvarChoosedColumns - 1
        intLoc = mvarChoosedLoc(intCount)
        Select Case mvarFieldDesc(intLoc)
        Case "配款项目"
            mvarFieldName(intLoc) = "Ltrim(To_Char(Sum(" & mstrIncome & "),'999999999990.00'))"
        Case "百元"
            arrQuota(1) = True
            arrLoc(1) = intLoc
        Case "五十元"
            arrQuota(2) = True
            arrLoc(2) = intLoc
        Case "二十元"
            arrQuota(3) = True
            arrLoc(3) = intLoc
        Case "十元"
            arrQuota(4) = True
            arrLoc(4) = intLoc
        Case "五元"
            arrQuota(5) = True
            arrLoc(5) = intLoc
        Case "两元"
            arrQuota(6) = True
            arrLoc(6) = intLoc
        Case "一元"
            arrQuota(7) = True
            arrLoc(7) = intLoc
        Case "五角"
            arrQuota(8) = True
            arrLoc(8) = intLoc
        Case "两角"
            arrQuota(9) = True
            arrLoc(9) = intLoc
        Case "一角"
            arrQuota(10) = True
            arrLoc(10) = intLoc
        Case "五分"
            arrQuota(11) = True
            arrLoc(11) = intLoc
        Case "两分"
            arrQuota(12) = True
            arrLoc(12) = intLoc
        Case "一分"
            arrQuota(13) = True
            arrLoc(13) = intLoc
        Case Else
        End Select
    Next intCount
     ''''''''''Oracle函数：Floor ==Access函数：INT
    ''''''''''Oracle函数：SUBSTR(str,a,[b]) b>0 LEFT(str,b)；b<0 Right(str,b)
    strTemp = "Sum(" & mstrIncome & " * 100)"
    If arrQuota(1) Then
        mvarFieldName(arrLoc(1)) = "Floor(" & strTemp & "/10000)"
        strTemp = "(SUBSTR(" & strTemp & ",-4,4)) "
    End If
    If arrQuota(2) Then
        mvarFieldName(arrLoc(2)) = "Floor(" & strTemp & "/5000)"
        strTemp = "MOD(" & strTemp & ",5000) "
    End If
    If arrQuota(3) Then
        mvarFieldName(arrLoc(3)) = "Floor(" & strTemp & "/2000)"
        strTemp = "MOD(" & strTemp & ",2000) "
    End If
    If arrQuota(4) Then
        mvarFieldName(arrLoc(4)) = "Floor(" & strTemp & "/1000)"
        strTemp = "MOD(" & strTemp & ",1000) "
    End If
    If arrQuota(5) Then
        mvarFieldName(arrLoc(5)) = "Floor(" & strTemp & "/500)"
        strTemp = "MOD(" & strTemp & ",500) "
    End If
    If arrQuota(6) Then
        mvarFieldName(arrLoc(6)) = "Floor(" & strTemp & "/200)"
        strTemp = "MOD(" & strTemp & ",200) "
    End If
    If arrQuota(7) Then
        mvarFieldName(arrLoc(7)) = "Floor(" & strTemp & "/100)"
        strTemp = "MOD(" & strTemp & ",100) "
    End If
    If arrQuota(8) Then
        mvarFieldName(arrLoc(8)) = "Floor(" & strTemp & "/50)"
        strTemp = "MOD(" & strTemp & ",50) "
    End If
    If arrQuota(9) Then
        mvarFieldName(arrLoc(9)) = "Floor(" & strTemp & "/20)"
        strTemp = "MOD(" & strTemp & ",20) "
    End If
    If arrQuota(10) Then
        mvarFieldName(arrLoc(10)) = "Floor(" & strTemp & "/10)"
        strTemp = "MOD(" & strTemp & ",10) "
    End If
    If arrQuota(11) Then
        mvarFieldName(arrLoc(11)) = "Floor(" & strTemp & "/5)"
        strTemp = "MOD(" & strTemp & ",5) "
    End If
    If arrQuota(12) Then
        mvarFieldName(arrLoc(12)) = "Floor(" & strTemp & "/2)"
        strTemp = "MOD(" & strTemp & ",2) "
    End If
    If arrQuota(13) Then
        mvarFieldName(arrLoc(13)) = "Floor(" & strTemp & ")"
    End If
    Erase arrQuota
    Erase arrLoc
End Sub

Private Sub Class_Terminate()
    Erase mvarColumnID()
    Erase mvarColumnDesc()
    Erase mvarColumnWidth()
    Erase mvarColumnHeight()
    Erase mvarColumnLeft()
    Erase mvarColumnTop()
    Erase mvarColumnAlign()
    Erase mvarColumnChoosed()
    Erase mvarColumnStyle()
    Erase mvarFieldDesc()
    Erase mvarFieldSize()
    Erase mvarFieldName()
    Erase mvarFieldType()
    Erase mvarFieldHead()
    Erase mvarCodeName()
    
    Erase mvarChoosedID()
    Erase mvarChoosedLoc()
    Erase mvarListID()
    Erase mvarListLoc()
End Sub