求助高手，万分感谢。VB 调用 EXCEL

Dim app As Object
Dim sheet As Object
Dim book As Object
app = Server.CreateObject("Excel.Application")
Set Book = app.WorkBooks.Open(xlsPath, ...)
Set sheet = xlBook.Sheets("Sheet1")
sheet.Range("A1") = Text1.Text

Dim MyExcel As Object
Set MyExcel = CreateObject("excel.application")
    MyExcel.Workbooks.Add   '新建excel文档
  'MyExcel.Workbooks.Open (App.Path & "\test2.xls")         '打开现有文档


  '添加边框
          MyExcel.Range("A1", "C3").Borders.LineStyle = 1
         MyExcel.Range("A1", "C3").Borders.Color = RGB(255, 0, 0)


  '合并单元格
  MyExcel.Range("A1", "A3").Select     '选择
  MyExcel.Selection.Merge   '合并
  MyExcel.Range("b2", "c2").Select
  MyExcel.Selection.Merge   '合并


  '写入文字

MyExcel.Cells(1, 2) = "测试1"
MyExcel.Cells(1, 3) = "测试2"
MyExcel.Cells(2, 2) = "测试3"
MyExcel.Cells(3, 2) = "测试4"
MyExcel.Cells(3, 3) = "测试5"

  '设置格式
  MyExcel.Range("a1", "c3").Font.Color = RGB(0, 0, 255)             '颜色
  MyExcel.Range("a1", "c3").Font.Name = "宋体"         '字体
  MyExcel.Range("a1", "c3").HorizontalAlignment = xlCenter         '水平居中
  MyExcel.Range("a1", "c3").VerticalAlignment = xlCenter         '竖直居中

  ''''
  MyExcel.Worksheets(2).Cells(1, 1) = "测试二"
  MyExcel.Worksheets(3).Cells(1, 1) = "测试三"   MyExcel.ActiveWorkbook.SaveAs App.Path & "\test3.xls"      '另存为
  'MyExcel.ActiveWorkbook.Save'直接保存
  MyExcel.Workbooks.Close   '关闭文档
  MyExcel.Quit '退出excel程序

'**********************************************************
'功能：导出用户数据库到EXCEL文件
'**********************************************************
Private Sub mExl_Save_Click()
Dim nFileNum1%, rs As DAO.Recordset, rsT As DAO.Recordset, rsC As DAO.Recordset, rsD As DAO.Recordset, sql$, sExlFileOut$, i%, j%, k&, cnt&, cnt_K%, cnt_I%, sFlds$(), sData$(), sTemp$
    '读入配置文件信息
    sExlFileOut = GetSetting("Cadence建库管理系统", "ModelWork", "ExcelOutPath")
    If Check_FileExist(g_DbExlPath_Name) = False Then
        '数据库不存在错误提示信息
        MsgBox "用户元器件表未导入系统，请先进行导入操作!", vbExclamation + vbOKOnly, "错误提示"
        Exit Sub
    End If
    If Check_FileExist(sExlFileOut) = True Then
        '导出文件已存在提示信息
        If MsgBox("导出EXCEL文件 " & Chr(34) & sExlFileOut & Chr(34) & " 已经存在，是否覆盖？", vbQuestion + vbOKCancel + vbDefaultButton2, "提示") = vbCancel Then
            Exit Sub
        End If
    End If
    '打开数据库
    Set g_WS = DBEngine.Workspaces(0)
    Set g_DB = g_WS.OpenDatabase(g_DbExlPath_Name)
    '等待提示
    sbrMain.Panels(1).Text = "正在导出用户元器件表数据，请耐心等待......"
    Screen.MousePointer = vbHourglass        '11 沙漏,表示等待状态
    '建立Excel进程
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then Set xlApp = CreateObject("Excel.Application")
    Err.Clear
    On Error GoTo 0 '禁止当前过程中任何已启动的错误处理程序
    sql = "select distinct table_name from Key_Injected "
    Set rs = g_DB.OpenRecordset(sql) '查询有哪些表进行了属性设置，只导出进行了属性设置的表
    xlApp.Visible = False
    xlApp.DisplayAlerts = False '关闭时不提示保存
    On Error Resume Next
    rs.MoveLast: rs.MoveFirst
    On Error GoTo 0
    '表个数为0，无需导出
    If rs.RecordCount = 0 Then
        Screen.MousePointer = vbDefault '0 （缺省值）形状由对象决定。
        sbrMain.Panels(1).Text = ""
        MsgBox "对不起，由于用户元器件表未进行" & Chr(34) & "Key_Injected属性设置" & Chr(34) & ",导出操作无法完成！", vbExclamation + vbOKOnly, "提示"
        GoTo EXITL
    End If
    xlApp.SheetsInNewWorkbook = rs.RecordCount '确定新建工作簿中含有的sheet数目
    '生成各个需要导出的Excel表
    Set xlBook = xlApp.Workbooks.Add
    For i = 1 To xlApp.Worksheets.Count
        xlApp.Worksheets(i).Activate
        Set xlSheet = xlApp.Worksheets(i)
        xlSheet.Name = rs.Fields(0).Value
        sbrMain.Panels(1).Text = "正在导出" & Chr(34) & xlSheet.Name & Chr(34) & "表数据......"
        cnt = 0 '用于记载导出EXCEL工作表中的第几条记录
        'Part Name
        xlSheet.Cells(1, 1) = "Part_Name"
        xlSheet.Range("A1:A2").Select
        With xlApp.Selection
            .MergeCells = True
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
        End With
        sql = "select 中文字段 as chi_name from MSys" & xlSheet.Name & " where 英文字段='Part_Name'"
        Set rsC = g_DB.OpenRecordset(sql)
        xlSheet.Cells(3, 1).Select
        xlApp.ActiveCell = rsC.Fields(0).Value
        With xlApp.ActiveCell
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Font.Bold = True
        End With
        ReDim sFlds(1)         '保存字段名到字符串数组中
        sFlds(1) = "Part_Name"
        'Key Properties
        sql = "select Field_Name from Key_Injected where Table_Name='" & xlSheet.Name & "' and Key=True order by Xh Asc"
        Set rsT = g_DB.OpenRecordset(sql)
        On Error Resume Next
        rsT.MoveLast: rsT.MoveFirst
        On Error GoTo 0
        cnt_K = rsT.RecordCount
        If cnt_K <> 0 Then
            xlSheet.Range(xlSheet.Cells(1, 2), xlSheet.Cells(1, cnt_K + 1)).Select
            With xlApp.Selection
                .MergeCells = True
                .FormulaR1C1 = "Key Properties"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            For j = 1 To cnt_K
                xlSheet.Cells(2, j + 1).Select
                xlApp.ActiveCell = rsT.Fields(0).Value
                With xlApp.ActiveCell
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                sql = "select 中文字段 as chi_name from MSys" & xlSheet.Name & " where 英文字段='" & rsT.Fields(0).Value & "'"
                Set rsC = g_DB.OpenRecordset(sql)
                xlSheet.Cells(3, j + 1).Select
                On Error Resume Next
                xlApp.ActiveCell = rsC.Fields(0).Value
                On Error GoTo 0
                With xlApp.ActiveCell
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                ReDim Preserve sFlds(j + 1)
                On Error Resume Next
                sFlds(j + 1) = rsT.Fields(0).Value
                On Error GoTo 0
                rsT.MoveNext
            Next j
        End If
        'Injected Properties
        sql = "select Field_Name from Key_Injected where Table_Name='" & xlSheet.Name & "' and Injected=True order by Xh Asc"
        Set rsT = g_DB.OpenRecordset(sql)
        On Error Resume Next
        rsT.MoveLast: rsT.MoveFirst
        On Error GoTo 0
        cnt_I = rsT.RecordCount
        If cnt_I <> 0 Then
            xlSheet.Range(xlSheet.Cells(1, cnt_K + 2), xlSheet.Cells(1, cnt_K + cnt_I + 1)).Select
            With xlApp.Selection
                .MergeCells = True
                .FormulaR1C1 = "Injected Properties"
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .Font.Bold = True
            End With
            For j = 1 To cnt_I
                xlSheet.Cells(2, j + 1 + cnt_K).Select
                xlApp.ActiveCell = rsT.Fields(0).Value
                With xlApp.ActiveCell
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                sql = "select 中文字段 as chi_name from MSys" & xlSheet.Name & " where 英文字段='" & rsT.Fields(0).Value & "'"
                Set rsC = g_DB.OpenRecordset(sql)
                xlSheet.Cells(3, j + 1 + cnt_K).Select
                On Error Resume Next
                xlApp.ActiveCell = rsC.Fields(0).Value '新增字段无中文名称
                On Error GoTo 0
                With xlApp.ActiveCell
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .Font.Bold = True
                End With
                ReDim Preserve sFlds(j + 1 + cnt_K)
                On Error Resume Next
                sFlds(j + 1 + cnt_K) = rsT.Fields(0).Value
                On Error GoTo 0
                rsT.MoveNext
            Next j
        End If
        '每张表的数据导出
        For k = 1 To UBound(sFlds)
            If k > 1 Then
                sql = sql & "," + sFlds(k)
            Else
                sql = sFlds(k)
            End If
        Next k
        sql = "select " & sql & " from " & xlSheet.Name
        Set rsD = g_DB.OpenRecordset(sql)
        On Error Resume Next
        rsD.MoveLast: rsD.MoveFirst
        On Error GoTo 0
        ReDim sData(rsD.Fields.Count)
        sTemp = ""
        If Check_FileExist(App.path + "\temp.txt") Then Kill App.path + "\temp.txt"
        nFileNum1 = FreeFile()
        Open App.path + "\temp.txt" For Output As nFileNum1
        For k = 1 To rsD.RecordCount
            For j = 0 To rsD.Fields.Count - 1
                sData(j) = SNull(rsD.Fields(j).Value)
            Next j
            cnt = cnt + 1
            sbrMain.Panels(1).Text = "正在导出" & Chr(34) & xlSheet.Name & Chr(34) & "表数据" & "的第 " & cnt & " 条记录"
            Print #nFileNum1, Join(sData, Chr(9))
            rsD.MoveNext
        Next k
        Close #nFileNum1
        nFileNum1 = FreeFile()
        Open App.path + "\temp.txt" For Input As nFileNum1
        '非常关键的一句代码，导入全部文件转为Unicode赋值给sline变量特大的文件是你用Line Input的N倍速度
        sTemp = StrConv(InputB(LOF(nFileNum1), #nFileNum1), vbUnicode)
        Close #nFileNum1
        Kill App.path + "\temp.txt"
        Clipboard.Clear
        Clipboard.SetText sTemp
        xlSheet.Range("A4").Select
        xlApp.ActiveSheet.Paste
        rs.MoveNext
    Next i
    xlBook.SaveAs sExlFileOut '保存工作簿
        Screen.MousePointer = vbDefault '0 （缺省值）形状由对象决定。
        sbrMain.Panels(1).Text = ""
        MsgBox "用户元器件表数据成功导出系统!", vbInformation + vbOKOnly, "提示"
EXITL:  Call CloseExcel   '退出EXCEL
        Call CloseAllDB
End Sub

http://download.csdn.net/source/1627060

vb的没有做过，c#的做过一个类库，楼主有兴趣的话可以看一下

http://download.csdn.net/source/1738578

调试易

求助高手，万分感谢。VB 调用 EXCEL

解决方案 »