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　一部修正しました。

備忘録必要だな・・・と

日常的に集めた環境報告やスクリプトがらみのことなど記載していきます