'----------------------------------------------------------------------
'空耳工房 (http://www.grn.mmtr.or.jp/~soramimi/)さんからCopy 1999/04/19
'----------------------------------------------------------------------
Option Compare Database
Option Explicit

Public fm As Form
'-----------------------------------------------------------------------------------------------------------------------
'フルパス名からファイル名を取得する
Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" (ByVal lpszFile As String, ByVal lpszTitle As String, ByVal cbBuf As Integer) As Integer
Public Const MAX_PATH = 261

'-----------------------------------------------------------------------------------------------------------------------
'「ファイルを開く」コモンダイアログを呼び出す
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

'-----------------------------------------------------------------------------------------------------------------------
'「名前を付けてファイルに保存」コモンダイアログを呼び出す
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long

'-----------------------------------------------------------------------------------------------------------------------
'「色指定」コモンダイアログを呼び出す
Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As YCHOOSECOLOR) As Long

Type YCHOOSECOLOR
    lStructSize As Long 'この構造体の長さ
    hwndOwner As Long 'ダイアログボックスを持つウインドウハンドル
    hInstance As Long 'モジュールのインスタンスハンドル
    rgbResult As Long '呼び出す前は初期色、終了時は、ユーザーが選択した色
    lpCustColors As Long 'カスタムカラーの配列のポインタ
    flags As Long '初期化フラグ
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

'Flagsの設定値
Public Const CC_ENABLEHOOK = &H10 'lpfnHoolで指定されたフック関数を有効にする
Public Const CC_ENABLETEMPLATE = &H20 'hInstanceとlpTemplateNameで指定されたダイアログテンプレートを使って作成する
Public Const CC_ENABLETEMPLATEHANDLE = &H40 'hInstanceがロード済みのテンプレートを含むメモリブロックを差す
Public Const CC_FULLOPEN = &H2 'ダイアログボックス作成時にダイアログ全体を表示する
Public Const CC_PREVENTFULLOPEN = &H4 '[色作成]ボタンを無効にする
Public Const CC_RGBINIT = &H1 'rgbResultで初期設定カラーとして指定されたカラーをダイアログに表示する
Public Const CC_SHOWHELP = &H8 '[ヘルプ]ボタンを表示する

' ヒープからメモリブロックを確保する
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Public Const GMEM_MOVEABLE = &H2 ' 移動可能メモリの割当て
Public Const GMEM_ZEROINIT = &H40 ' メモリ内容を0で初期化する
Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

'グローバルヒープに確保されたメモリブロックをロックする
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long

'メモリブロックを移動する。
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

'グローバルヒープにロードされたメモリブロックを解放する
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

'グローバルヒープに確保されていたメモリブロックを解放する
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
'-----------------------------------------------------------------------------------------------------------------------

Public Function Y_GetFileTitle(FullPath As String)

'***********************************************************
'機能 : フルパス名からファイル名を取得する
'引数 : FullPath = 取得したいファイル名のフルパス名
'戻り値:　ファイル名
'***********************************************************

    Dim StrBuf As String
    Dim longret As Long

    StrBuf = Space$(MAX_PATH)

    longret = GetFileTitle(FullPath, StrBuf, MAX_PATH)

    Y_GetFileTitle = BufEdit(StrBuf)

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

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 = MAX_PATH
    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 Y_GetSaveFileDialog(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 = MAX_PATH
    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

'Loadsystemによる変更開始(00/07/01)
'Saveするファイル名を初期値として表示する
    With getfile
        .lStructSize = Len(getfile)
        .hwndOwner = hWnd
        .hInstance = 0
        .lpstrFilter = FilterBuf
        .nMaxCustrFilter = 0&
        .nFilterIndex = filindex
        .lpstrFile = OpenInfo.FileName & String(OpenInfo.MaxFileSize - Len(OpenInfo.FileTitle), vbNullChar)
        .nMaxFile = OpenInfo.MaxFileSize
        .lpstrFileTitle = OpenInfo.FileTitle & String(OpenInfo.MaxFileSize - Len(OpenInfo.FileTitle), vbNullChar)
        .nMaxFileTitle = OpenInfo.MaxFileSize
        .lpstrInitialDir = OpenInfo.InitDir
        .lpstrTitle = OpenInfo.DialogTitle
        .flags = OpenInfo.flags
        .lpstrDefExt = OpenInfo.DefaultExt
    End With
'Loadsystemによる変更終了(00/07/01)

    longret = GetSaveFileName(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
    Y_GetSaveFileDialog = wkOpenInfo

End Function

Public Function Y_GetColorDialog(ByRef color As Long) As Long

'***********************************************************
'機能 : 「色指定」ダイアログを表示する
'戻り値:　1:色が選択された　0:[キャンセル]ボタンを押された
'　　　　　引数colorに選択された色コードをセットします
'***********************************************************

    Dim col As YCHOOSECOLOR
    Dim longret As Long
    Dim longret2 As Long
    Dim custcol(15) As Long
    Dim rescol As Long
    Dim i As Integer
    Dim colorsize As Long
    Dim colorAddress As Long
    Dim memhandle As Long

    rescol = 0
    longret2 = 0
    For i = 0 To 15
        custcol(i) = &HFFFFFF
    Next
'カスタムカラーに必要なメモリのサイズを得る。
    colorsize = Len(custcol(0)) * 16
'カスタムカラーのメモリブロックを確保
    memhandle = GlobalAlloc(GHND, colorsize)
    If memhandle Then
'カスタムカラーののググローバルメモリブロックロックする
        colorAddress = GlobalLock(memhandle)

        If colorAddress Then
        'カスタムカラーのグローバルメモリブロックを配列にコピーする
            Call MoveMemory(ByVal colorAddress, custcol(0), colorsize)

            With col
                .lStructSize = Len(col)
                .hwndOwner = fm.hWnd
                .hInstance = 0&
                .rgbResult = rescol
                .lpCustColors = colorAddress
                .flags = CC_RGBINIT
                .lCustData = 0&
                .lpfnHook = 0&
                .lpTemplateName = 0&
            End With

            longret2 = ChooseColor(col)
        'メモリブロックロック解除
            longret = GlobalUnlock(memhandle)
        'メモリブロック解放
            longret = GlobalFree(memhandle)

        Else
        'メモリブロック解放
            longret = GlobalFree(memhandle)
        End If
    End If
    color = col.rgbResult
    Y_GetColorDialog = longret2

End Function