frmcontractreport.frm

金算盘软件代码

                  For intCount = mintPayLoc - 1 To mintPayLoc + mintPayCount - 2
                      .ColWidth(intCount) = 90
                      .SetColAlignment intCount, intCount, 3, 2, -1, -1, -1
                      .SetColDataType intCount, intCount, 1, 1, 2, -1
                      intCol = intCol + 1
                  Next intCount
                  intColumn = intColumn + 1
               Else
                  If mclsListSet.ColumnWidth(intColumn) <> 0 Then
                     .ColWidth(intCol) = mclsListSet.ColumnWidth(intColumn) / Screen.TwipsPerPixelX + 10
                  Else
                     .ColWidth(intCol) = 1500 / Screen.TwipsPerPixelX + 10
                  End If
                  If UCase(mclsListSet.ColumnFieldType(intColumn)) = "INTEGER" Or UCase(mclsListSet.ColumnFieldType(intColumn)) = "LONG" Or UCase(mclsListSet.ColumnFieldType(intColumn)) = "DOUBLE" Then
                      .SetColAlignment intCol, intCol, 3, 2, -1, -1, -1
                      .SetColDataType intCol, intCol, 1, 1, 2, -1
                  End If
                  intColumn = intColumn + 1
                  intCol = intCol + 1
               End If
            Else
               intCol = intCol + 1
            End If
        Loop
        
        For intCol = 0 To intCols - 1
            .SetCellPattern 0, intCol, 1, intCol, 0, RGB(192, 192, 192), -1, -1
            .SetCellForeColor 0, 0, 1, intCols, RGB(0, 0, 0)
            .ColName(intCol) = mrstData.rdoColumns(intCol).Name
            
            If mrstData.rdoColumns(intCol).Name = "申请拨款" Then
               mintMoneyCol = intCol
            End If
            
            '工程预算批复明细表
            If mintPayCount > 0 And intCol >= mintPayLoc - 1 And intCol <= mintPayLoc + mintPayCount - 2 Then
                If intCol = mintPayLoc - 1 Then
                    .CellFormula(0, intCol) = "支付情况"
                    .SetCellAlignment 0, intCol, 0, intCol, -1, -1, -1, 0, mintPayCount - 1
                    .SetCellBorder 0, intCol, 0, intCol + mintPayCount - 1, 1, 0, 8
                End If
                .CellFormula(1, intCol) = mrstData.rdoColumns(intCol).Name
            Else
                .CellFormula(0, intCol) = mrstData.rdoColumns(intCol).Name
                If mrstData.rdoColumns(intCol).Name = "申请拨款" Then
                    mintRequire = intCol
                End If
                .SetCellAlignment 0, intCol, 0, intCol, 2, -1, -1, 1, -1
            End If
        Next intCol
        
        '加排序标志
        If mstrOrder = "" Then
            If mintPayCount > 0 And cmbFind.ListIndex + 1 >= mintPayLoc And cmbFind.ListIndex + 1 <= mintPayLoc + mintPayCount - 1 Then
               .CellFormula(1, cmbFind.ListIndex) = .CellFormula(1, cmbFind.ListIndex) & "↑"
               mbytOrder = 1
            Else
               .CellFormula(0, cmbFind.ListIndex) = .CellFormula(0, cmbFind.ListIndex) & "↑"
               mbytOrder = 1
            End If
        Else
            If mintPayCount > 0 And cmbFind.ListIndex + 1 >= mintPayLoc And cmbFind.ListIndex + 1 <= mintPayLoc + mintPayCount - 1 Then
               .CellFormula(1, cmbFind.ListIndex) = .CellFormula(1, cmbFind.ListIndex) & "↓"
               mbytOrder = 2
            Else
               .CellFormula(0, cmbFind.ListIndex) = .CellFormula(0, cmbFind.ListIndex) & "↓"
               mbytOrder = 2
            End If
        End If
        
        If mrtBook = rtDudgetDetail Then
           .SetColProtect intCols - 5, intCols - 1, -1, 1
        Else
           .SetColProtect intCols - 3, intCols - 1, -1, 1
        End If
        
        .Refresh
        .Row = 2
    End With
  
End Sub

'加合同参照
Private Sub AddContract()
  Dim strSql As String
  Dim rstJob As rdoResultset
  
  strSql = "Select ProjectOrder.lngOrderID,ProjectOrder.strOrderCode From ProjectOrder Order By strOrderCode"
  lstContract.ClearRefer
  Set lstContract.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  lstContract.AddRefer "所有"
  If mlngOrderID = 0 Then
     lstContract.ReferRow = 0
  Else
     lstContract.SeekId mlngOrderID
  End If
End Sub

'加查找栏目
Private Sub AddFind()
  Dim intCol As Integer, intCount As Integer
  
    cmbFind.Clear
    mstrOrder = ""
    mintOldCol = -1
    For intCol = 1 To mclsListSet.Columns
       'If mclsListSet.ColumnIsFind(intCol) Then
          If mclsListSet.ColumnDesc(intCol) <> "实际支付" Then
             cmbFind.AddItem mclsListSet.ColumnDesc(intCol)
          Else
             For intCount = 1 To mintPayCount
                 cmbFind.AddItem mstrPay(intCount)
             Next intCount
          End If
       'End If
    Next intCol
    If cmbFind.ListCount > 0 Then
       cmbFind.ListIndex = 0
    End If
End Sub

'加工程参照
Private Sub AddJob()
  Dim strSql As String
  Dim rstJob As rdoResultset
  
  strSql = "Select Project.lngProjectID,Project.strProjectCode,Project.strProjectName From Project Where blnIsInActive=0 Order By strProjectCode"
  lstJob.ClearRefer
  Set lstJob.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  lstJob.AddRefer "所有"
  If mlngJobID = 0 Then
     lstJob.ReferRow = 0
  Else
     lstJob.SeekId mlngJobID
  End If
End Sub

'加付款方参照
Private Sub AddPay()
  Dim strSql As String
  Dim rstJob As rdoResultset
  
  strSql = "Select PayCustomer.lngPayCustomerID,PayCustomer.strPayCustomerName From PayCustomer"
  lstPay.ClearRefer
  Set lstPay.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  lstPay.AddRefer "所有"
  If mlngPayID = 0 Then
     lstPay.ReferRow = 0
  Else
     lstPay.SeekId mlngPayID
  End If
End Sub

Private Sub AddReport()
  Dim strSql As String
  Dim rstReport As rdoResultset
  
  strSql = "Select lngRatifyID,strRatifyName,bytCount,intPayLoc,intPayCount,strEndDate,strUseDate From Ratify Order By strRatifyName"
  lstReport.ClearRefer
  lstReport.SeekCol = "1,2"
  Set lstReport.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
  lstReport.AddRefer "当前"
  lstReport.ReferRow = 1
End Sub

Private Function GetHeadCond() As String
 Dim strCode As String
 
  GetHeadCond = "1=1"
  If mrtBook = rtPayPlan Or mrtBook = rtContract Or mrtBook = rtRatifyDetail Or mrtBook = rtPayDetail Then
     If lstJob.Text <> "所有" Then
        strCode = GetNoXString(lstJob.Text, 1)
        GetHeadCond = GetHeadCond & " And (Project.strProjectCode='" & strCode & "' Or Project.strProjectCode Like '" & strCode & "-%')"
     End If
  End If
  If mrtBook = rtPayDetail Then
     If lstPay.Text <> "所有" Then
        GetHeadCond = GetHeadCond & " And PayCustomer.lngPayCustomerID=" & lstPay.ID
     End If
  End If
  If mrtBook = rtPayPlan Then
     If lstContract.Text <> "所有" Then
        GetHeadCond = GetHeadCond & " And ProjectOrder.lngOrderID=" & lstContract.ID
     End If
  End If
  If mrtBook = rtContract Then
     GetHeadCond = GetHeadCond & " And RprojectSum.strStopDate<='" & detEnd.Text & "'"
  End If
  
  If mrtBook = rtRatifyDetail Then
     GetHeadCond = GetHeadCond & " And ProjectFundIn.strDate<='" & detEnd.Text & "'"
  End If

  If mrtBook = rtPayDetail Then
     GetHeadCond = GetHeadCond & " And VoucherDetail.strPayDate<='" & detEnd.Text & "'"
  End If
