📄 index_blong.frm
字号:
VERSION 5.00
Object = "{314D6243-9F2F-11D2-88D1-00805FB6680E}#4.0#0"; "RSGRID.OCX"
Begin VB.Form index_blong
BorderStyle = 3 'Fixed Dialog
Caption = "temp3"
ClientHeight = 8370
ClientLeft = 1095
ClientTop = 330
ClientWidth = 9915
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MDIChild = -1 'True
MinButton = 0 'False
ScaleHeight = 8370
ScaleWidth = 9915
ShowInTaskbar = 0 'False
Begin SLISTGRIDLib.RsGrid RsGrid1
Height = 5175
Left = 1080
TabIndex = 2
Top = 600
Width = 5775
_Version = 262144
_ExtentX = 10186
_ExtentY = 9128
_StockProps = 4
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
EventCodes = "index_blong.frx":0000
PictureData = "index_blong.frx":001A
GridData = "index_blong.frx":0032
Reserved2 = 12930
Reserved1 = 12931
End
Begin VB.CommandButton Command1
Caption = "打印报表"
Height = 495
Left = 2280
TabIndex = 1
Top = 7200
Width = 1815
End
Begin VB.CommandButton cmdClose
Cancel = -1 'True
Caption = "关闭(&C)"
Height = 300
Left = 5340
TabIndex = 0
Top = 3960
Width = 1080
End
End
Attribute VB_Name = "index_blong"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Const MARGIN_SIZE = 60 ' 单位为缇
' 数据绑定变量
Private datPrimaryRS As ADODB.Recordset
Private datPrimaryRS_group As ADODB.Recordset
' 能列排序变量
Private m_iSortCol As Integer
Private m_iSortType As Integer
' 列拖拽变量
Private m_bDragOK As Boolean
Private m_iDragCol As Integer
Private xdn As Integer, ydn As Integer
Private Sub Command1_Click()
RsGrid1.PrintGrid True, True
End Sub
Private Sub Form_Load()
Dim id As String
Dim name As String
Dim quan As Long
Dim bflag As Boolean
Dim sConnect As String
Dim sSQL As String
Dim Ssql_group As String
Dim dfwConn As ADODB.Connection
Dim j As Integer
Dim strwhere As String
Dim id_compose As String
Dim q_current As Long
Dim q As Long
Dim quan_current As Long
q = 0
q_current = 0
bflag = True
strwhere = sconi
sSQL = "select temp1.ware_id as '零件编号',temp1.warename as '零件名称',quantity as '数量',current_quantity as '仓库数量',current_quantity-quantity as '还需数量' from temp1,wareinfo where temp1.ware_id = wareinfo.ware_id and blong_to = '" & strwhere & "'"
For j = 2 To i - 1
sSQL = sSQL & " union select temp" & CStr(j) & ".ware_id as '零件编号',temp" & CStr(j) & ".warename as '零件名称',quantity as '数量',current_quantity as '仓库数量',current_quantity-quantity as '还需数量' from temp" & CStr(j) & ",wareinfo where temp" & CStr(j) & ".ware_id = wareinfo.ware_id and blong_to = '" & strwhere & "'"
'
''' sSQL = "select temp1.ware_id as '零件编号' from temp1,wareinfo where temp1.ware_id = wareinfo.ware_id and blong_to = '" & strwhere & "'"
''' For j = 2 To 2
''' sSQL = sSQL & " union select temp" & CStr(j) & ".ware_id as '零件编号' from temp" & CStr(j) & " where temp" & CStr(j) & ".ware_id = wareinfo.ware_id and blong_to = '" & strwhere & "'"
Next
Ssql_group = sSQL & " and wareinfo.ware_id not like '*'"
' 设置字符串
sConnect = "Provider=MSDASQL.1;Connect Timeout=15;Extended Properties='DRIVER=SQL Server;SERVER=ht;UID=sa;PWD=;APP=Visual Basic;WSID=HT;DATABASE=warehouse';Locale Identifier=2052"
' sSQL = "select war_ware_id,ware_id,ware_layer_id,quantity,blong_to,warename from temp3"
' 打开连接
Set dfwConn = New Connection
dfwConn.Open sConnect
' 使用提供的集合创建 recordset
Set datPrimaryRS = New Recordset
Set datPrimaryRS_group = New Recordset
datPrimaryRS.CursorLocation = adUseClient
datPrimaryRS.Open sSQL, dfwConn, adOpenForwardOnly, adLockReadOnly
' Text1.Text = Ssql_group
Set cn = New ADODB.Connection
With cn
.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=warehouse;"
.Open
End With
cn.Execute "if exists (select * from sysobjects where id = object_id(N'[dbo].[ware_group]') and OBJECTPROPERTY(id, N'IsUserTable') = 1) drop table [dbo].[ware_group]"
cn.Execute "CREATE TABLE [dbo].[ware_group] ([ware_id] [varchar] (20) NOT NULL ,[warename] [varchar] (25) NULL ,[quantity] [numeric](7, 2) NOT NULL ,[current_quantity][numeric](9,2) NULL,[compose_quantity][numeric](7,2) NULL)"
datPrimaryRS_group.Open "ware_group", dfwConn, adOpenStatic, adLockOptimistic
With datPrimaryRS
If .RecordCount < 1 Then
If MsgBox("没有符号条件的记录！", vbOKOnly, "没有符号条件的记录！") = vbOK Then Exit Sub
End If
.MoveFirst
End With
id_compose = datPrimaryRS.Fields(0).Value
Do While Not datPrimaryRS.EOF
id = datPrimaryRS.Fields(0).Value
name = datPrimaryRS.Fields(1).Value
quan = datPrimaryRS.Fields(2).Value
quan_current = datPrimaryRS.Fields(3).Value
' If id <> id_compose Then bflag = False
' If bflag = True Then
If id = id_compose Then
datPrimaryRS_group.AddNew
datPrimaryRS_group.Fields(0).Value = id
datPrimaryRS_group.Fields(1).Value = name
datPrimaryRS_group.Fields(2).Value = quan
datPrimaryRS_group.Fields(3).Value = quan_current
datPrimaryRS_group.Fields(4).Value = 0
q = q + quan
q_current = q_current + quan_current
' id_compose = id
datPrimaryRS_group.Update
datPrimaryRS.MoveNext
Else
'' q_current = q_current - q_current
datPrimaryRS_group.AddNew
datPrimaryRS_group.Fields(0).Value = "小计"
datPrimaryRS_group.Fields(1).Value = ""
datPrimaryRS_group.Fields(2).Value = q
' datPrimaryRS_group!quantity = q
datPrimaryRS_group.Fields(3).Value = q_current
datPrimaryRS_group.Fields(4).Value = q_current - q
' datPrimaryRS_group.Fields(" quantity_current - quantity").Value = q_current
' datPrimaryRS_group.Fields(4).Value = q_current
id_compose = id
q = q - q
q_current = q_current - q_current
datPrimaryRS_group.Update
' bflag = True
End If
Loop
datPrimaryRS_group.AddNew
datPrimaryRS_group.Fields(0).Value = "小计"
datPrimaryRS_group.Fields(1).Value = ""
datPrimaryRS_group.Fields(2).Value = q
datPrimaryRS_group.Fields(3).Value = q_current
datPrimaryRS_group.Fields(4).Value = q_current - q
datPrimaryRS_group.Update
''' datPrimaryRS_group.UpdateBatch
datPrimaryRS_group.Close
datPrimaryRS_group.Open "ware_group"
RsGrid1.ExecSQL "SELECT ware_id as '零件编号',warename as '零件名称',quantity as '数量',current_quantity as '仓库数量',compose_quantity as '还剩数量' FROM dbo.ware_group"
'''''''''' Set MSHFlexGrid1.DataSource = datPrimaryRS_group
'' With MSHFlexGrid1
'
' .Redraw = False
' ' 设置网格列宽度
' .ColWidth(0) = -1
' .ColWidth(1) = -1
' .ColWidth(2) = -1
' .ColWidth(3) = -1
' .ColWidth(4) = -1
' .ColWidth(5) = -1
'
' ' 设置网格样式
' .AllowBigSelection = True
' .FillStyle = flexFillRepeat
'
' ' 将标头作成粗体
' .Row = 0
' .Col = 0
' .RowSel = .FixedRows - 1
'' .ColSel = .Cols - 1
' .CellFontBold = True
'
' .AllowBigSelection = False
' .FillStyle = flexFillSingle
' .Redraw = True
'
' End With
End Sub
Private Sub MSHFlexGrid1_DragDrop(Source As Control, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------
'' If m_iDragCol = -1 Then Exit Sub ' 现在不能拖拽
'' If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub
''
'' With MSHFlexGrid1
'' .Redraw = False
'' .ColPosition(m_iDragCol) = .MouseCol
'' .Redraw = True
'' End With
End Sub
Private Sub MSHFlexGrid1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------
' If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub
'
' xdn = X
' ydn = Y
' m_iDragCol = -1 ' 清除拖拽标志
' m_bDragOK = True
End Sub
Private Sub MSHFlexGrid1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------
' ' 测试是否能够开始拖拽
' If Not m_bDragOK Then Exit Sub
' If Button <> 1 Then Exit Sub ' 错误按钮
' If m_iDragCol <> -1 Then Exit Sub ' 已经开始拖拽
' If Abs(xdn - X) + Abs(ydn - Y) < 50 Then Exit Sub ' 移得不够
' If MSHFlexGrid1.MouseRow <> 0 Then Exit Sub ' 必须拖拽标头
'
' ' 如果到达这则开始拖拽
' m_iDragCol = MSHFlexGrid1.MouseCol
' MSHFlexGrid1.Drag vbBeginDrag
End Sub
Private Sub MSHFlexGrid1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'-------------------------------------------------------------------------------------------
' 网格中 DragDrop, MouseDown, MouseMove, 和 MouseUp 事件代码能进行列拖拽
'-------------------------------------------------------------------------------------------
m_bDragOK = False
End Sub
Private Sub MSHFlexGrid1_DblClick()
'-------------------------------------------------------------------------------------------
' 网格的 DblClick 事件代码能进行列排序
'-------------------------------------------------------------------------------------------
'
' Dim i As Integer
'
' ' 仅在单击固定行时进行排序
' If MSHFlexGrid1.MouseRow >= MSHFlexGrid1.FixedRows Then Exit Sub
'
' i = m_iSortCol ' 保存旧列
' m_iSortCol = MSHFlexGrid1.Col ' 设置新列
'
' ' 递增排序类型
' If i <> m_iSortCol Then
' ' 如果在新的列上单击鼠标，开始升序排序
' m_iSortType = 1
' Else
' ' 如果在相同列单击鼠标，则进行升序和降序排序的转换。
' m_iSortType = m_iSortType + 1
' If m_iSortType = 3 Then m_iSortType = 1
' End If
'
' DoColumnSort
End Sub
Sub DoColumnSort()
'-------------------------------------------------------------------------------------------
' 作 Exchange-type 排序在列 m_iSortCol
'-------------------------------------------------------------------------------------------
' With MSHFlexGrid1
' .Redraw = False
' .Row = 1
' .RowSel = .Rows - 1
' .Col = m_iSortCol
' .Sort = m_iSortType
' .Redraw = True
' End With
End Sub
Private Sub Form_Resize()
Dim sngButtonTop As Single
Dim sngScaleWidth As Single
Dim sngScaleHeight As Single
On Error GoTo Form_Resize_Error
With Me
sngScaleWidth = .ScaleWidth
sngScaleHeight = .ScaleHeight
' 移动“关闭”按钮到右下角
With .cmdClose
sngButtonTop = sngScaleHeight - (.Height + MARGIN_SIZE)
.Move sngScaleWidth - (.Width + MARGIN_SIZE), sngButtonTop
End With
' .MSHFlexGrid1.Move MARGIN_SIZE, _
MARGIN_SIZE, _
sngScaleWidth - (2 * MARGIN_SIZE), _
sngButtonTop - (2 * MARGIN_SIZE)
End With
Exit Sub
Form_Resize_Error:
' 避免负值错误
Resume Next
End Sub
Private Sub cmdClose_Click()
Unload Me
End Sub
Private Sub RsGrid1_OnCreate()
'If RsGrid1.GetCellNumber < 0 Then RsGrid1.SelBkColor = RGB(100, 200, 100)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -