frmcustomerdiscountcard.frm

金算盘软件代码

                    
                If txtSetting.Text = "" Then
                    txtSetting.SetFocus
                    Exit Sub
                End If
                For intCounter = .FixedRows To .Rows - 1
                    If .RowHeight(intCounter) <> 0 Then
                        If .TextMatrix(intCounter, 1) = "√" Then
                            If strRight(txtSetting.Text, 1) <> "%" Then '增减一定折扣率
                                '.TextMatrix(intCounter, 6) =
                                  dblRate = CDbl(.TextMatrix(intCounter, intOldRateCol)) + CDbl(txtSetting.Text)
                            Else  '增减当前折扣率的百分比
                               ' .TextMatrix(intCounter, 6) =
                                    dblRate = CDbl(.TextMatrix(intCounter, intOldRateCol)) + _
                                    CDbl(.TextMatrix(intCounter, intOldRateCol)) * _
                                    CDbl(strLeft(txtSetting.Text, StrLen(txtSetting.Text) - 1)) / 100
                            End If
                            If dblRate > 100 _
                                Or dblRate < 0 Then  '出错处理
                                'intMsgReturn =
                                ShowMsg Me.hwnd, "计算后的新扣率(%)只能在0到100之间。", _
                                 vbExclamation + vbOKOnly, frmCustomerDiscountCard.Caption
                                For intCounterRevert = 1 To intCounter
                                 .TextMatrix(intCounterRevert, intNewRateCol) = ""
                                Next intCounterRevert
                                Exit Sub
                            Else
                                If dblRate < 1 And dblRate > 0 Then
                                    .TextMatrix(intCounter, intNewRateCol) = "0" & CStr(dblRate)
                                Else
                                    .TextMatrix(intCounter, intNewRateCol) = dblRate
                                End If
                            End If
                        End If
                    End If
                Next intCounter
        End Select
    End With
End Sub

Private Sub Form_Activate()
    SetHelpID 30101
End Sub

Private Sub Form_Load()
    Me.HelpContextID = 30101
    frmCustomerList.IsShowCard(2) = True
    Me.Icon = GetFormResPicture(139, vbResIcon)
    cmdOKCancel(0).Picture = GetFormResPicture(1001, vbResBitmap)
    cmdOKCancel(1).Picture = GetFormResPicture(1002, vbResBitmap)
    gclsSys.CurrFormName = Me.hwnd
End Sub

Private Sub Form_Paint()
    ReFrameBox Me.hwnd, 60, Me.Height - 1490, Me.width - 1540, Me.Height - 555
End Sub

Private Sub Form_Resize()
    Dim intCounter As Integer

    If Me.WindowState = vbMinimized Then
        Exit Sub
    End If
    If Me.width < mintFormWidth Then Me.width = mintFormWidth
    If Me.Height < mintFormHeight Then Me.Height = mintFormHeight
    For intCounter = 0 To 4
        cmdOKCancel(intCounter).Left = Me.width - 1425
    Next intCounter
    cmdOKCancel(5).Left = Me.width - 2895
    cmdOKCancel(5).top = Me.Height - 960
    lblTitle(1).Left = Me.width - 8445
    lblTitle(1).top = Me.Height - 1320
    txtSetting.Left = Me.width - 2895
    txtSetting.top = Me.Height - 1350
    msgCustomer.width = Me.width - 1590
    msgCustomer.Height = Me.Height - 2115
    If txtPaste.Visible = True Then
        txtPaste.Move msgCustomer.CellLeft + 60, msgCustomer.CellTop + 500, _
            msgCustomer.CellWidth - 15, msgCustomer.CellHeight
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    mclsGridCustomer.GridToListSet
    Set mclsGridCustomer = Nothing
    frmCustomerList.IsShowCard(2) = False
    Utility.RemoveFormResPicture (139)
    Utility.RemoveFormResPicture (1001)
    Utility.RemoveFormResPicture (1002)
End Sub

Private Sub msgCustomer_Click()
    Dim intNewRateCol As Integer
    intNewRateCol = GetCol("新扣率％")
    With msgCustomer
        If .Row <> .MouseRow Then Exit Sub
        If .Row = 0 Then Exit Sub
        If .RowHeight(.MouseRow) = 0 Then Exit Sub
       ' .ColSel = .Cols - 1
        If .MouseCol = 1 Then  '选中后统一修改折扣率
            If .MouseRow = .Row Then
                If .TextMatrix(.Row, 1) = "√" Then
                    .TextMatrix(.Row, 1) = ""
                    .TextMatrix(.Row, intNewRateCol) = ""
                Else
                    .TextMatrix(.Row, 1) = "√"
                End If
            End If
            ElseIf .ColSel = intNewRateCol Then '直接修改折扣率
            
