Accessで お仕事 VBA

Option Compare Database
Option Explicit

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Declare Function AccessibleChildren Lib "oleacc" (ByVal paccContainer As IAccessible, ByVal iChildStart As Long, ByVal cChildren As Long, ByRef rgvarChildren As Any, ByRef pcObtained As Long) As Long
   '「system32」フォルダ内の「oleacc.dll」ファイルを参照する必要があります。
Declare Function AccessibleObjectFromWindow Lib "oleacc" (ByVal hWnd As Long, ByVal dwId As Long, riid As Any, ByRef ppvObject As IAccessible) As Long
Declare Function IIDFromString Lib "ole32" (ByVal lpsz As Long, lpiid As Any) As Long

Const CHILDID_SELF = 0&
Const OBJID_CLIENT = &HFFFFFFFC
Const ROLE_SYSTEM_PANE = &H10
Const ROLE_SYSTEM_PUSHBUTTON = &H2B

Dim インポートするファイルのパス As String
Dim 現在のパス As String
Dim Excelアプリケーション As Object  'Excel 参照用

Dim 開始日時 As Variant
Dim 終了日時 As Variant

'**********************************************************
Sub 前月データを削除してDBを最適化()
'http://www.ka-net.org/office/of18.html
   '初心者備忘録 の下記のコードを、そのまま使わせていただいています。
   '開いているデータベースを最適化する(Access 2010 VBA)
   '「system32」フォルダ内の「oleacc.dll」ファイルを参照する必要があります。

  Dim accApp As IAccessible
  Dim accBackstage As IAccessible
  Dim accBtnCompactAndRepair As IAccessible
  Dim accBtnFile As IAccessible
  Dim accRibbon As IAccessible
  Dim IID(0 To 3) As Long
  
   Call 削除クエリを実行
   Call 指定秒待つ(30)

  Set accRibbon = Application.CommandBars("Ribbon")
  Set accBtnFile = GetAcc(accRibbon, "ファイル タブ", ROLE_SYSTEM_PUSHBUTTON)
  If accBtnFile Is Nothing Then Exit Sub
  Call accBtnFile.accDoDefaultAction(CHILDID_SELF) 'ファイルタブボタンクリック
  DoEvents
  
  Call IIDFromString(StrPtr("{618736E0-3C3D-11CF-810C-00AA00389B71}"), IID(0))
  If AccessibleObjectFromWindow(Application.hWndAccessApp, OBJID_CLIENT, IID(0), accApp) <> 0& Then Exit Sub
  Set accBackstage = GetAcc(accApp, "Backstage ビュー", ROLE_SYSTEM_PANE) 'Backstage
  If accBackstage Is Nothing Then Exit Sub
  Set accBtnCompactAndRepair = GetAcc(accBackstage, "データベースの最適化/修復", ROLE_SYSTEM_PUSHBUTTON)
  If accBtnCompactAndRepair Is Nothing Then Exit Sub
  Call accBtnCompactAndRepair.accDoDefaultAction(CHILDID_SELF) 'データベースの最適化/修復ボタンクリック
End Sub
'**********************************************************

'**********************************************************
Sub 当月データを処理()

   'http://www.ken3.org/backno/hosoku/ETC_021.html
   '三流プログラマー Ken3のＨＰで教えていただいたままです。
   'ファイルを開くダイアログを使えるように、エクセルオブジェクトを作成します
   Set Excelアプリケーション = CreateObject("Excel.Application")
   Excelアプリケーション.Visible = False  '小細工でExcelを見えなくする
   
   現在のパス = CurrentProject.Path
'   Stop
   ChDrive 現在のパス
   ChDir 現在のパス
   ChDrive 現在のパス
   ChDir 現在のパス
   インポートするファイルのパス = Excelアプリケーション.GetOpenFilename("テキストファイル,*.txt")
   開始日時 = Now                ' 開始時刻を変数に格納します。

   Call テキストファイルをインポート
   Call 先頭のドルを空白に
   Call 品番PDCの有効日変更
       
   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
End Sub
'**********************************************************


Private Sub 先頭のドルを空白に()

    '警告ダイアログをOFF
    DoCmd.SetWarnings False

    'クエリを実行する
    DoCmd.OpenQuery "☆1先頭の「$」を「 」に"

    '警告ダイアログをON(戻す)
    DoCmd.SetWarnings True

End Sub


Private Sub 品番PDCの有効日変更()

    '警告ダイアログをOFF
    DoCmd.SetWarnings False

    'クエリを実行する
    DoCmd.OpenQuery "☆3品番PDCの有効日-変更"

    '警告ダイアログをON(戻す)
    DoCmd.SetWarnings True

End Sub


Private Sub テキストファイルをインポート()
'   http://okwave.jp/qa/q1691138.html
'   Access にマクロでテキストファイルをインポートする
'   インポートするレイアウトに合ったテーブルがあること
'   インポート定義があること
'   （定義の作り方は、ファイル→外部データの取り込み→インポート→設定で定義を作成）
'   あとは､以下のコードを変更
'   DoCmd.TransferText acImportFixed, "定義名", "データを格納するテーブル名", "C:\..テキストのパス....txt", False, ""
   
   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.TransferText acImportDelim, "品番PDCインポート定義", "品番PDCデータ", インポートするファイルのパス, False, ""
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True
End Sub

Private Sub 削除クエリを実行()
   Dim 削除クエリ As String
   削除クエリ = "DELETE * FROM [品番PDCデータ];"
   
   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.RunSQL 削除クエリ
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True
   
End Sub


Private Function GetAcc(myAcc As IAccessible, myAccName As String, myAccRole As Long) As IAccessible
  Dim ReturnAcc As IAccessible
  Dim ChildAcc As IAccessible
  Dim List() As Variant
  Dim Count As Long
  Dim i As Long
  
  If (myAcc.accState(CHILDID_SELF) <> 32769) And _
     (myAcc.accName(CHILDID_SELF) = myAccName) And _
     (myAcc.accRole(CHILDID_SELF) = myAccRole) Then
    Set ReturnAcc = myAcc
  Else
    Count = myAcc.accChildCount
    If Count > 0& Then
      ReDim List(Count - 1&)
      If AccessibleChildren(myAcc, 0&, ByVal Count, List(0), Count) = 0& Then
        For i = LBound(List) To UBound(List)
          If TypeOf List(i) Is IAccessible Then
            Set ChildAcc = List(i)
            Set ReturnAcc = GetAcc(ChildAcc, myAccName, myAccRole)
            If Not ReturnAcc Is Nothing Then Exit For
          End If
        Next
      End If
    End If
  End If
  Set GetAcc = ReturnAcc
End Function

Private Sub 指定秒待つ(待ち時間 As Integer)
   DoEvents       ' Sleep しているときに、画面を書き換えできるように、OS に制御を渡す。
   Sleep (待ち時間 * 1000)
End Sub

DoCmd.OpenForm "社員", , ,"[在籍支社] = '大阪支社'"

Sub ShowNewRecord()
    DoCmd.OpenForm "Employees", acNormal
    DoCmd.GoToRecord , , acNewRec
End Sub

DoCmd.SetWarnings False

DoCmd.OpenQuery "Sales Totals Query", , acReadOnly

DoCmd.TransferText acExportDelim, "Standard Output", _
    "External Report", "C:\Txtfiles\April.doc"

DoCmd.RunSQL "UPDATE 社員" & _
    " SET 社員.在籍支社 = '九州支社' " & _
    " WHERE 社員.在籍支社 = '北九州支社';"

Sub ApplicationInformation()
    ' このオブジェクトの名前と型を表示します。
    Debug.Print Application.CurrentProject.FullName
    Debug.Print Application.CurrentProject.ProjectType
    ' オプション・ダイアログ・ボックスの表示タブで、
    ' 隠しオブジェクト・オプションを表示するように設定します。
    Application.SetOption "Show Hidden Objects", True
End Sub

Sub GetAccessData()
' モジュールの宣言部分で、対象変数を宣言します
    Dim appAccess As Access.Application
    Dim strDB As String
    Dim strReportName As String

    strDB = "C:\Program Files\Microsoft "_
        & "Office\Office11\Samples\Northwind.mdb"
    strReportName = InputBox("Enter name of report to be verified", _
        "Report Verification")
    VerifyAccessReport strDB, strReportName
End Sub

Sub VerifyAccessReport(strDB As String, _
     strReportName As String)
    ' Return reference to Microsoft Access
    ' Application object.
    Set appAccess = New Access.Application
    ' Open database in Microsoft Access.
    appAccess.OpenCurrentDatabase strDB
    ' Verify report exists.
    On Error Goto ErrorHandler
    appAccess.CurrentProject.AllReports(strReportName)
    MsgBox "Report " & strReportName & _
        " verified within Northwind database."
    appAccess.CloseCurrentDatabase
    Set appAccess = Nothing
Exit Sub
ErrorHandler:
    MsgBox "Report " & strReportName & _
        " does not exist within Northwind database."
    appAccess.CloseCurrentDatabase
    Set appAccess = Nothing
End Sub

Dim cnn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rst As New ADODB.Recordset
...
cnn.Open "..."
cmd.Name = "yourCommandName"
cmd.ActiveConnection = cnn
...
'Your command name, any parameters, and an optional Recordset.
cnn.yourCommandName "parameter", rst

Dim cnn As New ADODB.Connection
...
'Your stored procedure name and any parameters.
cnn.sp_yourStoredProcedureName "parameter"

Dim インポートするファイルのパス As String
Dim 現在のパス As String
Dim Excelアプリケーション As Object  'Excel 参照用
Dim テーブル名 As String
Dim リンク元ファイル名 As String
Dim インポートするファイルのフォルダ As String

Dim 開始日時 As Variant
Dim 終了日時 As Variant

'***************************************************************
Sub dBaseのデータを取り込む()
'***************************************************************

   'http://www.ken3.org/backno/hosoku/ETC_021.html
   '三流プログラマー Ken3のＨＰで教えていただいたままです。
   'ファイルを開くダイアログを使えるように、エクセルオブジェクトを作成します
   Set Excelアプリケーション = CreateObject("Excel.Application")
   Excelアプリケーション.Visible = False  '小細工でExcelを見えなくする
   
   現在のパス = CurrentProject.Path
'   Stop
   ChDrive 現在のパス
   ChDir 現在のパス
   ChDrive 現在のパス
   ChDir 現在のパス
   インポートするファイルのパス = Excelアプリケーション.GetOpenFilename("dBASEファイル,*.dbf")

    開始日時 = Now                ' 開始時刻を変数に格納します。
   
   Call データベースのリンク追加
   
   Call 更新クエリを書き換えて実行
   
    終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub



Private Sub データベースのリンク追加()

テーブル名 = Left(Dir(インポートするファイルのパス), InStr(Dir(インポートするファイルのパス), ".") - 1)
リンク元ファイル名 = Dir(インポートするファイルのパス)
インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)

   If DLookup("Name", "MSysObjects", "Type=6 and Name='" & テーブル名 & "'") = Null Then
      DoCmd.TransferDatabase acLink, "dBase 5.0", インポートするファイルのフォルダ, acTable, リンク元ファイル名, テーブル名
   End If

End Sub


Private Sub 更新クエリを書き換えて実行()
   Dim 更新クエリ As String
   
   更新クエリ _
   = "UPDATE " & テーブル名 & " INNER JOIN 品番データ ON " & テーブル名 & ".HIN = 品番データ.品番 " _
   & "SET 品番データ.機種G = [KSGRP], 品番データ.補性 = [SEI], 品番データ.補性品番 = [HHIN], " _
   & "品番データ.海外ランク = [SBTW], 品番データ.統合ランク = [SBTA];"

   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.RunSQL 更新クエリ
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True
   
End Sub

DoCmd.TransferDatabase acImport, "Microsoft Access", _
    "C:\DBS\NWSales.mdb", acReport, "年間売上一覧", _
    "総売上"

DoCmd.TransferDatabase acLink, "ODBC Database", _
    "ODBC;DSN=DataSource1;UID=User2;PWD=www;LANGUAGE=us_english;" _
    & "DATABASE=pubs", acTable, "Authors", "dboAuthors"

DoCmd.TransferDatabase acLink, "dBase IV", "C:\DataDir", acTable, "TheDBF", "TheTable"

Option Compare Database
Option Explicit

Dim インポートするファイルのパス As String
Dim 現在のパス As String
Dim Excelアプリケーション As Object  'Excel 参照用
Dim リンク元ファイル名 As String
Dim インポートするファイルのフォルダ As String

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Dim 削除クエリ As String
   
'***************************************************************
Sub dBaseのデータを取り込む()
'***************************************************************

   'http://www.ken3.org/backno/hosoku/ETC_021.html
   '三流プログラマー Ken3のＨＰで教えていただいたままです。
   'ファイルを開くダイアログを使えるように、エクセルオブジェクトを作成します
   Set Excelアプリケーション = CreateObject("Excel.Application")
   Excelアプリケーション.Visible = False  '小細工でExcelを見えなくする
   
   現在のパス = CurrentProject.Path
'   Stop
   ChDrive 現在のパス
   ChDir 現在のパス
   ChDrive 現在のパス
   ChDir 現在のパス
   インポートするファイルのパス = Excelアプリケーション.GetOpenFilename("dBASEファイル,*.dbf")

    開始日時 = Now                ' 開始時刻を変数に格納します。
   
   Call データベースのリンク更新 'ファイル名を変更できなかった。このため、削除・追加で更新する。
   Call データベースのリンク削除
   Call データベースのリンク追加
   
   Call 用品品番差し替え
   
    終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub


Private Sub 用品品番差し替え()

   削除クエリ = "DELETE * FROM [用品品番];"

   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.RunSQL 削除クエリ
   DoCmd.OpenQuery "☆用品品番抽出ソート"
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True

End Sub

Private Sub データベースのリンク更新()

   Dim データベース As DAO.Database, テーブル As DAO.TableDef
   'VBAの画面の、[ツール] - [参照設定]で、DAOオブジェクトライブラリの参照設定を追加する。
   
   Set データベース = CurrentDb
   Set テーブル = データベース.TableDefs("BMF今月")
   
   インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)
   リンク元ファイル名 = Dir(インポートするファイルのパス)
   
   テーブル.Connect = "dBASE 5.0;DATABASE=" & インポートするファイルのフォルダ & ";TABLE=" & リンク元ファイル名
   テーブル.RefreshLink ' リンク情報の更新

End Sub

Private Sub データベースのリンク追加()

   リンク元ファイル名 = Dir(インポートするファイルのパス)
   インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)

   DoCmd.TransferDatabase acLink, "dBase 5.0", インポートするファイルのフォルダ, acTable, リンク元ファイル名, "BMF今月"

End Sub


Private Sub データベースのリンク削除()
   If テーブル存在("BMF今月") = True Then
      '警告ダイアログをOFF
      DoCmd.SetWarnings False
      DoCmd.DeleteObject acTable, "BMF今月"
      '警告ダイアログをON(戻す)
      DoCmd.SetWarnings True
   End If
End Sub


Public Function テーブル存在(テーブル名 As String) As Boolean
   'http://www.accessclub.jp/bbs5/0016/vba4558.html
   'テーブルの存在有無を確認する
   'hatena さんの書き込みより
   On Error Resume Next
   テーブル存在 = CurrentDb.TableDefs(テーブル名).Name = テーブル名
End Function

Sub RefreshLinkX()

    Dim dbsCurrent As Database
    Dim tdfLinked As TableDef

    ' リンク テーブルが追加されたデータベースを開きます。
    Set dbsCurrent = OpenDatabase("DB1.mdb")

    ' Microsoft SQL Server データベースを指定している
    ' リンク テーブルを作成します。
    Set tdfLinked = _
        dbsCurrent.CreateTableDef("AuthorsTable")
    tdfLinked.Connect = _
        "ODBC;DATABASE=pubs;UID=sa;PWD=;DSN=Publishers"
    tdfLinked.SourceTableName = "authors"
    dbsCurrent.TableDefs.Append tdfLinked

    ' リンク テーブルの内容を表示します。
    Debug.Print _
        "Data from linked table connected to first source:"
    RefreshLinkOutput dbsCurrent

    ' リンク テーブルの接続情報を変更し
    ' 新しいデータを使用可能にするために、接続を更新します。
    tdfLinked.Connect = _
        "ODBC;DATABASE=pubs;UID=sa;PWD=;DSN=NewPublishers"
    tdfLinked.RefreshLink

    ' リンク テーブルの内容を表示します。
    Debug.Print _
        "Data from linked table connected to second source:"
    RefreshLinkOutput dbsCurrent

    ' ここではデモとしてリンク テーブルを削除します。
    dbsCurrent.TableDefs.Delete tdfLinked.Name

    dbsCurrent.Close

End Sub

Sub RefreshLinkOutput(dbsTemp As Database)

    Dim rstRemote As Recordset
    Dim intCount As Integer

    ' リンク テーブルを開きます。
    Set rstRemote = _
        dbsTemp.OpenRecordset("AuthorsTable")

    intCount = 0

    ' Recordset を列挙し
    ' その数が 50 になったら列挙を中止します。
    With rstRemote
        Do While Not .EOF And intCount < 50
            Debug.Print , .Fields(0), .Fields(1)
            intCount = intCount + 1
            .MoveNext
        Loop
        If Not .EOF Then Debug.Print , "[more records]"
        .Close
    End With

End Sub

Option Compare Database
Option Explicit

Dim インポートするファイルのパス As String
Dim 現在のパス As String
Dim Excelアプリケーション As Object  'Excel 参照用
Dim テーブル名 As String
Dim リンク元ファイル名 As String
Dim インポートするファイルのフォルダ As String
Dim 前月テーブル名 As String
Dim 指定するファイルの種類 As String
Dim テーブル名前月 As String
Dim 年月 As String
Dim 前年月 As String

Dim 開始日時 As Variant
Dim 終了日時 As Variant

Sub 処理()

   MsgBox "次の処理で、dBASEのBMF を指定します。"
   指定するファイルの種類 = "dBASEファイル,*.dbf"
   
   Call インポートするファイルのパスを取得
   
   Call データベースのリンク更新 'ファイル名を変更できなかった。このため、削除・追加で更新する。
   Call データベースのリンク削除
   Call データベースのリンク追加


   MsgBox "次の処理で、エラーリストを指定します。"
   指定するファイルの種類 = "テキストファイル,*.csv"
   
   Call インポートするファイルのパスを取得
   
   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   テーブル名 = Left(Dir(インポートするファイルのパス), InStr(Dir(インポートするファイルのパス), ".") - 1) 
   'ダウンロードしたファイル名。拡張子なし
   リンク元ファイル名 = Dir(インポートするファイルのパス)
   インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)
'Stop

   年月 = Mid(テーブル名, InStr(テーブル名, "(") + 1, 6)
   If Val(Right(年月, 2)) = 1 Then
      前年月 = CStr(Val(Left(年月, 4) - 1)) & "12"
   Else
      前年月 = Left(年月, 4) & Right("0" & CStr(Val(Right(年月, 2)) - 1), 2)
   End If
   
   
   Call 既存テーブルの名前を変更

   Call テキストファイルを定義を使ってインポート
   
   Call 既存テーブルの構造のみコピー
   
   Call 追加クエリでキー重複を除外
   
   Call 更新クエリを実行

   終了日時 = Now
   MsgBox "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"

End Sub

Private Sub 更新クエリを実行()

    '警告ダイアログをOFF
    DoCmd.SetWarnings False

    'クエリを実行する
    
    DoCmd.OpenQuery "☆BMFの情報追記"
   '更新クエリを実行｡
   '(BMFから、dBASE存在と、dBASEのMPDCと、新品目が、テーブル「エラーリスト品番キー」にコピーされる)
      
    DoCmd.OpenQuery "☆用品CRの追記"
    '１０．クエリ「☆用品CRの追記」で、「用」を追記
    
    '警告ダイアログをON(戻す)
    DoCmd.SetWarnings True

End Sub


Private Sub 追加クエリでキー重複を除外()

   Dim 追加クエリ As String
   
   追加クエリ = "INSERT INTO エラーリスト品番キー ( 品番, 分類, 品名 ) " _
   & "SELECT [エラーリスト(" & 年月 & ")].品番, [エラーリスト(" & 年月 & ")].分類, [エラーリスト(" & 年月 & ")].品名 " _
   & "FROM [エラーリスト(" & 年月 & ")];"

   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.RunSQL 追加クエリ
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True
   
End Sub


Private Sub 既存テーブルの構造のみコピー()

   DoCmd.TransferDatabase acExport, "Microsoft Access", CurrentDb.Name, acTable, _
   "エラーリスト(" & 前年月 & ")品番キー", "エラーリスト品番キー", True
   
End Sub


Private Sub テキストファイルを定義を使ってインポート()
   '   http://okwave.jp/qa/q1691138.html
   '   Access にマクロでテキストファイルをインポートする
   '   インポートするレイアウトに合ったテーブルがあること
   '   インポート定義があること
   '   （定義の作り方は、ファイル→外部データの取り込み→インポート→設定で定義を作成）
   '   あとは､以下のコードを変更
   '   DoCmd.TransferText acImportFixed, "定義名", "データを格納するテーブル名", "C:\..テキストのパス....txt", False, ""
   
   '警告ダイアログをOFF
   DoCmd.SetWarnings False
   
   DoCmd.TransferText acImportFixed, "エラーリストのインポート定義", テーブル名, インポートするファイルのパス, False, ""
   
   '警告ダイアログをON(戻す)
   DoCmd.SetWarnings True
End Sub


Private Sub 既存テーブルの名前を変更()

   DoCmd.Rename "エラーリスト(" & 前年月 & ")品番キー", acTable, "エラーリスト品番キー"
   
End Sub


Private Sub インポートするファイルのパスを取得()

   'http://www.ken3.org/backno/hosoku/ETC_021.html
   '三流プログラマー Ken3のＨＰで教えていただいたままです。
   'ファイルを開くダイアログを使えるように、エクセルオブジェクトを作成します
   Set Excelアプリケーション = CreateObject("Excel.Application")
   Excelアプリケーション.Visible = False  '小細工でExcelを見えなくする
   
   現在のパス = CurrentProject.Path
'   Stop
   ChDrive 現在のパス
   ChDir 現在のパス
   ChDrive 現在のパス
   ChDir 現在のパス
   インポートするファイルのパス = Excelアプリケーション.GetOpenFilename(指定するファイルの種類)
End Sub

Private Sub データベースのリンク更新()

   Dim データベース As DAO.Database, テーブル As DAO.TableDef
   'VBAの画面の、[ツール] - [参照設定]で、DAOオブジェクトライブラリの参照設定を追加する。
   
   Set データベース = CurrentDb
   Set テーブル = データベース.TableDefs("BMF今月")
   
   インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)
   リンク元ファイル名 = Dir(インポートするファイルのパス)
   Stop
   
   テーブル.Connect = "dBASE 5.0;DATABASE=" & インポートするファイルのフォルダ & ";TABLE=" & リンク元ファイル名
   テーブル.RefreshLink ' リンク情報の更新

End Sub

Private Sub データベースのリンク追加()

   テーブル名 = Left(Dir(インポートするファイルのパス), InStr(Dir(インポートするファイルのパス), ".") - 1)
   リンク元ファイル名 = Dir(インポートするファイルのパス)
   インポートするファイルのフォルダ = Left(インポートするファイルのパス, InStrRev(インポートするファイルのパス, "\") - 1)

   DoCmd.TransferDatabase acLink, "dBase 5.0", インポートするファイルのフォルダ, acTable, リンク元ファイル名, "BMF今月"

End Sub

Private Sub データベースのリンク削除()
   If テーブル存在("BMF今月") = True Then
      '警告ダイアログをOFF
      DoCmd.SetWarnings False
      DoCmd.DeleteObject acTable, "BMF今月"
      '警告ダイアログをON(戻す)
      DoCmd.SetWarnings True
   End If
End Sub

DoCmd.Rename "前社員テーブル", acTable, "社員"

DoCmd.DeleteObject acTable, "前社員テーブル"