frmcontractreport.frm

金算盘软件代码

    With rstReport
       .AddNew
          lngRatifyID = BillPublic.GetNewID("Ratify")
          !lngRatifyID = lngRatifyID
          mlngRatifyID = lngRatifyID
          !strRatifyName = strName
          !lngOperatorID = gclsBase.OperatorID
          !strDate = Format(gclsBase.BaseDate, "yyyy-mm-dd")
          !bytCount = mGrid.Cols - 5
          !intPayLoc = mintPayLoc
          !intPayCount = mintPayCount
          !strEndDate = Format(detEnd.Text, "yyyy-MM-dd")
          !strUseDate = Format(detUse.Text, "yyyy-MM-dd")
       .Update
    End With

    strSql = "Select * from RatifyField Where lngRatifyID=" & mlngRatifyID
    Set rstReport = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic, rdConcurValues)
    With rstReport
       For intCol = 0 To mGrid.Cols - 6
            .AddNew
               lngFieldID = BillPublic.GetNewID("RatifyField")
               !lngRatifyID = mlngRatifyID
               !lngFieldID = lngFieldID
               !intOrder = intCol + 1
               If intCol >= mintPayLoc - 1 And intCol <= mintPayLoc + mintPayCount - 2 Then
                  !strDesc = strReplace(strReplace(mGrid.CellValue(1, intCol), "↑", ""), "↓", "")
               Else
                  !strDesc = strReplace(strReplace(mGrid.CellValue(0, intCol), "↑", ""), "↓", "")
               End If
            .Update
       Next intCol
    End With

    With mGrid
       For lngRow = 2 To mGrid.Rows - 1
            'If .CellValue(lngRow, .Cols - 4) = 1 Then
                lngRatifyDetailID = BillPublic.GetNewID("RatifyDetail")
                strField = "lngRatifyID,lngRatifyDetailID,lngProjectID"
                strValue = CStr(mlngRatifyID) & "," & CStr(lngRatifyDetailID) & "," & .CellValue(lngRow, mGrid.Cols - 3)
                For intCol = 0 To mGrid.Cols - 6
                   If InStr(1, .CellValue(0, intCol), "工程项目编号") = 0 And InStr(1, .CellValue(0, intCol), "工程项目名称") = 0 _
                      And InStr(1, .CellValue(0, intCol), "在建工程编号") = 0 And InStr(1, .CellValue(0, intCol), "在建工程名称") = 0 Then
                        strField = strField & ",dblData" & CStr(intCol + 1)
                        '计量单位为字符型
                        If InStr(1, .CellValue(0, intCol), "计量单位") <> 0 Then
                           strValue = strValue & ",0"
                        Else
                           strValue = strValue & "," & IIf(IsNumeric(.CellValue(lngRow, intCol)), CDbl(IIf(Not IsNull(.CellValue(lngRow, intCol)), .CellValue(lngRow, intCol), 0)), 0)
                        End If
                   End If
                Next intCol
                strSql = "Insert Into RatifyDetail (" & strField & ") Values (" & strValue & ")"
                gclsBase.BaseDB.Execute strSql
            'End If
       Next lngRow
    End With
    AddReport
End Sub

Private Sub detEnd_GotFocus()
   mstrOldEnd = detEnd.Text
End Sub

Private Sub detEnd_LostFocus()
   If mrtBook = rtDudgetDetail Then
        If detEnd.Text > detUse.Text And Not Me.ActiveControl Is detUse Then
           ShowMsg Me.hwnd, "截止日期不能大于预计用款日期!", vbOKOnly + vbInformation, Me.Caption
           detEnd.SetFocus
           Exit Sub
        End If
   End If
   If detEnd.Text <> mstrOldEnd And mstrOldEnd <> "" Then
      RefreshData
   End If
End Sub

Private Sub detUse_GotFocus()
   mstrOldUse = detUse.Text
End Sub

Private Sub detUse_LostFocus()
   If mrtBook = rtDudgetDetail Then
        If detEnd.Text > detUse.Text And Not Me.ActiveControl Is detEnd Then
           ShowMsg Me.hwnd, "截止日期不能大于预计用款日期!", vbOKOnly + vbInformation, Me.Caption
           detUse.SetFocus
           Exit Sub
        End If
   End If
   If detUse.Text <> mstrOldUse And mstrOldUse <> "" Then
      RefreshData
   End If
End Sub

Private Sub Form_Load()
   cmdAgain.Enabled = False
   gcolContract.Add Me, CStr(Me.hwnd)
   Set mclsMainControl = gclsSys.MainControls.Add(Me)
End Sub

Private Function FindText(ByVal strFind As String, Optional FromNow As Boolean = False)
  Dim lngBegin As Long, lngEnd As Long, lngFindRow As Long, lngPrev As Long
  Dim intFindCol As Integer
  Dim strCell As String
  Dim blnFound As Boolean
  Dim lngStopRow As Long, blnNum As Boolean, dblCell As Double, dblFind As Double
  
    If strFind = "" Or mblnNotFind Then
       Exit Function
    End If
    
    intFindCol = cmbFind.ListIndex
    
    If mintPayCount > 0 Then
        If intFindCol + 1 >= mintPayLoc And intFindCol + 1 <= mintPayLoc + mintPayCount - 1 Then
             blnNum = True
        Else
          If intFindCol + 1 < mintPayLoc Then
              If UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "INTEGER" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "LONG" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "DOUBLE" Then
                 blnNum = True
              Else
                 blnNum = False
              End If
          Else
              If UCase(mclsListSet.ColumnFieldType(intFindCol + 1 - (mintPayCount - 1))) = "INTEGER" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1 - (mintPayCount - 1))) = "LONG" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1 - (mintPayCount - 1))) = "DOUBLE" Then
                 blnNum = True
              Else
                 blnNum = False
              End If
          End If
        End If
    Else
        If UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "INTEGER" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "LONG" Or UCase(mclsListSet.ColumnFieldType(intFindCol + 1)) = "DOUBLE" Then
           blnNum = True
        Else
           blnNum = False
        End If
    End If
    
    
    If FromNow Then
      lngBegin = mlngLastPosition + 1
    Else
      lngBegin = 1
    End If
    lngStopRow = lngBegin
    lngEnd = mrstData.RowCount
    
    If IsNumeric(strFind) Then
       dblFind = CDbl(strFind)
    Else
       dblFind = 0
    End If
    
    With mrstData
        Do While lngEnd - lngBegin >= 0
            .AbsolutePosition = lngBegin + (lngEnd - lngBegin) \ 2
            
            strCell = IIf(IsNull(.rdoColumns(intFindCol).Value), "", .rdoColumns(intFindCol).Value)
            If IsNumeric(strCell) Then
               dblCell = CDbl(strCell)
            Else
               dblCell = 0
            End If
            
            If (InStr(strCell, strFind) = 1 And Not blnNum) Or (dblCell = dblFind And blnNum) Then
               lngFindRow = lngBegin + (lngEnd - lngBegin) \ 2
               If lngFindRow < 10 And lngFindRow > lngStopRow Then
                    lngPrev = lngBegin + (lngEnd - lngBegin) \ 2 - 1
                    If lngPrev >= 0 Then
                        .AbsolutePosition = lngPrev
                        strCell = IIf(IsNull(.rdoColumns(intFindCol).Value), "", .rdoColumns(intFindCol).Value)
                        If IsNumeric(strCell) Then
                           dblCell = CDbl(strCell)
                        Else
                           dblCell = 0
                        End If
                        
                        Do While lngPrev >= lngStopRow - 1 And Not .BOF
                           strCell = IIf(IsNull(.rdoColumns(intFindCol).Value), "", .rdoColumns(intFindCol).Value)
                           If IsNumeric(strCell) Then
                              dblCell = CDbl(strCell)
                           Else
                              dblCell = 0
                           End If
                           If (InStr(strCell, strFind) <> 1 And Not blnNum) Or (dblCell <> dblFind And blnNum) Then
                             Exit Do
                           Else
                             lngFindRow = lngPrev
                             lngPrev = lngPrev - 1
                             If Not .BOF Then
                                .MovePrevious
                             End If
                           End If
                        Loop
                    End If
                    blnFound = True
                    lngBegin = lngPrev
                    Exit Do
               End If
               blnFound = True
            End If
            
            If (strCell >= strFind And Not blnNum) Or (dblCell >= dblFind And blnNum) Then
                 If lngEnd - lngBegin > 1 Then
                    lngEnd = lngBegin + (lngEnd - lngBegin) \ 2
                 Else
                    lngEnd = lngEnd - 1
                 End If
            Else
                 If lngEnd - lngBegin > 1 Then
                    lngBegin = lngBegin + (lngEnd - lngBegin) \ 2
                 Else
                    lngBegin = lngBegin + 1
                 End If
            End If
        Loop
    End With
    If blnFound Then
        If mGrid.Row = lngFindRow + 1 Then
           mGrid.Row = lngFindRow + 1
           mGrid_AfterRowChange mGrid.Row
        Else
           mGrid.Row = lngFindRow + 1
        End If
        mlngLastPosition = lngFindRow
        cmdAgain.Enabled = True
    Else
        cmdAgain.Enabled = False
    End If
End Function

