VBScript ファイル参照/名前を付けて保存 ダイアログをつかう

Class clsGetFile
'***********************************************************
    ' 機能：ファイル参照ダイアログ表示処理
    ' 引数：FileFilter, FilterIndex, Title, ButtonText, MultiSelect はExcel同様
    ' InitDir 初期表示フォルダ
    ' 戻り値：ファイルフルパス キャンセル時はEmpty
    '注意事項：引数省略時は、""を入力
'***********************************************************
    Function xlGetOpenFilename(FileFilter, FilterIndex, Title, ButtonText,
MultiSelect, InitDir)

    Dim xlApp
    Dim defPath
  
        Set xlApp = CreateObject("Excel.Application")
        defPath = xlApp.DefaultFilePath
      
        If FileFilter = "" Then FileFilter = "すべてのファイル,*.*"
        If FilterIndex = "" Then FilterIndex = 1
        If Title = "" Then Title = "ファイルを開く"
        If ButtonText = "" Then ButtonText = "開く"
        If MultiSelect = "" Then MultiSelect = False
        If InitDir <> "" Then
            With xlApp
                .DefaultFilePath = InitDir
                .Quit
            End With
            Set xlApp = Nothing '開放しないと設定が反映されない為
            Set xlApp = CreateObject("Excel.Application")
        End If
      
        With xlApp
            xlGetOpenFilename = .GetOpenFilename(FileFilter, _
                                                 FilterIndex, _
                                                 Title, _
                                                 ButtonText, _
                                                 MultiSelect)
            If MultiSelect Then
                If Not IsArray(xlGetOpenFilename) Then xlGetOpenFilename = Empty
            Else
                If xlGetOpenFilename = False Then xlGetOpenFilename = Empty
            End If
            .DefaultFilePath = defPath
            .Quit
        End With
        Set xlApp = Nothing
    End Function

'***********************************************************
    ' 機能：名前を付けて保存ダイアログ表示処理
    ' 引数：InitialFilename, FileFilter, FilterIndex, Title, ButtonText はExcel同様
    ' 戻り値：ファイルフルパス キャンセル時はEmpty
    '注意事項：引数省略時は、""を入力
'***********************************************************
    Function xlGetSaveAsFilename(InitialFilename, FileFilter, FilterIndex,
Title, ButtonText)

    Dim xlApp
    Dim defPath
  
        Set xlApp = CreateObject("Excel.Application")
      
        If InitialFilename = "" Then InitialFilename = xlApp.DefaultFilePath
        If FileFilter = "" Then FileFilter = "すべてのファイル,*.*"
        If FilterIndex = "" Then FilterIndex = 1
        If Title = "" Then Title = "名前を付けて保存"
        If ButtonText = "" Then ButtonText = "保存"
      
        With xlApp
            xlGetSaveAsFilename = .GetSaveAsFilename(InitialFilename, _
                                                     FileFilter, _
                                                     FilterIndex, _
                                                     Title, _
                                                     ButtonText)
            If xlGetSaveAsFilename = False Then xlGetSaveAsFilename = Empty
            .Quit
        End With
        Set xlApp = Nothing
    End Function
End Class

=====================================================
要Excelではあるけれど、
ファイルフィルタ/マルチセレクトが使えるのはでかい
起動に時間を要するのが難点かな・・・

2010/11/26　一部修正しました。