'==================================== Public Module ========================================
Option Compare Database
Option Explicit

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

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

'OSのバージョンを取得
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を示す定数
Public Const VER_PLATFORM_WIN32_NT = 2
Public Const VER_PLATFORM_WIN32_WINDOWS = 1 '(Windows98/95とも 1)
Public Const VER_PLATFORM_WIN32s = 0

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

'-----------------------------------------------------------------------------------------------------------------------
'「ファイルを開く」コモンダイアログを呼び出す
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long

Type OpenFileName
    lStructSize As Long 'この構造体の長さ
    hwndOwner As Long '呼び出し元ウインドウハンドル
    hInstance As Long 'モジュールのインスタンスハンドル
    lpstrFilter As String 'フィルタ文字列
    lpstrCustomFilter As String 'ユーザー定義のフィルタ文字列のペア
    nMaxCustrFilter As Long 'lpstrCustomFilterのバッファサイズ
    nFilterIndex As Long 'フィルタコンボボックスの初期ｲﾝﾃﾞｯｸｽ値
    lpstrFile As String '選択されたファイル名のフルパス
    nMaxFile As Long 'lpstrFileのバッファサイズ
    lpstrFileTitle As String '選択されたファイル名のタイトル
    nMaxFileTitle As Long 'lpstrFileTitleのバッファサイズ
    lpstrInitialDir As String '初期ﾌｫﾙﾀﾞ名
    lpstrTitle As String 'ダイアログボックスのタイトル名
    Flags As Long '以下のFlagsの値の組み合わせ
    nFileOffset As Integer 'lpstrFileの最後の \までのオフセット値
    nFileExtension As Integer '拡張子までのオフセット値
    lpstrDefExt As String 'ファイル名の入力時、拡張子が省略された時の拡張子
    lCustrData As Long 'OSがlpfnHookで指定されたﾌｯｸ関数に渡すｱﾌﾟﾘ定義のデータ
    lpfnHook As Long 'ダイアログに送られるメッセージを処理するﾌｯｸ関数のポインタ
    lpTemplateName As String
End Type

'Flagsに設定する値
    Public Const OFN_ALLOWMULTISELECT = &H200 'ﾌｧｲﾙ名ﾘｽﾄﾎﾞｯｸｽで複数選択を可能にする
    Public Const OFN_CREATEPROMPT = &H2000 '現在存在しないﾌｧｲﾙを作成するかを確認する
    Public Const OFN_EXTENSIONDIFFERENT = &H400 'ﾌｧｲﾙ名の拡張子とlpstrDefExtで指定された拡張子が異なる
    Public Const OFN_FILEMUSTEXIST = &H1000 '既存のファイルだけ入力できるようにする
    Public Const OFN_HIDEREADONLY = &H4 '[読み取り専用]チェックボックスを表示しない
    Public Const OFN_NOCHANGEDIR = &H8 'ﾀﾞｲｱﾛｸﾞﾎﾞｯｸｽを開いたときに現在のﾃﾞｨﾚｸﾄﾘを表示する
    Public Const OFN_NOREADONLYRETURN = &H8000 '読み取り専用属性を持たず、読み取り専用ﾌｫﾙﾀﾞにないﾌｧｲﾙを取得する
    Public Const OFN_NOVALIDATE = &H100 '無効な文字を含むファイル名を指定出来るようにする
    Public Const OFN_OVERWRITEPROMPT = &H2 '[ﾌｧｲﾙ名を付けて保存]ダイアログで選択したﾌｧｲﾙが存在する場合の上書確認する
    Public Const OFN_PATHMUSTEXIST = &H800 '無効なパスを入力したときに警告メッセージを表示する
    Public Const OFN_READONLY = &H1 '[読み取り専用]チェックボックスをオンにする
    Public Const OFN_SHAREAWARE = &H4000 '共有違反エラーを無視する
    Public Const OFN_SHOWHELP = &H10 'ダイアログ ボックスに [ヘルプ] ボタンを表示する
    Public Const OFN_EXPLORER = &H80000 'エクスプローラに似たダイアログボックスにする
    Public Const OFN_NODEREFERENCELINKS = &H100000 'ショートカットを実行しない
    Public Const OFN_LONGNAMES = &H200000 '長いファイル名を使用する


