You need to enable JavaScript to run this app.
优惠活动
大模型
产品
解决方案
定价
更多

合并Access中两个TransposeToTxt函数输出至同一文件的问题

avatar
DevOps 小满
2026-7-25
问题描述

我有两个功能类似的VBA函数fnTransposeToTxt，都能通过FileDialog弹窗将数据导出为特定格式的文本文件。现在需要把两个函数的输出合并到同一个文件里，让第二个函数的内容紧跟在第一个之后，但自己编写的ExportToTxt函数总是报“文件已打开”或“无效名称”错误，求解决。

原第一个函数代码 

Option Compare Database
Option Explicit

Public Function fnTransposeToTxt()

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fd As DAO.Field
    Dim fnum As Integer
    Dim path As String
    Dim OK As Boolean
    Dim var As Variant
    ' export to this file
    path = FilToSave
    
    fnum = FreeFile
    
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            
            OK = True
            
            Open path For Output As fnum
            
        End If
        Do Until .EOF
            For Each fd In .Fields
                var = fd.Value
                Select Case fd.Name
                    Case "AFLKOEF"
                        var = Format$(var, "0.0")
                        var = Replace(var, ",", ".")
                    Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "PERPEND", "AFSTRØM"
                        var = Format$(var, "0.00")
                        var = Replace(var, ",", ".")
                    Case "DIMENSION"
                        var = Format$(var, "0.000")
                        var = Replace(var, ",", ".")
                    Case "OPLAND"
                        var = Format$(var, "0.0000")
                        var = Replace(var, ",", ".")
                End Select
                Print #fnum, fd.Name & " " & var
            Next
            .MoveNext
            If Not (.EOF) Then
                Print #fnum, ""
            End If
        Loop
        .Close
    End With
    
    Set rst = Nothing
    Set dbs = Nothing
    If OK Then
        Close #fnum
    
        MsgBox "table imported to " & path
    End If
End Function

原第二个函数代码 

Option Compare Database
Option Explicit

Public Function fnTransposeToTxt()

    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fd As DAO.Field
    Dim fnum As Integer
    Dim path As String
    Dim OK As Boolean
    Dim var As Variant
    Dim foundXY As Boolean
    ' export to this file
    path = FilToSave
    
    fnum = FreeFile
    
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            
            OK = True
            
            Open path For Output As fnum
            
        End If
        Do Until .EOF
            foundXY = False
            For Each fd In .Fields
                var = fd.Value
                Select Case fd.Name
                    Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
                        var = Format$(var, "0.0")
                        var = Replace(var, ",", ".")
                    Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "PERPEND", "AFSTRØM"
                        var = Format$(var, "0.00")
                        var = Replace(var, ",", ".")
                        If fd.Name = "XY" Then
                            foundXY = True
                        End If
                    Case "DIMENSION"
                        var = Format$(var, "0")
                        var = Replace(var, ",", ".")
                    Case "XY1"
                        var = Format$(var, "0.00")
                        var = Replace(var, ",", ".")
                        If foundXY Then
                            Print #fnum, "XY " & var
                        Else
                            Print #fnum, "XY"
                            foundXY = True
                        End If
                End Select
                If fd.Name <> "XY1" Then
                    Print #fnum, fd.Name & " " & var
                End If
            Next
            .MoveNext
            If Not (.EOF) Then
                Print #fnum, ""
            End If
        Loop
        .Close
    End With
    
    Set rst = Nothing
    Set dbs = Nothing
    If OK Then
        Close #fnum
    
        MsgBox "table imported to " & path
    End If
End Function

我尝试的错误代码 

Option Compare Database
Option Explicit

Public Function ExportToTxt()
    
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fd As DAO.Field
    Dim fnum As Integer
    Dim path As String
    Dim OK As Boolean
    Dim var As Variant
    Dim foundXY As Boolean
    Dim ff As Long
    
    ' export to this file
    path = FilToSave
    
    fnum = FreeFile
    
    Set dbs = CurrentDb
    
    ' open recordset for table VBK_Knude
    Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            OK = True
            Open path For Output As fnum
            Do Until .EOF
                For Each fd In .Fields
                    var = fd.Value
                    Select Case fd.Name
                        Case "AFLKOEF"
                            var = Format$(var, "0.0")
                            var = Replace(var, ",", ".")
                        Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "AFSTRØM" ' Removed duplicate "PERPEND" case
                            var = Format$(var, "0.00")
                            var = Replace(var, ",", ".")
                        Case "DIMENSION"
                            var = Format$(var, "0.000")
                            var = Replace(var, ",", ".")
                        Case "OPLAND"
                            var = Format$(var, "0.0000")
                            var = Replace(var, ",", ".")
                    End Select
                    Print #fnum, fd.Name & " " & var
                Next
                .MoveNext
                If Not (.EOF) Then
                    Print #fnum, ""
                End If
            Loop
        End If
        .Close
    End With
   
    ' open recordset for table VBK_Ledning
    Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
    
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            
            OK = True
            
            ' check if file is already open
            ff = FreeFile
            On Error Resume Next
            Open path For Append Access Write Lock Write As #ff
            If Err.Number = 70 Then ' file is already open
                Close #ff
                OK = False
                MsgBox "File " & path & " is already open. Please close the file and try again."
                Exit Function
            End If
            On Error GoTo 0
            
            ' append to file opened earlier
            
            Do Until .EOF
                foundXY = False
                For Each fd In .Fields
                    var = fd.Value
                    Select Case fd.Name
                        Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
                            var = Format$(var, "0.0")
                            var = Replace(var, ",", ".")
                        Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "AFSTRØM" ' Removed duplicate "PERPEND" case
                            var = Format$(var, "0.00")
                            var = Replace(var, ",", ".")
                            If fd.Name = "XY" Then
                                foundXY = True
                            End If
                Case "DIMENSION"
                    var = Format$(var, "0")
                    var = Replace(var, ",", ".")
                Case "XY1"
                    var = Format$(var, "0.00")
                    var = Replace(var, ",", ".")
                    If foundXY Then
                        Print #fnum, "XY " & var
                    Else
                        Print #fnum, "XY"
                        foundXY = True
                    End If ' Add this line
            End Select
            
            If fd.Name <> "XY1" Then
                Print #fnum, fd.Name & " " & var
            End If
            Next
            .MoveNext
            If Not (.EOF) Then
                Print #fnum, ""
            End If
            ' close the file before opening it again
            Close #fnum
            Loop
        End If
        .Close
    End With
    Set rst = Nothing
    Set dbs = Nothing
    
    If OK Then
        Close #fnum
    
        MsgBox "table imported to " & path
    End If
End Function

修正后的合并导出函数 

Option Compare Database
Option Explicit

Public Function ExportToTxt()
    Dim dbs As DAO.Database
    Dim rst As DAO.Recordset
    Dim fd As DAO.Field
    Dim fnum As Integer
    Dim path As String
    Dim OK As Boolean
    Dim var As Variant
    Dim foundXY As Boolean
    
    ' 获取保存路径
    path = FilToSave
    If path = "" Then Exit Function ' 处理未选择路径的情况
    
    fnum = FreeFile
    OK = False
    
    ' 打开文件准备写入（覆盖原有内容）
    On Error Resume Next
    Open path For Output As #fnum
    If Err.Number <> 0 Then
        MsgBox "无法打开文件：" & Err.Description
        Exit Function
    End If
    On Error GoTo 0
    
    Set dbs = CurrentDb
    
    ' 写入VBK_Knude表数据
    Set rst = dbs.OpenRecordset("VBK_Knude", dbOpenSnapshot, dbReadOnly)
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            OK = True
            Do Until .EOF
                For Each fd In .Fields
                    var = fd.Value
                    Select Case fd.Name
                        Case "AFLKOEF"
                            var = Format$(var, "0.0")
                            var = Replace(var, ",", ".")
                        Case "XY", "TEXTXY", "Z_F", "DYBDE", "OB", "PERPEND", "Q", "STATION", "AFSTRØM"
                            var = Format$(var, "0.00")
                            var = Replace(var, ",", ".")
                        Case "DIMENSION"
                            var = Format$(var, "0.000")
                            var = Replace(var, ",", ".")
                        Case "OPLAND"
                            var = Format$(var, "0.0000")
                            var = Replace(var, ",", ".")
                    End Select
                    Print #fnum, fd.Name & " " & var
                Next
                .MoveNext
                If Not (.EOF) Then Print #fnum, ""
            Loop
        End If
        .Close
    End With
    
    ' 如果第一个表有数据，添加空行分隔两个表的内容（可选）
    If OK Then Print #fnum, ""
    
    ' 写入VBK_Ledning表数据
    Set rst = dbs.OpenRecordset("VBK_Ledning", dbOpenSnapshot, dbReadOnly)
    With rst
        If Not (.BOF And .EOF) Then
            .MoveFirst
            OK = True
            Do Until .EOF
                foundXY = False
                For Each fd In .Fields
                    var = fd.Value
                    Select Case fd.Name
                        Case "AFLKOEF", "FALD", "MANNING", "ACCU_Q"
                            var = Format$(var, "0.0")
                            var = Replace(var, ",", ".")
                        Case "XY", "TEXTXY", "FRA_Z", "TIL_Z", "LÆNGDE", "PERPEND", "REDUKTION", "EXTRA_OB", "AFSTRØM"
                            var = Format$(var, "0.00")
                            var = Replace(var, ",", ".")
                            If fd.Name = "XY" Then foundXY = True
                        Case "DIMENSION"
                            var = Format$(var, "0")
                            var = Replace(var, ",", ".")
                        Case "XY1"
                            var = Format$(var, "0.00")
                            var = Replace(var, ",", ".")
                            If foundXY Then
                                Print #fnum, "XY " & var
                            Else
                                Print #fnum, "XY"
                                foundXY = True
                            End If
                    End Select
                    If fd.Name <> "XY1" Then
                        Print #fnum, fd.Name & " " & var
                    End If
                Next
                .MoveNext
                If Not (.EOF) Then Print #fnum, ""
            Loop
        End If
        .Close
    End With
    
    ' 清理资源
    Set rst = Nothing
    Set dbs = Nothing
    Close #fnum
    
    If OK Then
        MsgBox "数据已导出到：" & path
    Else
        MsgBox "没有数据可导出"
    End If
End Function

错误原因说明

  1. 文件未正确关闭：原尝试代码写完第一个表后未关闭文件，后续又尝试用新文件号打开Append模式，导致文件被占用报错。
  2. 语法错误：原代码中Select Case的分支缩进错误，导致代码结构混乱，触发“无效名称”类错误。
  3. 文件号复用问题：原代码在Append模式下打开新文件号ff，但后续写入仍用旧文件号fnum，导致文件句柄混乱。

修正要点

  • 全程使用同一个文件号打开文件，一次性完成两个表的写入，避免重复打开/关闭的问题。
  • 修复Select Case的缩进错误，确保代码语法正确。
  • 添加文件打开错误的捕获处理，避免因权限、文件占用等问题崩溃。
  • 可选添加两个表数据之间的空行分隔，提升可读性。

内容的提问来源于stack exchange，提问作者FoolzRailer

相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分)， 限时 9.9 元起

产品介绍相关文档
相关产品推荐
方舟 Agent Plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列、Doubao-Seedream-5.0-pro、Kimi-K3 (部分)， 限时 9.9 元起

产品介绍相关文档
火山引擎 最新活动
全面开放
Doubao-Seedance-2.5全新模型升级

模型再升级,30秒超长叙事, 模态参考扩容

HOT
方舟Codingplan

模型自由，工具不限，最新支持 Deepseek-V4 系列、GLM-5.3 系列

HOT
方舟Agent plan

超全模态模型 × Harness 升级，最新支持 Deepseek-V4.1-Flash、GLM-5.3 系列

HOT
新用户特惠专场

大模型19元起，Al应用9.9元畅享，新人首购爆款尽享优惠

最近更新时间：2026.07.25 17:27:00