frmcopyprice.frm

金算盘软件代码

VERSION 5.00
Begin VB.Form frmCopyPrice 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "复制单价"
   ClientHeight    =   2130
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   5010
   HelpContextID   =   14007
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   2130
   ScaleWidth      =   5010
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.OptionButton optCopy 
      Caption         =   "直接复制当前单价"
      Height          =   195
      Index           =   0
      Left            =   270
      TabIndex        =   3
      Top             =   930
      Value           =   -1  'True
      Width           =   1755
   End
   Begin VB.OptionButton optCopy 
      Caption         =   "复制同时增加一定金额"
      Height          =   195
      Index           =   1
      Left            =   270
      TabIndex        =   4
      Top             =   1260
      Width           =   2115
   End
   Begin VB.OptionButton optCopy 
      Caption         =   "按一定比例复制"
      Height          =   195
      Index           =   2
      Left            =   270
      TabIndex        =   6
      Top             =   1590
      Width           =   1725
   End
   Begin VB.TextBox txtCopy 
      BackColor       =   &H80000004&
      Enabled         =   0   'False
      Height          =   270
      Index           =   0
      Left            =   2430
      MaxLength       =   12
      TabIndex        =   5
      Top             =   1230
      Width           =   855
   End
   Begin VB.TextBox txtCopy 
      BackColor       =   &H80000004&
      Enabled         =   0   'False
      Height          =   270
      Index           =   1
      Left            =   2430
      MaxLength       =   10
      TabIndex        =   7
      Top             =   1590
      Width           =   705
   End
   Begin VB.ComboBox cboDataSource 
      Height          =   300
      ItemData        =   "frmCopyPrice.frx":0000
      Left            =   1230
      List            =   "frmCopyPrice.frx":0002
      Style           =   2  'Dropdown List
      TabIndex        =   1
      Top             =   150
      Width           =   2295
   End
   Begin VB.CommandButton cmdCancelOk 
      Cancel          =   -1  'True
      Height          =   350
      Index           =   1
      Left            =   3660
      Style           =   1  'Graphical
      TabIndex        =   9
      Tag             =   "1002"
      Top             =   510
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton cmdCancelOk 
      Height          =   350
      Index           =   0
      Left            =   3660
      Style           =   1  'Graphical
      TabIndex        =   8
      Tag             =   "1001"
      Top             =   120
      UseMaskColor    =   -1  'True
      Width           =   1215
   End
   Begin VB.Label lblCopy 
      Caption         =   "复制选项(&F)"
      Height          =   225
      Index           =   1
      Left            =   270
      TabIndex        =   2
      Top             =   630
      Width           =   1185
   End
   Begin VB.Label lblCopy 
      Caption         =   "%"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   195
      Index           =   2
      Left            =   3210
      TabIndex        =   10
      Top             =   1620
      Width           =   135
   End
   Begin VB.Label lblCopy 
      Caption         =   "数据来源(&S)"
      Height          =   195
      Index           =   0
      Left            =   180
      TabIndex        =   0
      Top             =   210
      Width           =   1005
   End
End
Attribute VB_Name = "frmCopyPrice"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'复制价格卡片
' 作者：欧中建
'日期：1998-7-15
'ShowCard()用于调用此卡片
Option Explicit

Private mbytDec As Byte
Private mbytCol As Byte
Private mCurrMsgSource As MSFlexGrid

Public Property Let colNo(ByVal vNewValue As Byte)
    mbytCol = vNewValue
End Property

Public Property Set FlexGrid(ByVal vNewValue As MSFlexGrid)
    Set mCurrMsgSource = vNewValue
End Property

Public Property Let Dec(ByVal vNewValue As Byte)
    mbytDec = vNewValue
End Property

Private Sub cmdCancelOk_Click(Index As Integer)
    If Index = 0 Then
        ChangePrice
        frmAdaptCard.IsChanged = True
    End If
    Unload Me
End Sub

Private Sub Form_Activate()
    SetHelpID Me.HelpContextID
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        BKKEY Me.ActiveControl.hwnd, vbKeyTab
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn And Shift = 2 Then
        cmdcancelOk(0).Value = True
    End If
End Sub

Private Sub Form_Load()
    Dim i As Integer
    Dim edtErrReturn As ErrDealType
    
    On Error GoTo ErrHandle
'    SetHelpID hwnd, 14007
    Utility.LoadFormResPicture Me
    If Not mCurrMsgSource Is Nothing Then
        With mCurrMsgSource
        If .Row > 0 Then
            For i = 2 To .Cols - 1
                If InStr(1, .TextMatrix(0, i), "新") = 0 And InStr(1, .TextMatrix(0, i), "价") <> 0 Then
                    cboDataSource.AddItem .TextMatrix(0, i)
                    cboDataSource.ItemData(cboDataSource.NewIndex) = i
                End If
            Next
        End If
        End With
        If cboDataSource.ListCount > 0 Then cboDataSource.ListIndex = 0
