导入EXECEL出现的新问题

Question

'*************************************************************************
'**函 数 名：xpcmdbutton1_Click
'**输    入：无
'**输    出：无
'**功能描述：导出数据至EXCEL表格
'**全局变量：
'**调用模块：
'**作    者：
'**日    期：2005-05-25 15:07:29
'**修 改 人：
'**日    期：
'**版    本：V2005.04.001
'*************************************************************************
Private Sub xpcmdbutton1_Click()
    On Error GoTo ToExit '打开错误陷阱
    '------------------------------------------------
    Dim myexcel As New Excel.Application
    Dim mybook As New Excel.Workbook
    Dim mysheet As New Excel.Worksheet
    'Dim myexceltable As New Excel.QueryTable
    Set mybook = myexcel.Workbooks.Add '添加一个新的BOOK
    Set mysheet = mybook.Worksheets.Add '添加一个新的SHEET
        MyConn.Execute "delete from 条码表"
    StringSql   '生成字符串的过程
    Call Rss
    rs.Open strsql, cn, adOpenDynamic, adLockBatchOptimistic
    If rs.EOF = False Then
        MousePointer = 11
        Do While Not rs.EOF
            If MyRecord.State = adStateOpen Then MyRecord.Close
            MyRecord.Open "select * from 条码表 ", MyConn, adOpenDynamic, adLockOptimistic
            MyRecord.AddNew
            MyRecord.Fields("条码号") = rs.Fields("条码号")
            MyRecord.Fields("品名") = rs.Fields("品名")
            MyRecord.Fields("规格") = rs.Fields("规格")
            MyRecord.Fields("单位") = rs.Fields("单位")
            MyRecord.Fields("重量") = rs.Fields("重量")
            MyRecord.Fields("品牌") = rs.Fields("品牌")
            MyRecord.Fields("销售价") = rs.Fields("销售价")
            MyRecord.Fields("款号") = rs.Fields("款号")
            MyRecord.Fields("石料类型") = rs.Fields("石料类型")
            MyRecord.Fields("石头名称") = rs.Fields("石头名称")
            MyRecord.Fields("石头重量") = rs.Fields("石头重量")
            MyRecord.Fields("粒数") = rs.Fields("粒数")
            MyRecord.Fields("石头颜色") = rs.Fields("石头颜色")
            MyRecord.Fields("切工") = rs.Fields("切工")
            MyRecord.Fields("切工") = rs.Fields("切工")
            MyRecord.Fields("证书号") = rs.Fields("证书号")            MyRecord.Update
            rs.MoveNext
        Loop
        If MyRecord.State = adStateOpen Then MyRecord.Close
        MyRecord.Open "select * from 条码表", MyConn, adOpenDynamic, adLockOptimistic
        myexcel.Visible = False
        mysheet.Cells.CopyFromRecordset MyRecord
        mybook.SaveAs (App.Path & "\条码表") '保存文件
        MousePointer = 0
        MsgBox "导出完毕!", vbInformation, Me.Caption
        myexcel.Quit
        Set mysheet = Nothing
        Set mybook = Nothing
        Set myexcel = Nothing
        Exit Sub
    Else
        MsgBox "记录集为空！", vbInformation, Me.Caption
        Exit Sub
    End If    '------------------------------------------------
    Exit Sub
    '----------------
ToExit:
    MsgBox Err.Description, vbInformation, Me.Caption
End Sub
每次导出时都提示“在当前的位置发现已经存在名为‘D：\JXJXC\条码表’的文件，是否要替换现有的文件？”。
1、这个提示要通过设置那个属性可以使其不出现呢？
2、这个导入只导入了记录值，要如何才能实现连字段名称一起导入？

Answer 1

转贴
Public Function ExporToExcel(strOpen As String, strAppPath As String, sFileName As String)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(strOpen-sql查询字符串,strAppPath-文件路经,sFileName-文件名)
'*********************************************************
Dim Rs_Data As New ADODB.Recordset
    On Error Resume Next
    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
    
    Dim ExclFileName As String
    Dim i As Integer
    With Rs_Data
        If .State = adStateOpen Then
            .Close
        End If
        .ActiveConnection = Cn
        .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"))
    
    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    
    With xlSheet
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
        .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
        .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
    End With
    
'    With xlSheet.PageSetup
'        .LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
'        .CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
'        .RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
'        .LeftFooter = "&""楷体_GB2312,常规""&10制表人："
'        .CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
'        .RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
'    End With
'
 '   ExclFileName = App.Path & "\Excel\" & Date & sFileName & ".xls"
    ExclFileName = strAppPath & Date & sFileName & ".xls"
    i = 1
Sign:   If Dir(ExclFileName) <> "" Then
            'Kill ExclFileName
            'ExclFileName = App.Path & "\Excel\" & Date & sFileName & i & ".xls"
            ExclFileName = strAppPath & Date & sFileName & i & ".xls"
            i = i + 1
            GoTo Sign
        End If
        
'    xlApp.Application.Visible = True      '"交还控制给Excel
'    xlApp.WindowState = xlMaximized
    xlBook.SaveAs (ExclFileName)
    xlApp.Quit
    Set xlApp = Nothing
    Set xlBook = Nothing
    Set xlSheet = Nothing
    
    Exit Function
Err_Folder:
    If Err.Number = 1004 Then
        MsgBox Err.Description
        MkDir strAppPath
        Resume
    Else
        Resume Next
    End If
End Function