End Function

'得到工程项目子查询
Private Sub GetProjectQuery(strReturn As String, strName As String, Optional ByVal lngViewId As Long = 1193)
Dim intCount As Integer
Dim strSql As String, strTemp As String
Dim strZero As String, strValue As String
Dim rdoProject As rdoResultset
   
    mintPayLoc = -1
    mintPayCount = 0
    '找到实际支付项目位置
    strName = ""
    With mclsListSet
        For intCount = 1 To .Columns
            If .ColumnDesc(intCount) = "实际支付" Then
                mintPayLoc = intCount
                Exit For
            End If
        Next intCount
    End With
    
    Erase mstrPay
    
    '生成子查询项目
    intCount = 0
    strSql = "SELECT * FROM PayCustomer"
    Set rdoProject = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rdoProject
        Do Until .EOF
            intCount = intCount + 1
            If intCount > 100 Then
                Utility.ShowMsg Me.hwnd, "付款方太多，后面的将丢掉！", vbInformation + vbOKOnly, App.title
                Exit Do
            End If
            strTemp = """" & !lngPayCustomerID & "~"""
            strZero = strZero & ",0 As " & strTemp
            strValue = strValue & ",Decode(VoucherDetail.lngPayCustomerID," & !lngPayCustomerID & ",VoucherDetail.dblPaymentAmount,0) As " & strTemp
            strName = strName & "Sum(Decode(Sign(To_Date('JZRQ','YYYY-MM-DD')-To_Date(Rproject.strDate,'YYYY-MM-DD')),-1,0,Rproject." & strTemp & ")) As """ & !strPayCustomerName & ""","
            ReDim Preserve mstrPay(intCount)
            mstrPay(intCount) = !strPayCustomerName
            .MoveNext
        Loop
    End With
    Set rdoProject = Nothing
    
    If strName = "" Then       '没有付款方
        strZero = ",0 As ""1~"""
        strValue = strZero
        strName = "Sum(0) As ""实际支付"""
        mintPayCount = 1
        ReDim Preserve mstrPay(mintPayCount)
        mstrPay(mintPayCount) = "实际支付"
    Else
        strZero = strZero & ",0 As ""合计~"""
        strValue = strValue & ",VoucherDetail.dblPaymentAmount As ""合计~"" "
        strName = strName & "Sum(Decode(Sign(To_Date('JZRQ','YYYY-MM-DD')-To_Date(Rproject.strDate,'YYYY-MM-DD')),-1,0,Rproject.""合计~"")) As ""合计"""
        mintPayCount = intCount + 1
        ReDim Preserve mstrPay(mintPayCount)
        mstrPay(mintPayCount) = "合计"
    End If
    '组织子查询
    strTemp = "SELECT ProjectOrder.lngProjectID, ProjectOrderPlan.strDate, ProjectOrderPlan.dblAmount As dblOrderAmount,0 As dblFundAmount"
    strTemp = strTemp & strZero & " FROM ProjectOrder, ProjectOrderPlan Where ProjectOrder.lngOrderID = ProjectOrderPlan.lngOrderID"
    
    strTemp = strTemp & " UNION All SELECT ProjectFundIn.lngProjectID, ProjectFundIn.strDate, 0 As dblOrderAmount,ProjectFundIn.dblAmount As dblFundAmount"
    strTemp = strTemp & strZero & " FROM ProjectFundIn"
    
    strTemp = strTemp & " UNION All SELECT Project.lngProjectID, VoucherDetail.strPayDate,0 As dblOrderAmount,0 As dblFundAmount"
    strTemp = strTemp & strValue & " FROM VoucherDetail, Project, Voucher Where Project.lngProjectID = VoucherDetail.lngProjectID And Voucher.lngVoucherID = VoucherDetail.lngVoucherID And Voucher.blnIsVoid = 0 And VoucherDetail.lngPayCustomerID>0"
    
    strReturn = "(" & strTemp & ") Rproject"
    If mintPayLoc = -1 Then
       mintPayCount = 0
       mintPayLoc = 0
    End If
