frmmutidepartment.frm

金算盘软件代码

VERSION 5.00
Object = "{9C4B12C2-D5CE-11D1-9ABC-444553540000}#1.0#0"; "GACEDIT.DLL"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F6125AB1-8AB1-11CE-A77F-08002B2F4E98}#2.0#0"; "MSRDC20.OCX"
Object = "{81110CCB-022B-11D3-A348-0080C89152FF}#1.3#0"; "ORAGLIST.OCX"
Begin VB.Form frmMutiDpm 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "固定资产使用部门"
   ClientHeight    =   3750
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5220
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   3750
   ScaleWidth      =   5220
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin MSRDC.MSRDC datDpm 
      Height          =   330
      Left            =   3960
      Top             =   2880
      Visible         =   0   'False
      Width           =   1200
      _ExtentX        =   2117
      _ExtentY        =   582
      _Version        =   393216
      Options         =   0
      CursorDriver    =   0
      BOFAction       =   0
      EOFAction       =   0
      RecordsetType   =   1
      LockType        =   3
      QueryType       =   0
      Prompt          =   3
      Appearance      =   1
      QueryTimeout    =   30
      RowsetSize      =   100
      LoginTimeout    =   15
      KeysetSize      =   0
      MaxRows         =   0
      ErrorThreshold  =   -1
      BatchSize       =   15
      BackColor       =   -2147483643
      ForeColor       =   -2147483640
      Enabled         =   -1  'True
      ReadOnly        =   0   'False
      Appearance      =   -1  'True
      DataSourceName  =   ""
      RecordSource    =   ""
      UserName        =   ""
      Password        =   ""
      Connect         =   ""
      LogMessages     =   ""
      Caption         =   "MSRDC1"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin GATLCTRLLibCtl.CalEdit txtEdit 
      Height          =   330
      Left            =   3930
      OleObjectBlob   =   "frmMutiDepartment.frx":0000
      TabIndex        =   4
      Top             =   1650
      Width           =   1200
   End
   Begin ListRefer.ListText ltxtDpm 
      Height          =   315
      Left            =   3900
      TabIndex        =   3
      Top             =   2130
      Visible         =   0   'False
      Width           =   1245
      _ExtentX        =   2196
      _ExtentY        =   556
      CodeSort        =   -1  'True
      BackColor       =   -2147483643
      Appearance      =   0
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   1
      Left            =   3900
      Style           =   1  'Graphical
      TabIndex        =   2
      Tag             =   "1002"
      Top             =   480
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdOk 
      Height          =   350
      Index           =   0
      Left            =   3900
      Style           =   1  'Graphical
      TabIndex        =   1
      Tag             =   "1001"
      Top             =   90
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin MSFlexGridLib.MSFlexGrid msgMutiDpm 
      Bindings        =   "frmMutiDepartment.frx":0081
      Height          =   3555
      Left            =   60
      TabIndex        =   0
      Top             =   90
      Width           =   3735
      _ExtentX        =   6588
      _ExtentY        =   6271
      _Version        =   393216
      Rows            =   21
      Cols            =   3
      FixedCols       =   0
      RowHeightMin    =   250
   End
   Begin VB.Menu MenuPopup 
      Caption         =   "Main"
      Visible         =   0   'False
      Begin VB.Menu mnuNew 
         Caption         =   "新增使用部门(&N)"
      End
      Begin VB.Menu mnuDelete 
         Caption         =   "删除使用部门(&D)"
      End
   End
