frmmemo.frm

金算盘软件代码

VERSION 5.00
Object = "{D252F124-F62C-11D1-9ABD-444553540000}#1.0#0"; "GADATE.DLL"
Begin VB.Form frmMemo 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "新增备忘录"
   ClientHeight    =   3825
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   8370
   HelpContextID   =   80007
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3825
   ScaleWidth      =   8370
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin GACALENDARLibCtl.Calendar calendar 
      Height          =   285
      Left            =   1200
      OleObjectBlob   =   "frmMemo.frx":0000
      TabIndex        =   1
      Top             =   188
      Width           =   1215
   End
   Begin GACALENDARLibCtl.SpinEdit spnBeforeDays 
      Height          =   300
      Left            =   6090
      OleObjectBlob   =   "frmMemo.frx":0089
      TabIndex        =   5
      Top             =   180
      Width           =   825
   End
   Begin VB.ComboBox cboExecuter 
      Height          =   300
      Left            =   3570
      Style           =   2  'Dropdown List
      TabIndex        =   3
      Top             =   180
      Width           =   1365
   End
   Begin VB.CheckBox chkMemo 
      Caption         =   "完成(&F)"
      Height          =   195
      Index           =   1
      Left            =   7110
      TabIndex        =   8
      Top             =   3210
      Width           =   945
   End
   Begin VB.CommandButton cmdMemo 
      Height          =   350
      Index           =   0
      Left            =   7110
      Style           =   1  'Graphical
      TabIndex        =   9
      Tag             =   "1001"
      Top             =   240
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdMemo 
      Cancel          =   -1  'True
      Height          =   350
      Index           =   1
      Left            =   7110
      Style           =   1  'Graphical
      TabIndex        =   10
      Tag             =   "1002"
      Top             =   630
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdMemo 
      Height          =   345
      Index           =   2
      Left            =   7110
      Style           =   1  'Graphical
      TabIndex        =   11
      Tag             =   "1009"
      Top             =   1020
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.TextBox txtContent 
      BorderStyle     =   0  'None
      Height          =   2445
      Left            =   150
      MultiLine       =   -1  'True
      TabIndex        =   7
      Top             =   960
      Width           =   6705
   End
   Begin VB.Label lblmemo 
      Caption         =   "提前天数(&B)"
      Height          =   195
      Index           =   5
      Left            =   5070
      TabIndex        =   4
      Top             =   233
      Width           =   1035
   End
   Begin VB.Label lblmemo 
      Height          =   255
      Index           =   4
      Left            =   840
      TabIndex        =   13
      Top             =   3550
      Width           =   975
   End
   Begin VB.Label lblmemo 
      Caption         =   "撰写人:"
      Height          =   255
      Index           =   3
      Left            =   150
      TabIndex        =   12
      Top             =   3550
      Width           =   975
   End
   Begin VB.Label lblmemo 
      Caption         =   "提醒对象(&P)"
      Height          =   195
      Index           =   2
      Left            =   2580
      TabIndex        =   2
      Top             =   233
      Width           =   1035
   End
   Begin VB.Label lblmemo 
      Caption         =   "提醒日期(&D)"
      Height          =   195
      Index           =   1
      Left            =   180
      TabIndex        =   0
      Top             =   233
      Width           =   1095
   End
   Begin VB.Label lblmemo 
      Caption         =   "提醒内容(&N)"
      Height          =   225
      Index           =   0
      Left            =   180
      TabIndex        =   6
      Top             =   720
      Width           =   1035
   End
End
Attribute VB_Name = "frmMemo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'       作者：郑权
'       日期：98.7.20
'       功能:      完成备忘录的增、删、改。                              '
'       接口： AddCard   增加备忘录记录。
'                        参数：intModal 显示模式
'              EditCard  修改备忘录记录。
'                        参数： lngID 被修改的记录的ID，intModal 显示模式
'              DelCard   删除备忘录记录。
'                        参数： lngID 被删除的记录的ID
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private Type MemoRecord           '处理备忘录表的记录
    lngNoteID As Long             '备忘录ID
    strNote As String         '备忘录
    strDate As String         '提醒日期
    bytDay As Integer         '提前天数
    lngOperatorID As Long     '撰写人
    blnIsDoned As Boolean     '执行标志
    lngExecutantID As Long    '被提醒者
End Type

'Private WithEvents mclsMainControl As MainControl '主控对象
Private mblnAddRecord As Boolean          '是增加记录还是修改记录
Private mstrSQLBuffer() As String         '暂时存储对数据库的增删改操作
Private mintSQLIndex As Integer           'strSQLBuffer的索引
Private mWRMemo As MemoRecord        '暂存读写记录的数据
Private mstrInitCode As String         '暂存编码的初始值，以备判断是否修改
Private ID As Long
Private mblnIsChanged As Boolean
Private Const mintDays = 365  '提前天数限制
Private mblnIsFirstUse As Boolean    '第一次装入



'进入新增摘要
Public Function AddCard(Optional strName As String = "", Optional intModal As Integer = 0) As Long
        
     
    mblnAddRecord = True
    frmMemo.Caption = "新增备忘录"
    cmdMemo(2).Visible = True
    InitAddCard strName
    Debug.Print "end:" & Timer
    If Me.WindowState = 1 Then Me.WindowState = 0
    If Me.Visible = True Then
       Unload Me
       Me.Show vbModal
       'Me.ZOrder 0
    Else
       Show intModal 'intModal
    End If
    AddCard = ID
    
    If intModal <> vbModal Then
       Refresh
       ZOrder 0
    End If
End Function

