Option Compare Database
Option Explicit


'ShortPath名を取得
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

'LongPath名を取得。GetLongPathNameはWin95では使えません
Private Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal cchBuffer As Long) As Long

'OSのバージョンを取得
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long     '構造体のバイト数
    dwMajorVersion As Long          'メジャーバージョン番号(Windows98/95とも &H4)
    dwMinorVersion As Long          'マイナーバージョン番号(Windows95 = &H0  Windows98 = &HA)
    dwBuildNumber As Long           'ビルド番号
    dwPlatformId As Long            'プラットフォームのIDを示す定数
    szCSDVersion As String * 128    'OSに関する付加情報を示す文字列
End Type

'プラットフォームのIDを示す定数
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1 '(Windows98/95とも 1)
Const VER_PLATFORM_WIN32s = 0

Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long

Dim cdbs As Database, rst As Recordset

'Open時にテーブルのリンク状態を確認し、正常な接続でなければつなぎ直します。
'フォルダを移動した場合の自動処理が可能になります。
'データMDBがプログラムMDBのフォルダにあることを前提にしています。
Private Sub Form_Open(Cancel As Integer)
    Const DatDb = "LsConnectDat.mdb"
    Dim 作業フォルダ As String
    
    Set cdbs = CurrentDb()
    
    'プログラムMDBのフォルダを取出します。
    'LsGetPathの機能拡張(00/03/22)
    '   LongPathを取得します。作業フォルダはLsTblConnectな内でConnectプロパティと文字列比較されます。
    作業フォルダ = LsGetPath(cdbs.Name, "L")
    
    'ConectTblにはリンクテーブル名を入力します。
    Set rst = cdbs.OpenRecordset("ConectTbl")
    With rst
        Do Until .EOF
            If LsTblConnect(作業フォルダ & "\" & DatDb, !TblName) Then
                DoCmd.Close
                Exit Sub
            End If
            .MoveNext
        Loop
        .Close
    End With
    cdbs.Close
    Set rst = Nothing
    Set cdbs = Nothing
    Me.RecordSource = "d1"
End Sub

Private Function LsTblConnect(Db As String, tb As String) As Integer
    Dim cCon As String, wCon As String, tdf As TableDef
    On Error GoTo ErrRtn
    
    'リンクされていない場合（Err = 3265）はErrRtnに飛びます。
    wCon = LCase(cdbs.TableDefs(tb).Connect)
    cCon = ";Database=" & Db
    
    '正常な接続であれば抜けます。この処理を入れないと毎回接続し直すことになり、立ち上がりが遅くなります。
    'LongPathでないと論理式はFalseになります。
    If wCon = LCase(cCon) Then Exit Function
    
    Set tdf = cdbs.CreateTableDef(tb)
    tdf.Connect = cCon
    tdf.SourceTableName = tb
    
    '接続します。接続済みの場合（Err = 3012）はErrRtnに飛びます。
    cdbs.TableDefs.Append tdf
LsTblConnect_exit:
Exit Function

ErrRtn:
    If Err = 3012 Then '接続済みの場合は一旦接続を切り、つなぎ直します。
        cdbs.TableDefs.Delete tb
        Err.Clear
        Resume
    ElseIf Err = 3265 Then 'リンクされていない場合は無視して次のステップへ
        Err.Clear
        Resume Next
    Else
        MsgBox "データベースの接続に失敗しました。（" & Db & "／" & tb & "）" & Chr$(13) & Error, vbCritical
        
        LsTblConnect = True
        Screen.MousePointer = 0
        Resume LsTblConnect_exit
    End If
End Function

Function LsGetPath(ByVal FullPath As String, FileName As String) As String
    'パス名とファイル名の分割
    '   渡されたFullPathのPath名とFile名を分解して返します。
    '   Win98ではGetLongPathNameでロングパス名を取得できますが、95ではDir関数で組み立てます。
    '
    '   FullPath(in)  依頼するPath名+File名
    '   FileName(in)  "S"を指定するとShortPathName、"L"を指定するとLongPathNameを返します。
    '                 ""の場合は単純に分割のみを行います。
    '           (out) File名を返します。
    '   GetPathName   Path名を返します。
    Dim lpszLongPath As String, lpszShortPath As String, cchBuffer As Long
    Dim i As Integer, j As Integer, fil As String, rtn As Long
    Dim Win98Flg As Boolean, LongFlg As Boolean
    Dim NetDrv As Boolean, Fld As String
    
    cchBuffer = 255
    Win98Flg = (LsGetWinPlatform() = "98")
    
    Select Case UCase(FileName)
    Case "S"
        lpszShortPath = String(cchBuffer, " ")
        rtn = GetShortPathName(FullPath, lpszShortPath, cchBuffer)
        FullPath = Left$(lpszShortPath, rtn)
    Case "L"
        LongFlg = True
        If Win98Flg Then
            lpszLongPath = String(cchBuffer, " ")
            rtn = GetLongPathName(FullPath, lpszLongPath, cchBuffer)
            FullPath = Left$(lpszLongPath, rtn)
        End If
    End Select
    
    lpszLongPath = ""
    j = 1
    i = InStr(FullPath, "\")
    Do Until i < 1
        If LongFlg = True And Win98Flg = False Then
            fil = Left$(FullPath, i - 1)
            If InStr(":\", Right$(fil, 1)) > 0 Then
                lpszLongPath = fil & "\"
            Else
                lpszLongPath = lpszLongPath & Dir$(fil, vbDirectory) & "\"
            End If
        End If
        j = i
        i = i + 1
        i = InStr(i, FullPath, "\")
    Loop
    Do Until i < 1
        If LongFlg = True And Win98Flg = False Then
            fil = Left$(FullPath, i - 1)
            If InStr(":\", Right$(fil, 1)) > 0 Then
                lpszLongPath = fil & "\"
            Else
                '-----Network Driveに対応(2001/12/01)
                If NetDrv = False And Left$(fil, 2) = "\\" Then
                    lpszLongPath = fil & "\"
                    NetDrv = True
                Else
                    Fld = Dir$(fil, vbDirectory)
                    If Fld = "." Then
                        lpszLongPath = fil & "\"
                    Else
                        lpszLongPath = lpszLongPath & Fld & "\"
                    End If
                End If
                '------------------------------------
            End If
        End If
        j = i
        i = i + 1
        i = InStr(i, FullPath, "\")
    Loop
    
    If j > 1 Then
        If LongFlg = True And Win98Flg = False Then
            LsGetPath = Left$(lpszLongPath, Len(lpszLongPath) - 1)
            FileName = Dir$(FullPath)
        Else
            LsGetPath = Left$(FullPath, j - 1)
            FileName = Mid$(FullPath, j + 1)
        End If
    End If
End Function

Public Function LsGetWinPlatform() As String
    Dim rc As Long, lpVersionInformation As OSVERSIONINFO, v(3) As String
    
    lpVersionInformation.dwOSVersionInfoSize = Len(lpVersionInformation)
    rc = GetVersionEx(lpVersionInformation)
    With lpVersionInformation
        v(0) = Hex$(.dwMajorVersion)          'メジャーバージョン番号
        v(1) = Hex$(.dwMinorVersion)          'マイナーバージョン番号
        v(2) = Hex$(.dwBuildNumber)           'ビルド番号
        v(3) = Hex$(.dwPlatformId)            'プラットフォームのIDを示す定数
    End With
    Select Case v(3)
    Case 2
        LsGetWinPlatform = "NT"
    Case 1
        If v(0) = "4" And v(1) > "1" Then
            LsGetWinPlatform = "98"
        Else
            LsGetWinPlatform = "95"
        End If
    Case Else
        LsGetWinPlatform = "??"
    End Select
End Function