clsorder.cls

金算盘软件代码

   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
    ReDim Field(12)                  '表头输入控件的附加属性
    ReDim ColProperty(36)           'GRID附加属性
    ReDim arrItemProperty(1) As ItemProperty
    
    Set frmName = vData
    Set NewQ = New UnitCtrl
    NewQ.SetWin frmName.QuanInput.hwnd
    NewQ.font = frmName.font
    
    If UCase(frmName.Name) = "FRMSALEORDER" Then
        m_lngReceiptTypeID = 12
    Else
        m_lngReceiptTypeID = 1
    End If
    frmName.GrdCol.Cols = 37
    My.blnIsChanged = False
    My.bytRegion = FcmdButton
    My.bytIndex = 0
    
    '设置窗体控件颜色
    SetFormColor fccolor
    ApplyFormColor frmName, fccolor
    SeparateLineColor = fccolor.lngGridLineColor   'GRID列分隔线色
    lngBackColor = GetSysColor(COLOR_BTNFACE)
    
    frmName.GrdCol.Rows = 1
    Set clsRecord = New RecordClass
    Set clsRecordCustomer = New RecordClass  '控件参照类
    strPriceDec = FormatString(gclsBase.PriceDec)
    
    '给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
    mclsHook.Messages(WM_WINDOWPOSCHANGING) = 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(gclsBase.BaseDate)   '会计年度
    My.bytAccountPeriod = gclsBase.PeriodOfDate(gclsBase.BaseDate)  '会计期间
    My.blnCtrlBinding = True
    My.blnRefresh = False
    My.blnPasteRec = False
'设置GRID附加属性
'    frmname.grdCol.RowHeight(0) = CLng(frmname.grdCol.RowHeight(0) / 2)
    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
'       应付单只有4列显示
'        If i >= 4 Then
'            Exit For
'        End If
    Next i
    
    frmName.lblTotal(1).Caption = "合计"

'   创建Field控件(表头输入)
    CreateField (12)
    

    If UCase(frmName.Name) = "FRMSALEORDER" Then
        blnCanAdjustDisc = IsCanDo(225)
    Else
        blnCanAdjustDisc = True
    End If
    
'    GrdAndLabelInitial
    ReDim strColRow(frmName.GrdCol.Cols - 1) As String  '单据体行复制/粘贴存储区
    
    frmName.refInput(0).BackColor = fccolor.lngBackColor
    frmName.refInput(1).BackColor = fccolor.lngBackColor
    frmName.refInput(2).BackColor = fccolor.lngBackColor
    NewQ.BackColor = fccolor.lngBackColor
    
    setRefer 1
    
    frmName.refInput(1).Appearance = 1
    frmName.refInput(1).BorderStyle = 1
        
    setRefer 2
    
    frmName.refInput(2).Appearance = 0
    frmName.refInput(2).BorderStyle = 0
    
    frmName.curInput.Move -32000, -32000
    frmName.refInput(0).Move -32000, -32000
    frmName.refInput(1).Move -32000, -32000
    frmName.refInput(2).Move -32000, -32000
    frmName.txtInput.Move -32000, -32000
    frmName.dtmInput.Move -32000, -32000
    frmName.QuanInput.Move -32000, -32000
    SetRight
    #If conWan = 1 Then
      SetToolBar True
    #End If
End Property
Public Property Get Form() As Object
'当检索属性值时在参数右边使用。
'Syntax: Debug.Print X.GridName
    Set Form = frmName
End Property

Public Sub SetColblnReadonly(ByVal ColID As Long, ByVal blnReadOnly As Boolean)
'设置表列只读属性
    ColProperty(ColID).blnReadOnly = blnReadOnly
    ColIsGray ColID, blnReadOnly
End Sub
'确定滚动条的存在(待优化)
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 - 0 * 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
        blnRowIsVisible = False
    End If
    If frmName.GrdCol.RowIsVisible(RowNo) = False Then
        blnRowIsVisible = False
        Exit Function
    End If
    Call ScrollBarExist(blnHscroll, blnVscroll) '判断是否滚动条
    If blnHscroll Then
        '下边有滚动水平条
        If frmName.GrdCol.RowPos(RowNo) + frmName.GrdCol.RowHeight(RowNo) > frmName.GrdCol.Height - gclsEniv.HScrollHeight Then
            blnRowIsVisible = False
        Else
            blnRowIsVisible = True
        End If
   Else
        '下边无水平滚动条
        If frmName.GrdCol.RowPos(RowNo) + frmName.GrdCol.RowHeight(RowNo) > frmName.GrdCol.Height Then
            blnRowIsVisible = False
        Else
            blnRowIsVisible = True
        End If
   End If
End Function

'各列宽度之和
Public Function lngSumOfColWidth() As Long
    Dim i As Integer, lngSum As Long
    lngSum = 0
    For i = 0 To frmName.GrdCol.Cols - 1
        lngSum = lngSum + frmName.GrdCol.ColWidth(i)
    Next i
    lngSumOfColWidth = lngSum
End Function

Public Function dblTotalOfCol(ByVal intCol As Integer) As Double
'GRID列合计
    Dim lngRow As Long
    Dim dblTmp As Double
    Dim lngRowBak As Long, lngColBak As Long
    Dim blnRefreshBak As Boolean
    dblTmp = 0
    
    lngRowBak = frmName.GrdCol.Row
    lngColBak = frmName.GrdCol.col
    blnRefreshBak = My.blnRefresh
    My.blnRefresh = False
'    frmName.grdCol.Redraw = False
    For lngRow = 1 To frmName.GrdCol.Rows - 1
        dblTmp = dblTmp + C2Dbl(strGrdCell(lngRow, intCol, False))
    Next lngRow
    frmName.GrdCol.Row = lngRowBak
    frmName.GrdCol.col = lngColBak
    dblTotalOfCol = dblTmp
'    frmName.grdCol.Redraw = True
    My.blnRefresh = blnRefreshBak
End Function

'---------------------------------
'单据类型数组初始化
'---------------------------------
Private Sub InitReceiptArray()
    ReceiptType(1).lngReceiptTypeID = 1
    ReceiptType(1).strReceiptTypeName = "采购订单"
    ReceiptType(1).lngReceiptID = 1

    ReceiptType(2).lngReceiptTypeID = 2