End Sub

Private Sub GetSaveData(strSelect As String)
  Dim strSql As String
  Dim rstRatify As rdoResultset
  Dim intCount As Integer, blnPay As Boolean, intCol As Integer, intReqire As Integer

    blnPay = False
    strSql = "Select * From RatifyField Where lngRatifyID=" & mlngRatifyID & " Order By intOrder"
    Set rstRatify = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    With rstRatify
       mclsListSet.Columns = .RowCount + 2
       intCount = 1
       intCol = 1
       Do While Not .EOF
          If intCount >= mintPayLoc And intCount <= mintPayLoc + mintPayCount - 1 Then
              If Not blnPay Then
                 mclsListSet.ColumnDesc(intCount) = "实际支付"
                 mclsListSet.ColumnWidth(intCount) = 1500
                 intCount = intCount + 1
                 blnPay = True
              End If
          Else
              mclsListSet.ColumnDesc(intCount) = !strDesc
              mclsListSet.ColumnWidth(intCount) = 1500
              intCount = intCount + 1
          End If
          Select Case !strDesc
            Case "工程项目编号"
             strSelect = strSelect & ",Project.strProjectCode As 工程项目编号"
            Case "在建工程编号"
             strSelect = strSelect & ",Project.strProjectCode As 在建工程编号"
            Case "工程项目名称"
                 strSelect = strSelect & ",Project.strProjectName As 工程项目名称"
            Case "在建工程名称"
                 strSelect = strSelect & ",Project.strProjectName As 在建工程名称"
            Case "计量单位"
                 strSelect = strSelect & ",Project.strUnit As 计量单位"
            Case "申请拨款"
                 mclsListSet.ColumnFieldType(intCount - 1) = "DOUBLE"
                 intReqire = intCol
                 strSelect = strSelect & ",dblData" & CStr(intCol) & " As " & !strDesc
            Case Else
                 mclsListSet.ColumnFieldType(intCount - 1) = "DOUBLE"
                 strSelect = strSelect & ",dblData" & CStr(intCol) & " As " & !strDesc
          End Select
          .MoveNext
          intCol = intCol + 1
       Loop
       mclsListSet.ColumnDesc(intCount) = "增减变动"
       mclsListSet.ColumnWidth(intCount) = 1500
       mclsListSet.ColumnFieldType(intCount) = "DOUBLE"
       strSelect = strSelect & "," & "dblData20 As 增减变动"
       intCount = intCount + 1
       mclsListSet.ColumnDesc(intCount) = "审批金额"
       mclsListSet.ColumnWidth(intCount) = 1500
       mclsListSet.ColumnFieldType(intCount) = "DOUBLE"
       strSelect = strSelect & ",dblData20+dblData" & intReqire & " As 审批金额"
    End With
    rstRatify.Close
    Set rstRatify = Nothing
    If Left(strSelect, 1) = "," Then
       strSelect = Mid(strSelect, 2)
    End If
End Sub

Private Sub RefreshData(Optional IsFilter As Boolean = True, Optional IsAddFind As Boolean = False)
 Dim strSql As String
 Dim strHeadCond As String, strGroup As String, strOrder As String
 Dim strTemp As String, strEnd As String, strUse As String, strsub As String
 Dim strID As String, strWhere As String, strSelect As String
 
   If Not mblnChoose Then
      Exit Sub
   End If
   
   On Error GoTo ErrHandle
   mblnChoose = False
   If IsFilter Or mrtBook = rtDudgetDetail Then
     strWhere = Filter.GetInitWhere(mclsListSet.ListID, 1)
     If strWhere = "" Then
        strWhere = mclsListSet.GetWhereInFrom
     Else