LoginSignup
1
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

@sato_7411(Kazunori Sato)

MS Access エクスポートツール

Posted at

はじめに

Microsoft Access VBA でフォーム、テーブル、クエリ、マクロ、モジュールなどをテキストファイルにエクスポートする方法については、ウェブ検索するといくつかの方法が見つかります。本文では、自分の環境用にまとめています。

Python（win32com.client）を使用して作成した Excel エクスポートツールは動作したのですが、Access 用を作成するとどうしても動作しなかったため、VBA で作成しました。
　

使用方法

エクスポートを実行する余分なモジュールを追加するので、元の *.accdb ファイルはバックアップを取っておいてください。

運用で使用している Access のファイルを開き、［作成］タブから［Visual Basic］を選択します。

011_ACCESS-Visual_Basic.png

　
マウス右クリックで表示されるメニューから、［挿入］－［標準モジュール］を選択します。

021_ACCESS-標準モジュールの挿入.png

空のモジュールが作成されたら、別途テキストファイルで用意しておいた access_export.bas の内容をコピーして貼り付けます（1行目の「Option Compare Database」は削除します）。この際、access_export.bas のテキストファイルは文字コードが UTF-8 であっても、Access の標準モジュールに追加された後、文字コードが SJIS に変換される点に注意してください。

022_ACCESS-Module1コード1.png

三角ボタンをクリックして（またはF5ボタンを押下、またはメニューの［実行］－［Sub/ユーザー フォームの実行］を選択して）モジュールを実行します。実行可能な複数のモジュールがある場合は、モジュールを選択するウィンドウが表示されるので ExportModules を選択します。正常に実行された場合は何も表示されませんが、実際に実行されたかどうかを判断するために、事前にプログラムコードの最初にブレークポイントを設定しておくと良いでしょう。

023_ACCESS-Module1コード2m.png

　

031_ACCESS-マクロの実行.png

プログラムの記述にあるように、src フォルダ内のファイル名と同じ名前のフォルダに、エクスポートされたフォーム、テーブル、クエリ、マクロ、モジュールなどのテキストファイルが保存されます。

作成した Module1 は、実際の運用では不要なので、削除するか、バックアップしていた *.accdb ファイルで上書きして元の状態に戻します。

　

セキュリティ

インターネット経由でダウンロードしたファイルは、マクロの実行が許可されていない場合があります。その際は、ファイルのプロパティ（エクスプローラでマウス右クリック）からアクセス許可を行います。

入手したファイルのアクセス許可.png

　
クエリを実行する際に都度メッセージが表示されないように、以下の設定を行います。Access のメニューの［ファイル］－［オプション］、「クライアントの設定」で変更します。

Accessクライアントの設定.png

　
マクロが実行可能になるよう、以下の設定を行います。Access のメニューの［ファイル］－［オプション］－［トラストセンター］、「マクロの設定」で変更します。

Accessマクロの設定.png

access_export.bas

実際は1つのテキストファイルですが、分割して示します。

メインといくつかのサブルーチン

access_export.bas (1/11)
Option Explicit

'Accessエクスポートツール

Public Sub ExportModules()
    Dim outputDirectory As String
    Dim currentData As Object
    Dim currentProject As Object
    Dim tableDef As DAO.TableDef

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    outputDirectory = GetDir(CurrentDb.Name)

    outputDirectory = outputDirectory & "\" & "src" 'srcフォルダに出力する
    If Not fso.FolderExists(outputDirectory) Then
        fso.CreateFolder outputDirectory
    End If

    outputDirectory = outputDirectory & "\" & GetFileNameWithoutExt(CurrentDb.Name) 'ファイル名のフォルダに出力する
    If Not fso.FolderExists(outputDirectory) Then
        fso.CreateFolder outputDirectory
    End If

    Set currentData = Application.CurrentData
    Set currentProject = Application.CurrentProject
    ExportByObjType acQuery, currentData.AllQueries, outputDirectory, ".qry"
    ExportByObjType acForm, currentProject.AllForms, outputDirectory, ".frm"
    ExportByObjType acReport, currentProject.AllReports, outputDirectory, ".rpt"
    ExportByObjType acMacro, currentProject.AllMacros, outputDirectory, ".mcr"
    ExportModuleStdClass acModule, currentProject.AllModules, outputDirectory, ".bas", ".cls" ' 又は .mdl


    ' DAOを使ってデータベース内の全テーブルをループ処理
    'For Each tableDef In CurrentDb.TableDefs
    '    ' システムテーブルを除外
    '    If Left(tableDef.Name, 4) <> "MSys" Then
    '        Dim filePath As String
    '        filePath = outputDirectory & "\" & tableDef.Name & ".txt"
    '
    '        ' テーブルをテキスト形式でエクスポート
    '        DoCmd.TransferText _
    '            TransferType:=acExportDelim, _
    '            TableName:=tableDef.Name, _
    '            FileName:=filePath, _
    '            HasFieldNames:=True  ' フィールド名を含める
    '
    '        Debug.Print "テーブル '" & tableDef.Name & "' をテキスト形式で '" & filePath & "' に保存しました。"
    '    End If
    'Next tableDef


    ' DAOを使ってデータベース内の全テーブルをループ処理
    For Each tableDef In CurrentDb.TableDefs
        ' システムテーブルを除外
        If Left(tableDef.Name, 4) <> "MSys" Then
            Dim field As DAO.Field
            Dim filePath As String
            Dim fileNum As Integer
            ' テーブル定義のエクスポートファイルのパス
            filePath = outputDirectory & "\" & tableDef.Name & ".txt"
            fileNum = FreeFile
            
            ' ファイルを開いてテーブル定義を書き込む
            Open filePath For Output As fileNum
            Print #fileNum, "Table Name: " & tableDef.Name
            Print #fileNum, "--------------------------------------------------"
            Print #fileNum, "Field Name | Data Type | Size"
            Print #fileNum, "--------------------------------------------------"
            
            ' 各フィールドの定義を取得
            For Each field In tableDef.Fields
                Print #fileNum, field.Name & " | " & FieldTypeName(field.Type) & " | " & field.Size
            Next field
            
            ' ファイルを閉じる
            Close fileNum
            
            Debug.Print "テーブル定義 '" & tableDef.Name & "' を '" & filePath & "' に保存しました。"
        End If
    Next tableDef


    ' 全クエリのSQLコードを指定フォルダにUTF-8でエクスポートする
    Dim qdf As DAO.QueryDef
    For Each qdf In CurrentDb.QueryDefs
        filePath = outputDirectory & "\" & qdf.Name & ".sql"
        
        ' UTF-8形式でファイルに書き込み
        WriteSQLFileInUTF8 filePath, qdf.SQL
        
        Debug.Print "クエリ '" & qdf.Name & "' を '" & filePath & "' に保存しました。"
    Next qdf 
    Set qdf = Nothing


    ConvertUTF16FilesToUTF8 outputDirectory '.qry .frm .rpt .mcr
    ConvertSJISFilesToUTF8 outputDirectory ' .txt [.bas .cls](又は .mdl)

    ExportFormCode acForm, currentProject.AllForms, outputDirectory, ".frm" ' -> ".cls"

End Sub

Private Function FieldTypeName(fieldType As Integer) As String
    Select Case fieldType
        Case dbBoolean: FieldTypeName = "Boolean"
        Case dbByte: FieldTypeName = "Byte"
        Case dbInteger: FieldTypeName = "Integer"
        Case dbLong: FieldTypeName = "Long"
        Case dbCurrency: FieldTypeName = "Currency"
        Case dbSingle: FieldTypeName = "Single"
        Case dbDouble: FieldTypeName = "Double"
        Case dbDate: FieldTypeName = "Date"
        Case dbText: FieldTypeName = "Text"
        Case dbLongBinary: FieldTypeName = "LongBinary"
        Case dbMemo: FieldTypeName = "Memo"
        Case dbGUID: FieldTypeName = "GUID"
        Case Else: FieldTypeName = "Unknown"
    End Select
End Function

Private Function GetDir(FileName As String) As String
    Dim p As Integer

    GetDir = FileName
    p = InStrRev(FileName, "\")
    If p > 0 Then GetDir = Left(FileName, p - 1)
End Function

Private Sub ExportByObjType(ObjType As Integer, ObjCollection As Variant, Path As String, Ext As String)

    Dim obj As Variant
    Dim filePath As String
    
    For Each obj In ObjCollection
        filePath = Path & "\" & obj.Name & Ext
        SaveAsText ObjType, obj.Name, filePath
        Debug.Print "Save " & obj.Name
    Next
End Sub

Private Sub ExportModuleStdClass(ObjType As Integer, ObjCollection As Variant, Path As String, Ext1 As String, Ext2 As String)

    Dim obj As Variant
    Dim filePath As String
    
    For Each obj In ObjCollection
        If Right(obj.name, 5) = "Class" Then ' vbext_ct_ClassModules
            filePath = Path & "\" & obj.name & Ext2
        Else ' vbext_ct_StdModules
            filePath = Path & "\" & obj.name & Ext1
        End If
        SaveAsText ObjType, obj.name, filePath
        Debug.Print "Save " & obj.name
    Next
End Sub

Private Function IsInArray(value As String, arr As Variant) As Boolean
    Dim i As Integer
    IsInArray = False
    For i = LBound(arr) To UBound(arr)
        If arr(i) = value Then
            IsInArray = True
            Exit Function
        End If
    Next i
End Function

Private Sub ExportFormCode(ObjType As Integer, ObjCollection As Variant, Path As String, Ext As String)
    Dim obj As Variant
    Dim formName As String
    
    For Each obj In ObjCollection
        formName = obj.Name
        ExportFormCodeAsClassFile Path, formName
        Debug.Print "Save " & obj.Name
    Next
End Sub

拡張子を除いたファイル名を取得

access_export.bas (2/11)
'拡張子を除いたファイル名を取得
Private Function GetFileNameWithoutExt(FileName As String) As String
    Dim pSlash As Integer
    Dim pDot As Integer
    Dim dirPath As String
    Dim fileNameWithoutExt As String

    ' 最後のバックスラッシュの位置を取得
    pSlash = InStrRev(FileName, "\")
    ' 最後のピリオドの位置を取得
    pDot = InStrRev(FileName, ".")

    ' ディレクトリパスを取得
    If pSlash > 0 Then
        dirPath = Left(FileName, pSlash - 1)
    Else
        dirPath = ""
    End If

    ' 拡張子を除いたファイル名を取得
    If pDot > pSlash Then
        GetFileNameWithoutExt = Mid(FileName, pSlash + 1, pDot - pSlash - 1)
    Else
        GetFileNameWithoutExt = Mid(FileName, pSlash + 1)
    End If
End Function

Access のフォームの VBA コードをクラスファイルとして保存する

access_export.bas (3/11)
'Access のフォームの VBA コードをクラスファイルとして保存する
Sub ExportFormCodeAsClassFile(savePath As String, formName As String)
    Dim filePath1 As String
    Dim filePath2 As String
    Dim stream1 As Object
    Dim stream2 As Object
    Dim startAdding As Boolean
    Dim textData As String
    Dim bufLine As String

    filePath1 = savePath & "\" & formName & ".frm" ' 保存済み、UTF-8 に変換したフォームファイルを開く
    filePath2 = savePath & "\Form_" & formName & ".cls"

    Set stream1 = CreateObject("ADODB.Stream")
    stream1.Type = 2
    stream1.Charset = "utf-8"
    stream1.Open
    stream1.LoadFromFile filePath1

    Set stream2 = CreateObject("ADODB.Stream")
    stream2.Type = 2
    stream2.Charset = "utf-8"
    stream2.Open

    startAdding = False
    textData = ""

    Do While Not stream1.EOS
        bufLine = stream1.ReadText(-2)
        If startAdding Then
            textData = textData & bufLine & vbCrLf
        End If
        If Not startAdding Then
            If InStr(bufLine, "CodeBehindForm") > 0 Then ' CodeBehindForm の行は含まない
                startAdding = True
            End If
        End If
    Loop

    stream2.writeText textData
    stream2.SaveToFile filePath2, 2 
    stream1.Close
    stream2.Close
    Set stream1 = Nothing
    Set stream2 = Nothing
End Sub

指定フォルダ内の特定の拡張子を持つファイルをUTF-8形式で保存し直す（UTF-16）

access_export.bas (4/12)
'指定フォルダ内の特定の拡張子を持つファイルをUTF-8形式で保存し直す
Public Sub ConvertUTF16FilesToUTF8(folderPath As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    ' FileSystemObjectの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません: " & folderPath
        Exit Sub
    End If
    
    ' フォルダオブジェクトを取得
    Set folder = fso.GetFolder(folderPath)
    
    ' 対象ファイルの拡張子を定義
    Dim targetExtensions As Variant
    targetExtensions = Array("qry", "frm", "rpt", "mcr")
    
    ' フォルダ内のすべてのファイルをループ処理
    For Each file In folder.Files
        Dim fileExt As String
        fileExt = fso.GetExtensionName(file.Name)
        
        ' 対象の拡張子であればUTF-8形式で再保存
        If IsInArray(fileExt, targetExtensions) Then
            ConvertUTF16FileToUTF8 file.Path
        End If
    Next file
    
    ' クリーンアップ
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
End Sub

ファイルをUTF-8形式で再保存する関数（UTF-16）

access_export.bas (5/11)
'ファイルをUTF-8形式で再保存する関数
Private Sub ConvertUTF16FileToUTF8(filePath As String)
    Dim fileContent As String
    Dim utf8FilePath As String
    
    ' ファイルの内容を読み込む
    fileContent = ReadUTF16FileContent(filePath)
    
    ' UTF-8形式で再保存
    WriteFileInUTF8 filePath, fileContent
    
    Debug.Print "ファイル '" & filePath & "' をUTF-8形式で再保存しました。"
End Sub

UTF-16形式でファイルの内容を読み込む関数

access_export.bas (6/11)
'UTF-16形式でファイルの内容を読み込む関数
Private Function ReadUTF16FileContent(filePath As String) As String
    Dim fso As Object
    Dim file As Object
    Dim content As String
    
    ' FileSystemObjectの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' UTF-16形式でファイルを開く（3: Unicode（UTF-16）として読み込み）
    Set file = fso.OpenTextFile(filePath, 1, False, -1) ' 1: ForReading, False: Create, -1: Unicode
    
    ' ファイルの内容を読み込む
    content = file.ReadAll
    
    ' ファイルを閉じる
    file.Close
    
    ' オブジェクトのクリーンアップ
    Set file = Nothing
    Set fso = Nothing
    
    ReadUTF16FileContent = content
End Function

UTF-8形式でファイルに書き込むサブルーチン

access_export.bas (7/11)
'UTF-8形式でファイルに書き込むサブルーチン
Private Sub WriteFileInUTF8(filePath As String, content As String)
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    ' UTF-8形式でストリームを設定
    With stream
        .Type = 2  ' テキストストリームとして設定
        .Charset = "UTF-8"  ' UTF-8エンコードを指定
        .Open
        .WriteText content  ' 内容を書き込み
        .SaveToFile filePath, 2  ' ファイルに保存（2: 上書き保存）
        .Close
    End With
    
    ' クリーンアップ
    Set stream = Nothing
End Sub

指定フォルダ内の特定の拡張子を持つファイルをUTF-8形式で保存し直す（SJIS）

access_export.bas (8/11)
'指定フォルダ内の特定の拡張子を持つファイルをUTF-8形式で保存し直す
Public Sub ConvertSJISFilesToUTF8(folderPath As String)
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    
    ' FileSystemObjectの作成
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    ' フォルダが存在するか確認
    If Not fso.FolderExists(folderPath) Then
        MsgBox "指定されたフォルダが存在しません: " & folderPath
        Exit Sub
    End If
    
    ' フォルダオブジェクトを取得
    Set folder = fso.GetFolder(folderPath)
    
    ' 対象ファイルの拡張子を定義
    Dim targetExtensions As Variant
    targetExtensions = Array("txt", "bas", "cls") ' 又は mdl
    
    ' フォルダ内のすべてのファイルをループ処理
    For Each file In folder.Files
        Dim fileExt As String
        fileExt = fso.GetExtensionName(file.Name)
        
        ' 対象の拡張子であればUTF-8形式で再保存
        If IsInArray(fileExt, targetExtensions) Then
            ConvertSJISFileToUTF8 file.Path
        End If
    Next file
    
    ' クリーンアップ
    Set file = Nothing
    Set folder = Nothing
    Set fso = Nothing
End Sub

ファイルをUTF-8形式で再保存する関数（SJIS）

access_export.bas (9/11)
'ファイルをUTF-8形式で再保存する関数
Private Sub ConvertSJISFileToUTF8(filePath As String)
    Dim fileContent As String
    Dim utf8FilePath As String
    
    ' ファイルの内容を読み込む
    fileContent = ReadSJISFileContent(filePath)
    
    ' UTF-8形式で再保存
    WriteFileInUTF8 filePath, fileContent
    
    Debug.Print "ファイル '" & filePath & "' をUTF-8形式で再保存しました。"
End Sub

SJIS形式でファイルの内容を読み込む関数

access_export.bas (10/11)
' SJIS形式でファイルの内容を読み込む関数
Private Function ReadSJISFileContent(filePath As String) As String
    Dim stream As Object
    Dim content As String
    
    ' ADODB.Streamオブジェクトの作成
    Set stream = CreateObject("ADODB.Stream")
    
    ' Shift JIS形式でストリームを設定
    With stream
        .Type = 2  ' テキストモード
        .Charset = "Shift-JIS"  ' Shift JIS（SJIS）エンコードを指定
        .Open
        .LoadFromFile filePath  ' ファイルを読み込む
        content = .ReadText  ' ファイル内容を読み込む
        .Close
    End With
    
    ' クリーンアップ
    Set stream = Nothing
    
    ' 結果を返す
    ReadSJISFileContent = content
End Function

UTF-8形式でSQLファイルに書き込むサブルーチン

access_export.bas (11/11)
' UTF-8形式でSQLファイルに書き込むサブルーチン
Private Sub WriteSQLFileInUTF8(filePath As String, content As String)
    Dim stream As Object
    Set stream = CreateObject("ADODB.Stream")
    
    ' UTF-8形式でストリームを設定
    With stream
        .Type = 2  ' テキストストリームとして設定
        .Charset = "UTF-8"  ' UTF-8エンコードを指定
        .Open
        .WriteText content  ' 内容を書き込み
        .SaveToFile filePath, 2  ' ファイルに保存（2: 上書き保存）
        .Close
    End With
    
    ' クリーンアップ
    Set stream = Nothing
End Sub

参考ページ

1
2
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
Sign upLogin
1
2

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?