Type OpenFileName2
    DefaultExt As String '拡張子を付けなかった時のデフォルト拡張子
    DialogTitle As String 'タイトルバーに表示するタイトル名
    FileName As String 'ダイアログを閉じた後、選択したﾌｧｲﾙのﾌﾙﾊﾟｽが入る
    FilePath As String '選択したファイルが含まれるパスの名前
    FileTitle As String '選択したファイルのパスを含まない名前
    Filter As String 'フィルター
    FilterIndex As Long '複数ﾌｨﾙﾀｰを設定している時の表示するﾌｨﾙﾀｰのｲﾝﾃﾞｯｸｽ番号
    Flags As Long 'ダイアログボックスの作成フラグ
    InitDir As String '初期フォルダ名
    MaxFileSize As Long 'ファイル名の最大サイズを設定 (1〜 32768 既定値256)
    OKFlg As Integer '1:ファイルを選択した 0:選択をキャンセルした
End Type

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

Public Function Y_GetOpenFileDialog(hWnd As Long, OpenInfo As OpenFileName2) As OpenFileName2
'***********************************************************
'機能 : 「ﾌｧｲﾙを開く」コモンダイアログを呼び出す
'引数 :　 Fm　　= 呼び出し元のフォームのウインドウハンドル
'　　　　　OpenInfo = 「ﾌｧｲﾙを開く」ダイアログの初期設定値
'戻り値:　ダイアログを閉じた後の設定値
'***********************************************************

    Dim getfile As OpenFileName
    Dim FilterBuf As String
    Dim StrBuf As String
    Dim i As Long
    Dim j As Long
    Dim cnt As Integer
    Dim filindex As Integer
    Dim longret As Long
    Dim wkOpenInfo As OpenFileName2

'初期値設定
    If Left$(OpenInfo.DefaultExt, 1) = "." Then
        OpenInfo.DefaultExt = Mid$(OpenInfo.DefaultExt, 2)
    End If
    If OpenInfo.DialogTitle = vbNullString Then
        OpenInfo.DialogTitle = "ﾌｧｲﾙを開く"
    End If
    If OpenInfo.MaxFileSize < 1 Or OpenInfo.MaxFileSize > 32768 Then
        OpenInfo.MaxFileSize = 255
    End If
    If OpenInfo.FileTitle = vbNullString Then
        OpenInfo.FileTitle = String$(OpenInfo.MaxFileSize, 0)
    End If
    FilterBuf = OpenInfo.Filter
    j = 1
    cnt = 1
    Do While True
        i = InStr(j, FilterBuf, "|")
        If i = 0 Then
            Exit Do
        End If
        Mid$(FilterBuf, i, 1) = vbNullChar
        j = i + 1
        cnt = cnt + 1
    Loop

    If OpenInfo.FilterIndex < 1 Or OpenInfo.FilterIndex > cnt Then
        filindex = 0
    Else
        filindex = OpenInfo.FilterIndex
    End If

    StrBuf = String(OpenInfo.MaxFileSize, 0)

'コモンダイアログを呼び出す
    With getfile
        .lStructSize = Len(getfile)
        .hwndOwner = hWnd
        .hInstance = 0
        .lpstrFilter = FilterBuf
        .nMaxCustrFilter = 0&
        .nFilterIndex = filindex
        .lpstrFile = StrBuf
        .nMaxFile = OpenInfo.MaxFileSize
        .lpstrFileTitle = OpenInfo.FileTitle
        .nMaxFileTitle = Len(OpenInfo.FileTitle) + 1
        .lpstrInitialDir = OpenInfo.InitDir
        .lpstrTitle = OpenInfo.DialogTitle
        .Flags = OpenInfo.Flags
        .lpstrDefExt = OpenInfo.DefaultExt
    End With

    longret = GetOpenFileName(getfile)

'戻り値セット
'    wkOpenInfo = OpenInfo
'    With wkOpenInfo
'        .FileName = BufEdit(getfile.lpstrFile)
'        .FilePath = StrConv(LeftB$(StrConv(getfile.lpstrFile, vbFromUnicode), getfile.nFileOffset), vbUnicode)
'        .FileTitle = BufEdit(getfile.lpstrFileTitle)
'        .OKFlg = longret
'    End With

'変更点(1999/06/05 load)
'   FileName
'       ファイルの複数選択不可の場合(FileTitleにファイル名が返る)、現行どおりファイル名をフルパスで返す
'       ファイルを複数選択した場合(FileTitleに""が返る)、ファイル名のみを　/ で区切って返す（パス名だけが返っていた）
'   FilePath
'       最後の\をとる(複数選択の可不可で不定、最後にChr$(0)が付いた)
    wkOpenInfo = OpenInfo
    With wkOpenInfo
        .FileTitle = BufEdit(getfile.lpstrFileTitle)
        If .FileTitle = "" Then
            .FileName = BufEdit(getfile.lpstrFile, "/")
            i = InStr(.FileName, "/")
            If i Then .FileName = Mid$(.FileName, i + 1)
        Else
            .FileName = BufEdit(getfile.lpstrFile)
        End If
        .FilePath = BufEdit(StrConv(LeftB$(StrConv(getfile.lpstrFile, vbFromUnicode), getfile.nFileOffset), vbUnicode))
        If Right$(.FilePath, 1) = "\" Then .FilePath = Left$(.FilePath, Len(.FilePath) - 1)
        .OKFlg = longret
    End With
    
    Y_GetOpenFileDialog = wkOpenInfo

End Function

Public Function BufEdit(Buf As String, Optional delimiter) As String

'***********************************************************
'機能 : 引数 Bufの文字列中の Nullコードを検索し、Nullコードを
'　　　　除いた文字列を返す
'引数 : Buf = Nullコードを含む文字列
'       delimiter 指定で vbNullCharを delimiterに変更(追加 1999/06/05 load)
'戻り値: Nullコードを除いた文字列
'***********************************************************

    Dim i As Long, j As Long, w As String

    If IsMissing(delimiter) Then
        i = InStr(Buf, vbNullChar)
        If i <> 0 Then
            BufEdit = Left$(Buf, i - 1)
        Else
            BufEdit = Buf
        End If
    Else
        w = Buf
        i = InStr(w, vbNullChar)
        Do Until i < 1 Or i = j + 1
            j = i
            Mid$(w, i, 1) = delimiter
            i = i + 1
            i = InStr(i, w, vbNullChar)
        Loop
        If i <= Len(w) Then w = Left$(w, i - 1)
        If Right$(w, 1) <> delimiter Then w = w & delimiter
        BufEdit = w
    End If
End Function


'==================================== Form Module ========================================
Option Compare Database
Option Explicit

Private Sub 参照File_Click()
'OCX(Active X)を使わずに「ファイルを開く」コモンダイアログを呼び出します。
'COMDLG32.OCXを組み込みたくない時や､MS -Accessで使いたい時に有効です｡
    Dim tag As OpenFileName2
    Dim FileName As String

'ダイアログのパラメータ設定
    With tag
        .DefaultExt = "txt"
        .DialogTitle = "ファイルを選択して下さい。"
        .FileName = vbNullString
        .FilePath = vbNullString
        .FileTitle = vbNullString
        .Filter = "ﾃｷｽﾄ(*.txt)|*.txt|ﾃﾞｰﾀﾍﾞｰｽ(*.mdb)|*.mdb|全てのﾌｧｲﾙ(*.*)|*.*"
        .FilterIndex = 1
        .Flags = OFN_HIDEREADONLY
        .InitDir = "c:\"
        .MaxFileSize = 255
        .OKFlg = 0
    End With

'ダイアログ呼び出し
    tag = Y_GetOpenFileDialog(Me.hWnd, tag)

    If tag.OKFlg = 0 Then
        Call MsgBox("選択をキャンセルしました。")
    Else
        Me!OpenFileName = tag.FileName
        'ShortPathを取得します。
        FileName = "S"
        Me!ShortPathName = LsGetPath(tag.FileName, FileName)
        Me!ShortFileName = FileName
        '上記で取得したShortPathからLongPathを取得します。
        FileName = "L"
        Me!LongPathName = LsGetPath(Me!ShortPathName & "\" & Me!ShortFileName, FileName)
        Me!LongFileName = FileName
    End If
End Sub