frmprojordercard.frm

金算盘软件代码

    Case vbKeyReturn
        If msgOrder.Row = msgOrder.Rows - 1 Then
            mnuAdd_Click
        Else
            msgOrder.Row = msgOrder.Row + 1
            msgOrder.col = 0
        End If
    Case Else
        If InStr("0123456789.", Chr(KeyAscii)) = 0 And KeyAscii <> 8 Then KeyAscii = 0
    End Select
End Sub

Private Sub EditGrid(ByVal KeyCode As Integer)
    Dim strText As String
    On Error Resume Next
    
    With msgOrder
    strText = Format(.Text)
    mlngRow = .Row
    If .RowHeight(.Row) = 0 Or .col = 0 Then Exit Sub
    If VisableRow > 3 Then
        .ColWidth(1) = 2000
    Else
        .ColWidth(1) = 2250
    End If
    txtPaste.Move .Left + .CellLeft, .top + .CellTop, .CellWidth, .CellHeight
    If KeyCode = 8 Then
        txtPaste.Text = Mid(strText, 1, Len(strText) - 1)
    Else
        txtPaste.Text = strText & Chr(KeyCode)
    End If
    txtPaste.Visible = True
    txtPaste.SetFocus
    txtPaste.SelStart = Len(txtPaste.Text)
    If .Row = .Rows - 1 Then .Rows = .Rows + 1
    mblnIsChanged = True
    End With
End Sub

Private Function VisableRow() As Long
    Dim l As Long, lc As Long
    
    lc = 0
    For l = 1 To msgOrder.Rows - 1
        If msgOrder.RowHeight(l) > 0 Then lc = lc + 1
    Next l
    VisableRow = lc
End Function

Private Sub txtPaste_KeyUp(KeyCode As Integer, Shift As Integer)
    Dim i As Integer
    Static blnFir As Boolean
    
    Select Case KeyCode
    Case vbKeyUp
        For i = msgOrder.Row - 1 To 1 Step -1
            If msgOrder.RowHeight(i) > 0 Then Exit For
        Next i
        msgOrder.SetFocus
        If i > 0 Then msgOrder.Row = i
    Case vbKeyDown
        For i = msgOrder.Row + 1 To msgOrder.Rows - 1
            If msgOrder.RowHeight(i) > 0 Then Exit For
        Next i
        msgOrder.SetFocus
        If i < msgOrder.Rows Then msgOrder.Row = i
    Case vbKeyLeft
        If txtPaste.SelStart = 0 Then
            If Not blnFir Then
                blnFir = True
            Else
                msgOrder.SetFocus
                BKKEY msgOrder.hwnd, vbKeyLeft
                blnFir = False
            End If
        End If
    Case vbKeyRight
        If txtPaste.SelStart = Len(txtPaste.Text) Then
            msgOrder.SetFocus
        End If
    End Select
End Sub

Private Sub txtPaste_LostFocus()
    msgOrder.TextMatrix(mlngRow, 1) = FormatShow(msgOrder.TextMatrix(mlngRow, 1), gclsBase.NaturalCurDec)
    RefreshSum
    txtPaste.Visible = False
End Sub

Private Sub Paste()
    On Error Resume Next
    dtePaste.Text = msgOrder.TextMatrix(msgOrder.Row, 0)
    dtePaste.Move msgOrder.Left + msgOrder.CellLeft, msgOrder.top + msgOrder.CellTop, msgOrder.CellWidth, msgOrder.CellHeight
    dtePaste.Visible = True
    mblnIsChanged = True
    dtePaste.SetFocus
End Sub

Private Sub GetLstValue()
    Dim i As Integer
    
    For i = 0 To 1
        If Trim(lstOrder(i).Text) = "" Then mlngLstID(i) = 0
    Next i
End Sub

'检查录入 1--正确  -1--编码重复  -2--名称重复
Private Function CheckCode() As Integer
    Dim recOrder As rdoResultset, strSql As String
    
    strSql = "SELECT * FROM ProjectOrder WHERE strOrderCode='" & txtOrder(0).Text _
        & "' AND lngOrderID <>" & IIf(mblnIsNew, 0, mlngOrderID)
    Set recOrder = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recOrder.EOF Then
        CheckCode = -1
    Else
        CheckCode = 1
    End If
    recOrder.Close
End Function

Private Function SaveCard(Optional ByVal blnByAdd As Boolean = False) As Boolean
    Dim intResult As Integer    '编码检查结果:1--合法 -1--编码重复 -2--名称重复
    Dim recOrder As rdoResultset, strSql As String
    Dim strNote As String, dblSum As Double
 
  '需要事务处理
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    SaveCard = False
'    If mblnIsExist Then GoTo ErrHandle
    If Not blnByAdd Then
        If Not CheckNotEmpty Then GoTo ErrHandle
    End If
    If Not blnByAdd Then GetLstValue
    If Not LstIsValid Then GoTo ErrHandle
    intResult = CheckCode()
    If intResult = -1 Then
        If Not blnByAdd Then
            ShowMsg hwnd, "合同号“" & Trim(txtOrder(0).Text) _
                & "”已经存在,请重新录入！", vbExclamation, Caption
            sstOrder.Tab = 0
            txtOrder(0).SetFocus
            txtOrder(0).SelStart = 0
            txtOrder(0).SelLength = Len(txtOrder(0).Text)
        End If
        GoTo ErrHandle
    End If
    
    strNote = IIf(txtOrder(1).Text = "", " ", txtOrder(1).Text)
    If mblnIsNew Then
        mlngOrderID = GetNewID("ProjectOrder")
        strSql = "INSERT INTO ProjectOrder(lngOrderID,lngProjectID,strOrderCode," _
            & "lngCustomerID,strDate,blnIsClosed,strCloseDate,strOrderName) VALUES (" _
            & mlngOrderID & "," & mlngLstID(1) & ",'" & txtOrder(0).Text & "'," _
            & mlngLstID(0) & ",'" & IIf(dteOrder.Text = "", " ", dteOrder.Text) _
            & "'," & chkClose.Value & ",'" & IIf(dteClose.Text = "", " ", dteClose.Text) _
            & "','" & IIf(txtOrder(2).Text = "", " ", txtOrder(2).Text) & "')"
            If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    Else
        strSql = "UPDATE ProjectOrder SET strOrderCode='" & txtOrder(0).Text _
            & "',lngProjectID=" & mlngLstID(1) & ",lngCustomerID=" & mlngLstID(0) _
            & ",strDate='" & IIf(dteOrder.Text = "", " ", dteOrder.Text) _
            & "',blnIsClosed=" & chkClose.Value & ",strCloseDate='" _
            & IIf(dteClose.Text = "", " ", dteClose.Text) _
            & "',strOrderName='" & IIf(txtOrder(2).Text = "", " ", txtOrder(2).Text) _
            & "' WHERE lngOrderID=" & mlngOrderID
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    End If
    strSql = "SELECT * FROM ProjectOrder WHERE lngOrderID=" & mlngOrderID
    Set recOrder = gclsBase.BaseDB.OpenResultset(strSql, rdOpenKeyset, 4)
    recOrder.Edit
    recOrder("strNote") = strNote
    recOrder.Update
    recOrder.Close
    If Not SaveGrid Then GoTo ErrHandle
    strSql = "SELECT SUM(dblAmount) dblSum FROM ProjectOrderPlan WHERE lngOrderID=" & mlngOrderID
    Set recOrder = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
    dblSum = Format(recOrder("dblSum"), "@;0;")
    recOrder.Close
    
'    strSQL = "UPDATE ProjectOrder SET dblSumAmount=(SELECT SUM(dblAmount) FROM ProjectOrderPlan " _
        & " WHERE lngOrderID=" & mlngOrderID & ") WHERE lngOrderID=" & mlngOrderID
    strSql = "UPDATE ProjectOrder SET dblSumAmount=" & dblSum & " WHERE lngOrderID=" & mlngOrderID
    If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
    If mblnIsClose And chkClose.Value = Unchecked Then
        strSql = "UPDATE Project SET blnIsClosed=0,strCloseDate=' '" _
                & " WHERE lngProjectID=" & mlngLstID(1)
        If Not gclsBase.ExecSQL(strSql) Then GoTo ErrHandle
        If Not ChangeHigherClose(StringOut(lstOrder(1).Text)) Then GoTo ErrHandle
    End If
    gclsBase.BaseWorkSpace.CommitTrans
    SaveCard = True
    gclsSys.SendMessage Me.hwnd, Message.msgProjectOrder
    Exit Function
ErrHandle:
    gclsBase.BaseWorkSpace.RollBacktrans
End Function

