billstart.cls

金算盘软件代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BillStart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Const intButtonWidth = 285 '下拉按纽宽度
Const intCmd0Width = 1215    '命令按纽宽度
Const intCaptionHeight = 195 'FIELD按纽标题高度
Const intField0width = 2500 'FIELD按纽标题高度
Const intFieldHeight = 255 'FIELD按纽输入框高度
Const intSpace = 10 '粘贴控件之间距
Const SPACETWIPS = 30 '单据头控件之列距
Const SpaceTwRow = 15 '单据头控件之行距
Const FixedCols = 1 'GRID固定列数
Const SeparateLineColor = &H808080     'GRID列分隔线色
Const lngDefaultWidth = 8985  'Min 8985
Const lngDefaultHeight = 5600 'Min 5600

Private blnIsBusy As Boolean

Private blnTime As Boolean
Private intReceiptTypeID As Integer   '  18 =商品期初ID
Private WithEvents mclsSubClass As SubClass32.SubClass  'Grid回调函数对象
Attribute mclsSubClass.VB_VarHelpID = -1
'Dim WithEvents mclsPicHook As SubClass32.SubClass     '输入PictureBox回调函数对象
Private WithEvents mclsHook As SubClass32.SubClass     '窗体回调函数对象
Attribute mclsHook.VB_VarHelpID = -1
Private WithEvents HookHe As Hook                      '窗体回调函数对象
Attribute HookHe.VB_VarHelpID = -1
Private Field() As ClassField        '表头输入控件的附加属性
Private arrItemProperty() As ItemProperty
'Private PicLbl(10) As ClassPicInputField  'PIC输入时的附加属性
Private ColProperty() As ClassGridProperty   'GRID附加属性
Private FormClipRect As RECT
Private GridClipRect As RECT
Private My As clsBillMark
Private lngPosition(0 To 20, 0 To 3) As Long    'FieldButton定位数组 Left,Top,Width,Height
Private strColRow() As String   '单据体行复制/粘贴存储区
Private ColBill As New Collection   '单据内容集合(不包括ActivityID和DetailID)
Private ctrInput As Object          '通用输入控件
'Private ctrPicInput As Object         '列表输入为PIC方式时的输入控件

Private intGrdBorderWidth As Long    'GRD边框垂直线宽
Private intGrdBorderHeight As Long   'GRD边框水平线宽
Private strOldText As String         '输入点原内容
Private lngOldID As Long             '输入点原ID

'局部变量保存属性值
Private frmName As Form
Public Property Get DropButtonWidth() As Integer
     DropButtonWidth = intButtonWidth
End Property

'单据类型属性
Public Property Let ReceiptTypeID(ByVal vData As Integer)
   Let intReceiptTypeID = vData
End Property
Public Property Get ReceiptTypeID() As Integer
     ReceiptTypeID = intReceiptTypeID
End Property
'是否绑定控件属性
Public Property Let blnCtrlBinding(ByVal vData As Boolean)
   Let My.blnCtrlBinding = vData
End Property
Public Property Get blnCtrlBinding() As Boolean
     blnCtrlBinding = My.blnCtrlBinding
End Property
'当前单据ID 属性
Public Property Let lngNowID(ByVal vData As Long)
   Let My.lngNowID = vData
End Property
Public Property Get lngNowID() As Long
     lngNowID = My.lngNowID
End Property
'当前输入区域属性
Public Property Let bytRegion(ByVal vData As Byte)
   Let My.bytRegion = vData
End Property
Public Property Get bytRegion() As Byte
     bytRegion = My.bytRegion
End Property
'当前输入区域序号属性
Public Property Let bytIndex(ByVal vData As Byte)
   Let My.bytIndex = vData
End Property
Public Property Get bytIndex() As Byte
     bytIndex = My.bytIndex
End Property

'数据是否改变属性
Public Property Let blnIsChanged(ByVal vData As Boolean)
   Let My.blnIsChanged = vData
End Property
Public Property Get blnIsChanged() As Boolean
     blnIsChanged = My.blnIsChanged
End Property
'窗体是否刷新属性
Public Property Let blnRefresh(ByVal vData As Boolean)
   Let My.blnRefresh = vData
End Property
Public Property Get blnRefresh() As Boolean
    blnRefresh = My.blnRefresh
End Property
'是否可行粘贴属性
Public Property Let blnPasteRec(ByVal vData As Boolean)
   Let My.blnPasteRec = vData
End Property
Public Property Get blnPasteRec() As Boolean
    blnPasteRec = My.blnPasteRec
End Property
'是否可删除属性
Public Property Let blnMayDelete(ByVal vData As Boolean)
   Let My.blnMayDelete = vData
End Property
Public Property Get blnMayDelete() As Boolean
    blnMayDelete = My.blnMayDelete
End Property
'是否触发CHANGE事件属性
Public Property Let blnChangeEvent(ByVal vData As Boolean)
   Let My.blnChangeEvent = vData
End Property
Public Property Get blnChangeEvent() As Boolean
    blnChangeEvent = My.blnChangeEvent
End Property
    
'会计年度属性
Public Property Let intAccountYear(ByVal vData As Integer)
   Let My.intAccountYear = vData
End Property
Public Property Get intAccountYear() As Integer
    intAccountYear = My.intAccountYear
End Property
'会计期间属性
Public Property Let bytAccountPeriod(ByVal vData As Byte)
   Let My.bytAccountPeriod = vData
End Property
Public Property Get bytAccountPeriod() As Byte
    bytAccountPeriod = My.bytAccountPeriod
End Property
'GRD原列号属性
Public Property Let lngOldCol(ByVal vData As Long)
   Let My.lngOldCol = vData
End Property
Public Property Get lngOldCol() As Long
    lngOldCol = My.lngOldCol
End Property
'GRD原行号属性
Public Property Let lngOldRow(ByVal vData As Long)
   Let My.lngOldRow = vData
End Property
Public Property Get lngOldRow() As Long
    lngOldRow = My.lngOldRow
End Property
    
Public Property Get grdBorderWidth() As Integer
'当检索属性值时在参数右边使用。
'Syntax: Debug.Print X.grdBorderWidth
    grdBorderWidth = intGrdBorderWidth
End Property
Public Property Set Form(ByVal vData As Form)
'当把对象赋值给属性时在 Set 语句左边使用。
'Syntax: Set x.GridName = Form1
    Set frmName = vData
    My.blnIsChanged = False
    My.bytRegion = FcmdButton
    My.bytIndex = 0

    '给GRDCOL设HOOK
    Set mclsSubClass = New SubClass32.SubClass
    mclsSubClass.hWnd = frmName.grdCol.hWnd
    mclsSubClass.Messages(WM_PAINT) = True
    mclsSubClass.Messages(WM_LBUTTONDOWN) = True
    mclsSubClass.Messages(WM_LBUTTONUP) = True

    Set mclsHook = New SubClass32.SubClass
    mclsHook.hWnd = frmName.hWnd
    mclsHook.Messages(WM_PAINT) = True
    mclsHook.Messages(WM_KEYUP) = True
    mclsHook.Messages(WM_GETMINMAXINFO) = True
    
    '上下左右按键信息
    Set HookHe = New Hook
    HookHe.SetHookAll frmName.hWnd
    
'    Set mclsPicHook = New SubClass32.SubClass
'    mclsPicHook.hWnd = picInput.hWnd
'    mclsPicHook.Messages(WM_PAINT) = True
    
    My.intAccountYear = gclsBase.FYearOfDate(Date)   '会计年度
    My.bytAccountPeriod = gclsBase.PeriodOfDate(Date)  '会计期间
    My.blnCtrlBinding = True
    My.blnRefresh = False
    My.blnPasteRec = False
'设置GRID附加属性
'    frmname.grdCol.RowHeight(0) = CLng(frmname.grdCol.RowHeight(0) / 2)
    frmName.lblInput(0).Height = frmName.grdCol.RowHeight(0)
    frmName.lblTitle(0).Height = frmName.grdCol.RowHeight(0)
    
    ReDim ColProperty(31) As ClassGridProperty
    SetColProperty
'创建GRID列粘贴控键
  Dim i As Integer
    For i = 1 To frmName.grdCol.Cols - 1
        Load frmName.lblTotal(i)
        frmName.lblTotal(i).Caption = ""
        frmName.lblTotal(i).ZOrder 0
    Next i

'   创建Field控件(表头输入)
    ReDim Field(12) As ClassField
    CreateField (12)
'    GrdAndLabelInitial
    ReDim strColRow(frmName.grdCol.Cols - 1) As String  '单据体行复制/粘贴存储区
    ReDim arrItemProperty(1) As ItemProperty
End Property
Public Property Get Form() As Object
'当检索属性值时在参数右边使用。
'Syntax: Debug.Print X.GridName
    Set Form = frmName
End Property
'确定滚动条的存在(待优化)
Public Sub ScrollBarExist(blnHscroll As Boolean, blnVscroll As Boolean)
    Dim intTotalColsWidth As Long
    intTotalColsWidth = lngSumOfColWidth()
    If frmName.grdCol.Rows <= 2 Then
        '总行数小于2,必无垂直滚动条
        blnVscroll = False
        If intTotalColsWidth >= frmName.grdCol.Width - 2 * intGrdBorderWidth Then
            blnHscroll = True
        Else
            blnHscroll = False
        End If
        GoTo Endproc
    End If
    If (Not frmName.grdCol.RowIsVisible(frmName.grdCol.Rows - 1)) Or (Not frmName.grdCol.RowIsVisible(1)) Then
        '第一行或最大行不可视(第0行为固定行),必有垂直滚动条
        blnVscroll = True
        If intTotalColsWidth >= frmName.grdCol.Width - 2 * intGrdBorderWidth - gclsEniv.VScrollWidth Then
            blnHscroll = True
        Else
            blnHscroll = False
        End If
        GoTo Endproc
    End If
    If intTotalColsWidth >= frmName.grdCol.Width - 2 * intGrdBorderWidth Then
        blnHscroll = True
        If frmName.grdCol.RowPos(frmName.grdCol.Rows - 1) + frmName.grdCol.RowHeight(frmName.grdCol.Rows - 1) >= frmName.grdCol.Height - 2 * intGrdBorderHeight - gclsEniv.HScrollHeight Then
            blnVscroll = True
        Else
            blnVscroll = False
        End If
        GoTo Endproc
    End If
    If intTotalColsWidth < frmName.grdCol.Width - 2 * intGrdBorderWidth - gclsEniv.VScrollWidth Then
        blnHscroll = False
        If frmName.grdCol.RowPos(frmName.grdCol.Rows - 1) + frmName.grdCol.RowHeight(frmName.grdCol.Rows - 1) >= frmName.grdCol.Height - 2 * intGrdBorderHeight Then
            blnVscroll = True
        Else
            blnVscroll = False
        End If
        GoTo Endproc
    End If
    
    If intTotalColsWidth < frmName.grdCol.Width - 2 * intGrdBorderWidth _
        And intTotalColsWidth > frmName.grdCol.Width - 2 * intGrdBorderWidth - gclsEniv.VScrollWidth Then
        If frmName.grdCol.RowPos(frmName.grdCol.Rows - 1) + frmName.grdCol.RowHeight(frmName.grdCol.Rows - 1) >= frmName.grdCol.Height - 2 * intGrdBorderHeight Then
            blnVscroll = True
            blnHscroll = True
        Else
            blnVscroll = False
            blnHscroll = False
        End If
    End If

Endproc:
    If frmName.grdCol.ScrollBars = flexScrollBarNone Or _
       frmName.grdCol.ScrollBars = flexScrollBarVertical Then
        blnHscroll = False
    End If
    If frmName.grdCol.ScrollBars = flexScrollBarNone Or _
       frmName.grdCol.ScrollBars = flexScrollBarHorizontal Then
        blnVscroll = False
    End If

End Sub
'在GRID上的下一个增加行
Public Sub NextLineWithAdded()
    Dim intNewRow As Integer
    If frmName.grdCol.Row < frmName.grdCol.Rows - 1 Then
        intNewRow = frmName.grdCol.Row + 1
    Else
        frmName.grdCol.Rows = frmName.grdCol.Rows + 1
        frmName.grdCol.TextMatrix(frmName.grdCol.Rows - 1, 0) = "0"
        intNewRow = frmName.grdCol.Row + 1
    End If
    If Not blnRowIsVisible(intNewRow) Then
        frmName.grdCol.TopRow = frmName.grdCol.TopRow + 1
    End If
    frmName.grdCol.Row = intNewRow
    If frmName.grdCol.Col = 0 Then
        frmName.grdCol.Col = 1
    End If
End Sub
'在GRID上确定行是否可见
Public Function blnRowIsVisible(ByVal RowNo As Integer) As Boolean
    '该行高度完全可视时为TRUE
    Dim blnHscroll As Boolean, blnVscroll As Boolean
    If frmName.grdCol.Rows <= 1 Then
        frmName.grdCol.Rows = 2
    End If
    If RowNo > frmName.grdCol.Rows - 1 Then