'                .SelectionMode = flexSelectionFree
'                .HighLight = flexHighlightNever
'                .FocusRect = flexFocusNone
                mlngGridRow = .Row
                If .TextMatrix(.Row, intNewRateCol) = " " Then
                    txtPaste.Text = ""
                Else
                    txtPaste.Text = .TextMatrix(.Row, intNewRateCol)
                End If
                txtPaste.Move .ColPos(intNewRateCol) + 75, .RowPos(.Row) + 500, .ColWidth(intNewRateCol), .CellHeight
                lngX = .CellLeft
                lngY = .CellTop
                mintRow = .Row
                txtPaste.SelStart = 0
                txtPaste.SelLength = StrLen(txtPaste.Text)
                txtPaste.Visible = True
                If txtPaste.Enabled Then
                    txtPaste.SetFocus
                End If
'            Else
'                .SelectionMode = flexSelectionByRow
'                .HighLight = flexHighlightAlways
'                .ColSel = .Cols - 1
'                .FocusRect = flexFocusHeavy
            'End If
'            SendKeys "{HOME}" + "{END}"
        End If
    End With
End Sub

Private Sub msgCustomer_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    With msgCustomer
        If .MouseCol = 1 Then
            .MousePointer = vbCustom
        Else
            .MousePointer = vbDefault
        End If
    End With
End Sub


Private Sub msgCustomer_Scroll()
   Dim intNewRateCol As Integer
   intNewRateCol = GetCol("新扣率％")
    With msgCustomer
        If txtPaste.Visible = True Then
            If .ColIsVisible(intNewRateCol) Then
                If .ColPos(intNewRateCol) + .ColWidth(intNewRateCol) < .width - 60 Then
                        txtPaste.Left = .ColPos(intNewRateCol) + 75
                        txtPaste.top = .RowPos(.Row) + 500
                        txtPaste.width = .ColWidth(intNewRateCol) ' - 15 ' .CellHeight
                Else
                    If mintRow = .Row Then
                        txtPaste.Left = .ColPos(intNewRateCol) + 75
                        txtPaste.top = .RowPos(.Row) + 500
                        txtPaste.width = .width - .ColPos(intNewRateCol) '- 15
                    End If
                End If
            End If
        End If
    End With
End Sub

Private Sub txtPaste_Change()
    mblnIsChangetxtPaste = True
End Sub

Private Sub txtPaste_KeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer)
    If KeyCode = 13 Then
        txtPaste_LostFocus
    End If
End Sub

'直接输入新折扣率数据合法性判断
Private Sub txtPaste_LostFocus()
    Dim intMsgReturn As Integer
    Dim intNewRateCol As Integer
    intNewRateCol = GetCol("新扣率％")
    If txtPaste.Text <> "" Then
        If IsNumeric(txtPaste.Text) Then
            If CDbl(txtPaste.Text) < 0 Or CDbl(txtPaste.Text) > 100 Then
                intMsgReturn = ShowMsg(0, "扣率(%)只能在0到100之间。", _
                    vbExclamation + vbOKOnly + MB_TASKMODAL, frmCustomerDiscountCard.Caption)
                txtPaste.SelStart = 0
                txtPaste.SelLength = StrLen(txtPaste.Text)
                txtPaste.SetFocus
            Else
                
                msgCustomer.TextMatrix(mlngGridRow, intNewRateCol) = IIf(Abs(Val(txtPaste.Text)) < 1, _
                                                                      IIf(Sgn(Val(txtPaste.Text)) < 0, "-", "") & "0" & CStr(CDbl(txtPaste.Text)), _
                                                                     CStr(CDbl(txtPaste.Text)))
                txtPaste.Visible = False
            End If
        Else
            intMsgReturn = ShowMsg(0, "录入的数字非法，请重新录入。", _
                vbExclamation + vbOKOnly + MB_TASKMODAL, frmCustomerDiscountCard.Caption)
            txtPaste.SelStart = 0
            txtPaste.SelLength = StrLen(txtPaste.Text)
            txtPaste.SetFocus
        End If
    Else
        '
        If mblnIsChangetxtPaste Then
            msgCustomer.TextMatrix(mlngGridRow, intNewRateCol) = txtPaste.Text
            mblnIsChangetxtPaste = False
        End If
        txtPaste.Visible = False
    End If
End Sub

Private Sub txtSetting_Change()
    If txtSetting.Text Like "0[0,1,2,3,4,5,6,7,8,9]*" Then BKKEY txtSetting.hwnd
End Sub

'统一调整折扣率数据合法性判断
Private Sub txtSetting_LostFocus()
    Dim intMsgReturn As Integer
    
    If txtSetting.Text <> "" Then
        If IsNumeric(txtSetting.Text) Then
            If Left(txtSetting.Text, 1) = "." Then
                MsgBox "扣率(%)必须是数字", vbExclamation + vbOKOnly, Caption
                Exit Sub
            End If
            If CDbl(txtSetting.Text) < -100 Or CDbl(txtSetting.Text) > 100 Then
                intMsgReturn = MsgBox("扣率(%)只能在-100到100之间。", _
                    vbExclamation + vbOKOnly, frmCustomerDiscountCard.Caption)
                txtSetting.SelStart = 0
                txtSetting.SelLength = StrLen(txtSetting.Text)
                txtSetting.SetFocus
            End If
        Else
            If Not IsNumeric(strLeft(txtSetting.Text, StrLen(txtSetting.Text) - 1)) _
                Or strRight(txtSetting.Text, 1) <> "%" Then
                intMsgReturn = MsgBox("扣率(%)必须是数字或带“%”的数字。", _
                    vbExclamation + vbOKOnly, frmCustomerDiscountCard.Caption)
                txtSetting.SelStart = 0
                txtSetting.SelLength = StrLen(txtSetting.Text)
                txtSetting.SetFocus
            End If
        End If
    End If
End Sub

'得到调整折扣率列表记录集
Private Function GetAddCostList(ByVal ViewId As Integer) As rdoResultset
    Dim recRecordset As rdoResultset
    Dim strSelectOfSql As String
    Dim strFromOfSql As String
    Dim strWhereOfSql As String
    Dim strSql As String
    Dim intCount As Integer
    
    With msgCustomer
        .Redraw = False
        .FixedCols = 0
    End With
    
    With mclsGridCustomer.ListSet
        strSelectOfSql = "SELECT lngCustomerID ,' ' AS ""选择""," & .SelectOfSql
        strFromOfSql = .FromOfSql
        strWhereOfSql = .WhereOfSql
    End With
    strSql = strSelectOfSql & strFromOfSql
    strWhereOfSql = Trim(strWhereOfSql)
    If strWhereOfSql <> "" Then
        strSql = strSql & " Where  " & strWhereOfSql
    End If
    Set recRecordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)

    With msgCustomer
        .FocusRect = flexFocusLight
        .ColWidth(0) = 0                                     ' 隐藏ID列
        .ColWidth(1) = 450
        .Redraw = True
'        .SelectionMode = flexSelectionByRow
    End With
    Set GetAddCostList = recRecordset
End Function

'画Frame类型边框
Public Sub ReFrameBox(ByVal hwnd, x1, y1, x2, y2 As Long)
    Static lngX1 As Long
    Static lngY1 As Long
    Static lngX2 As Long
    Static lngY2 As Long
    Dim hdc As Long
    Dim hPen1 As Long, hPen2 As Long, hSavePen As Long
    Dim Point As POINTAPI
    
    hdc = GetDC(hwnd)
    
    x1 = x1 / Screen.TwipsPerPixelX
    x2 = x2 / Screen.TwipsPerPixelX
    y1 = y1 / Screen.TwipsPerPixelY
    y2 = y2 / Screen.TwipsPerPixelY
    
    '清除老Frame类型边框
    hPen1 = CreatePen(PS_SOLID, 1, RGB(192, 192, 192))
    hSavePen = SelectObject(hdc, hPen1)
    Rectangle hdc, lngX1, lngY1, lngX2, lngY2
    
    hPen2 = CreatePen(PS_SOLID, 1, RGB(192, 192, 192))
    SelectObject hdc, hPen2
    MoveToEx hdc, lngX1 + 1, lngY1 + 1, Point
    LineTo hdc, lngX2 - 1, lngY1 + 1
    MoveToEx hdc, lngX1 + 1, lngY1 + 1, Point
    LineTo hdc, lngX1 + 1, lngY2 - 1
    MoveToEx hdc, lngX1, lngY2, Point
    LineTo hdc, lngX2, lngY2
    MoveToEx hdc, lngX2, lngY1, Point
    LineTo hdc, lngX2, lngY2 + 1
    
    '画新Frame类型边框
    hPen1 = CreatePen(PS_SOLID, 1, RGB(128, 128, 128))
    hSavePen = SelectObject(hdc, hPen1)
    Rectangle hdc, x1, y1, x2, y2
    
    hPen2 = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
    SelectObject hdc, hPen2
    MoveToEx hdc, x1 + 1, y1 + 1, Point
    LineTo hdc, x2 - 1, y1 + 1
    MoveToEx hdc, x1 + 1, y1 + 1, Point
    LineTo hdc, x1 + 1, y2 - 1
    MoveToEx hdc, x1, y2, Point
    LineTo hdc, x2, y2
    MoveToEx hdc, x2, y1, Point
    LineTo hdc, x2, y2 + 1
    SelectObject hdc, hSavePen
    DeleteObject hPen1
    DeleteObject hPen2
    
    ReleaseDC hwnd, hdc
    lngX1 = x1
    lngX2 = x2
    lngY1 = y1
    lngY2 = y2
End Sub

Private Function GetCol(ByVal strColName As String) As Integer
    Dim i As Integer
    With mclsGridCustomer.Grid
         For i = 1 To .Cols - 1
             If .TextMatrix(0, i) = strColName Then
                GetCol = i
                Exit For
             End If
         Next
    End With
End Function