📄 frmplay.frm
字号:
_Version = 393216
End
Begin VB.Frame Frame2
Height = 3700
Left = 4245
TabIndex = 13
Top = 860
Width = 4695
Begin VB.Label Label10
Caption = "2.下一级代码应该跟上一级代码相对应."
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 18
Top = 1605
Width = 4095
End
Begin VB.Label Label9
Caption = "4.０即为""合计""为最高级,不可删除."
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 17
Top = 3120
Width = 4095
End
Begin VB.Label Label8
Caption = "3.删除工作须从底级开始."
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 16
Top = 2355
Width = 4095
End
Begin VB.Label Label7
Caption = "1.部门代码共分为四级,每级可输入二位."
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 360
TabIndex = 15
Top = 840
Width = 4095
End
Begin VB.Label Label6
AutoSize = -1 'True
Caption = " ****说明**** "
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Left = 120
TabIndex = 14
Top = 240
Width = 4200
End
End
End
End
Attribute VB_Name = "初始化"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim db As Database
Dim tb As TableDef, my As TableDef
Dim fd As DAO.Field
Private Sub Adodc3_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
Adodc3.Caption = "公式" & Adodc3.Recordset.AbsolutePosition
End Sub
Private Sub Command1_Click()
On Error GoTo AddErr
Adodc1.Recordset.MoveLast
DataGrid1.SetFocus
SendKeys "{down}"
Exit Sub
AddErr:
MsgBox err.Description
End Sub
Private Sub Command12_Click()
SSTab1.Tab = 1
End Sub
Private Sub Command13_Click()
Adodc1.Recordset.Save
If frmLogin.txtPassword1.Text <> "" Then
With frmLogin
.Data1.Recordset.AddNew
.Data1.Recordset.Fields("系统员") = .txtUserName.Text
.Data1.Recordset.Fields("pass") = from(.txtPassword1.Text)
.Data1.Recordset.Update
End With
End If
Dim i As Integer
Dim tye As DataTypeEnum
Set db = Workspaces(0).OpenDatabase("c:\program files\common files\main.mdb")
Set tb = db.TableDefs("main")
'---------------------------------
Adodc4.Refresh
Do Until Adodc4.Recordset.EOF
Adodc1.Refresh
Do Until Adodc1.Recordset.EOF
If Adodc1.Recordset.Fields("字段名称") = Adodc4.Recordset.Fields("字段名称") Then Exit Do
Adodc1.Recordset.MoveNext
Loop
If Adodc1.Recordset.EOF Then tb.Fields.Delete (Adodc4.Recordset.Fields("字段名称"))
Adodc4.Recordset.MoveNext
Loop
'-------------------------------
Adodc1.Refresh
Do Until Adodc1.Recordset.EOF
Adodc4.Refresh
Do Until Adodc4.Recordset.EOF
If Adodc4.Recordset.Fields("字段名称") = Adodc1.Recordset.Fields("字段名称") Then Exit Do
Adodc4.Recordset.MoveNext
Loop
If Adodc4.Recordset.EOF Then
Select Case Adodc1.Recordset.Fields("类型")
Case Is = "C"
tye = 10
Case Is = "N"
tye = adDate
Case Is = "D"
tye = adBSTR
Case Is = "L"
tye = adBoolean
End Select
Set fd = tb.CreateField(Adodc1.Recordset.Fields("字段名称"), tye, Adodc1.Recordset.Fields("长度"))
tb.Fields.Append fd
End If
Adodc1.Recordset.MoveNext
Loop
'---------------------------------
Adodc1.Refresh
Do Until Adodc1.Recordset.EOF
Dim str As String
str = Adodc1.Recordset.Fields("字段名称")
tb.Fields(str).OrdinalPosition = Adodc1.Recordset.AbsolutePosition - 1
Adodc1.Recordset.MoveNext
Loop
'---------------------------------------------------------------
Adodc4.Refresh
Adodc1.Refresh
Do Until Adodc4.Recordset.EOF
Adodc4.Recordset.Delete
Adodc4.Recordset.MoveNext
Loop
Dim fld As Field
While Adodc1.Recordset.EOF = False
Adodc4.Recordset.AddNew
For i = 0 To Adodc1.Recordset.Fields.Count - 1
Set fld = Adodc1.Recordset.Fields(i)
Adodc4.Recordset(fld.name).value = fld.value
Next
Adodc4.Recordset.Update
Adodc1.Recordset.MoveNext
Wend
'----------------------------------------------------------------
Adodc3.Refresh
Set my = db.TableDefs("汇总")
Do Until Frmmain.Adodc3.Recordset.EOF
Frmmain.Adodc3.Recordset.Delete
Frmmain.Adodc3.Recordset.MoveNext
Loop
For i = 0 To my.Fields.Count - 1
my.Fields.Delete (my.Fields(0).name)
Next i
Do Until Adodc3.Recordset.EOF
Select Case Adodc3.Recordset.Fields("类型")
Case Is = "C"
tye = 10
Case Is = "N"
tye = adDate
Case Is = "D"
tye = adBSTR
Case Is = "L"
tye = adBoolean
End Select
If Adodc3.Recordset.AbsolutePosition = 2 Then
Set fd = my.CreateField("部门名称", 10, 16)
my.Fields.Append fd
Set fd = my.CreateField(Adodc3.Recordset.Fields("字段名称"), tye, Adodc3.Recordset.Fields("长度"))
my.Fields.Append fd
Else
Set fd = my.CreateField(Adodc3.Recordset.Fields("字段名称"), tye, Adodc3.Recordset.Fields("长度"))
my.Fields.Append fd
End If
Adodc3.Recordset.MoveNext
Loop
'------------------------
Frmmain.SSTab1.Tab = 0
Frmmain.Adodc3.Refresh
For i = 0 To Frmmain.Adodc3.Recordset.Fields.Count - 1
Frmmain.DataGrid3.Columns(i).Width = 10700 / Frmmain.Adodc3.Recordset.Fields.Count
Next i
Frmmain.Adodc3.Refresh
For i = 0 To Frmmain.Adodc3.Recordset.Fields.Count - 1
Frmmain.DataGrid3.Columns(i).Width = 10700 / Frmmain.Adodc3.Recordset.Fields.Count
Next i
Frmmain.systemformat.Enabled = False
Frmmain.Adodc1.Refresh
For i = 0 To Frmmain.Adodc1.Recordset.Fields.Count - 1
Frmmain.DataGrid1.Columns(i).Width = 10950 / Frmmain.Adodc1.Recordset.Fields.Count
Next i
Unload frmLogin
Unload Me
End Sub
Private Sub Command2_Click()
On Error GoTo DeleteErr
Dim r As VbMsgBoxResult
r = MsgBox("确定要删除该记录吗?", vbQuestion + vbOKCancel, "确认删除")
If r = vbOK Then
With Adodc1.Recordset
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
End If
Exit Sub
DeleteErr:
MsgBox err.Description
End Sub
Private Sub Command3_Click()
SSTab1.Tab = 1
End Sub
Private Sub Command4_Click()
Dim r As VbMsgBoxResult
r = MsgBox("确定要退出数据的初始化吗?", vbQuestion + vbOKCancel, "确认退出")
If r = vbOK Then
Frmmain.SSTab1.Tab = 0
Unload Me
End If
End Sub
Private Sub Command5_Click()
Dim r As VbMsgBoxResult
r = MsgBox("确定要退出数据的初始化吗?", vbQuestion + vbOKCancel, "确认退出")
If r = vbOK Then Unload Me
End Sub
Private Sub Command6_Click()
Adodc1.Recordset.Save
Adodc1.Refresh
End Sub
Private Sub Command7_Click()
On Error GoTo DeleteErr
With Adodc2.Recordset
.Delete
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
MsgBox err.Description
End Sub
Private Sub Command8_Click()
On Error GoTo AddErr
Adodc2.Recordset.MoveLast
DataGrid2.SetFocus
SendKeys "{down}"
Exit Sub
AddErr:
MsgBox err.Description
End Sub
Private Sub Command9_Click()
SSTab1.Tab = 0
End Sub
Private Sub Form_Load()
SSTab1.Tab = 0
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -