在VB6.0中如何把ORACLE中的查询结果按格式导出到EXCLE中啊？？？

Question

本人新学VB6.0，现在手头一个任务，需要把ORACLE中的查询结果按照一定的格式导出到EXCEL中，我看过李洪根曾经贴出的一段代码，但是在落实到ORACLE数据库上，我就不知道怎么修改这段代码了，谢谢，急！！！

Answer 1

'Private PIshowExc As ADODB.Recordset  
'说明：需要建立ORACLE查询结果的ADODB.Recordset  
'说明：CommonDialog1是CommonDialog 控件，提供一组标准的操作对话框，进行诸如打开和保存文件，
'设置打印选项，以及选择颜色和字体等操作。
Private Sub SaveCode(SaveNote As String)
On Error GoTo Data_Err
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.Filter = "EXCEL文件(*.xls)"
CommonDialog1.DialogTitle = "需导出的EXCEL文件"
CommonDialog1.FilterIndex = 1
CommonDialog1.InitDir = MyPath
CommonDialog1.FileName = ""
CommonDialog1.ShowSave
MyBankFile = CommonDialog1.FileName
StrFile = MyBankFile
If MyBankFile <> "" Then
    If UCase(Dir(StrFile)) = UCase(Mid(StrFile, Len(MyPath) + 1)) Then
        If MsgBox("发现同名文件" & StrFile & "，是否替换？" & Chr(13) & "若不替换请重新命名！", vbSystemModal + vbYesNo + vbQuestion, Me.Caption) = vbYes Then
        Kill StrFile
    
        Else
        Exit Sub
        End If
    End If
If PIshowExc.RecordCount > 0 Then
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim app_add As Long
Dim appII%
'"正在生成EXCEL文件............"
    
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    Set xlBook = xlApp.Workbooks.Add    'xlApp.Workbooks.Open("文件名") '打开已经存在的EXCEL工件簿文件
    xlApp.Visible = False '设置EXCEL对象可见（或不可见）
    Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
    xlSheet.Activate
    '加页眉、页脚
    With xlBook.ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "查询数据清单" 
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&P－&N"
        .RightFooter = ""
        .LeftMargin = xlApp.InchesToPoints(0.75)
        .RightMargin = xlApp.InchesToPoints(0.75)
        .TopMargin = xlApp.InchesToPoints(1)
        .BottomMargin = xlApp.InchesToPoints(1)
        .HeaderMargin = xlApp.InchesToPoints(0.5)
        .FooterMargin = xlApp.InchesToPoints(0.5)
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 100
        .PrintErrors = xlPrintErrorsDisplayed
    End With
For appII% = 0 To PIshowExc.Fields.Count - 1
xlSheet.Cells(1, appII% + 1) = PIshowExc.Fields(appII%).Name
xlApp.ActiveSheet.Cells(1, appII% + 1).Font.Name = "黑体"
Next appII%
xlSheet.Range(xlSheet.Cells(1, 1), xlSheet.Cells(1, appII%)).Borders.LineStyle = xlContinuousPIshowExc.MoveFirst
app_add = 2
Do While Not PIshowExc.EOF
For appII% = 0 To PIshowExc.Fields.Count - 1
xlSheet.Cells(app_add, appII% + 1) = "'" & PIshowExc.Fields(appII%)
Next appII%
app_add = app_add + 1
PIshowExc.MoveNext
Loop
   xlBook.SaveAs (StrFile)
    If Not (xlApp Is Nothing) Then
        
        xlBook.Close (True) '关闭工作簿
        
        xlApp.Quit '必须结束EXCEL对象
        Set xlApp = Nothing '释放xlApp对象
        Set xlBook = Nothing
        Set xlSheet = Nothing
    End If
MsgBox "导出EXCEL完毕！", vbSystemModal + vbInformation, Me.Caption
End IfEnd If
Exit Sub
Data_Err:
     If Err.Number = 3021 Or Err.Number = 13 Then
          Resume Next
     ElseIf Err.Number = 32755 Then
     Exit Sub
     Else
          MsgBox "出错代码：" & Format(Err.Number) & Chr(13) & "提示：" & Err.Description, vbSystemModal + vbCritical, Me.Caption
     End IfEnd Sub

Answer 2

plsql developer查询到的结果就可以导出为cvs....把你的代码全部贴出来帮你看看，就这么一句话，20分，谁有那个闲工夫啊

Answer 3

很久以前写的一段代码，比较简便
Sub CreatexcelFile(ByVal sFileName As String, ByVal rst As ADODB.Recordset)
On Error Resume Next
''    Dim oExcel As Excel.Application
''    Dim oExcelBook As Excel.Workbook
''    Dim oExcelSheet As Excel.Worksheet    Dim oExcel
    Dim oExcelBook
    Dim oExcelSheet
    
    Dim intCol As Long
    Dim intRow As Long
    Dim intRowAs As Long
   
    If rst Is Nothing Then Exit Sub    Set oExcel = CreateObject("Excel.Application")
    Set oExcelBook = oExcel.Workbooks.Add
    Set oExcelSheet = oExcelBook.Worksheets(1)
    
    With rst
        .MoveFirst
        '输出内容
        Do While Not .EOF
            For intCol = 0 To .Fields.Count - 1
                oExcelSheet.Cells(intRow + 1, intCol + 1) = .Fields(intCol).Value
            Next intCol
            .MoveNext
            intRow = intRow + 1
        Loop
    End With
    
    '关闭所有提示
    oExcel.AlertBeforeOverwriting = False
    oExcel.PromptForSummaryInfo = False
    oExcel.ShowStartupDialog = False
        oExcelBook.SaveAs sFileName
    '自动杀掉Excel进程
    'xlAutoOpen=1;xlAutoClose=2
    oExcelBook.RunAutoMacros (1) '运行EXCEL启动宏
    oExcelBook.RunAutoMacros (2) '运行EXCEL关闭宏
    oExcel.Quit    Set oExcel = Nothing
    Set oExcelBook = Nothing
    Set oExcelSheet = Nothing
         
End Sub