frmmemo.frm

金算盘软件代码

End Sub

Private Sub calendar_KeyPress(KeyAscii As Integer, bCancel As Long)
    mblnIsChanged = True
End Sub

Private Sub calendar_MouseUp(Button As Integer, Shift As Integer, x As Integer, y As Integer, bCancel As Long)
    mblnIsChanged = True
End Sub

Private Sub cboExecuter_KeyPress(KeyAscii As Integer)
    mblnIsChanged = True
End Sub

Private Sub cboExecuter_LostFocus()
    mblnIsChanged = True
End Sub

Private Sub chkMemo_Click(Index As Integer)
    mblnIsChanged = True
End Sub

Private Sub cmdMemo_Click(Index As Integer)
   Dim strSql As String
   Dim recType As rdoResultset
   
   Select Case Index
          Case 0 '确定
               If SaveCard(True) Then
                  strSql = "select * from note order by lngnoteID"
                  Set recType = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
                  If recType.RowCount > 0 Then
                     recType.MoveLast
                     ID = recType!lngNoteID
                  Else
                     ID = 0
                  End If
                  Unload Me
               End If
          Case 1 '取消
               mblnIsChanged = False
               Unload Me
          Case 2 '下一个
               SaveCard False
   End Select
End Sub

Private Sub Form_Activate()
SetHelpID C2lng(Me.HelpContextID)
End Sub

Private Sub Form_Load()
    On Error GoTo ErrHandle
    Me.HelpContextID = 80007
    Utility.LoadFormResPicture Me
   ' Set mclsMainControl = gclsSys.MainControls.Add(Me)
    InitcboExecuter
    spnBeforeDays.Max = 365
    spnBeforeDays.Min = 0
   ' frmNotelist.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_Paint()
   paintrectangles Me.hwnd, 150, 960, 6915, 3455
End Sub
Private Sub paintrectangles(ByVal hwnd, x1, y1, x2, y2 As Long)
    Dim hdc As Long
    Dim hPen1 As Long, hPen2 As Long, hSavePen As Long
    Dim Point As POINTAPI
    
    hdc = GetDC(hwnd)
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    hPen2 = CreatePen(PS_SOLID, 4, &H707070)
    hSavePen = SelectObject(hdc, hPen2)
    Rectangle hdc, x1 + 4, y1 + 4, x2, y2
    
    hPen1 = CreatePen(PS_SOLID, 1, vbBlack)
    hSavePen = SelectObject(hdc, hPen1)
    Rectangle hdc, x1 - 1, y1 - 1, x2 - 2, y2 - 2
    
    SelectObject hdc, hSavePen
    DeleteObject hPen1
    DeleteObject hPen2
    
    ReleaseDC hwnd, hdc
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
        Dim intMsgReturn As Integer
    
        If UnloadMode = vbFormControlMenu Then
           If mblnIsChanged = True Then
              intMsgReturn = ShowMsg(0, "当前备忘录已被修改，是否保存？", _
              vbExclamation + vbYesNoCancel + MB_TASKMODAL, Me.Caption)
              If intMsgReturn = vbYes Then
                 Cancel = Not SaveCard(True)
              ElseIf intMsgReturn = vbCancel Then
                 Cancel = True
              End If
           End If
           If Not Cancel Then mblnIsChanged = False
        End If
End Sub

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

Private Sub InputAgain()
    txtContent.SelStart = 0
    txtContent.SelLength = StrLen(txtContent.Text)
    txtContent.SetFocus
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.msgnote
            mblnIsChanged = False
            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
'得到消除回车和换行符后的文本 chr(13),chr(10)
Private Function GetText(ByVal intAsc As Integer, ByVal strContText As String) As String
    Dim intCount As Integer
    
    intCount = InStr(1, strContText, Chr(intAsc))
    Do While intCount <> 0
       strContText = Left(strContText, intCount - 1) & Mid(strContText, intCount + 1)
       intCount = InStr(1, strContText, Chr(intAsc))
    Loop
    GetText = strContText
    
End Function

'检查数据的有效性并整理记录值,存储记录
'blnClickOK：是按[确定]按钮还是按[下一个]按钮
Private Function validityCheck(blnClickOK As Boolean) As Boolean
    Dim intMsgReturn As Integer
    Dim strSql As String
    Dim recnote As rdoResultset
    Dim strStDate As Date
    Dim strText As String
    
    validityCheck = True
    strSql = "SELECT * FROM note WHERE lngNoteID =" & mWRMemo.lngNoteID
    Set recnote = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If Not recnote.EOF Then
       If recnote!lngOperatorID <> gclsBase.OperatorID Then
          ShowMsg 0, "该操作员不是撰写人，不能对该备忘录进行修改！", _
                     vbExclamation + MB_SYSTEMMODAL, Me.Caption
          validityCheck = False
          cmdMemo(1).SetFocus
          Exit Function
       End If
    End If
    
    If StrLen(Trim(calendar.Text)) = 0 Then  '检查非空项
        ShowMsg 0, " 提醒日期必需输入！", _
                vbExclamation + MB_TASKMODAL, Me.Caption
        validityCheck = False
        calendar.SelStart = 0
        calendar.SelLenth = StrLen(calendar.Text)
        calendar.SetFocus
        Exit Function
    End If
    strText = txtContent.Text
    strText = GetText(13, strText)
    strText = GetText(10, strText)
    If StrLen(Trim(strText)) = 0 Then  '检查非空项
        ShowMsg 0, " 备忘录内容必需输入！", _
                vbExclamation + MB_TASKMODAL, Me.Caption
        validityCheck = False
        InputAgain
        Exit Function
    End If
    
    strSql = "select strStartDate from business"
    Set recnote = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    strStDate = CDate(recnote.rdoColumns(0))
    If CDate(calendar.Text) < strStDate Then
       ShowMsg 0, "提醒日期小于了帐套启用日期'" & Format(gclsBase.BaseDate, "yyyy-mm-dd") & "' ！", vbExclamation + MB_TASKMODAL, Me.Caption
       validityCheck = False
       calendar.Text = gclsBase.BaseDate
       calendar.SelStart = 0
       calendar.SelLenth = StrLen(calendar.Text)
       calendar.SetFocus
       Exit Function
    End If
    If mblnIsChanged = False Then
       Unload Me
       validityCheck = False
       Exit Function
    End If
    If InStr(1, txtContent.Text, "'") <> 0 Then
       ShowMsg Me.hwnd, "摘要内容中不能有单引号,请重输！", vbExclamation + MB_TASKMODAL, Me.Caption
       validityCheck = False
       txtContent.SelStart = 0
       txtContent.SelLength = StrLen(txtContent.Text)
       txtContent.SetFocus
       Exit Function
    ElseIf InStr(1, txtContent.Text, "|") <> 0 Then
       ShowMsg Me.hwnd, "摘要内容中不能有‘|’,请重输！", vbExclamation + MB_TASKMODAL, Me.Caption
       validityCheck = False
       txtContent.SelStart = 0
       txtContent.SelLength = StrLen(txtContent.Text)
       txtContent.SetFocus
       Exit Function
    End If
    With mWRMemo
         SettingRecord '整理记录
         Dim lngTempID As Long
         lngTempID = GetNewID("Note")
         If mblnAddRecord Then
            SetBuffer "INSERT INTO Note(lngNoteID,strnote,strdate,bytday,blnisdoned,lngExecutantID,lngOperatorID) VALUES(" & lngTempID & ",'" _
                 & .strNote & "','" & .strDate & "'," & .bytDay & "," & IIf(.blnIsDoned, 1, 0) & _
                 "," & .lngExecutantID & "," & gclsBase.OperatorID & ")"   '插入数据库记录
         Else
            SetBuffer "UPDATE note SET strnote='" & .strNote _
                 & "',strdate='" & .strDate _
                 & "',bytday=" & .bytDay _
                 & ",blnIsDoned=" & IIf(.blnIsDoned, 1, 0) & ", lngExecutantID=" & .lngExecutantID _
                 & " WHERE lngnoteID =" & .lngNoteID   '修改数据库记录
         End If
    End With
End Function

'存入数据库之前整理记录值
Private Sub SettingRecord()
    If StrLen(spnBeforeDays.Text) = 0 Then
       spnBeforeDays.Text = 0
    End If
    With mWRMemo
         .strNote = txtContent.Text
         .strDate = calendar.Text
         .bytDay = spnBeforeDays.Text
         .blnIsDoned = IIf(chkMemo(1).Value, True, False)
         .lngExecutantID = cboExecuter.ItemData(cboExecuter.ListIndex)
    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


Public Property Get getID() As Long
       getID = mWRMemo.lngNoteID
End Property

Private Sub Label1_Click()

End Sub

Private Sub spnBeforeDays_Change()
    Dim intCount As Integer
 Dim i As Integer
 
 If mblnIsFirstUse = True Then Exit Sub
 intCount = StrLen(spnBeforeDays.Text)
 For i = 1 To intCount
     If InStr(1, "0123456789", Mid(spnBeforeDays.Text, i, 1)) = 0 Then
        'ShowMsg Me.hwnd, "提前天数必须是数字型！", vbExclamation + MB_SYSTEMMODAL, Me.Caption
'        spnBeforeDays.SelStart = i - 1
'        spnBeforeDays.SelLength = 1
'        spnBeforeDays.Text = Mid(spnBeforeDays.Text, 1, i - 1) & Mid(spnBeforeDays.Text, i + 1)
'        intCount = intCount - 1
'        spnBeforeDays.SetFocus
        SendKeys "{BS}"
        Exit Sub
     End If
 Next
 
    If Val(spnBeforeDays.Text) >= mintDays Then
       SendKeys "{BS}"
       Exit Sub
    End If
    mblnIsChanged = True
End Sub

Private Sub spnBeforeDays_KeyPress(KeyAscii As Integer, bCancel As Long)
    mblnIsChanged = True
End Sub

Private Sub spnBeforeDays_MouseUp(Button As Integer, Shift As Integer, x As Integer, y As Integer, bCancel As Long)
mblnIsChanged = True
End Sub

Private Sub txtContent_Change()
    If ContainErrorChar(txtContent.Text, "'|") Then
       BKKEY txtContent.hwnd
       Exit Sub
    End If
End Sub

Private Sub txtContent_KeyPress(KeyAscii As Integer)
    mblnIsChanged = True
End Sub

Private Sub txtContent_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    mblnIsChanged = True
End Sub