プロが教える店舗&オフィスのセキュリティ対策術

いつもお世話になってます。
フォルダを選択して、その中にあるファイル名を読んで書き出すマクロを作りました。
そのプログラム一部を下記に示します。

Sub フォルダ選択()

Dim ff As Object
Set ff = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)
 ・
 ・
(読み出し、書き出し)
 ・
 ・
Q$ = MsgBox("次やりますか", vbYesNo)
If Q$ = "6" Then
Call フォルダ選択
End If

一応正常に動いているので問題はないのですが、少し改良を加えたいと思ってます。

1.冒頭に出てくる「フォルダ選択ウィンドウ」を画面の中央に表示させたい。
  現状は画面の左上に出てきます。
2.続けて操作をするために「次やりますか」にYESで答えると、「フォルダ選択ウィンドウ」が再び現れますが、最上位のフォルダが表示されます。これを先ほど選んだフォルダを基準に次のフォルダを選ばせるように表示させたい。階層が非常に深い複数のフォルダを連続して操作するとすごく疲れますので。

こんなことできますか?

ご存知の方、よろしくお願い申し上げます。

なお、上記冒頭の構文はどこかに出ていたものをコピーさせて頂いたものなので、詳しい書式がわかりません。
よろしくお願いします。

A 回答 (9件)

KenKen_SPさん、こんばんは。


早速の対応、ありがとうございました。

私は、単純に、以下の部分だけに着目したので、
>.hwndOwner = Application.hwnd

あまり深いことは考えていませんでしたが、
WH = GetForegroundWindow()
を、

 .hwndOwner =WH

で、GetForegroundWindow()が、アクティブなウィンドウのハンドルということで、コントロールの違いによって変わるかどうか、気がかりでしたので、
 HW = GetForegroundWindow()
 myHwnd = FindWindow("ThunderDFrame", Caption)
 「myHwnd = FindWindow("XLMAIN", Application.Caption)」
とSPY++

で比較して、何度か違った方法で試してみましたが、特別、問題になる部分は出てきませんでした。

ただ、Application.hwndの場合と比較すると、ワークシートのClassのほうがハンドルされるようですが、ワークシートClass であってもなくても、Excel内には違いありませんから、出てくるダイアログには関係ありませんね。

>フォルダ参照ダイアログ」が表示されているにも関わらず、UserForm
>を選択できてしまいます。