Private Function CheckNotEmpty() As Boolean
    Dim i As Integer
    
    CheckNotEmpty = False
    If Trim$(txtOrder(0).Text) = "" Then
        ShowMsg hwnd, "合同号不能为空！", vbExclamation, Caption
        sstOrder.Tab = 0
        txtOrder(0).SetFocus
        Exit Function
    End If
    If Trim$(lstOrder(1).Text) = "" Then
        ShowMsg hwnd, "工程不能为空！", vbExclamation, Caption
        sstOrder.Tab = 0
        lstOrder(1).SetFocus
        Exit Function
    End If
    If Trim$(lstOrder(0).Text) = "" Then
        ShowMsg hwnd, "合同单位不能为空！", vbExclamation, Caption
        sstOrder.Tab = 0
        lstOrder(0).SetFocus
        Exit Function
    End If
    If chkClose.Value = Checked And dteClose.Text = "" Then
        ShowMsg hwnd, "选择了关闭，则关闭日期不能为空!", vbExclamation, Caption
        sstOrder.Tab = 0
        dteClose.SetFocus
        Exit Function
    End If
    
    With msgOrder
    For i = 1 To .Rows - 1
        If .RowHeight(i) > 0 Then
            If .TextMatrix(i, 0) <> "" And TxtToDouble(.TextMatrix(i, 1)) > 0 Then Exit For
        End If
    Next i
    End With
    If i = msgOrder.Rows Then
        ShowMsg hwnd, "工程合同必须要有有效的计划付款金额！", vbExclamation, Caption
        sstOrder.Tab = 0
        Exit Function
    End If
    CheckNotEmpty = True
End Function

Private Function LstIsValid() As Boolean
    LstIsValid = False
    If Not ItemIsValid("Project", "lngProjectID", mlngLstID(1), False) Then
        ShowMsg hwnd, "工程应该是末级，您选择的“" & lstOrder(1).Text _
            & "”无效，请重新选择！", vbExclamation, Caption
        lstOrder(1).SetFocus
        Exit Function
    End If
    LstIsValid = True
End Function

Private Function SaveGrid() As Boolean
    Dim i As Integer, strSql As String
    
    SaveGrid = False
    For i = 1 To msgOrder.Rows - 1
        If msgOrder.RowHeight(i) = 0 Then
            If msgOrder.RowData(i) = "0" Then
                strSql = ""
            Else
                strSql = "DELETE FROM ProjectOrderPlan WHERE lngPlanID=" & msgOrder.RowData(i)
            End If
        Else
            If msgOrder.TextMatrix(i, 0) <> "" And TxtToDouble(msgOrder.TextMatrix(i, 1)) <> 0 Then
                If msgOrder.RowData(i) = "0" Then
                    strSql = "INSERT INTO ProjectOrderPlan(lngPlanID,lngOrderID,strDate,dblAmount) " _
                        & "VALUES(" & GetNewID("ProjectOrderPlan") & "," & mlngOrderID & ",'" _
                        & msgOrder.TextMatrix(i, 0) & "'," & TxtToDouble(msgOrder.TextMatrix(i, 1)) & ")"
                Else
                    If msgOrder.TextMatrix(i, 2) = "3" Then
                        strSql = "UPDATE ProjectOrderPlan SET strDate='" & msgOrder.TextMatrix(i, 0) _
                        & "',dblAmount=" & TxtToDouble(msgOrder.TextMatrix(i, 1)) & " WHERE lngPlanID=" _
                        & msgOrder.RowData(i) & " AND lngOrderID=" & mlngOrderID
                    Else
                        strSql = ""
                    End If
                End If
            Else
                If msgOrder.RowData(i) <> "0" Then
                    strSql = "DELETE FROM ProjectOrderPlan WHERE lngPlanID=" & msgOrder.RowData(i)
                Else
                    strSql = ""
                End If
            End If
        End If
        If strSql <> "" Then
            If Not gclsBase.ExecSQL(strSql) Then Exit Function
        End If
    Next i
    SaveGrid = True
End Function

Private Sub SetTabIndex()
    Dim conX As Control
    
    On Error Resume Next
    For Each conX In Me.Controls
        Select Case conX.Name
        Case "cmdOK", "sstOrder"
        Case Else
            conX.TabStop = False
        End Select
    Next conX
    Select Case sstOrder.Tab
    Case 0
        txtOrder(0).TabStop = True
        txtOrder(1).TabStop = False
        txtOrder(2).TabStop = True
        dteOrder.TabStop = True
        lstOrder(0).TabStop = True
        lstOrder(1).TabStop = True
        msgOrder.TabStop = True
        chkClose.TabStop = True
        dteClose.TabStop = dteClose.Enabled
        If dteClose.TabStop Then
            SetCmdIndex chkClose.TabIndex + 1
        Else
            SetCmdIndex dteClose.TabIndex + 1
        End If
    Case 1
        txtOrder(1).TabStop = True
        SetCmdIndex txtOrder(1).TabIndex + 1
    End Select
End Sub

Private Sub SetCmdIndex(ByVal Index As Integer)
    cmdOK(0).TabIndex = Index
    cmdOK(1).TabIndex = cmdOK(0).TabIndex + 1
    cmdOK(2).TabIndex = cmdOK(1).TabIndex + 1
    cmdOK(3).TabIndex = cmdOK(2).TabIndex + 1
End Sub