📄 frmcalcsingle.frm
字号:
VERSION 5.00
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Object = "{F6125AB1-8AB1-11CE-A77F-08002B2F4E98}#2.0#0"; "MSRDC20.OCX"
Begin VB.Form frmCalcSingle
Caption = "成本批次"
ClientHeight = 2625
ClientLeft = 60
ClientTop = 345
ClientWidth = 3765
KeyPreview = -1 'True
LinkTopic = "Form2"
MDIChild = -1 'True
ScaleHeight = 2625
ScaleWidth = 3765
Begin MSRDC.MSRDC datItem
Height = 330
Left = 240
Top = 1920
Visible = 0 'False
Width = 1200
_ExtentX = 2117
_ExtentY = 582
_Version = 393216
Options = 0
CursorDriver = 0
BOFAction = 0
EOFAction = 0
RecordsetType = 1
LockType = 3
QueryType = 0
Prompt = 3
Appearance = 1
QueryTimeout = 30
RowsetSize = 100
LoginTimeout = 15
KeysetSize = 0
MaxRows = 0
ErrorThreshold = -1
BatchSize = 15
BackColor = -2147483643
ForeColor = -2147483640
Enabled = -1 'True
ReadOnly = 0 'False
Appearance = -1 'True
DataSourceName = ""
RecordSource = ""
UserName = ""
Password = ""
Connect = ""
LogMessages = ""
Caption = "MSRDC1"
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.PictureBox picGrid
Height = 975
Left = 210
ScaleHeight = 915
ScaleWidth = 1785
TabIndex = 5
Top = 435
Width = 1845
Begin MSFlexGridLib.MSFlexGrid msgBody
Bindings = "frmCalcSingle.frx":0000
Height = 465
Left = 0
TabIndex = 6
Top = 465
Width = 1815
_ExtentX = 3201
_ExtentY = 820
_Version = 393216
FixedCols = 0
BackColor = 16777215
BackColorBkg = 12632256
BorderStyle = 0
Appearance = 0
End
Begin MSFlexGridLib.MSFlexGrid msgHead
Height = 450
Left = 0
TabIndex = 7
Top = 0
Width = 1800
_ExtentX = 3175
_ExtentY = 794
_Version = 393216
Rows = 3
FixedRows = 2
FixedCols = 0
BackColorBkg = 12632256
ScrollBars = 0
AllowUserResizing= 1
BorderStyle = 0
Appearance = 0
End
End
Begin VB.CommandButton cmdList
Caption = "批次取消"
Height = 350
Index = 4
Left = 2280
TabIndex = 4
Top = 1605
Width = 1215
End
Begin VB.CommandButton cmdList
Caption = "批次指定"
Height = 350
Index = 3
Left = 2280
TabIndex = 3
Top = 1260
Width = 1215
End
Begin VB.CommandButton cmdList
Height = 350
Index = 2
Left = 2280
Style = 1 'Graphical
TabIndex = 2
Tag = "1010"
Top = 2100
UseMaskColor = -1 'True
Visible = 0 'False
Width = 1215
End
Begin VB.CommandButton cmdList
Height = 350
Index = 1
Left = 2280
Style = 1 'Graphical
TabIndex = 1
Tag = "1002"
Top = 765
UseMaskColor = -1 'True
Width = 1215
End
Begin VB.CommandButton cmdList
Height = 350
Index = 0
Left = 2280
Style = 1 'Graphical
TabIndex = 0
Tag = "1001"
Top = 420
UseMaskColor = -1 'True
Width = 1215
End
Begin VB.Label lblItem
AutoSize = -1 'True
Caption = "商品"
Height = 180
Left = 225
TabIndex = 8
Top = 90
Width = 360
End
End
Attribute VB_Name = "frmCalcSingle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 成本批次
' 作者：唐维勇
' 日期：1998.7.17
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Private WithEvents mclsMainControl As MainControl
Attribute mclsMainControl.VB_VarHelpID = -1
Private WithEvents mclsGrid As MutiGrid 'Grid对象
Attribute mclsGrid.VB_VarHelpID = -1
Private WithEvents mclsSubClassform As SubClass32.SubClass
Attribute mclsSubClassform.VB_VarHelpID = -1
Private Const HelpID = 13006
Private Const mViewID = 90 '成本批次视图号
Private Const mlngFormMinWidth = 450 '窗体最小尺寸
Private Const mlngFormMinHeight = 200
Private Const mintLeft = 45 '窗体位置尺寸
Private Const mintTop = 420
Private Const mintBottomHeight = 75
Private Const mlngColOutID = 0 'ID列号
Private Const mlngColInID = 1 '出库ID列号
Private Const mlngColOutQuantity = 5 '出库数量
Private Const mlngColOutPrice = 6 '出库单价
Private Const mlngColOutAmount = 7 '出库金额
Private mblnExistChild As Boolean '指定批次窗口是否显示
Private mblnReCalc As Boolean
Private mdtmStart As Date '起止日期
Private mdtmEnd As Date
Private mlngItemID As Long '商品ID
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'
' 外部方法
'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'设置查询商品ID、名称、起止日期
Public Sub SetPararmeters(lngItemID As Long, strItemName As String, dtmStart As Date, dtmEnd As Date)
mlngItemID = lngItemID
mdtmStart = dtmStart
mdtmEnd = dtmEnd
InitCostDetail
lblItem.Caption = "商品：" & strItemName
mblnReCalc = True
End Sub
Public Sub InitCostDetail(Optional ByVal blnRefresh As Boolean = False)
Dim strSql As String
Dim intYear As Integer
Dim bytPeriod As Integer
Dim recDetail As rdoResultset
Dim qrfQuery As rdoQuery
intYear = GetintYear(frmCalcCost.cboCost(0).Text)
bytPeriod = GetbytPeriod(frmCalcCost.cboCost(0).Text)
strSql = "SELECT lngActivityDetailID FROM CostDetail " _
& "WHERE lngItemID=" & mlngItemID & " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
Set recDetail = gclsBase.BaseDB.OpenResultset(strSql, rdOpenForwardOnly)
If recDetail.EOF Or blnRefresh Then
Set qrfQuery = gclsBase.BaseDB.CreateQuery("", "{CALL " & gclsBase.UID & ".ClearCostDetail(?,?,?)}")
qrfQuery.rdoParameters(0).Type = rdTypeINTEGER
qrfQuery.rdoParameters(1).Type = rdTypeINTEGER
qrfQuery.rdoParameters(2).Type = rdTypeINTEGER
qrfQuery.rdoParameters(0).Direction = rdParamInput
qrfQuery.rdoParameters(1).Direction = rdParamInput
qrfQuery.rdoParameters(2).Direction = rdParamInput
qrfQuery.rdoParameters(0).Value = mlngItemID
qrfQuery.rdoParameters(1).Value = intYear
qrfQuery.rdoParameters(2).Value = bytPeriod
qrfQuery.Execute
qrfQuery.Close
Set qrfQuery = Nothing
End If
recDetail.Close
Set recDetail = Nothing
End Sub
'设置指定成本批次窗口显示标志
Public Sub AddChildWindow(strChildWindow As String)
mblnExistChild = True
End Sub
'清除指定成本批次窗口显示标志
Public Sub RemoveChildWindow(strChildWindow As String)
mblnExistChild = False
End Sub
'清除商品出库明细对应的进货明细
Public Sub ClearInDetail(ByVal OutID As Long)
Dim lngRow As Long
Dim errNo As Long
Dim strSql As String
Dim intYear As Integer
Dim bytPeriod As Integer
intYear = GetintYear(frmCalcCost.cboCost(0).Text)
bytPeriod = GetbytPeriod(frmCalcCost.cboCost(0).Text)
On Error GoTo ErrHandle
With msgBody
'把指针移到出库明细对应的第一条入库明细
lngRow = .Row
If CLng(.TextMatrix(lngRow, mlngColOutID)) = OutID Then
Do While lngRow > .FixedRows
If CLng(.TextMatrix(lngRow - 1, mlngColOutID)) = OutID Then
lngRow = lngRow - 1
Else
Exit Do
End If
Loop
Else
For lngRow = 0 To .Rows - 1
If CLng(.TextMatrix(lngRow - 1, mlngColOutID)) = OutID Then
Exit For
End If
Next lngRow
End If
If lngRow < .Rows Then
'从成本明细表中清除商品入库资料
strSql = "UPDATE COSTDETAIL SET dblSaleQuantity=dblSaleQuantity-" & .TextMatrix(lngRow, 11) _
& ",dblSaleAmount=dblSaleAmount-" & .TextMatrix(lngRow, 13) _
& " WHERE lngActivityDetailID=" & .TextMatrix(lngRow, mlngColInID) _
& " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
gclsBase.ExecSQL strSql
strSql = "DELETE FROM ItemCostDetail WHERE lngItemID=" & mlngItemID _
& " AND lngOutActivityDetailID=" & .TextMatrix(lngRow, mlngColOutID)
gclsBase.ExecSQL strSql
strSql = "UPDATE ItemCostDetail SET dblQuantity=dblQuantity-" _
& .TextMatrix(lngRow, 11) & ",dblAmount=dblAmount-" & .TextMatrix(lngRow, 13) _
& " WHERE lngItemID=" & mlngItemID & " AND lngOutActivityDetailID=" _
& .TextMatrix(lngRow, mlngColOutID) & " AND lngInActivityDetailID=" & .TextMatrix(lngRow, 1)
gclsBase.ExecSQL strSql
.TextMatrix(lngRow, mlngColInID) = 0
.TextMatrix(lngRow, 8) = ""
.TextMatrix(lngRow, 9) = ""
.TextMatrix(lngRow, 10) = ""
.TextMatrix(lngRow, 11) = ""
.TextMatrix(lngRow, 12) = ""
.TextMatrix(lngRow, 13) = ""
'从Grid中删除多余的行（因清除入库资料可能造成空行）
lngRow = lngRow + 1
Do While lngRow < .Rows
If CLng(.TextMatrix(lngRow, mlngColOutID)) = OutID Then
strSql = "UPDATE COSTDETAIL SET dblSaleQuantity=dblSaleQuantity-" & .TextMatrix(lngRow, 11) _
& ",dblSaleAmount=dblSaleAmount-" & .TextMatrix(lngRow, 13) _
& " WHERE lngActivityDetailID=" & .TextMatrix(lngRow, mlngColInID) _
& " AND intYear=" & intYear & " AND bytPeriod=" & bytPeriod
gclsBase.ExecSQL strSql
strSql = "UPDATE ItemCostDetail SET dblQuantity=dblQuantity-" _
& .TextMatrix(lngRow, 11) & ",dblAmount=dblAmount-" & .TextMatrix(lngRow, 13) _
& " WHERE lngItemID=" & mlngItemID & " AND lngOutActivityDetailID=" _
& .TextMatrix(lngRow, mlngColOutID) & " AND lngInActivityDetailID=" & .TextMatrix(lngRow, mlngColInID)
gclsBase.ExecSQL strSql
.RemoveItem lngRow
Else
lngRow = .Rows
End If
Loop
End If
End With
gclsBase.ExecSQL "UPDATE Item SET strReCalcCost='" & Format(mdtmStart, "yyyy-mm-dd") _
& "' WHERE lngItemID=" & mlngItemID & " AND strReCalcCost>'" & Format(mdtmStart, "yyyy-mm-dd") & "'"
Exit Sub
ErrHandle:
errNo = Errors.ErrorsDeal(True, Me)
Select Case errNo
Case edtResume: Resume
Case edtResumeNext: Resume Next
Case edtCanNotKnown
ShowMsg hWnd, "程序出错：" & Err.Description, vbOKOnly + vbCritical, Caption
End Select
End Sub
'指定出库商品对应的入库批次
Public Sub SetInDetail(ByVal OutID As Long, ByVal InID As Long, ByVal strDate As String, _
ByVal strType As String, ByVal strNo As String, ByVal dblQuantity As Double, ByVal dblAmount As Double)
Dim lngRow As Long
Dim errNo As Long
On Error GoTo ErrHandle
With msgBody
'把指针移到出库商品的第一条记录
lngRow = .Row
If CLng(.TextMatrix(lngRow, mlngColOutID)) = OutID Then
Do While lngRow > .FixedRows
If CLng(.TextMatrix(lngRow - 1, mlngColOutID)) = OutID Then
lngRow = lngRow - 1
Else
Exit Do
End If
Loop
Else
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -