TO:henrryzhang(North Wolf) 有EMAIL或QQ吗?谢谢你愿意帮我。
我用类似的方法,修改visdata上导出DBF的例子,已成功,但导出XLS文件却不行。
Private Sub Command3_Click()   '------点击导出按钮触发事件
    SetCommDlg
    MDIFrmMain.dlgCMD1.Flags = FileOpenConstants.cdlOFNHideReadOnly
    MDIFrmMain.dlgCMD1.ShowSave
    If Len(MDIFrmMain.dlgCMD1.FileName) > 0 Then
        Dim DBName As String
        DBName = "dbo.KDB_Bank"
        export DBName, (MDIFrmMain.dlgCMD1.FileName)
    End If
End SubSub export(rsFromTbl As String, rsToDB As String)
  Dim sConnect, sConnect1 As String
  Dim sNewTblName As String
  Dim sDBName As String
  Dim nErrState As Integer
  Dim idxFrom As Index
  Dim idxTo As Index
  Dim sSQL As String              'local copy of sql string
  Dim sField As String
  Dim sFrom As String
  Dim sTmp As String
  Dim i As Integer  On Error Resume Next
  '设置 DBEngine
  DBEngine.IniPath = "HKEY_CURRENT_USER\Software\VB and VBA Program Settings\" & APP_CATEGORY & "\" & APPNAME
  DBEngine.DefaultUser = "admin"
  DBEngine.DefaultPassword = vbNullString
  Set gwsMainWS = DBEngine.CreateWorkspace("MainWS", "admin", vbNullString)
  Workspaces.Append gwsMainWS
  gwsMainWS.BeginTrans
    If Err.Number <> 0 Then
        MsgBox Err.Number & Err.Description
        Exit Sub
    End If
    nErrState = 1
    
    '*********sql数据库连接
    sConnect1 = GetODBCString()
    Set gExpDB = gwsMainWS.OpenDatabase("", 0, 0, sConnect1)
    GetODBCConnectParts gExpDB.Connect
    '*********sql数据库连接
    
    'sDBName = StripFileName(rsToDB)
    'MsgBox "导出表:'" & rsFromTbl & "'", True
    'sConnect = "[FoxPro 2.6;database=" & StripFileName(rsToDB) & "]."
    'Set gdbCurrentDB = gwsMainWS.OpenDatabase(sDBName, 0, 0, "FoxPro 2.6;")
    sConnect = "[Excel 5.0;database=" & rsToDB & "]."
    Set gdbCurrentDB = gwsMainWS.OpenDatabase(rsToDB, 0, 0, "Excel 5.0;")
    'sConnect1 = "ODBC;DSN=NewVankeoa;UID=sa;PWD=;Database=NewVankeoa;"    'gExpDB
    'DBF
      sNewTblName = "dbo.KDB_Bank"
       '     For i = Len(rsToDB) To 1 Step -1
        '      If Mid(rsToDB, i, 1) = "\" Then
         '       Exit For
       '       End If
       '     Next
       '     sTmp = Mid(rsToDB, i + 1, Len(rsToDB))
       '     'strip off the extension
       '     For i = 1 To Len(sTmp)
       '       If Mid(sTmp, i, 1) = "." Then
       '         Exit For
       '       End If
       '     Next
       '     sNewTblName = Left(sTmp, i - 1)    Screen.MousePointer = vbHourglass
    'gdbCurrentDB.Execute "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)
    'MsgBox "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)
    gExpDB.Execute "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)
    'gExpDB.Execute "select * into " & sConnect & StripOwner(sNewTblName) & " from " & StripOwner(rsFromTbl)    Screen.MousePointer = vbDefault
    MsgBox "成功导出:'" & rsFromTbl & "'", 64
End SubPrivate Sub SetCommDlg()
   With MDIFrmMain.dlgCMD1
     .DialogTitle = "MSG4"
     .Filter = "Excel (*.xls)|*.xls"
     .Flags = FileOpenConstants.cdlOFNOverwritePrompt Or FileOpenConstants.cdlOFNHideReadOnly
       
     .FilterIndex = 1
     .FileName = vbNullString
     .CancelError = True
  End With
End Sub