'        If cboDataSource.ListIndex > -1 Then cboDataSource.ListIndex = 0
    End If
    Exit Sub
ErrHandle:
    edtErrReturn = Errors.ErrorsDeal
    
    If edtErrReturn = edtResume Then
         Resume
    Else
         On Error Resume Next
         Unload Me
    End If
End Sub

Private Sub Form_Paint() '划框框
    FrameBox Me.hwnd, 150, 700, 3500, 1900
End Sub

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

Private Sub OptCopy_Click(Index As Integer)
    Select Case Index
    Case 0
        txtCopy(0).Enabled = False
        txtCopy(0).Text = ""
        txtCopy(0).BackColor = &H80000004
        txtCopy(1).Enabled = False
        txtCopy(1).Text = ""
        txtCopy(1).BackColor = &H80000004
    Case 1
        txtCopy(0).Enabled = True
        txtCopy(0).BackColor = &H80000005
        txtCopy(1).Enabled = False
        txtCopy(1).Text = ""
        txtCopy(1).BackColor = &H80000004
        txtCopy(0).SetFocus
    Case 2
        
        txtCopy(0).Enabled = False
        txtCopy(0).Text = ""
        txtCopy(0).BackColor = &H80000004
        txtCopy(1).Enabled = True
        txtCopy(1).BackColor = &H80000005
        txtCopy(1).SetFocus
    End Select
End Sub

Private Sub ChangePrice() '改变Grid的选定项
    Dim intCol As Integer, dblPrice As Double
    Dim i As Integer ', intDCol As Integer
    
    intCol = cboDataSource.ItemData(cboDataSource.ListIndex)
'    intDCol = GetColNO
    With mCurrMsgSource
    Select Case True
        Case optCopy(0).Value
            For i = 1 To .Rows - 1
                If .TextMatrix(i, 1) = "√" Then
                    .TextMatrix(i, mbytCol) = FormatShow(.TextMatrix(i, intCol), mbytDec)
                    .RowData(i) = -1 '价格已经修改
                End If
            Next
        Case optCopy(1).Value
            For i = 1 To .Rows - 1
                If .TextMatrix(i, 1) = "√" Then
                    dblPrice = TxtToDouble(txtCopy(0).Text) + TxtToDouble(.TextMatrix(i, intCol))
                    If dblPrice > 0 Then
                        .TextMatrix(i, mbytCol) = FormatShow(dblPrice, mbytDec)
                        .RowData(i) = -1 '价格已经修改
                    End If
                End If
            Next
        Case optCopy(2).Value
            For i = 1 To .Rows - 1
                If .TextMatrix(i, 1) = "√" Then
                    dblPrice = TxtToDouble(txtCopy(1).Text)
                    If dblPrice > 0 Then
                        .TextMatrix(i, mbytCol) = FormatShow(TxtToDouble(.TextMatrix(i, intCol)) * dblPrice / 100, mbytDec)
                        .RowData(i) = -1 '价格已经修改
                    End If
                End If
            Next
    End Select
    End With
End Sub

'Private Function GetColNO() As Integer
'    Dim iCol As Integer
'
'    With mCurrMsgSource
'    For iCol = 1 To .Cols - 1
'        If InStr(1, .TextMatrix(0, iCol), "新") <> 0 Then Exit For
'    Next iCol
'    End With
'    GetColNO = iCol
'End Function
'
Private Sub txtCopy_Change(Index As Integer)
    If Index = 0 Then
        If Not IsNum(txtCopy(Index).Text, mbytDec) Then
                BKKEY txtCopy(Index).hwnd
        End If
    Else
        If Not ContainSpecifyChar(txtCopy(1).Text, ".0123456789") Then
            BKKEY txtCopy(1).hwnd
        ElseIf Not IsNum(txtCopy(1).Text, mbytDec) Then
            BKKEY txtCopy(1).hwnd
'        ElseIf TxtToDouble(txtCopy(1).Text) > 100 Then
'            BKKEY txtCopy(1).hwnd
        End If
    End If
End Sub
'Private Function CheckIsRight(strChecked As String) As Boolean '检查输入值的正确性
'    Dim n As Integer
'    CheckIsRight = False
'
'    If Len(strChecked) = 0 Then Exit Function
'    If Left(strChecked, 1) = "." Then Exit Function
'    If Not IsNumeric(strChecked) Then Exit Function
'    CheckIsRight = True
'
'End Function