'
' Access 97 用 「リンク更新」モジュール  version 1.10
'
' - version 1.00 (2000.02.11)
' - version 1.10 (2000.12.02)
'
' Copyright (C) Evio, 2000

'==================================================================================================
' 書式: ファイル名 = ファイル名抽出(絶対パス)
' 概要: ファイルの絶対パスから、ファイル名を抽出する
'
' 書式: ディレクトリ名 = ディレクトリ名抽出(絶対パス)
' 概要: ファイルの絶対パスから、そのファイルのあるディレクトリの絶対パス（\で終わる）を抽出する
'
' 書式: リンク更新()
' 概要: 本MDB内のリンクテーブルのリンク先が欠落していたら、本MDBと同じフォルダ内にリンク先を確認更新する
'==================================================================================================

Option Compare Database
Option Explicit

' ファイルの絶対パスから、そのファイルのあるディレクトリの絶対パス（\で終わる）を抽出する関数
Public Function ディレクトリ名抽出(ByVal path As String) As String
On Error Resume Next
    Dim top As Integer
    Dim loc As Integer
    loc = InStr(path, "\")
    Do
        top = loc + 1
        loc = InStr(top, path, "\")
    Loop While loc > 0
    ディレクトリ名抽出 = left$(path, top - 1)
End Function

' ファイルの絶対パスから、ファイル名を抽出する関数
Public Function ファイル名抽出(ByVal path As String) As String
On Error Resume Next
    Dim top As Integer
    Dim loc As Integer
    loc = InStr(path, "\")
    Do
        top = loc + 1
        loc = InStr(top, path, "\")
    Loop While loc > 0
    ファイル名抽出 = Mid$(path, top)
End Function

Public Function リンク更新()
On Error Resume Next
    Dim s As String
    Dim d As Variant
    Dim db As Database
    Dim td As TableDef
    
    Set db = CurrentDb
    Dim newdir As String
    Dim hdrloc As Integer
    Dim hdr As String
    Dim oldpath As String
    Dim newpath As String
    Dim fname As String
    
    newdir = ディレクトリ名抽出(CurrentDb.NAME)
    
    For Each td In db.TableDefs
        If (td.Attributes And &H80000003) = 0 Then
            d = ""
            d = td.Connect
            If d <> "" Then ' tdがリンクテーブルの時
                s = d
                d = 0
                hdrloc = InStr(s, ";DATABASE=") + 10
                hdr = left$(s, hdrloc - 1)
                oldpath = Mid$(s, hdrloc)
                If hdrloc = 11 Then
                    ' JET(Access)の場合 >>> Connect = ";DATABASE=C:\Document\Access\sample.mdb"
                    d = FileLen(oldpath)
                    If d = 0 Then
                        newpath = newdir & ファイル名抽出(oldpath)
                        d = FileLen(newpath)
                        If d > 0 Then
                            Call リンク更新確認ダイアログ(td, oldpath, newpath, hdr)
                        End If
                    End If
                ElseIf hdrloc > 11 Then
                    ' 外部データソースの場合 >>> Connect = "dBase 5.0;HDR=NO;IMEX=2;DATABASE=C:\Document\Access"
                    fname = "\" & td.SourceTableName
                    d = FileLen(oldpath & fname)
                    If d = 0 Then
                        d = FileLen(newdir & fname)
                        If d > 0 Then
                            Call リンク更新確認ダイアログ(td, oldpath, left$(newdir, Len(newdir) - 1), hdr)
                        End If
                    End If
                End If
            End If
        End If
    Next td
End Function

Private Sub リンク更新確認ダイアログ(td As TableDef, oldpath As String, newpath As String, hdr As String)
On Error Resume Next
    Beep
    If MsgBox("ﾘﾝｸﾃｰﾌﾞﾙ [" & td.NAME & "] のリンク先を" & Chr$(13) _
        & oldpath & " から" & Chr$(13) _
        & newpath & " に" & Chr$(13) _
        & "更新してよろしいですか？", vbQuestion + vbYesNo, "リンク更新") = vbYes Then
        
        td.Properties("Connect") = hdr & newpath
        td.Properties.Refresh
        td.RefreshLink
    End If
End Sub

'=== end of module ===