frmcalcdisc.frm

金算盘软件代码

VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmCalcDisc 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "贴息折扣计算底稿"
   ClientHeight    =   6210
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   9540
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   6210
   ScaleWidth      =   9540
   StartUpPosition =   2  '屏幕中心
   Begin MSFlexGridLib.MSFlexGrid grdCol 
      Height          =   5565
      Left            =   60
      TabIndex        =   2
      Top             =   300
      Width           =   9435
      _ExtentX        =   16642
      _ExtentY        =   9816
      _Version        =   393216
      Rows            =   1
      Cols            =   14
      FixedCols       =   0
      RowHeightMin    =   270
      BackColorBkg    =   -2147483643
      FocusRect       =   0
      SelectionMode   =   1
      AllowUserResizing=   1
      FormatString    =   $"frmCalcDisc.frx":0000
   End
   Begin VB.Label lblMemo 
      AutoSize        =   -1  'True
      Caption         =   "制单人："
      Height          =   180
      Index           =   1
      Left            =   7290
      TabIndex        =   4
      Top             =   5970
      Visible         =   0   'False
      Width           =   720
   End
   Begin VB.Label lblMemo 
      AutoSize        =   -1  'True
      Caption         =   "剩余打款金额："
      Height          =   180
      Index           =   0
      Left            =   90
      TabIndex        =   3
      Top             =   5970
      Width           =   1260
   End
   Begin VB.Label lblTitle 
      AutoSize        =   -1  'True
      Caption         =   "币种："
      Height          =   180
      Index           =   1
      Left            =   7290
      TabIndex        =   1
      Top             =   60
      Visible         =   0   'False
      Width           =   540
   End
   Begin VB.Label lblTitle 
      AutoSize        =   -1  'True
      Caption         =   "单位："
      Height          =   180
      Index           =   0
      Left            =   60
      TabIndex        =   0
      Top             =   60
      Width           =   540
   End
End
Attribute VB_Name = "frmCalcDisc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private frmName As Form
Private DiscInfos As Collection
Private strCurrDec As String
Private blnByOrder As Boolean
Private RowData() As RowProperty
Private strColName() As String
Private dblUsableAmount As Double
Private Const blnDiscMethod = True  '计算方式：True 预付款/(1-贴息)=折扣 ,False 预付款*(1+贴息)=折扣
Private mclsGrid As Grid

Private Type RowProperty
    lngRowno As Long
    lngTableID As Long
    lngID As Long
    dblDiscAmount As Double
    dblPayAmount As Double
End Type
Public Sub ShowMe(frmTmp As Form, DiscInfosTmp As Collection)
    Set frmName = frmTmp
    Set DiscInfos = DiscInfosTmp
    On Error Resume Next
    Me.Show vbModal
End Sub

Private Sub Form_Activate()
    If Me.HelpContextID <> 0 Then
        SetHelpID Me.HelpContextID
    End If

End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Or KeyCode = 27 Then
        Unload Me
    End If
End Sub
Private Sub grdCol_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Or KeyCode = 27 Then
        Unload Me
    End If
End Sub

Private Sub Form_Load()
    Me.HelpContextID = 700001
    Me.Icon = Utility.GetFormResPicture(139, vbResIcon) '窗体图标
    
    Set mclsGrid = New Grid
    Set mclsGrid.Grid = GrdCol
    mclsGrid.ListSet.ViewId = 999999999 '虚拟视图
    
    If UCase(frmName.Name) = "FRMSALEORDER" Then
        blnByOrder = True
        strCurrDec = FormatString(CurrencyDec(frmName.getFieldID(9)))
        lblTitle(1).Caption = lblTitle(1).Caption & " " & frmName.lblField(9).Caption
    Else
        blnByOrder = False
        strCurrDec = FormatString(CurrencyDec(frmName.getFieldID(7)))
        lblTitle(1).Caption = lblTitle(1).Caption & " " & frmName.lblField(7).Caption
    End If
    
    lblTitle(0).Caption = lblTitle(0).Caption & " " & frmName.lblHead(1).Caption
    
    LblMemo(1).Caption = LblMemo(1).Caption & " " & frmName.LblMemo(frmName.LblMemo.Count - 1).Caption
    lblTitle(0).Visible = True
    lblTitle(0).Left = lblTitle(0).Left + 200
    LblMemo(0).Left = LblMemo(0).Left + 200
    lblTitle(1).Left = GrdCol.Left + GrdCol.width - lblTitle(1).width - 200
    LblMemo(1).Left = GrdCol.Left + GrdCol.width - LblMemo(1).width - 200
    lblTitle(1).Visible = True
    LblMemo(1).Visible = True
    LblMemo(0).Visible = False
    LoadGrdColWidth
    
    Dim i As Long
    
    For i = 1 To DiscInfos.Count Step 7
      If DiscInfos.Item(i) > 0 Then
        AddARow DiscInfos.Item(i), DiscInfos.Item(i + 1), DiscInfos.Item(i + 2), _
        DiscInfos.Item(i + 3), DiscInfos.Item(i + 4), DiscInfos.Item(i + 5), DiscInfos.Item(i + 6)
      End If
    Next
    
    
    ReDim strColName(GrdCol.Cols - 1)
    For i = 0 To GrdCol.Cols - 1
        If InStr(GrdCol.TextMatrix(0, i), "数量") <> 0 Or InStr(GrdCol.TextMatrix(0, i), "额") <> 0 Or InStr(GrdCol.TextMatrix(0, i), "率") <> 0 Or InStr(GrdCol.TextMatrix(0, i), "价") <> 0 Then
            GrdCol.ColAlignment(i) = flexAlignRightCenter
        Else
            GrdCol.ColAlignment(i) = flexAlignLeftCenter
        End If
        strColName(i) = GrdCol.TextMatrix(0, i)
    Next
    
    mclsGrid.ListSet.Columns = GrdCol.Cols - 1
    mclsGrid.SetupStyle
End Sub

Private Sub Form_Unload(Cancel As Integer)
    SaveGrdColWidth
    Utility.UnLoadFormResPicture Me
    Utility.RemoveFormResPicture 139
    Set frmName = Nothing
    Set DiscInfos = Nothing
    Erase RowData
    Erase strColName
    Set mclsGrid = Nothing
End Sub

Private Sub LoadGrdColWidth()
    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim i As Integer
    
    strSQL = "SELECT strKey,strSetting FROM Setting WHERE lngModuleID=0 AND strSection='" & Me.Name & "列宽'"
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenStatic)
    If recTmp.BOF And recTmp.EOF Then
        FirstGrdColWidth
    Else
'        FirstGrdColWidth
        Do While Not recTmp.EOF
            GrdCol.ColWidth(C2lng(recTmp!strKey)) = C2lng(recTmp!strSetting)
            recTmp.MoveNext
        Loop
    End If
    recTmp.Close
    Set recTmp = Nothing
End Sub
Private Sub FirstGrdColWidth()
'    Dim lngTmp As Long
    Dim i As Integer
    
'    lngTmp = 0
'    For i = 0 To grdCol.Cols - 1
'        lngTmp = lngTmp + IIf(InStr(grdCol.TextMatrix(0, i), "日期") <> 0, 10, StrLen(grdCol.TextMatrix(0, i)))
'    Next
    For i = 0 To GrdCol.Cols - 1
        GrdCol.ColWidth(i) = Int(IIf(InStr(GrdCol.TextMatrix(0, i), "日期") <> 0, 10, StrLen(GrdCol.TextMatrix(0, i))) * 8 * Screen.TwipsPerPixelX)
    Next
End Sub
Private Sub SaveGrdColWidth()
    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim i As Integer
    
    On Error GoTo ErrHandle
    gclsBase.BaseWorkSpace.BeginTrans
    
    strSQL = " FROM Setting WHERE lngModuleID=0 AND strSection='" & Me.Name & "列宽'"
    gclsBase.BaseDB.Execute "DELETE " & strSQL
        
    strSQL = "SELECT *" & strSQL
    Set recTmp = gclsBase.BaseDB.OpenResultset(strSQL, rdOpenDynamic, rdConcurValues)
    With recTmp
        For i = 0 To GrdCol.Cols - 1
            .AddNew
            !lngModuleID = 0
            !strSection = Me.Name & "列宽"
            !strKey = i
            !strSetting = CStr(IIf(GrdCol.ColWidth(i) < 400, 400, GrdCol.ColWidth(i)))
            !strTypeName = "Long"
            .Update
        Next
    End With
    recTmp.Close
    Set recTmp = Nothing
    gclsBase.BaseWorkSpace.CommitTrans
    Exit Sub
ErrHandle:
    If Not recTmp Is Nothing Then
        recTmp.Close
        Set recTmp = Nothing
    End If
    gclsBase.BaseWorkSpace.RollBacktrans
End Sub

Private Sub AddARow(ByVal lngGetRowNo As Long, ByVal lngTableID As Long, _
    ByVal lngActivityDetailID As Long, ByVal dblUsedAmount As Double, ByVal dblSavedAmount As Double, _
    ByVal dblDiscountRate As Double, ByVal strDate As String)

    Dim strSQL As String
    Dim recTmp As rdoResultset
    Dim lngRowno As Long