'初始化暂存读写记录的数据的自定义类型变量和卡片
Private Sub InitAddCard(Optional strName As String = "")
    
     mblnIsFirstUse = True
     With mWRMemo
        .lngNoteID = 0
        .strNote = strName
        .strDate = Format(Date, "yyyy-mm-dd")
        .bytDay = 0
        .blnIsDoned = False
        .lngExecutantID = 0
    End With
    
    lblMemo(4).Caption = gclsBase.OperatorName
    txtContent.Text = strName
    calendar.Text = Format(gclsBase.BaseDate, "yyyy-mm-dd")
    'chkMemo(0).Value = 0
    spnBeforeDays.Text = 0
    chkMemo(1).Value = 0
    InitBuffer '清空暂时存储数据库操作的数组
     mblnIsFirstUse = False
End Sub

'进入修改摘要
Public Sub EditCard(ByVal lngID As Long, Optional intModal As Integer = 0)
    mblnAddRecord = False
    frmMemo.Caption = "修改备忘录"
    cmdMemo(2).Visible = False
    If Not SelectRecord(lngID) Then Exit Sub   '查找记录
    If Me.WindowState = 1 Then Me.WindowState = 0
    Show intModal
    
    If intModal <> vbModal Then
       Refresh
       ZOrder 0
    End If
End Sub

'查找出想修改的摘要表编码记录，存放在自定义类型变量中，设置想修改项
Private Function SelectRecord(ByVal lngRecordID As Long) As Boolean
    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim i As Integer
    
    SelectRecord = False
     mblnIsFirstUse = True
    With mWRMemo
        .lngNoteID = lngRecordID
        strSql = "SELECT * FROM note WHERE lngNoteID =" & .lngNoteID
        Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If recSelect.EOF Then
            ShowMsg 0, "该备忘录不存在，不能进行修改！", vbExclamation + MB_TASKMODAL, Me.Caption
            Unload Me
            Exit Function
        End If
'        If recSelect!lngOperatorID <> gclsBase.OperatorID Then
'           ShowMsg 0, "该操作员不是撰写人，不能对该备忘录进行修改！", _
'                      vbExclamation + MB_TASKMODAL, Me.Caption
'           Unload Me
'           Exit Function
'        End If
        .strNote = recSelect!strNote
        .strDate = Format(recSelect!strDate, "yyyy-mm-dd")
        .bytDay = recSelect!bytDay
        .lngOperatorID = recSelect!lngOperatorID
        .blnIsDoned = recSelect!blnIsDoned
        .lngExecutantID = recSelect!lngExecutantID
        
        strSql = "SELECT strOperatorName FROM Operator " _
                   & "WHERE lngoperatorid=" & .lngOperatorID
        Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
        If Not recSelect.EOF Then
           lblMemo(4).Caption = recSelect.rdoColumns(0)
        Else
           lblMemo(4).Caption = ""
        End If
        txtContent.Text = .strNote
        calendar.Text = .strDate
        spnBeforeDays.Text = .bytDay
        chkMemo(1).Value = IIf(.blnIsDoned, 1, 0)
        For i = 0 To cboExecuter.ListCount
            If .lngExecutantID = cboExecuter.ItemData(i) Then
               cboExecuter.ListIndex = i 'cboExecuter.Index
               Exit For
            End If
        Next
        InitBuffer '清空暂时存储数据库操作的数组
        recSelect.Close
        SelectRecord = True
         mblnIsFirstUse = False
    End With
End Function

'进入删除摘要，判断记录是否是末级和被使用，删除记录
Public Function DelCard(ByVal lngID As Long, Optional ByVal lnghWnd As Long) As Boolean

    Dim strSql As String
    Dim recSelect As rdoResultset
    Dim intMsgReturn As Integer
    Dim blnSQLExec As Boolean
    
    DelCard = False
    strSql = "SELECT * FROM note WHERE lngnoteID=" & lngID
    Set recSelect = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recSelect.EOF Then
        recSelect.Close
        Exit Function
    End If
    If recSelect!lngOperatorID <> gclsBase.OperatorID Then
       ShowMsg lnghWnd, "该操作员不是撰写人，不能删除当前备忘录！", _
                   vbExclamation + MB_TASKMODAL, Me.Caption
       Exit Function
    End If
    If frmNotelist.IsShowCard Then
       If lngID = frmNoteListCard.getID Then
          ShowMsg lnghWnd, "不能删除正在修改的备忘录！", _
                  vbExclamation + MB_TASKMODAL, "删除备忘录"
          frmMemo.Show
          Exit Function
       End If
    End If
    intMsgReturn = ShowMsg(lnghWnd, "你确实要删除当前备忘录吗？", _
                  vbQuestion + vbOKCancel + MB_TASKMODAL, "删除备忘录")
    If intMsgReturn = vbOK Then
        strSql = "DELETE FROM note  WHERE lngnoteID = " & lngID
        blnSQLExec = gclsBase.ExecSQL(strSql)
        If blnSQLExec Then
           gclsSys.SendMessage CStr(Me.hwnd), Message.msgnote
        End If
    End If
    recSelect.Close
    DelCard = blnSQLExec
End Function

Private Sub InitcboExecuter()
    Dim strSql As String
    Dim recOperator As rdoResultset
    
    cboExecuter.AddItem "所有人员"
    cboExecuter.ItemData(cboExecuter.NewIndex) = 0
    strSql = "SELECT lngOperatorID,strOperatorName FROM Operator " _
                   & "WHERE blnIsInActive=0"
    Set recOperator = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    If recOperator.RowCount > 0 Then
       recOperator.MoveLast
       recOperator.MoveFirst
       
       With recOperator
            Do While Not .EOF
               cboExecuter.AddItem !strOperatorName
               cboExecuter.ItemData(cboExecuter.NewIndex) = !lngOperatorID
               .MoveNext
            Loop
       End With
       cboExecuter.ListIndex = 0
    End If