この件に関しては、Userform の場合は、そのコードの間だけ、Me.Hide ~ Me.Show 0としていればよさそうですね。しょせん、Excelの範疇の中ですからね(^^;

>しかし、自信はありません(汗)
Excel 2000以上でしたら、私のほうから、保証させていただきます(^^;

こういうのは、ある程度知っていても、機会がないと、とってもやる気起こりません。ご質問者さん不在にして申し訳ないけれども、今回のご回答は、とても勉強させていただきました。

注意:Win32 APIを扱ったことがない方は、そのまま貼り付けすることをお勧めします。失敗すると、確実にOSレベルでハングします。
    • good
    • 0

Wendy02さん、ありがとうございます。



ご指摘の点については、BrowseForFolder関数を下記のように修正させていただきます。これで、、Excel2000でも動きますか?


  'ユーザーが操作中のウインドウハンドル取得
  WH = GetForegroundWindow()
  'BROWSEINFO構造体を用意
  With typBrowserInfo
    .hwndOwner = WH ' <-------------------------------- ここを修正
    .pidlRoot = CSIDL_DESKTOP
    .lpszTitle = strCaption
    .ulFlags = BIF_RETURNONLYFSDIRS
    .lpfn = FARPROC(AddressOf BrowseCallbackProc)
    If Len(strPrevDir) Then
      .lParam = strPrevDir
    Else
      .lParam = CurDir & vbNullChar '初期フォルダパス
    End If
  End With


FindWindow で XLMAIN 決め打ちだと UserForm から BrowseForDolder 関数がコールされた場合、「フォルダ参照ダイアログ」が表示されているにも関わらず、UserForm
を選択できてしまいます。
これでは、ちょっと都合が悪いので、ちょっと考えて見ました。

上記の GetForegroundWindow でウインドウハンドルを取得する方法だと UserForm から関数がコールされた場合でも対応できそうです。

しかし、自信はありません(汗)
    • good
    • 0

KenKen_SP様、こんにちは。



参考ボタンを押させていただきました。

コードを試してみて、APIに、そういうのがあったのを思い出しました。やったことはあったけれども、すぐに忘れてしまうものでして(^^ゞ

#5 の
>あと、言い忘れましたが #4 のコードは Excel2000 以上で動作します。コールバック関数の都合です。

ですが、これは、そのままですと、以下があるので、
>.hwndOwner = Application.hwnd

Excel 2002 以上になってしまいますね。

Excel 2000 ですと、

もう1つAPI関数を加えて
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long

BrowseForFolder関数に、

Dim hWnd    As Long
hWnd = FindWindow("XLMAIN", Application.Caption)

'BROWSEINFOの構造体の代入に、
  .hwndOwner = hWnd

とすればよいのですが、面倒なら、hWnd に、1200 を入れればよいですね。
(&H000004B0 =1200)
    • good
    • 0

すみません、、寝ぼけてたみたいです。

#4は多くのバグがありましたので、
撤回いたします。長くて申し訳ないのですが、バグフィックスしたものを
再アップしておきます。


'フォルダ参照ダイアログ表示
Option Explicit

'********************************************************************
'フォルダ参照ダイアログ表示用API
'********************************************************************
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" ( _
  lpBROWSEINFO As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" ( _
  ByVal pidl As Long, ByVal pszPath As String) As Long

'BROWSEINFO構造体
Private Type BROWSEINFO
  hwndOwner   As Long  'Windowのハンドル
  pidlRoot    As Long  'ルートフォルダ定数
  pszDisplayName As String '選択フォルダ名
  lpszTitle   As String 'ダイアログ表示メッセージ
  ulFlags    As Long  'オプション
  lpfn      As Long  'CallBack関数アドレス
  lParam     As String 'CallBack関数パラメータ
  iImage     As Long
End Type

'オプションフラグ(ulFlags)定数
Private Const CSIDL_DESKTOP = &H0    'ルートフォルダをデスクトップに
Private Const BIF_RETURNONLYFSDIRS = &H1 '特殊フォルダを選択させない
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
Private Const BFFM_INITIALIZED = 1

'********************************************************************
'UNC変換およびその他API
'********************************************************************
Private Declare Function WNetGetConnection Lib "mpr.dll" _
  Alias "WNetGetConnectionA" ( _
  ByVal lpszLocalName As String, ByVal lpszRemoteName As String, _
  cbRemoteName As Long) As Long
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" ( _
  ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
  lParam As Any) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long

'********************************************************************
'ダイアログ表示位置用API宣言
'********************************************************************
Private Declare Function MoveWindow Lib "user32" ( _
  ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, _
  ByVal nWidth As Long, ByVal nHeight As Long, _
  ByVal bRepaint As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" _
  Alias "SystemParametersInfoA" ( _
  ByVal uAction As Long, ByVal uParam As Long, _
  ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

'RECT構造体
Public Type RECT
  Left  As Long
  Top  As Long
  Right As Long
  Bottom As Long
End Type
'モニターの有効なスクリーンサイズを取得
Private Const SPI_GETWORKAREA = 48

Public Function BrowseForFolder( _
  Optional strCaption As String = "フォルダを指定して下さい", _
  Optional UNC As Boolean = False) As String
  
  Dim WH       As Long
  Dim typBrowserInfo As BROWSEINFO
  Dim lngRet     As Long
  Dim strPath    As String
  Static strPrevDir As String
  
  'ユーザーが操作中のウインドウハンドル取得
  WH = GetForegroundWindow()
  'BROWSEINFO構造体を用意
  With typBrowserInfo
    .hwndOwner = Application.hwnd
    .pidlRoot = CSIDL_DESKTOP
    .lpszTitle = strCaption
    .ulFlags = BIF_RETURNONLYFSDIRS
    .lpfn = FARPROC(AddressOf BrowseCallbackProc)
    If Len(strPrevDir) Then
      .lParam = strPrevDir
    Else
      .lParam = CurDir & vbNullChar '初期フォルダパス
    End If
  End With
  'フォルダの参照ダイアログ呼び出し
  lngRet = SHBrowseForFolder(typBrowserInfo)
  If lngRet Then
    '予めNull文字をセット
    strPath = String$(MAX_PATH, vbNullChar)
    'フォルダパスを取得
    SHGetPathFromIDList lngRet, strPath
    BrowseForFolder = Left$(strPath, InStr(strPath, vbNullChar) - 1)
    'UNC変換オプション
    If UNC Then BrowseForFolder = ConvertUNC(BrowseForFolder)
    '選択フォルダのパス記憶
    strPrevDir = BrowseForFolder
    'メモリ解放
    CoTaskMemFree lngRet
  Else
    BrowseForFolder = vbNullString
  End If

End Function

'AddressOf演算子ラッパー関数
Private Function FARPROC(pfn As Long) As Long
  FARPROC = pfn
End Function

'コールバック関数(表示位置調整ほか)
Private Function BrowseCallbackProc( _
  ByVal hwnd As Long, ByVal uMsg As Long, _
  ByVal lParam As Long, ByVal lpData As Long) As Long
  
  Dim typRect As RECT
  Dim X As Long, Y As Long
  
  'ダイアログサイズ定義
  Const DlgW = 377
  Const DlgH = 309
  
  If uMsg = BFFM_INITIALIZED Then
    'コールバックのBFFM_INITIALIZEDメッセージはウィンドウハンドルが返る
    SendMessage hwnd, BFFM_SETSELECTIONA, 1, ByVal lpData
    'スクリーンサイズ取得
    Call SystemParametersInfo(SPI_GETWORKAREA, 0, typRect, 0)
    'ダイアログ表示位置の移動
    With typRect
      X = (.Right / 2) - (DlgW / 2)
      Y = (.Bottom / 2) - (DlgH / 2)
    End With
    Call MoveWindow(hwnd, X, Y, DlgW, DlgH, 0)
  End If

End Function

'UNC変換関数
Private Function ConvertUNC(strPath As String)
  
  Dim strDRV As String
  Dim strBuf As String * MAX_PATH
  Dim lngRet As Long
  
  On Error GoTo ErrorHandler
  'ドライブレター切り出し
  strDRV = Left$(strPath, 2)
  'UNC変換
  lngRet = WNetGetConnection(strDRV, strBuf, MAX_PATH)
  If lngRet = 0 Then
    If InStr(1, strBuf, vbNullChar) > 1 Then
      strPath = _
      Left$(strBuf, InStr(1, strBuf, vbNullChar) - 1) _
      & Mid$(strPath, 3)
    End If
  End If
  ConvertUNC = strPath
  Exit Function
  
ErrorHandler:
  ConvertUNC = strPath
  On Error GoTo 0
  Exit Function
End Function
    • good
    • 0

#4ですが、見直すと変数の宣言がもれたりしてますね。


すみません。

あと、言い忘れましたが #4 のコードは Excel2000 以上で動作します。コールバック関数の都合です。
    • good
    • 0

こんばんは。

長文ですみませんが、ご希望の条件を満たせたと思います。

API を使いまくってますので解説はできませんが、以下のマクロを標準
モジュールにコピー&ペーストしてお使い下さい。

あと、オプションで UNC 変換機能を付加しています。UNC については
参考URLをご覧下さい。

【使い方】

Sub test()

  Dim strPath As String

  'フォルダ参照ダイアログ表示
  '第1引数:(省略可)キャプション
  '第2引数:(省略可)UNC変換オプション
  strPath = BrowseForFolder(, True)

  If strPath = vbNullString Then
    MsgBox "キャンセルされました"
  Else
    MsgBox strPath
  End If

End Sub




'以下フォルダ参照ダイアログ表示プロシージャ
'その他のプロシージャとは別の標準モジュールに単独で貼り付けて下さい。

'********************************************************************
'フォルダ参照ダイアログ表示用API
'********************************************************************
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" ( _
  lpBROWSEINFO As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" ( _
  ByVal pidl As Long, ByVal pszPath As String) As Long

'BROWSEINFO構造体
Private Type BROWSEINFO
  hwndOwner   As Long  'Windowのハンドル
  pidlRoot    As Long  'ルートフォルダ定数
  pszDisplayName As String '選択フォルダ名
  lpszTitle   As String 'ダイアログ表示メッセージ
  ulFlags    As Long  'オプション
  lpfn      As Long  'CallBack関数アドレス
  lParam     As String 'CallBack関数パラメータ
  iImage     As Long
End Type

'オプションフラグ(ulFlags)定数
Private Const CSIDL_DESKTOP = &H0    'ルートフォルダをデスクトップに
Private Const BIF_RETURNONLYFSDIRS = &H1 '特殊フォルダを選択させない
Private Const MAX_PATH = 260
Private Const WM_USER = &H400
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
Private Const BFFM_INITIALIZED = 1

'********************************************************************
'UNC変換およびその他API
'********************************************************************
Private Declare Function WNetGetConnection Lib "mpr.dll" _
  Alias "WNetGetConnectionA" ( _
  ByVal lpszLocalName As String, ByVal lpszRemoteName As String, _
  cbRemoteName As Long) As Long
Private Declare Function SendMessage Lib "user32" _
  Alias "SendMessageA" ( _
  ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
  lParam As Any) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long

'********************************************************************
'ダイアログ表示位置用API宣言
'********************************************************************
Private Declare Function MoveWindow Lib "user32" ( _
  ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, _
  ByVal nWidth As Long, ByVal nHeight As Long, _
  ByVal bRepaint As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" _
  Alias "SystemParametersInfoA" ( _
  ByVal uAction As Long, ByVal uParam As Long, _
  ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

'RECT構造体
Public Type RECT
  Left  As Long
  Top  As Long
  Right As Long
  Bottom As Long
End Type
'モニターの有効なスクリーンサイズを取得
Private Const SPI_GETWORKAREA = 48

Public Function BrowseForFolder( _
  Optional strCaption As String = "フォルダを指定して下さい", _
  Optional UNC As Boolean = False) As String
  
  Dim WH       As Long
  Dim typBrowserInfo As BROWSEINFO
  Dim lngRet     As Long
  Dim strPath    As String
  Static strPrevDir As String
  
  'ユーザーが操作中のウインドウハンドル取得
  WH = GetForegroundWindow()
  'BROWSEINFO構造体を用意
  With typBrowserInfo
    .hwndOwner = Application.hwnd
    .pidlRoot = CSIDL_DESKTOP
    .lpszTitle = strCaption
    .ulFlags = BIF_RETURNONLYFSDIRS
    .lpfn = FARPROC(AddressOf BrowseCallbackProc)
    If Len(strPrevDir) Then
      .lParam = strPrevDir
    Else
      .lParam = CurDir & vbNullChar '初期フォルダパス
    End If
  End With
  'フォルダの参照ダイアログ呼び出し
  lngRet = SHBrowseForFolder(typBrowserInfo)
  If lngRet Then
    '予めNull文字をセット
    strPath = String$(MAX_PATH, vbNullChar)
    'フォルダパスを取得
    SHGetPathFromIDList lngRet, strPath
    BrowseForFolder = Left$(strPath, InStr(strPath, vbNullChar) - 1)
    'UNC変換オプション
    If UNC Then Broeseforfolder = ConvertUNC(BrowseForFolder)
    '選択フォルダのパス記憶
    strPrevDir = BrowseForFolder
    'メモリ解放
    CoTaskMemFree lngRet
  Else
    BrowseForFolder = vbNullString
  End If

End Function

'AddressOf演算子ラッパー関数
Private Function FARPROC(pfn As Long) As Long
  FARPROC = pfn
End Function

'コールバック関数(表示位置調整ほか)
Private Function BrowseCallbackProc( _
  ByVal hwnd As Long, ByVal uMsg As Long, _
  ByVal lParam As Long, ByVal lpData As Long) As Long
  
  Dim typRect As RECT
  
  'ダイアログサイズ定義
  Const DlgW = 377
  Const DlgH = 309
  
  If uMsg = BFFM_INITIALIZED Then
    'コールバックのBFFM_INITIALIZEDメッセージはウィンドウハンドルが返る
    SendMessage hwnd, BFFM_SETSELECTIONA, 1, ByVal lpData
    'スクリーンサイズ取得
    Call SystemParametersInfo(SPI_GETWORKAREA, 0, typRect, 0)
    'ダイアログ表示位置の移動
    With typRect
      x = (.Right / 2) - (DlgW / 2)
      y = (.Bottom / 2) - (DlgH / 2)
    End With
    Call MoveWindow(hwnd, x, y, DlgW, DlgH, 0)
  End If

End Function

'UNC変換関数
Private Function ConvertUNC(ByVal strPath As String)
  
  Dim strDRV As String
  Dim strBuf As String * MAX_PATH
  Dim lngRet As Long
  
  On Error GoTo ErrorHandler
  'ドライブレター切り出し
  strDRV = Left$(strFullPath, 2)
  'UNC変換
  lngRet = WNetGetConnection(strDRV, strBuf, MAX_PATH)
  If lngRet Then
    If InStr(1, strBuf, vbNullChar) > 1 Then
      strPath = _
      Left$(strBuf, InStr(1, strBuf, vbNullChar) - 1) _
      & Mid$(strFullPath, 3)
    End If
  End If
  ConvertUNC = strPath
  Exit Function
  
ErrorHandler:
  ConvertUNC = strPath
  On Error GoTo 0
  Exit Function
End Function

参考URL:http://e-words.jp/w/UNC.html
    • good
    • 0

後で考えてみましたが、



>フォルダを選択して、その中にあるファイル名を読んで書き出すマクロを作りました。

>("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0)

これだけで、その目的は達成できないはすでずね。一体、どうやって実際のファイル名を取っているのでしょうか?

それから、Loop で取れば、別に、TempFolderなど必要はありませんでした。

'--------------------------------------
Sub test2()
 Dim myFname As Variant
  Dim orgPath As String
  orgPath = Application.DefaultFilePath
  ChDir "C:\"
 Do
  myFname = Application.GetOpenFilename("Excelファイル(*.xls),*.xls")
  If VarType(myFname) = vbBoolean Then GoTo Endline
 '処理...
 '処理...
 Loop
Endline:
  ChDir orgPath
End Sub
'--------------------------------------

#2 さんのコードを試して、それを参考にしてみました。(気を悪くしたら、すみません。)

No1の私の発言の
#特に、2番目のご質問は、あらかじめ、選べるRootFolderの定数名(49個)が決
#められているので、それ以外は無理だと思います。

この発言は、違っていたようですね。

CreateObject で、オートメーション・オブジェクトを作って、その後に、BrowseForFolderを作ると、数値(Numeric Value)のみのようでした。まさか、その都度、最初のオブジェクトを作るのは、ちょっと気が退けますので、以下のようにしてみました。(オートメーション・オブジェクトは、1回しか作らないはずだから、複数常駐することはないのですが。)

'--------------------------------------
Sub Test3()
 '要参照設定: Microsoft Shell Controls And Automation
 Dim objShell As Shell32.Shell
 Dim objFolder As Shell32.Folder
 Dim myPath As String
 myPath = "C:\"
 Set objShell = New Shell32.Shell
 Do
 Set objFolder = objShell.BrowseForFolder( _
      0, "フォルダを選択してください", &H0, myPath)
 If objFolder Is Nothing Then GoTo EndLine
 If objFolder.Items.Item Is Nothing Then
  myPath = objFolder.Self.Path
  Else
  myPath = objFolder.Items.Item.Path & "\"
 '?処理(どうやって、ファイル名を取るのかな?)
 End If
 Loop
EndLine:
 Set objFolder = Nothing
 Set objShell = Nothing
End Sub

'--------------------------------------
ただ、どんどん、掘り下げていくだけで、逆はできませんね。

参考:MSDNのBrowseForFolder

参考URL:http://msdn.microsoft.com/library/default.asp?ur …
    • good
    • 0

次のプログラムで2回目は1回目に選んだフォルダが最初に表示されます。


CreateObjectの最後の引数に,ffを追加します。
ウィンドウの初期位置はわかりませんでした。(私のは最初から中央に表示されました)

Sub Macro1()
'
' Macro1 Macro
'
Dim ff As Object
x = 0
While (x < 2)
Set ff = CreateObject("Shell.Application").BrowseForFolder(0, "フォルダを選択してください", 0, ff)
x = x + 1
Wend

'
End Sub
    • good
    • 0

いろいろと考えてみましたが、



BrowseForFolder(lngHWND, strTitle, lngOptions, [RootFolder])

BrowseForFolderは、あくまでも、Windowsの外部ツールで、表現力が低いので、無理ではないかと思います。

特に、2番目のご質問は、あらかじめ、選べるRootFolderの定数名(49個)が決められているので、それ以外は無理だと思います。

通常、Excelの中から、ファイルを選ぶのでしたら、GetOpenFilename のダイアログを使うのだと思います。(2002なら、フォルダだけの選択は、FileDialogの msoFileDialogFolderPickerがあります。)

最初から、GetOpenFileName で、だいたいの目的の場所に、ChDir で行って、それで再び取得したフォルダ(以下でしたら、TempFolder) は、また、ChDir (TempFolder)で、使えばよいわけですね。

Sub test()
 Dim myFname As Variant
  Dim orgPath As String
  Dim TempFolder As String
  orgPath = Application.DefaultFilePath
  ChDir "C:\"
  myFname = Application.GetOpenFilename("Excelファイル(*.xls),*.xls")
 TempFolder = Mid$(myFname, 1, InStrRev(myFname, "\") - 1)
  If VarType(myFname) = vbBoolean Then Exit Sub
 '処理...
 '処理...

  ChDir orgPath
End Sub

表示位置のほうは、設定はわかりません。
というか、APIを使うような気がしているのですが、これは考えたこともありません。

ただ、プライベートで使うのなら、ファイルを取捨選択するに、もっと簡単な方法は、

Dim myPath As String
myPath = ThisWorkbook.Path
ID = Shell("Explorer.exe /e, /root," & myPath, vbNormalFocus)
If ID = 0 Then Exit Sub

こんな風にして、エキスプローラを常に開けていけばよいです。
ドラッグして、Excelに置けば、そのファイルが開きます。
要らなくなったら、閉じればよいだけです。ただし、うっかりすれば、Excel以外のも開く危険性があります。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!