📄 frm1.frm
字号:
VERSION 5.00
Begin VB.Form Frm1
Caption = "数据导入"
ClientHeight = 4575
ClientLeft = 60
ClientTop = 345
ClientWidth = 6495
Icon = "Frm1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 4575
ScaleWidth = 6495
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame2
Caption = "导入到："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 795
Left = 180
TabIndex = 7
Top = 3600
Width = 4545
Begin VB.OptionButton Option1
Caption = "离休库"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 2
Left = 3150
TabIndex = 10
Top = 330
Width = 1155
End
Begin VB.OptionButton Option1
Caption = "退休库"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 1
Left = 1650
TabIndex = 9
Top = 330
Width = 1155
End
Begin VB.OptionButton Option1
Caption = "在职库"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Index = 0
Left = 240
TabIndex = 8
Top = 330
Value = -1 'True
Width = 1155
End
End
Begin VB.CommandButton Command2
Caption = "退出(&Q)"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 4950
TabIndex = 4
Top = 4050
Width = 1305
End
Begin VB.CommandButton Command1
Caption = "导入(&D)"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 4950
TabIndex = 3
Top = 3600
Width = 1305
End
Begin VB.Frame Frame1
Caption = "选择原工资系统的路径："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 3375
Left = 150
TabIndex = 0
Top = 120
Width = 6135
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 405
Left = 2100
TabIndex = 6
Text = "Text1"
Top = 2790
Width = 3855
End
Begin VB.DirListBox Dir1
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1980
Left = 210
TabIndex = 2
Top = 720
Width = 5745
End
Begin VB.DriveListBox Drive1
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 360
Left = 210
TabIndex = 1
Top = 330
Width = 2325
End
Begin VB.Label Label1
Caption = "导入的文件路径："
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = 240
TabIndex = 5
Top = 2850
Width = 1935
End
End
End
Attribute VB_Name = "Frm1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim hwk1 As String
Dim hwk2 As String
Dim hwjlj As String
Dim hxfyn As Integer
Public tb1 As Recordset
Public tb2 As Recordset
Public wws As Workspace
Public wdb1 As Database
Public wdb2 As Database
Dim xtlj As String
Dim I As Integer
Private Sub Command1_Click()
xtlj = Trim(App.Path) & "\"
'On Error GoTo errcl:
If Len(Trim(Text1.Text)) > 0 Then
hwjlj = Trim(Text1.Text)
Set wws = DBEngine.Workspaces(0)
Set wdb1 = wws.OpenDatabase(xtlj + "bzxx.mdb")
Set wdb2 = wws.OpenDatabase(hwjlj, False, False, "FoxPro 2.5;")
Set tb1 = wdb1.OpenRecordset(hwk1, dbOpenTable)
Set tb2 = wdb2.OpenRecordset("标准库.dbf", dbOpenTable)
Me.Caption = "正在导入文件，请等待！"
Do While tb1.RecordCount <> 0
tb1.MoveFirst
tb1.Delete
Loop
If tb2.RecordCount > 0 Then
tb2.MoveFirst
Do While Not tb2.EOF()
tb1.AddNew
tb1("工号") = tb2("a01")
tb1("部门") = tb2("a02")
tb1("姓名") = tb2("a03")
tb1("卡号") = tb2("a07")
tb1("应发合计") = tb2("a04")
tb1("代扣合计") = tb2("a05")
tb1("实发现金") = tb2("a06")
I = 3
Do While I <= 16
If tb2.Fields(I).Value > 0 Then
tb1.Fields(I + 1).Value = tb2.Fields(I).Value
Else
tb1.Fields(I + 1).Value = 0
End If
I = I + 1
Loop
Do While I <= 22
tb1.Fields(I + 1).Value = 0
I = I + 1
Loop
I = 18
Do While I <= 31
If tb2.Fields(I).Value > 0 Then
tb1.Fields(I + 8).Value = tb2.Fields(I).Value
Else
tb1.Fields(I + 8).Value = 0
End If
I = I + 1
Loop
tb1.Update
tb2.MoveNext
Loop
End If
Set tb1 = wdb1.OpenRecordset(hwk2, dbOpenTable)
Set tb2 = wdb2.OpenRecordset("收入项目.dbf", dbOpenTable)
Do While tb1.RecordCount <> 0
tb1.MoveFirst
tb1.Delete
Loop
If tb1.RecordCount = 0 Then
tb1.AddNew
tb1.Update
End If
If tb2.RecordCount > 0 Then
tb2.MoveFirst
tb1.MoveFirst
tb1.Edit
I = 1
Do While I <= tb2.Fields.Count
tb1.Fields(I - 1).Value = tb2.Fields(I - 1).Value
I = I + 1
Loop
tb1.Update
End If
Set tb2 = wdb2.OpenRecordset("支出项目.dbf", dbOpenTable)
If tb2.RecordCount > 0 Then
tb2.MoveFirst
tb1.Edit
I = 1
Do While I <= tb2.Fields.Count
tb1.Fields(I + 19).Value = tb2.Fields(I - 1).Value
I = I + 1
Loop
tb1.Update
End If
wdb1.Close
wdb2.Close
hxfyn = MsgBox("导入完毕！", 48)
Me.Caption = "数据库导入"
Else
hxfyn = MsgBox("必须选择原工资系统路径！", 48)
End If
GoTo en:
errcl:
hxfyn = MsgBox("导入路径错误，请重新选择路径！", 48)
en: End Sub
Private Sub Command2_Click()
Unload Me
End
End Sub
Private Sub Dir1_Change()
Text1.Text = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
Text1.Text = Dir1.Path
End Sub
Private Sub Form_Load()
Drive1.Drive = "c:\"
Dir1.Path = Drive1.Drive
hwk1 = "zzbzk"
hwk2 = "zzbzzd"
End Sub
Private Sub Option1_Click(Index As Integer)
If Index = 0 Then
hwk1 = "zzbzk"
hwk2 = "zzbzzd"
End If
If Index = 1 Then
hwk1 = "txbzk"
hwk2 = "txbzzd"
End If
If Index = 2 Then
hwk1 = "lxbzk"
hwk2 = "lxbzzd"
End If
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -