📄 frmmain.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmmain
BorderStyle = 1 'Fixed Single
Caption = "数据导入导出管理"
ClientHeight = 9345
ClientLeft = 150
ClientTop = 540
ClientWidth = 9750
FillColor = &H8000000B&
ForeColor = &H000000FF&
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 9345
ScaleWidth = 9750
StartUpPosition = 2 '屏幕中心
Begin VB.Frame framimport
Caption = "请选择要从Excel文件中导入的字段"
Height = 4275
Left = 45
TabIndex = 21
Top = 5040
Visible = 0 'False
Width = 3795
Begin VB.ListBox listimport
Height = 3630
Left = 90
Style = 1 'Checkbox
TabIndex = 22
Top = 240
Width = 3525
End
End
Begin VB.Frame frm4
Caption = "选择构建sql方式"
ForeColor = &H80000008&
Height = 705
Left = 45
TabIndex = 17
Top = 4290
Width = 9555
Begin VB.CheckBox chk2
Caption = "构造sql"
Height = 255
Left = 4275
TabIndex = 19
Top = 270
Width = 960
End
Begin VB.CheckBox chk1
Caption = "选择字段"
Height = 255
Left = 1710
TabIndex = 18
Top = 270
Width = 1050
End
End
Begin VB.Frame Frame3
Caption = "复杂SQL导出"
Height = 2925
Left = 3960
TabIndex = 15
Top = 5040
Width = 5640
Begin VB.TextBox txtsql
Height = 2295
Left = 135
MultiLine = -1 'True
TabIndex = 16
Top = 510
Width = 5370
End
Begin VB.Label Label2
Caption = "注意：表名前加上库名及dbo如test.dbo.user"
ForeColor = &H000000FF&
Height = 315
Left = 360
TabIndex = 20
Top = 240
Width = 5010
End
End
Begin VB.Frame Frame2
Caption = "请选择要导出的字段"
Height = 4275
Left = 45
TabIndex = 13
Top = 5040
Width = 3795
Begin VB.ListBox listfield
Height = 3840
Left = 135
Style = 1 'Checkbox
TabIndex = 14
Top = 300
Width = 3480
End
End
Begin MSComctlLib.ListView listtable
Height = 3375
Left = 4095
TabIndex = 12
Top = 810
Width = 5370
_ExtentX = 9472
_ExtentY = 5953
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 0
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "表ID"
Object.Width = 2540
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "表名称"
Object.Width = 2822
EndProperty
End
Begin VB.Frame frm2
Caption = "用户定义表"
Height = 3705
Left = 3960
TabIndex = 11
Top = 540
Width = 5640
End
Begin VB.Frame Frame1
Caption = "数据库列表"
Height = 3705
Left = 45
TabIndex = 9
Top = 540
Width = 3795
Begin MSComctlLib.ListView listdatabase
Height = 3375
Left = 90
TabIndex = 10
Top = 240
Width = 3615
_ExtentX = 6376
_ExtentY = 5953
View = 3
LabelWrap = -1 'True
HideSelection = -1 'True
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 0
NumItems = 2
BeginProperty ColumnHeader(1) {BDD1F052-858B-11D1-B16A-00C0F0283628}
Text = "数据库ID"
Object.Width = 1766
EndProperty
BeginProperty ColumnHeader(2) {BDD1F052-858B-11D1-B16A-00C0F0283628}
SubItemIndex = 1
Text = "数据库名称"
Object.Width = 2118
EndProperty
End
End
Begin VB.CommandButton cmdquery
Caption = "连接"
Height = 405
Left = 7110
TabIndex = 8
Top = 90
Width = 1185
End
Begin VB.TextBox txtIP
Height = 345
Left = 2385
TabIndex = 7
Top = 120
Width = 4560
End
Begin VB.CommandButton cmdopen
Caption = "选择"
Height = 345
Left = 8190
TabIndex = 5
Top = 8880
Width = 510
End
Begin VB.TextBox txtfilename
Height = 375
Left = 6030
TabIndex = 4
Top = 8880
Width = 2130
End
Begin VB.CommandButton Command4
Caption = "关闭"
Height = 345
Left = 8550
TabIndex = 3
Top = 8310
Width = 1005
End
Begin VB.CommandButton Command1
Caption = "excel--->sqlserver"
Height = 375
Left = 4050
TabIndex = 2
Top = 8880
Width = 1950
End
Begin VB.CommandButton cmd1
Caption = "sqlserver--->excel"
Height = 435
Left = 4050
TabIndex = 1
Top = 8310
Width = 1950
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 9720
Top = 7740
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmd2
Caption = "Accee--->excel"
Height = 435
Left = 6030
TabIndex = 0
Top = 8310
Width = 1500
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "请输入要连接的服务器地址"
Height = 180
Left = 135
TabIndex = 6
Top = 180
Width = 2160
End
Begin VB.Menu menuedit
Caption = "编辑"
Begin VB.Menu menuselall
Caption = "全选"
End
Begin VB.Menu menucacel
Caption = "取消"
End
Begin VB.Menu memuoutport
Caption = "导入excel"
End
End
Begin VB.Menu menufield
Caption = "字段设置"
Begin VB.Menu menufieldenter
Caption = "对应字段"
End
End
End
Attribute VB_Name = "frmmain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Private mycon As ADODB.Connection
Private prdbname As String
Private prtable As String
Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal _
wParam As Long, lParam As Any) As Long
Const LVS_EX_FULLROWSELECT = &H20
Const LVM_FIRST = &H1000
Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H37
Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + &H36
Private Sub chk1_Click()
chk2.Value = False
End Sub
Private Sub chk2_Click()
chk1.Value = False
End Sub
Private Sub cmd2_Click()
On Error GoTo ErrChu
Dim temp As String
Dim sql As String
CommonDialog1.Filter = "电子表格Excel文件(*.XLS)|*.XLS"
CommonDialog1.ShowSave
If CommonDialog1.fileName <> "" Then
temp = CommonDialog1.fileName
' conReport.Execute "SELECT name1 as 编号,name2 as 客户编号 ,name3 as 客户姓名 ,name4 as 售电电量 ,name5 as 单价 ,name6 as 售电金额 ,name7 as 实缴金额 ,name8 as 累计余额 ,name9 as 售电次数 , name10 as 售电日期 ,name11 as 售电员 INTO 售电查询信息 IN '" + temp + "' 'EXCEL 5.0;' FROM report"
sql = "select f_user_name as 用户姓名,f_user_tel as 用户电话 into 用户信息 IN '" + temp + "' 'EXCEL 5.0;' FROM t_user_def"
conn.Execute sql
MsgBox "已将查询结果成功存到指定的目录下！", vbInformation, "提示"
Exit Sub
Else
Exit Sub
End If
ErrChu:
If Err.Number = -2147217900 Then
MsgBox "该文件夹下已经有一个同名的.XLS文件,请重新填写新文件名！", vbExclamation, "提示"
Else
MsgBox Err.Number & Err.Description
End If
Exit Sub
End Sub
Private Sub cmdopen_Click()
Dim file As String
Dim i As Integer
Dim count As Integer '定义excel列的数量
Dim col As String
Dim fieldname As String
Dim objExcel As Object
CommonDialog1.Filter = "电子表格Excel文件(*.XLS)|*.XLS"
CommonDialog1.ShowOpen
file = Trim(CommonDialog1.fileName)
If Trim(file) <> "" Then
txtfilename.Text = file
framimport.Visible = True
Frame2.Visible = False
Set objExcel = CreateObject("Excel.Application")
objExcel.Workbooks.Open fileName:=file
count = objExcel.Worksheets(1).UsedRange.Columns.count
listimport.Clear
For i = 1 To count
col = returnChar(i)
' fieldname = Trim(objExcel.Worksheets("Sheet1").Range(col & 1).Cells(1, i))
fieldname = objExcel.Worksheets("Sheet1").Cells(1, i)
listimport.AddItem (fieldname)
' MsgBox (objExcel.Worksheets("Sheet1").Cells(1, i))
Next
Set objExcel = Nothing
Else
Exit Sub
End If
End Sub
Private Sub cmdquery_Click()
Dim constr As String
'Dim mycon As ADODB.Connection
' Dim rs As New ADODB.Recordset
Dim strsql As String
If Trim(txtIP) = "" Then
MsgBox ("请输入数据库所在的IP")
Exit Sub
End If
Set mycon = New ADODB.Connection
constr = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=master;Data Source=" + Trim(txtIP) + ""
mycon.CursorLocation = adUseClient
mycon.ConnectionString = constr
mycon.ConnectionTimeout = 30
mycon.Open
strsql = "select name as dbname,dbid from sysdatabases order by dbid asc"
initListdatabase (strsql)
'rs.Open strsql, mycon, 1, 3
'If rs.RecordCount > 0 Then
'End If
End Sub
Private Sub Command1_Click()
Dim i As Integer
Dim oleExcel As Object
Dim sFiles As String
Dim strtel As String
Dim strsex As String
Dim rsTemp As New ADODB.Recordset
Dim strsql As String
Dim j As Integer
Dim h As Integer
Dim strrs As String
Dim strField As String
Dim FieldCol As String
Dim tempcol As String
strsql = "select * from t_user_def"
rsTemp.Open strsql, conn, 1, 3
Set oleExcel = CreateObject("Excel.Application")
sFiles = Trim(txtfilename.Text)
If sFiles = "" Then
MsgBox ("请选择要导入的数据文件!")
Exit Sub
End If
oleExcel.Workbooks.Open fileName:=sFiles
i = 2
' While oleExcel.Worksheets("Sheet1").Range("A" & i).Cells(1, 1) <> ""
' rsTemp.AddNew
' strtel = oleExcel.Worksheets("Sheet1").Range("A" & i).Cells(1, 1)
' rsTemp("f_user_tel") = Trim(strtel)
' rsTemp("f_user_name") = oleExcel.Worksheets("Sheet1").Range("B" & i).Cells(1, 1)
' rsTemp("f_sex") = oleExcel.Worksheets("Sheet1").Range("C" & i).Cells(1, 1)
' rsTemp("f_old") = Trim(oleExcel.Worksheets("Sheet1").Range("D" & i).Cells(1, 1))
' rsTemp("f_address") = Trim(oleExcel.Worksheets("Sheet1").Range("E" & i).Cells(1, 1))
' rsTemp("f_email") = Trim(oleExcel.Worksheets("Sheet1").Range("F" & i).Cells(1, 1))
' rsTemp("f_localman") = Trim(oleExcel.Worksheets("Sheet1").Range("G" & i).Cells(1, 1))
' rsTemp("f_area") = Trim(oleExcel.Worksheets("Sheet1").Range("H" & i).Cells(1, 1))
' rsTemp("f_memo") = Trim(oleExcel.Worksheets("Sheet1").Range("I" & i).Cells(1, 1))
' i = i + 1
' rsTemp.Update
' Wend
For j = 0 To listimport.ListCount - 1
If listimport.Selected(j) Then
strField = Trim(listfield.List(j))
For h = 1 To oleExcel.Worksheets(1).UsedRange.Columns.count
If strField = Trim(oleExcel.Worksheets("Sheet1").Cells(1, h)) Then
tempcol = returnChar(h)
If tempcol <> "" Then
FieldCol = tempcol
End If
End If
Next
End If
Next
If rsTemp.State = adStateOpen Then
rsTemp.Clone
Set rsTemp = Nothing
End If
'*********************************
Set oleExcel = Nothing
'*********************************
MsgBox "数据导入成功！", vbInformation, "提示"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -