📄 reftab.frm
字号:
VERSION 5.00
Object = "{67397AA1-7FB1-11D0-B148-00A0C922E820}#6.0#0"; "MSADODC.OCX"
Object = "{CDE57A40-8B86-11D0-B3C6-00A0C90AEA82}#1.0#0"; "MSDATGRD.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form reftab
Caption = "用户代码参照表维护界面"
ClientHeight = 5190
ClientLeft = 2955
ClientTop = 2415
ClientWidth = 6555
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5190
ScaleWidth = 6555
Begin VB.Frame Frame1
Caption = "设置"
Height = 1215
Left = 120
TabIndex = 0
Top = 3960
Width = 6375
Begin VB.CommandButton update
Caption = "保存(&S)"
Height = 375
Left = 3840
TabIndex = 4
ToolTipText = "保存当前行的数据"
Top = 240
Width = 975
End
Begin VB.CommandButton delete
Caption = "删除(&D)"
Height = 375
Left = 2640
TabIndex = 3
ToolTipText = "删除当前行"
Top = 240
Width = 975
End
Begin VB.CommandButton insert
Caption = "插入(&I) "
Height = 375
Left = 240
TabIndex = 1
ToolTipText = "插入一新行"
Top = 240
Width = 975
End
Begin VB.CommandButton exit
Caption = "退出(&E)"
Height = 375
Left = 5040
TabIndex = 5
ToolTipText = "退出此系统"
Top = 240
Width = 975
End
Begin VB.CommandButton edit
Caption = "编辑(&E)"
Height = 375
Left = 1440
TabIndex = 2
ToolTipText = "开始编辑数据"
Top = 240
Width = 975
End
Begin VB.CommandButton insertref
Caption = "生成参照表(&G)"
Height = 375
Left = 4680
TabIndex = 7
Top = 720
Width = 1335
End
Begin VB.CommandButton delreftab
Caption = "清空参照表(&C)"
Height = 375
Left = 3000
TabIndex = 6
Top = 720
Width = 1335
End
Begin MSAdodcLib.Adodc Admoney
Height = 375
Left = 120
Top = 720
Width = 2535
_ExtentX = 4471
_ExtentY = 661
ConnectMode = 0
CursorLocation = 3
IsolationLevel = -1
ConnectionTimeout= 15
CommandTimeout = 30
CursorType = 3
LockType = 3
CommandType = 8
CursorOptions = 0
CacheSize = 50
MaxRecords = 0
BOFAction = 0
EOFAction = 0
ConnectStringType= 1
Appearance = 1
BackColor = -2147483643
ForeColor = -2147483640
Orientation = 0
Enabled = -1
Connect = ""
OLEDBString = ""
OLEDBFile = ""
DataSourceName = ""
OtherAttributes = ""
UserName = ""
Password = ""
RecordSource = ""
Caption = ""
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
_Version = 393216
End
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 0
Top = 3840
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin MSDataGridLib.DataGrid DataGrid1
Bindings = "reftab.frx":0000
Height = 3735
Left = 120
TabIndex = 8
Top = 120
Width = 6375
_ExtentX = 11245
_ExtentY = 6588
_Version = 393216
AllowArrows = 0 'False
HeadLines = 1
RowHeight = 15
BeginProperty HeadFont {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
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
End
Attribute VB_Name = "reftab"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public ex As New Excel.Application
Public exwbook As Excel.Workbook
Public exsheet As Excel.Worksheet
Option Explicit
Dim cnn1 As ADODB.Connection
Dim cnn2 As ADODB.Connection
Dim rst1 As ADODB.Recordset
Dim rst2 As ADODB.Recordset
Dim cmm1 As ADODB.Command
Dim strConnect As String
Dim strcnn As String
Dim strsql As String
Dim strdw As String
Dim dwname As String
Dim dwcode As String
Dim yhcode As String
Dim i As Integer
Dim len1 As Integer
Dim rown As Integer
Dim excelname As String
Dim sheetname As String
Dim rowcount As Long
Dim msg As String
Private Sub delreftab_Click()
'**************************************************
'删除参照表数据
If Not (Admoney.Recordset.BOF) Then
If MsgBox("真的要清除所有记录吗?", vbYesNo, "删除设置") = vbYes Then
Set cnn1 = New ADODB.Connection
'strConnect = "User ID=Admin;Password=;Data Source=" & App.Path & _
"\users.mdb;Provider=Microsoft.Jet.OLEDB.3.51"
'strConnect = "DSN=users;DBQ=" & App.Path & "\USERS.MDB;DriverId=281;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;UID=admin;"
strConnect = "DBQ=" & App.Path & "\exceltemp.mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=" & App.Path & "\users.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
cnn1.Open strConnect
strsql = "DELETE FROM REFYHDM"
Set cmm1 = New ADODB.Command
Set cmm1.ActiveConnection = cnn1
With cmm1
'.ActiveConnection = cnn1
.CommandType = adCmdText
.CommandText = strsql
.Execute
End With
MsgBox "参照表数据已经清除", vbOKOnly, "提示"
strsql = "select * from refyhdm "
Set rst1 = New ADODB.Recordset
Call OpenSourceSet(strsql, cnn1, rst1)
Set Admoney.Recordset = rst1
End If
End If
If Err.Number <> 0 Then
' Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
msg = "删除数据有错,请重新删除!"
MsgBox msg, , "出错", Err.HelpFile, Err.HelpContext
End If
End Sub
Private Sub update_Click()
On Error Resume Next
Admoney.Recordset.update
If Err.Number <> 0 Then
' Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
msg = "保存数据有错,请重新保存!"
MsgBox msg, , "出错", Err.HelpFile, Err.HelpContext
Else
End If
End Sub
Private Sub insert_Click()
' 如果有错误发生，就构成一个错误信息
On Error Resume Next ' 改变错误处理的方式。
Admoney.Recordset.AddNew
'Admoney.Recordset.Move
' 检查错误代号，显示相关错误信息。
If Err.Number <> 0 Then
' Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
msg = "插入数据有错,请重新插入"
MsgBox msg, , "出错", Err.HelpFile, Err.HelpContext
Else
End If
End Sub
Private Sub edit_Click()
DataGrid1.EditActive = True
End Sub
Private Sub delete_Click()
On Error Resume Next
If Not (Admoney.Recordset.BOF) Then
If MsgBox("真的要删除当前记录吗?", vbYesNo, "删除设置") = vbYes Then
Admoney.Recordset.delete
End If
End If
If Err.Number <> 0 Then
' Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
msg = "删除数据有错,请重新删除!"
MsgBox msg, , "出错", Err.HelpFile, Err.HelpContext
End If
End Sub
Private Sub exit_Click()
If Admoney.Recordset.BOF Or Admoney.Recordset.EOF Then
Else
If Admoney.Recordset.EditMode = adEditAdd Or Admoney.Recordset.EditMode = adEditInProgress Then
If MsgBox("当前记录已经改变,在退出前保存更改吗?", vbYesNo, "提示") = vbYes Then
Admoney.Recordset.update
Else
Admoney.Recordset.CancelUpdate
End If
End If
End If
Unload reftab
End Sub
Private Sub insertref_Click()
MsgBox "请选择要生成参照表的EXCEL源数据文件后按确定，否则按取消！", vbOKOnly, "提示"
CommonDialog1.CancelError = True
On Error GoTo ErrHandler
'CommonDialog1.Flags = cdlOFNHideReadOnly ' 设置标志
CommonDialog1.Flags = &H200&
CommonDialog1.InitDir = "A:\"
CommonDialog1.Filter = "All Files (*.*)|*.*|Excel Files(*.xls)|*.xls" ' 设置过滤器
CommonDialog1.FilterIndex = 2 ' 指定缺省的过滤器
CommonDialog1.ShowOpen ' 显示“打开”对话框
excelname = CommonDialog1.FileName ' 显示选定文件的名字
Set ex = CreateObject("excel.application")
Set exwbook = ex.Workbooks.Open(excelname)
Set exsheet = exwbook.Worksheets(1)
rowcount = 0
If Right(Trim(excelname), 9) = "F0131.XLS" Then
For rown = 2 To 444
strdw = Trim(exsheet.Cells(rown, 3))
For i = 1 To Len(strdw)
If Mid(strdw, i, 1) = " " Then
len1 = i - 1
Exit For
Else
len1 = Len(strdw)
End If
Next i
dwcode = Trim(Mid(strdw, 1, len1))
dwname = Trim(Right(strdw, Len(strdw) - len1))
yhcode = Trim(exsheet.Cells(rown, 2))
If CLng(yhcode) < 5000 Then
rst1.AddNew
rst1!DWDM = dwcode
rst1!DWMC = dwname
rst1!YHDM = yhcode
rst1.update
rowcount = rowcount + 1
End If
Next rown
Else
Set cnn2 = New ADODB.Connection
'strcnn = "driver={Oracle ODBC Driver};Service Name=sqcdb;" & _
"User Id=gas;Password=gas;"
'strcnn = "Provider=MSDASQL.1;Persist Security Info=False;User ID=gas;Password=gas;Data Source=oracle2"
strcnn = "Provider=MSDAORA.1;User ID=gas;Password=gas;Data Source=sqcdb;Persist Security Info=False"
cnn2.Open strcnn
Set rst2 = New ADODB.Recordset
For rown = 1 To 443
strdw = Trim(exsheet.Cells(rown, 2))
For i = 1 To Len(strdw)
If Mid(strdw, i, 1) = " " Then
len1 = i - 1
Exit For
Else
len1 = Len(strdw)
End If
Next i
dwcode = Trim(Mid(strdw, 1, len1))
dwname = Trim(Right(strdw, Len(strdw) - len1))
strsql = "select FYHDM from T_YHJBDA where FYHMC='" + dwname + "'"
Call OpenSourceSet(strsql, cnn2, rst2)
If (rst2.BOF = False) And (rst2.EOF = False) Then
yhcode = rst2.Fields(0).Value
rst1.AddNew
rst1!DWDM = dwcode
rst1!DWMC = dwname
rst1!YHDM = yhcode
rst1.update
rowcount = rowcount + 1
End If
rst2.Close
Next rown
End If
Set Admoney.Recordset = rst1
MsgBox "总共成功生成" + CStr(rowcount) + "条参照记录！", vbOKOnly, "提示"
Admoney.Caption = "共" + CStr(rowcount) + "条记录！"
ErrHandler:
' 用户按了“取消”按钮
Exit Sub
End Sub
Private Sub Form_Load()
Set cnn1 = New ADODB.Connection
'strConnect = "User ID=Admin;Password=;Data Source=" & App.Path & _
"\users.mdb;Provider=Microsoft.Jet.OLEDB.3.51"
'strConnect = "DSN=users;DBQ=" & App.Path & "\USERS.MDB;DriverId=281;FIL=MS Access;MaxBufferSize=2048;PageTimeout=5;UID=admin;"
strConnect = "DBQ=" & App.Path & "\exceltemp.mdb;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=" & App.Path & "\users.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
cnn1.Open strConnect
strsql = "select * from refyhdm order by yhdm "
Set rst1 = New ADODB.Recordset
Call OpenSourceSet(strsql, cnn1, rst1)
Set Admoney.Recordset = rst1
DataGrid1.EditActive = False
Admoney.Caption = "共" + CStr(Admoney.Recordset.RecordCount) + "条记录！"
End Sub
Private Sub OpenSourceSet(sqlstr As String, cnn As Connection, ByRef rst As Recordset)
rst.CursorType = adOpenKeyset
rst.LockType = adLockOptimistic
rst.CursorLocation = adUseClient '必须设置此属性，否则相应的grid表不显示数据
rst.Open sqlstr, cnn, , , adCmdText
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -