根据SQL语句导出数据到txt记事本

发布日期：2025-02-04 18:28    点击次数：136

可以自己指定sql语句导出，并且可以指定导出的分隔符号“，”、“|”、“;”、空格、制表符等。

'=====================================================

'函数名称： SQLExportToTxt

'功能描述： 根据SQL语句导出数据到记事本

'输入参数： strSQL 必选的。select选择性SQL语句

' FileName 可选。导出的记事本文件名

' Separator 可选。分隔符，可以是“，”、“|”、“;”、空格、制表符

'返回参数： 无

'使用示例： SQLExportToTxt "select * from 表名称/查询名称","导出数据.txt",","

'作 者： 金宇

'创建日期： 2012-8-19

'=====================================================

Public Function SQLExportToTxt(ByVal strSQL As String, ByVal FileName As String, ByVal Separator As Variant)

On Error GoTo Err_ExportToTxt

Dim intI As Integer

Dim intMsgResult As VbMsgBoxResult

Dim rstCount As Long

Dim rst As Adodb.Recordset

Dim FileNumber As Integer

Dim sText As String

Dim I As Long

rstCount = CurrentProject.Connection.Execute("select count(*) from (" & strSQL & ") as temp_A")(0).Value '取总的记录数

If rstCount = 0 Then

MsgBox ("没有数据可导出！"), vbExclamation, "提示"

Exit Function

End If

If Trim$(FileName) = "" Then FileName = "导出的数据.txt"

If Not FileName Like "*.txt" Then

FileName = FileName & ".txt"

End If

If Not (FileName Like "[A-z]:\*" or FileName Like "\\*") Then

With Application.FileDialog(2)

.InitialFileName = FileName

.AllowMultiSelect = False

If .Show Then

FileName = .SelectedItems(1)

Else

Exit Function

End If

End With

End If

'如果txt文件已存在，则先删除

If Dir(FileName) "" Then Kill FileName

Set rst = New Adodb.Recordset

rst.Open strSQL, CurrentProject.Connection, 1, 1

FileNumber = FreeFile ' Get unused file number

Open FileName For Append As #FileNumber ' Connect to the file

Do While Not rst.EOF

sText = ""

For intI = 0 To rst.Fields.Count - 1

sText = sText & rst.Fields(intI) & Separator

Next

sText = Left(sText, Len(sText) - 1)

Print #FileNumber, sText ' Append our string

rst.MoveNext

Loop

rst.Close

Close #FileNumber ' Close the file

intMsgResult = MsgBox("数据已导出，是否打开并查看？", vbQuestion + vbYesNo)

If intMsgResult = vbYes Then ShellEx (FileName) '打开文件

Exit_ExportToTxt:

On Error Resume Next

DoCmd.Hourglass False

Exit Function

Err_ExportToTxt:

If Err = 70 Then

MsgBox "无法删除文件 '" & FileName & "'，可能该文件已被打开或没有权限。", vbCritical

Else

MsgBox Err.Source & " #" & Err & vbCrLf & vbCrLf & Err.Description, vbCritical

End If

Resume Exit_ExportToTxt

End Function

演 示：