Private Sub Form_Resize()
  On Error GoTo ErrHandle
  If Me.Height < conHeight Then
     Me.Height = conHeight
  End If
  If Me.width < conWidth Then
     Me.width = conWidth
  End If
  lblDate.Visible = False
  detEnd.Visible = False
  lblUse.Visible = False
  detUse.Visible = False
  lblJob.Visible = False
  lstJob.Visible = False
  lblPay.Visible = False
  lstPay.Visible = False
  lblCon.Visible = False
  lstContract.Visible = False
  lblReport.Visible = False
  lstReport.Visible = False
  
  lblFind.Left = conLeft
  cmdFilter.Left = conLeft
  cmdFilter.top = Me.Height - conDownTop
  cmdColset.Left = cmdFilter.Left + cmdFilter.width + 45
  cmdColset.top = Me.Height - conDownTop
  CmdGoto.Visible = False
  cmdPrint.Left = cmdColset.Left + cmdColset.width + 45
  cmdPrint.top = Me.Height - conDownTop
  
  cmdSave.Left = cmdPrint.Left + cmdPrint.width + 45
  cmdSave.top = Me.Height - conDownTop
  
  cmdDel.Left = cmdSave.Left + cmdSave.width + 45
  cmdDel.top = Me.Height - conDownTop
  
'暂时不要关联按钮(等何健处理底层)
'  CmdGoto.Left = cmdColset.Left + cmdColset.width + 45
'  CmdGoto.top = Me.Height - conDownTop
'  cmdPrint.Left = CmdGoto.Left + CmdGoto.width + 45
'  cmdPrint.top = Me.Height - conDownTop
  
  cmdAgain.Left = Me.width - conRight - cmdAgain.width
  txtContent.width = cmdAgain.Left - txtContent.Left
  Select Case mrtBook
    Case rtDudgetDetail      '工程预算批复明细表
       lblReport.Visible = True
       lstReport.Visible = True
       lblDate.Visible = True
       detEnd.Visible = True
       lblUse.Visible = True
       detUse.Visible = True
       
       lblReport.Left = conLeft
       lstReport.Left = lblReport.Left + lblReport.width + conCtlComp
       lstReport.top = cmbFind.top + cmbFind.Height + conRowComp
       lblReport.top = lstReport.top + (lstReport.Height - lblReport.Height) / 2
       
       lblDate.Left = lstReport.Left + lstReport.width + conCtlComp + 20
       detEnd.Left = lblDate.Left + lblDate.width + conCtlComp
       detEnd.top = cmbFind.top + cmbFind.Height + conRowComp
       lblDate.top = detEnd.top + (detEnd.Height - lblDate.Height) / 2
       
'       lblDate.Left = conLeft
'       detEnd.Left = lblDate.Left + lblDate.width + conCtlComp
'       detEnd.top = cmbFind.top + cmbFind.Height + conRowComp
'       lblDate.top = detEnd.top + (detEnd.Height - lblDate.Height) / 2
       
       detUse.Left = Me.width - conRight - detUse.width
       lblUse.Left = detUse.Left - lblUse.width - conCtlComp
       lblUse.top = lblDate.top
       detUse.top = detEnd.top
       
       picBook.Left = conLeft
       picBook.width = Me.width - conLeft - conRight
       picBook.top = detEnd.top + detEnd.Height + conRowComp
       picBook.Height = cmdFilter.top - picBook.top - conRowComp
       
    Case rtContract          '合同汇总表
       lblDate.Visible = True
       detEnd.Visible = True
       lblJob.Visible = True
       lstJob.Visible = True
       
       lblDate.Left = conLeft
       detEnd.Left = lblDate.Left + lblDate.width + conCtlComp
       detEnd.top = cmbFind.top + cmbFind.Height + conRowComp
       lblDate.top = detEnd.top + (detEnd.Height - lblDate.Height) / 2
       
       lblJob.Left = lblContent.Left
       lstJob.Left = lblJob.Left + lblJob.width + conCtlComp
       lstJob.width = Me.width - conRight - lstJob.Left
       lblJob.top = lblDate.top
       lstJob.top = detEnd.top
       
       picBook.Left = conLeft
       picBook.width = Me.width - conLeft - conRight
       picBook.top = detEnd.top + detEnd.Height + conRowComp
       picBook.Height = cmdFilter.top - picBook.top - conRowComp
    
    Case rtRatifyDetail      '批复明细表
       lblDate.Visible = True
       detEnd.Visible = True
       lblJob.Visible = True
       lstJob.Visible = True
       
       lblDate.Left = conLeft
       detEnd.Left = lblDate.Left + lblDate.width + conCtlComp
       detEnd.top = cmbFind.top + cmbFind.Height + conRowComp
       lblDate.top = detEnd.top + (detEnd.Height - lblDate.Height) / 2
       
       lblJob.Left = lblContent.Left
       lstJob.Left = lblJob.Left + lblJob.width + conCtlComp
       lstJob.width = Me.width - conRight - lstJob.Left
       lblJob.top = lblDate.top
       lstJob.top = detEnd.top
       
       picBook.Left = conLeft
       picBook.width = Me.width - conLeft - conRight
       picBook.top = detEnd.top + detEnd.Height + conRowComp
       picBook.Height = cmdFilter.top - picBook.top - conRowComp
    Case rtPayDetail         '合同付款明细表
       lblDate.Visible = True