?? 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 + -