📄 frmdatagrid.frm
字号:
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "mscomctl.ocx"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Begin VB.Form frmdatagrid
Caption = "Form1"
ClientHeight = 5640
ClientLeft = 1950
ClientTop = 1635
ClientWidth = 8490
LinkTopic = "Form1"
MDIChild = -1 'True
ScaleHeight = 5640
ScaleWidth = 8490
Begin MSComctlLib.Toolbar Toolbar1
Align = 1 'Align Top
Height = 420
Left = 0
TabIndex = 1
Top = 0
Width = 8490
_ExtentX = 14975
_ExtentY = 741
ButtonWidth = 609
ButtonHeight = 582
Appearance = 1
ImageList = "imlToolbarIcons"
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 3
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "New"
Object.ToolTipText = "New"
ImageKey = "New"
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Find"
Object.ToolTipText = "Find"
ImageKey = "Find"
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Key = "Delete"
Object.ToolTipText = "Delete"
ImageKey = "Delete"
EndProperty
EndProperty
End
Begin MSDataGridLib.DataGrid DataGrid1
Height = 4815
Left = 840
TabIndex = 0
Top = 960
Width = 6495
_ExtentX = 11456
_ExtentY = 8493
_Version = 393216
AllowUpdate = -1 'True
AllowArrows = -1 'True
HeadLines = 1
RowHeight = 17
WrapCellPointer = -1 'True
RowDividerStyle = 5
AllowAddNew = -1 'True
AllowDelete = -1 'True
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 11.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 11.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ColumnCount = 2
BeginProperty Column00
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
BeginProperty Column01
DataField = ""
Caption = ""
BeginProperty DataFormat {6D835690-900B-11D0-9484-00A0C91110ED}
Type = 0
Format = ""
HaveTrueFalseNull= 0
FirstDayOfWeek = 0
FirstWeekOfYear = 0
LCID = 2052
SubFormatType = 0
EndProperty
EndProperty
SplitCount = 1
BeginProperty Split0
BeginProperty Column00
EndProperty
BeginProperty Column01
EndProperty
EndProperty
End
Begin MSComctlLib.ImageList imlToolbarIcons
Left = 2715
Top = 2580
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 16
ImageHeight = 16
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 3
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmdatagrid.frx":0000
Key = "New"
EndProperty
BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmdatagrid.frx":0112
Key = "Find"
EndProperty
BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmdatagrid.frx":0224
Key = "Delete"
EndProperty
EndProperty
End
End
Attribute VB_Name = "frmdatagrid"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public ins_vc_in As vc_in
Public ListNo As String
Dim sps As New spListHeaders
Dim rsx As New Recordset
Attribute rsx.VB_VarHelpID = -1
Private Sub DataGrid1_Error(ByVal DataError As Integer, Response As Integer)
If DataError = 7007 Then
Response = 0
Exit Sub
End If
MsgBox "输入错误,请查看！", vbInformation, "系统提示"
DataGrid1.DataChanged = False
Response = 0
End Sub
Private Sub Form_Load()
With rsx
.ActiveConnection = cnnString
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
End With
updateField
SetDefault sps
Me.fFilter
DataGrid1.AllowAddNew = False ' Not sps.ReadOnly
DataGrid1.AllowUpdate = False ' Not sps.ReadOnly
Me.caption = sps.vName
Init_DataGridImglist Me.imlToolbarIcons, Me.Toolbar1, sps.ReadOnly, sps.other
Set DataGrid1.DataSource = rsx
Me.WindowState = 2
End Sub
Private Sub Form_Resize()
On Error Resume Next
Me.DataGrid1.Width = Me.ScaleWidth
Me.DataGrid1.Height = Me.ScaleHeight - Me.Toolbar1.Height
Me.DataGrid1.Top = Me.Toolbar1.Height
Me.DataGrid1.Left = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Dim vn As String
releObject rsx
DataGrid1.DataChanged = False
vn = sps.ViewNo
releObject sps
' Select Case vn
' Case "vcustomers"
' User.ReleaseTask ACCUSS, SysParas.BusDate + Time
' Case "VEditUsers"
' User.ReleaseTask ACMAKERS, SysParas.BusDate + Time
'
' Case "vfuns"
' User.ReleaseTask ACFUNS, SysParas.BusDate + Time
'
' Case "vrate"
' User.ReleaseTask ACHQLLS, SysParas.BusDate + Time
'
' Case "vcurs"
' User.ReleaseTask ACCURRS, SysParas.BusDate + Time
'
' Case "vlogs"
' User.ReleaseTask ACSYSLOG, SysParas.BusDate + Time
'
' Case "vstatus"
' User.ReleaseTask ACSYSSTATUS, SysParas.BusDate + Time
'
'
' End Select
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
'On Error Resume Next
Select Case Button.key
Case strKprint
Case strKpreview
Case strKOUTPUT
Case strKadd
faddnew
Case strKedit
Fedit
Case strKdel
fdelete
Case strKfilter
Case strKfind
fFind
Case strKsort
fSort
Case strKsetfield
SetField
Case strKrefresh
fRefresh
Case strKsave
FsaveLayout
Case strKhelp
Case strKclose
Unload Me
End Select
End Sub
Public Sub fSort()
With frmSort
Set .sps = sps
.Show 1
If .ok Then
rsx.Sort = .Strsort
End If
End With
End Sub
Public Sub FsaveLayout()
Dim i As Long
On Error Resume Next
For i = 1 To DataGrid1.Columns.Count
sps(i).Width = DataGrid1.Columns(i - 1).Width
Next i
SaveViewStruct sps, cnnString, ListNo
End Sub
Public Sub faddnew()
On Error GoTo errh
Select Case sps.ViewNo
Case "graphiclib"
graphmaintain.creategraph
Case "VUsers"
usermaintain.createuser
Case "Vtimecontrol"
timeCmaintain.createTimeC
Case Else
Me.ins_vc_in.createrec
End Select
Me.fRefresh
Exit Sub
errh:
MsgBox "不能创建图形资料！", vbInformation, "错误"
End Sub
Public Sub Fedit()
On Error GoTo errh
Select Case sps.ViewNo
Case "graphiclib"
graphmaintain.modifygraph Me.value("gid")
Case "VUsers"
usermaintain.modifyuser Me.value("userid")
Case "Vtimecontrol"
timeCmaintain.modifyTimeC Me.value("tid")
Case Else
Me.ins_vc_in.modifyrec Me.value(Me.ins_vc_in.getidstring)
End Select
Me.fRefresh
Exit Sub
errh:
MsgBox "不能修改图形信息！", vbInformation, "修改错误"
End Sub
Public Sub fdelete()
On Error GoTo errh
Select Case sps.ViewNo
Case "graphiclib"
graphmaintain.pdelgraph Me.value("gid")
Case "VUsers"
usermaintain.deluser Me.value("userid")
Case "Vtimecontrol"
timeCmaintain.pdelTimeC Me.value("tid")
Case Else
Me.ins_vc_in.deleterec Me.value(Me.ins_vc_in.getidstring)
End Select
Me.fRefresh
Exit Sub
errh:
MsgBox "该图片正在使用，不能删除！", vbInformation, "删除错误"
' If DataGrid1.DataChanged Then
' DataGrid1.DataChanged = False
' Exit Sub
' End If
End Sub
Public Sub fRefresh()
If rsx.State = adStateOpen Then
rsx.Close
End If
ResetCond sps, rsx
Set Me.DataGrid1.DataSource = rsx
End Sub
Sub SetField()
With frmSetList
Set .listX = sps
.Show 1
If .ok Then
updateField
End If
End With
End Sub
Sub updateField()
Me.DataGrid1.ClearFields
Set Me.DataGrid1.DataSource = Nothing
FillViewStruct sps, cnnString, ListNo
'me.DataGrid1.c
FillDataGridStruct sps, DataGrid1.Columns
Me.DataGrid1.HoldFields
Set Me.DataGrid1.DataSource = rsx
End Sub
Public Sub fFind()
On Error Resume Next
If rsx.EOF Or rsx.BOF Then
rsx.MoveFirst
End If
With frmFind
Set .sps = sps
.Show 1
If .ok Then
rsx.Find .StrFind, 1, IIf(.ForeDirection, adSearchForward, adSearchBackward)
If rsx.EOF Or rsx.BOF Then
MsgBox "Cann't find! ", vbInformation, "Information"
End If
End If
End With
End Sub
'取得表体某单元格的值
Property Get value(strkey As String) As Variant
On Error Resume Next
value = Me.DataGrid1.Columns(sps.SUBIndex(strkey) - 1).text
'.TextMatrix(R, sps.SUBIndex(strkey) - 1)
End Property
Function fFilter()
Dim cond As New condtion
cond.sDate = CDate(Date - 1)
cond.eDate = CDate(Date + 1)
cond.userid = 0
cond.ledid = "%"
Select Case sps.ViewNo
Case "abortview"
Set frmcondled.cond1 = cond
frmcondled.Show 1
If frmcondled.ok Then
If cond.ledid = "" Then
sps("ledid").condValue1 = "%"
Else
sps("ledid").condValue1 = cond.ledid
End If
sps("checkdate").condValue1 = cond.sDate
sps("checkdate").CondValue2 = cond.eDate
End If
Case "operateview"
Set frmconduser.cond1 = cond
frmconduser.Show 1
If frmconduser.ok Then
If cond.userid = 0 Then
sps("userid").condValue1 = "0"
Else
sps("userid").condValue1 = cond.userid
End If
sps("optime").condValue1 = cond.sDate
sps("optime").CondValue2 = cond.eDate
End If
Case "displayview"
Set frmcondled.cond1 = cond
frmcondled.Show 1
If frmcondled.ok Then
If cond.ledid = "" Then
sps("ledid").condValue1 = "%"
Else
sps("ledid").condValue1 = cond.ledid
End If
sps("playtime").condValue1 = cond.sDate
sps("playtime").CondValue2 = cond.eDate
End If
End Select
releObject cond
fRefresh
End Function
Public Function SetDefault(sps As spListHeaders)
Select Case sps.ViewNo
Case "displayview"
sps("playtime").condValue1 = Date
sps("playtime").CondValue2 = Date + 1
sps("ledid").condValue1 = "%"
End Select
End Function
Public Function ResetCond(sps As spListHeaders, rsx As Recordset) As Boolean
Select Case sps.ViewNo
Case "VUsers"
rsx.Open "Users"
Case "displayview"
Modplayrecord.openrs rsx, sps
Case Else
Me.ins_vc_in.openrs rsx
End Select
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -