Public Sub saveExcelInput()
With dlgExcelSave
.FileName = ""
.CancelError = True
.DialogTitle = "±£´æ"
.Filter = "ExcelÊý¾ÝÎļþ|*.xls"
On Error GoTo aaa
.ShowSave
End With
If Dir(dlgExcelSave.FileName) <> "" Then
If MsgBox("¡°" & dlgExcelSave.FileName & "¡±ÎļþÒѾ´æÔÚ£¬ÊÇ·ñ´ú»»£¿", 16 + vbYesNo, "ÌáÎÊ") = vbYes Then
Kill dlgExcelSave.FileName
Else
Exit Sub
End If
End If
Dim i As Integer
Dim exstring As String
Dim exConn As ADODB.Connection
Dim exRs As ADODB.Recordset
Dim exPath As String
Dim exName As String
Dim exPos As Integer
'''
Dim rs As ADODB.Recordset
Dim sql As String
Dim j As Integer
Set rs = New ADODB.Recordset
sql = "select * from " & sqlTable
conndbOpen
rs.Open sql, conn, 1, 1
If rs.RecordCount = 0 Then
MsgBox "ûÓÐÊý¾Ý£¬µ«Äܵ¼³öÊý¾Ý¿â½á¹¹£¡", 48, "Ìáʾ"
End If
ProgressExcel.Visible = True
ProgressExcel.Max = rs.RecordCount
If sqlTable = "Apparatus" Or sqlTable = "Consignment" Then '''µ±Ñ¡ÔñÁ˱íApparatus»òÕßConsignmentµÄʱºò
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
If ListFieldPrint.List(i) = "Ê¡±àºÅ" Then '''»ñµÃÊ¡Ãû
Dim Prs As ADODB.Recordset
Dim Psql As String
Set Prs = New ADODB.Recordset
Psql = "select * from Province where Ê¡±àºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Prs.Open Psql, conn, 1, 1
If Not (Prs.BOF And Prs.EOF) Then
exRs.Fields(i).Value = Prs.Fields("Ê¡Ãû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "ÊбàºÅ" Then '''»ñµÃ³ÇÊÐÃû
Dim Crs As ADODB.Recordset
Dim Csql As String
Set Crs = New ADODB.Recordset
Csql = "select * from City where ÊбàºÅ='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Crs.Open Csql, conn, 1, 1
If Not (Crs.BOF And Crs.EOF) Then
exRs.Fields(i).Value = Crs.Fields("ÊÐÃû").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
ElseIf ListFieldPrint.List(i) = "µ¥Î»±àºÅ" Then '''»ñµÃµ¥Î»Ãû
Dim Srs As ADODB.Recordset
Dim Ssql As String
Set Srs = New ADODB.Recordset
Ssql = "select * from School where µ¥Î»´úÂë='" & rs.Fields("" & ListFieldPrint.List(i) & "").Value & "'"
Srs.Open Ssql, conn, 1, 1
If Not (Srs.BOF And Srs.EOF) Then
exRs.Fields(i).Value = Srs.Fields("µ¥Î»").Value
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
Else
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
End If
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
Else
Do While Not rs.EOF
exRs.AddNew
For i = 0 To ListFieldPrint.ListCount - 1
exRs.Fields(i).Value = rs.Fields("" & ListFieldPrint.List(i) & "").Value
Next
exRs.Update
j = j + 1
ProgressExcel.Value = j
rs.MoveNext
Loop
End If
MsgBox "µ¼³öÍê³É£¡", 64, "Ìáʾ"
' ProgressExcel.Value = 0
'''
Prs.Close
Set Prs = Nothing
Crs.Close
Set Crs = Nothing
Srs.Close
Set Srs = Nothing
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
exRs.Close
Set exRs = Nothing
exConn.Close
Set exConn = Nothing
aaa:
' Exit Sub
End Sub
Public Function ExporToExcel(strOpen As String)
'*********************************************************
'* 名称:ExporToExcel
'* 功能:导出数据到EXCEL
'* 用法:ExporToExcel(sql查询字符串)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
Dim xlApp As New Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlQuery As Excel.QueryTable
With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Conn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With
Set xlApp = CreateObject("Excel.Application")
Set xlBook = Nothing
Set xlSheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlSheet = xlBook.Worksheets("sheet1")
xlApp.Visible = True
'添加查询语句,导入EXCEL数据
Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))