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
我用类似的方法,修改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
http://support.microsoft.com/default.aspx?scid=KB;en-us;q247412