End
Attribute VB_Name = "frmMutiDpm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'''''''''''''''''''''''''''''''''''''''''''''''
'   固定资产使用部门
'   作者:肖宇
'   日期:98-07-03
'
'   功能:录入部门及分摊比例
'
'''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit

Private Const mlngColID = 0
Private Const mlngColDpmID = 1
Private Const mlngColDpm = 2
Private Const mlngColRate = 3

Private WithEvents mclsList As Grid                 'Grid类
Attribute mclsList.VB_VarHelpID = -1

Private mlngDpmStr As String
Private mlngDpmID As Long                           '与参照框内容对应的部门ID
Private mlngAlterID As Long
Private mblnLocked As Boolean
Private mblnCopyMode As Boolean
Private mblnChanged As Boolean

'部门，比例
Public Sub LoadFromString(ByVal strValue As String)
    Dim strResult As String
    Dim intCount As Integer, lngRow As Long
    Dim lngCnt As Long
    
    intCount = msgMutiDpm.Rows
    If AlterID = -1 Then
        AlterID = 0
    End If
    mblnCopyMode = True
    intCount = 1
    If GetString(strValue, strResult, intCount, Asc("=")) Then
        lngRow = msgMutiDpm.Rows
        msgMutiDpm.Rows = msgMutiDpm.Rows + 1
        ltxtDpm.Text = strResult
        msgMutiDpm.TextMatrix(lngRow, mlngColDpmID) = ltxtDpm.ID
        msgMutiDpm.TextMatrix(lngRow, mlngColDpm) = ltxtDpm.Text
        msgMutiDpm.Row = lngRow
    End If
    intCount = intCount + 1
    If GetString(strValue, strResult, intCount, Asc("=")) Then
        lngRow = msgMutiDpm.Row
        msgMutiDpm.TextMatrix(lngRow, mlngColRate) = C2Dbl(strResult)
    End If
End Sub

Public Sub EditCard(lngAlterID As Long, Optional blnLock As Boolean = False)
    Dim lngCnt As Long
    On Error Resume Next
    lngCnt = msgMutiDpm.Rows
    mblnLocked = blnLock
    If AlterID <> lngAlterID Or AlterID = -1 Then
        AlterID = lngAlterID
    End If
    For lngCnt = 1 To msgMutiDpm.Cols - 1
        mclsList.ReadOnlyCol(lngCnt) = mblnLocked
    Next lngCnt
    cmdOk(1).Enabled = (Not mblnLocked)
    RefreshLtxtDpm
    Show vbModal
End Sub

Public Property Get AlterID() As Long
    AlterID = mlngAlterID
End Property

Public Property Let AlterID(ByVal vNewValue As Long)
    msgMutiDpm.Rows = 1
    mlngAlterID = vNewValue
    RefreshGrid
End Property

Public Property Get DepartmentStr() As String
    Dim lngRow As Long
    Dim strDepartment As String
    
    With msgMutiDpm
        For lngRow = 1 To .Rows - 1
            If .RowHeight(lngRow) > 100 And .TextMatrix(lngRow, mlngColDpm) <> "" Then
                If strDepartment <> "" Then
                    strDepartment = strDepartment & " / "
                End If
                strDepartment = strDepartment & .TextMatrix(lngRow, mlngColDpm) & "(" & .TextMatrix(lngRow, mlngColRate) & "%)"
            End If
        Next lngRow
    End With
    DepartmentStr = strDepartment
End Property

Public Property Get Changed() As Boolean
    Changed = mblnChanged
End Property

Public Sub Save(Optional lngAlterID As Long)
    Dim lngRow As Long
    Dim strSql As String
    Dim lngDpmID As Long
    Dim dblRate As Double
    Dim lngID As Long
    Dim blnNew As Boolean
    Dim lngFixedAlterID As Long
    Dim lngAutoID As Long
    
    If lngAlterID <> 0 Then
        lngFixedAlterID = lngAlterID
    Else
        lngFixedAlterID = mlngAlterID
    End If
    
    blnNew = False
    If mlngAlterID <> lngFixedAlterID Then
        blnNew = True
        If lngFixedAlterID > 0 Then
            mlngAlterID = lngFixedAlterID
        Else
            strSql = "DELETE FROM FixedDepartment WHERE lngFixedAlterID=-1"
            gclsBase.ExecSQL strSql
        End If
    End If
    
    With msgMutiDpm
        For lngRow = 1 To .Rows - 1
            lngID = GetValue(lngRow, mlngColID)
            lngDpmID = GetValue(lngRow, mlngColDpmID)
            dblRate = GetValue(lngRow, mlngColRate)
            If lngDpmID > 0 Then
                If lngID > 0 And (Not blnNew) Then
                    If .RowHeight(lngRow) > 100 Then
                        strSql = "UPDATE FixedDepartment SET lngDepartmentID=" & lngDpmID _
                            & ",dblRate=" & dblRate & ",lngFixedAlterID=" & lngFixedAlterID _
                            & " WHERE lngFixedDepartmentID=" & lngID
                    Else
                        strSql = "DELETE FROM FixedDepartment WHERE lngFixedDepartmentID=" & lngID
                    End If
                ElseIf .RowHeight(lngRow) > 100 Then
                    lngAutoID = GetNewID("FixedDepartment")
                    strSql = "INSERT INTO FixedDepartment (lngFixedDepartmentID,lngFixedAlterID,lngDepartmentID,dblRate) " _
                        & "VALUES (" & lngAutoID & "," & lngFixedAlterID & "," & lngDpmID & "," & dblRate & ")"
                Else
                    strSql = ""
                End If
                If strSql <> "" Then
                    gclsBase.ExecSQL strSql
                End If
            End If
        Next lngRow
    End With
    If mlngAlterID = -1 Then mlngAlterID = 0
End Sub

Function GetDpm() As rdoResultset
    Dim strSql As String
    
    strSql = "SELECT lngFixedDepartmentID,FixedDepartment.lngDepartmentID," _
        & "strDepartmentCode || ' ' || strDepartmentName As 使用部门,dblRate As ""分摊比例(%)"" FROM FixedDepartment " _
        & ", Department WHERE FixedDepartment.lngDepartmentID=Department.lngDepartmentID " _
        & "AND lngFixedAlterID=" & IIf(mlngAlterID = 0, -1, mlngAlterID)
    Set GetDpm = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Function

'确定
Public Function DataIsVoid(Msg As String, Optional blnCheckAfterSave As Boolean = False) As Boolean
    Dim lngRow As Long
    Dim lngRow1 As Long
    Dim lngCnt As Long
    Dim dblTotalRate As Double
    Dim strDpm As String
    Dim dblRate As Double
    Dim strSql As String
    Dim recDpm As rdoResultset
    
    DataIsVoid = True
    lngCnt = 0
    dblTotalRate = 0
    Msg = ""
    With msgMutiDpm
        For lngRow = 1 To .Rows - 1
            If .RowHeight(lngRow) > 100 Then
                strDpm = GetValue(lngRow, mlngColDpm, "String")
                dblRate = GetValue(lngRow, mlngColRate)
            Else
                strDpm = ""
                dblRate = 1
            End If
            If .RowHeight(lngRow) > 100 And strDpm <> "" Then
                If strDpm <> "" And dblRate > 0 Then
                    lngCnt = lngCnt + 1
                    dblTotalRate = dblTotalRate + dblRate
                ElseIf strDpm <> "" And dblRate = 0 Then
                    DataIsVoid = False
                    Msg = "分摊比例必须大于0！"
                ElseIf strDpm = "" And dblRate > 0 Then
                    DataIsVoid = False
                    Msg = "固定资产使用部门不能为空！"
                End If
                If DataIsVoid Then