📄 dataform.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmDataControl
Caption = "数据控件"
ClientHeight = 4335
ClientLeft = 4575
ClientTop = 3255
ClientWidth = 7815
HelpContextID = 2016122
Icon = "Dataform.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form2"
ScaleHeight = 4335
ScaleWidth = 7815
ShowInTaskbar = 0 'False
Tag = "Recordset"
Begin VB.PictureBox picButtons
Align = 1 'Align Top
Appearance = 0 'Flat
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 585
Left = 0
ScaleHeight = 585
ScaleWidth = 7815
TabIndex = 0
Top = 0
Width = 7815
Begin VB.CommandButton cmdCancelAdd
Caption = "取消(&A)"
Height = 330
Left = 0
MaskColor = &H00000000&
TabIndex = 13
Top = 0
Visible = 0 'False
Width = 960
End
Begin VB.CommandButton cmdRefresh
Caption = "刷新(&R)"
Height = 330
Left = 3840
MaskColor = &H00000000&
TabIndex = 12
Top = 0
Width = 960
End
Begin VB.CommandButton cmdFind
Caption = "查找(&F)"
Height = 330
Left = 2880
MaskColor = &H00000000&
TabIndex = 5
Top = 0
Width = 960
End
Begin VB.CommandButton cmdClose
Cancel = -1 'True
Caption = "关闭(&C)"
Height = 330
Left = 4800
MaskColor = &H00000000&
TabIndex = 4
Top = 0
Width = 960
End
Begin VB.CommandButton cmdDelete
Caption = "删除(&D)"
Height = 330
Left = 1920
MaskColor = &H00000000&
TabIndex = 3
Top = 0
Width = 960
End
Begin VB.CommandButton cmdAdd
Caption = "添加(&A)"
Height = 330
Left = 0
MaskColor = &H00000000&
TabIndex = 2
Top = 0
Width = 960
End
Begin VB.CommandButton cmdUpdate
Caption = "更新(&U)"
Height = 330
Left = 960
MaskColor = &H00000000&
TabIndex = 1
Top = 0
Width = 960
End
End
Begin VB.Data datDataCtl
Align = 2 'Align Bottom
Connect = "Access"
DatabaseName = ""
DefaultCursorType= 0 '缺省游标
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 345
Left = 0
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = ""
Tag = "OLE"
Top = 3990
Width = 7815
End
Begin VB.VScrollBar vsbScrollBar
Height = 2440
LargeChange = 3000
Left = 7560
SmallChange = 300
TabIndex = 11
Top = 360
Visible = 0 'False
Width = 255
End
Begin VB.PictureBox picFields
Appearance = 0 'Flat
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 1665
Left = 240
ScaleHeight = 1651.678
ScaleMode = 0 'User
ScaleWidth = 5201.759
TabIndex = 6
TabStop = 0 'False
Top = 480
Width = 5205
Begin VB.ComboBox CombFieldData
DataSource = "datDataCtl"
Height = 300
Index = 0
Left = 1680
TabIndex = 14
Top = 1320
Visible = 0 'False
Width = 2895
End
Begin VB.TextBox txtFieldData
DataSource = "datDataCtl"
ForeColor = &H00000000&
Height = 285
Index = 0
Left = 1665
TabIndex = 9
Top = 120
Visible = 0 'False
Width = 3240
End
Begin VB.CheckBox chkFieldData
DataSource = "datDataCtl"
Height = 282
Index = 0
Left = 1560
MaskColor = &H00000000&
TabIndex = 8
Top = 960
Visible = 0 'False
Width = 3270
End
Begin VB.PictureBox picFieldData
BackColor = &H80000005&
DataSource = "datDataCtl"
Height = 285
Index = 0
Left = 1680
ScaleHeight = 225
ScaleWidth = 3195
TabIndex = 7
Top = 600
Visible = 0 'False
Width = 3255
End
Begin VB.Label lblFieldName
ForeColor = &H00000000&
Height = 195
Index = 0
Left = 105
TabIndex = 10
Top = 0
Visible = 0 'False
Width = 300
End
End
Begin MSComDlg.CommonDialog dlgCMD1
Left = 1800
Top = 2640
_ExtentX = 847
_ExtentY = 847
_Version = 393216
FilterIndex = 1019
FontSize = 1.74012e-39
End
End
Attribute VB_Name = "frmDataControl"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>
Const BUTTON1 = "取消(&C)"
Const BUTTON2 = "更新(&U)"
Const BUTTON3 = "删除(&D)"
Const BUTTON4 = "查找(&F)"
Const BUTTON5 = "刷新(&R)"
Const BUTTON6 = "关闭(&C)"
Const BUTTON7 = "添加(&A)"
Const Label1 = "字段名称："
Const Label2 = "值："
Const MSG1 = "新记录"
Const MSG2 = "选择要加载的图片文件"
Const MSG3 = "数据错误事件在 Err 中："
Const MSG4 = "保存新记录吗？"
Const MSG5 = "提交改变吗？"
Const MSG6 = "关闭前提交改变吗？"
Const MSG7 = "删除当前记录吗？"
Const MSG8 = "输入搜索值："
Const MSG9 = "输入搜索表达式："
Const MSG10 = " 行"
Const MSG11 = " 行（仅向前记录集）"
Const MSG12 = " [不可更新]"
Const MSG13 = "对于参数化查询此功能不可用! "
'>>>>>>>>>>>>>>>>>>>>>>>>
'============================================================================
' 这是一个非常通用的窗体，它可以用于大多数情况下的任何 table 或 querydef。
'============================================================================
Dim maFldArr() As Object
Public mrsFormRecordset As Recordset
Public mbIsParameterized As Boolean
Dim mvBookMark As Variant '窗体书签
Dim mnNumFields As Integer '字段数
Dim mlNumRows As Long '记录集的记录计数器
Dim mbJustUsedFind As Boolean '查找函数的标志
Dim mbResizing As Boolean '防止改变尺寸时产生递归的标志
Dim mbCancel As Boolean '标志为取消添加新的
Dim mnFieldTop As Integer '顶端字段位置
Const mnMSGBOX_TYPE = vbYesNo + vbQuestion
Const mnCTLARRAYHEIGHT = 340
Private Sub cmdAdd_Click()
' On Error GoTo AddErr
datDataCtl.Recordset.AddNew
datDataCtl.Caption = MSG1
cmdCancelAdd.Visible = True
cmdAdd.Visible = False
If datDataCtl.Recordset.RecordCount <> 0 Then
mvBookMark = datDataCtl.Recordset.Bookmark
If maFldArr(0).Enabled = True Then
maFldArr(0).SetFocus
Else
maFldArr(1).SetFocus
End If
End If
Exit Sub
AddErr:
ShowErrMsg
End Sub
Private Sub cmdCancelAdd_Click()
On Error Resume Next
mbCancel = True
'回到当前记录前一个记录
If Len(mvBookMark) > 0 Then
datDataCtl.Recordset.Bookmark = mvBookMark
End If
End Sub
'----------------------------------------------------------
'这个子程序加载 Data 控件的属性页
'单独使用时，将其注释掉
'----------------------------------------------------------
'Sub datDataCtl_MouseUp(BUTTON As Integer, Shift As Integer, x As Single, y As Single)
' On Error GoTo DCPErr
'Dim i As Integer
' Dim recClone As Recordset
' Dim sTmpRS As String
' Dim sTmpDB As String
'Dim sTmpTag As String
'If BUTTON = 2 Then
' If mbIsParameterized Then
' MsgBox MSG13, vbInformation
' Exit Sub
'End If
'Screen.MousePointer = vbHourglass
'sTmpRS = datDataCtl.RecordSource
'sTmpDB = datDataCtl.DatabaseName
'sTmpTag = datDataCtl.Tag
'Set gDataCtlObj = datDataCtl
'frmDataCtlProp.Show vbModal
'If Not gDataCtlObj Is Nothing Then
'检查改变的记录集、数据库或绑定的二进制类型
'并且如果有改变的话，清除绑定的字段
' If (sTmpRS <> gDataCtlObj.RecordSource Or sTmpDB <> gDataCtlObj.DatabaseName) _
Or gDataCtlObj.Tag <> sTmpTag Then
'清除字段名称并将控件解除绑定
' For i = 0 To mnNumFields - 1
' lblFieldName(i).Caption = vbNullString
' maFldArr(i).DataField = vbNullString
' maFldArr(i).Visible = False
'Next
'End If
' datDataCtl.Refresh
'If (sTmpRS <> gDataCtlObj.RecordSource Or sTmpDB <> gDataCtlObj.DatabaseName) _
Or gDataCtlObj.Tag <> sTmpTag Then
' Set recClone = datDataCtl.Recordset.Clone()
' If recClone.BOF = False And (datDataCtl.Options And dbForwardOnly) = 0 Then
' recClone.MoveLast
' mlNumRows = recClone.RecordCount
' Else
' mlNumRows = 0
' End If
' recClone.Close
' LoadFields
' SetRecNum
' Else
'需要刷新本地记录集拷贝用于其他操作，
'诸如用它来访问属性的操作
' Set mrsFormRecordset = datDataCtl.Recordset
'如果是仅向前类型的记录集，需要调用 SetRecNum
'来显示正确的 data 控件标题
' If (datDataCtl.Options And dbForwardOnly) = dbForwardOnly Then
' SetRecNum
' End If
' End If
' gbSettingDataCtl = False
' If gDataCtlObj.Tag <> sTmpTag Then
' Form_Resize '需要对新加载的控件设置 left 属性
' End If
' End If
Private Sub Form_Unload(Cancel As Integer)
On Error GoTo EHand
mrsFormRecordset.Close
Exit Sub
EHand:
ShowErrMsg
End Sub
' End If
'Exit Sub
'DCPErr:
' ShowError
'Unload Me
'End Sub
'Private Sub Form_Unload(Cancel As Integer)
' DBEngine.Idle dbFreeLocks
'End Sub
Private Sub txtFieldData_KeyPress(Index As Integer, KeyAscii As Integer)
'按回车后，转向下一个字段
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{Tab}"
End If
End Sub
Private Sub picFieldData_Click(Index As Integer)
'这将控制 picture 控件的大小
'因此它可能能看见也可能压缩了
If picFieldData(Index).Height <= 280 Then
picFieldData(Index).AutoSize = True
Else
picFieldData(Index).AutoSize = False
picFieldData(Index).Height = 280
End If
End Sub
Private Sub picFieldData_DblClick(Index As Integer)
On Error GoTo PicErr
With dlgCMD1
.Filter = "位图(*.bmp)|*.bmp|图标(*.ico)|*.ico|元文件(*.wmf)|*.wmf|所有文件(*.*)|*.*"
.DialogTitle = MSG2
.FilterIndex = 1
.ShowOpen
If Len(.FileName) > 0 Then
picFieldData(Index).Picture = LoadPicture(.FileName)
End If
End With
Exit Sub
PicErr:
ShowErrMsg
Exit Sub
End Sub
Private Sub cmdClose_Click()
On Error Resume Next
'DBSGRG.Close
'WKSGRG.Close
Unload Me
End Sub
Private Sub vsbScrollBar_Change()
Dim nCurrVal As Integer
nCurrVal = vsbScrollBar
If (nCurrVal - mnFieldTop) Mod mnCTLARRAYHEIGHT = 0 Then
picFields.Top = nCurrVal
Else
picFields.Top = ((nCurrVal - mnFieldTop) \ mnCTLARRAYHEIGHT) * mnCTLARRAYHEIGHT + mnFieldTop
End If
End Sub
Private Sub datDataCtl_Error(DataErr As Integer, Response As Integer)
If DataErr = 481 Then '忽略坏图片错误
Response = vbDataErrContinue
Else
MsgBox MSG3 & Error(DataErr)
End If
End Sub
Private Sub datDataCtl_RePosition()
On Error GoTo RepErr
Dim sBookMark As String
Dim recClone As Recordset
Dim i As Integer
'如果在重置 data 控件，需要跳过这个子程序
'If gbSettingDataCtl Then Exit Sub
'如果记录集是空的并且也没有处在 AddNew 状态，
'需要调用 cmdAdd_Click 过程执行一个 AddNew
' If (datDataCtl.Recordset.RecordCount = 0) And _
' (datDataCtl.EditMode <> dbEditAdd) And _
' datDataCtl.Recordset.Updatable Then
' Call cmdAdd_Click
' Exit Sub
' End If
' SetRecNum
'判断是否已经加载
Exit Sub
RepErr:
' ShowErrMsg
' Exit Sub
End Sub
Private Sub datDataCtl_Validate(Action As Integer, Save As Integer)
' On Error GoTo ValErr
If mbCancel Then
Save = False
mbCancel = False
Exit Sub
End If
'第一次检查添加新记录（addnew）或编辑（edit）记录的变化
If Action < 5 Then
If Save Then '数据被更改
If datDataCtl.EditMode = dbEditAdd Then
If MsgBox(MSG4, mnMSGBOX_TYPE) = vbYes Then
mlNumRows = mlNumRows + 1
Else
Save = False
End If
Else
If MsgBox(MSG5, mnMSGBOX_TYPE) <> vbYes Then
Save = False '释放改变
End If
End If
End If
End If
Select Case Action
Case vbDataActionMoveFirst
'什么也不做
Case vbDataActionMovePrevious
'什么也不做
Case vbDataActionMoveNext
'什么也不做
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -