frmremarkcard.frm

金算盘软件代码

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn And mblnIsSetFocus = True Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
    mblnIsSetFocus = True
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdOKCancel(0).Value = True
    End If

End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    Utility.LoadFormResPicture Me
    
    Me.HelpContextID = 10215
    mintCur = -1
'    txtInput(0).SetFocus
    'frmRemarkList.IsShowCard = True
    Exit Sub
    Dim edtErrReturn As ErrDealType
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim intMsgReturn As Integer
    
    'If mIsCancel = True Then Exit Sub
    If UnloadMode = vbFormControlMenu Then
    With mrmkRemark
        If mblnIsChanged = True Then '(txtInput(0).Text <> .strRemarkCode And txtInput(0).Text <> mstrInitCode) _
            Or txtInput(1).Text <> .strRemarkName Then
            intMsgReturn = ShowMsg(0, "当前摘要已被修改，是否保存？", _
                          vbQuestion + vbYesNoCancel + MB_TASKMODAL, Me.Caption)
            If intMsgReturn = vbYes Then
                Cancel = Not SaveCard(True)
            ElseIf intMsgReturn = vbCancel Then
                Cancel = True
            End If
        End If
    End With
    End If
    If Not Cancel Then mblnIsChanged = False
End Sub

Private Sub Form_Unload(Cancel As Integer)
     On Error Resume Next
     Utility.UnLoadFormResPicture Me
End Sub

Private Sub Form_Paint()
    FrameBox Me.hwnd, 120, 120, 4575, 2930 '画边框
End Sub

Private Sub InputAgain()
    txtInput(0).SelStart = 0
    txtInput(0).SelLength = StrLen(txtInput(0).Text)
    txtInput(0).SetFocus
End Sub

Private Sub cmdokcancel_Click(Index As Integer)
    Dim strSql As String
    Dim recSelect As rdoResultset
      
    Select Case Index
        Case 0    '确定
            If SaveCard(True) Then
               Unload Me
               strSql = "SELECT * FROM Remark order by lngRemarkID"
               Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
               If recSelect.RowCount > 0 Then
                  recSelect.MoveLast
                  ID = recSelect!lngRemarkID
               Else
                  ID = 0
               End If
           End If
        Case 1    '取消
            
            Unload Me
        Case 2    '下一个
            SaveCard False
    End Select
End Sub

'通过事务处理完成对数据库的操作
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function SaveCard(blnClickOK As Boolean) As Boolean
    Dim intMsgReturn As Integer
    
    SaveCard = False
    If validityCheck(blnClickOK) Then '检查数据的有效性并整理记录值成功
        gclsBase.BaseWorkSpace.BeginTrans
        If ExecBuffer Then  '修改数据库成功
            gclsBase.BaseWorkSpace.CommitTrans
            gclsSys.SendMessage CStr(Me.hwnd), Message.msgRemark
            SaveCard = True
            If Not blnClickOK Then
                InitAddCard '为新增记录作设置
                InputAgain
            End If
        Else '修改数据库不成功
            gclsBase.BaseWorkSpace.RollBacktrans
            mblnAddRecord = True
            InitAddCard '初始化
            InputAgain
        End If
    Else '检查数据的有效性并整理记录值不成功
        InitBuffer   '清空暂时存储数据库操作的数组
    End If
End Function

'检查数据的有效性并整理记录值,存储记录
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function validityCheck(blnClickOK As Boolean) As Boolean
    Dim intMsgReturn As Integer
    Dim strSql As String
    Dim recSelect As rdoResultset

    validityCheck = True
    If StrLen(Trim(txtInput(0).Text)) = 0 Then  '检查非空项
        ShowMsg 0, "摘要编码不能为空！", _
                     vbExclamation + MB_TASKMODAL, Me.Caption
        validityCheck = False
        InputAgain
        Exit Function
    Else
       If InStr(1, txtInput(0).Text, "'") <> 0 Then
          ShowMsg 0, "摘要编码中不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          InputAgain
          Exit Function
       ElseIf InStr(1, txtInput(0).Text, "|") <> 0 Then
          ShowMsg 0, "摘要编码中不能有‘|’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          InputAgain
          Exit Function
       End If
    End If
    If StrLen(Trim(txtInput(1).Text)) = 0 Then  '检查非空项
        ShowMsg 0, " 摘要内容不能为空！", _
                      vbExclamation + MB_TASKMODAL, Me.Caption
        validityCheck = False
        txtInput(1).SelStart = 0
        txtInput(1).SelLength = StrLen(txtInput(1).Text)
        txtInput(1).SetFocus
        Exit Function
    Else
        If InStr(1, txtInput(1).Text, "'") <> 0 Then
          ShowMsg 0, "摘要内容中不能有‘'’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          txtInput(1).SelStart = 0
          txtInput(1).SelLength = StrLen(txtInput(1).Text)
          txtInput(1).SetFocus
          Exit Function
        ElseIf InStr(1, txtInput(1).Text, "|") <> 0 Then
          ShowMsg 0, "摘要内容中不能有‘|’符号！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          txtInput(1).SelStart = 0
          txtInput(1).SelLength = StrLen(txtInput(1).Text)
          txtInput(1).SetFocus
          Exit Function
        End If
    End If
    With mrmkRemark
        If .strRemarkCode <> txtInput(0).Text Then         '编码已改变
            strSql = "SELECT * FROM Remark WHERE strRemarkCode='" & txtInput(0).Text & "'"
            Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
            If recSelect.RowCount <> 0 Then         '编码不唯一，摘要不能重复
               ShowMsg 0, "此摘要编码已存在，请重新输入。", _
                        vbExclamation + MB_TASKMODAL, Me.Caption
               validityCheck = False
               InputAgain
               recSelect.Close
               Exit Function
            Else '编码唯一
               SettingRecord '整理记录
               
               Dim lngTempID As Long
               lngTempID = GetNewID("Remark")

               If mblnAddRecord Then
                  SetBuffer "INSERT INTO Remark (lngRemarkID,strRemarkCode,strRemarkName) VALUES(" & lngTempID & ",'" _
                       & .strRemarkCode & "','" & .strRemarkName & "')"  '插入数据库记录
               Else
                  SetBuffer "UPDATE Remark SET strRemarkCode='" & .strRemarkCode _
                       & "',strRemarkName='" & .strRemarkName _
                       & "' WHERE lngRemarkID =" & .lngRemarkID  '修改数据库记录
               End If
               recSelect.Close
            End If
        Else '编码未改变
            SettingRecord '整理记录
            SetBuffer "UPDATE Remark SET strRemarkCode='" & .strRemarkCode _
                & "',strRemarkName='" & .strRemarkName & "' WHERE lngRemarkID =" _
                & .lngRemarkID  '修改数据库记录
        End If
    End With
End Function

'存入数据库之前整理记录值
Private Sub SettingRecord()
    With mrmkRemark
        .strRemarkCode = txtInput(0).Text
        .strRemarkName = txtInput(1).Text
    End With
End Sub

'把对数据库的增删改操作暂时存储在数组中
Private Sub SetBuffer(strSql As String)
    If mintSQLIndex = 0 Then
        ReDim mstrSQLBuffer(0)
    Else
        ReDim Preserve mstrSQLBuffer(UBound(mstrSQLBuffer) + 1)
    End If
    mstrSQLBuffer(mintSQLIndex) = strSql
    mintSQLIndex = mintSQLIndex + 1
End Sub

'清空暂时存储数据库操作的数组
Private Sub InitBuffer()
    ReDim mstrSQLBuffer(0)
    mintSQLIndex = 0
End Sub

'执行暂时存储在数组中的数据库操作
Private Function ExecBuffer() As Boolean
    Dim blnExecSQL As Boolean
    Dim intSQLIndex As Integer
    
    If mintSQLIndex = 0 Then
        ExecBuffer = True
        Exit Function
    End If
    For intSQLIndex = 0 To mintSQLIndex - 1
        blnExecSQL = gclsBase.ExecSQL(mstrSQLBuffer(intSQLIndex))
        If Not blnExecSQL Then Exit For
    Next intSQLIndex
    ExecBuffer = blnExecSQL
End Function

Private Sub txtInput_Change(Index As Integer)
    If ContainErrorChar(txtInput(Index).Text, "`~@#$%^&*()!'|") Then
       BKKEY txtInput(Index).hwnd
       Exit Sub
    End If
End Sub


Private Sub txtInput_KeyPress(Index As Integer, KeyAscii As Integer)
     mblnIsChanged = True
End Sub

Private Sub txtInput_LostFocus(Index As Integer)
    If Index = 1 Then
        mintCur = txtInput(1).SelStart
'        lstRemark.Enabled = False
'        cmdRemark(0).Enabled = False
    End If
End Sub

Private Sub txtInput_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single)
    mblnIsChanged = True
End Sub
'数据引入
Public Function ImportRemark(ByVal strRemarkSource As String) As Integer
       Dim recRemark As rdoResultset
       Dim strSql As String
       Dim strCode As String
       Dim strName As String
       
       ImportRemark = 0
       If Not GetString(strRemarkSource, strCode, 1) Then Exit Function
       If Not GetString(strRemarkSource, strName, 2) Then Exit Function
       
       strSql = "SELECT * FROM Remark WHERE strRemarkCode='" & strCode & "'"
       Set recRemark = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
       If recRemark.RowCount <> 0 Then         '编码不唯一，摘要不能重复
          ImportRemark = 1
          recRemark.Close
          Exit Function
       End If
       recRemark.Close
       Dim lngTempID As Long
       lngTempID = GetNewID("Remark")
       strSql = "INSERT INTO Remark (lngRemarkID,strRemarkCode,strRemarkName) VALUES(" & lngTempID & ",'" _
                       & strCode & "','" & strName & "')"
       If gclsBase.ExecSQL(strSql) Then
          ImportRemark = 1
       Else
          ImportRemark = 0
       End If
End Function