Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


3088 / 13644 ツリー ←次へ | 前へ→

【64194】Excel2007でFileSearchエラー aki 10/1/24(日) 20:39 質問[未読]
【64195】Re:Excel2007でFileSearchエラー かみちゃん 10/1/24(日) 20:49 発言[未読]
【64340】Re:Excel2007でFileSearchエラー aki 10/1/31(日) 9:13 お礼[未読]
【64358】Re:Excel2007でFileSearchエラー かみちゃん 10/1/31(日) 14:13 発言[未読]
【64373】Re:Excel2007でFileSearchエラー aki 10/1/31(日) 21:21 お礼[未読]

【64194】Excel2007でFileSearchエラー
質問  aki  - 10/1/24(日) 20:39 -

引用なし
パスワード
   Excel2003で使用していたマクロなのですが、Excel2007では
実行時エラー'445'オブジェクトはこの動作をサポートしていません。
というエラーメッセージが表示されます。
ユーザーフォームのテキストボックス1の指定したフォルダの中の
画像ファイルをリストボックスに抽出するマクロです。
以下のソースですが、どちら様かお教え下さい。

  Dim i As Long, n As Long
  ListBox1.Clear
With Application.FileSearch
   .NewSearch
   .LookIn = TextBox1.Text
   .Filename = "*.jpg;*.bmp;*.tif;*.gif"
   n = .Execute()
   For i = 1 To .FoundFiles.Count
     ListBox1.AddItem Dir(.FoundFiles(i))
   Next
If ListBox1.ListCount = 0 Then
Else
  ListBox1.ListIndex = 0
End If
End With

【64195】Re:Excel2007でFileSearchエラー
発言  かみちゃん E-MAIL  - 10/1/24(日) 20:49 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>Excel2003で使用していたマクロなのですが、Excel2007では
>実行時エラー'445'オブジェクトはこの動作をサポートしていません。
>というエラーメッセージが表示されます。

Excel2007からは
Application.FileSearch
は、正式にサポートされなくなりました。
http://support.microsoft.com/kb/920229/ja
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_130.html

【64340】Re:Excel2007でFileSearchエラー
お礼  aki  - 10/1/31(日) 9:13 -

引用なし
パスワード
   かみちゃんさんへ
お礼が遅くなりました。お教え頂いた、アドレスを参考に、色々調べてコードを作成してみましたが、新規にユーザーフォームを作成し、下記のコードを組み込むと、動くには動くんですが、いまいちです。できれば改善個所をお教え出来ないでしょうか?

Option Explicit
Private g_strEXT As String

Private Sub TextBox1_Change()
  Dim objFSO As FileSystemObject
  Dim GYO As Long, cntFound As Long
  Dim ListDeTe As String

  Set objFSO = New FileSystemObject
  g_strEXT = UCase("jpg") '←一つの拡張子しか指定出来ない。
  Call Sample_FileSearch_SUB(objFSO, objFSO.GetFolder(Trim(TextBox1.Text)), GYO, cntFound)
  Set objFSO = Nothing
'↓一度シートにロードしてからListBoxに張付けていますが、直接
'ListBoxにロードできないものか?
Range("Y:Y").Select
  Selection.Cells.SpecialCells(xlConstants).Select
  Worksheets("sheet1").Range("Z1").Value = ActiveWindow.RangeSelection.Address
  ListDeTe = Worksheets("sheet1").Range("Z1").Value
  With ListBox1
    .Clear
    .RowSource = ListDeTe
  End With
End Sub

Private Sub Sample_FileSearch_SUB(objFSO As FileSystemObject, _
                  ByVal objFolder As Folder, _
                  GYO As Long, cntFound As Long)
   Dim objFile As File
  For Each objFile In objFolder.Files
    With objFile
      If ((UCase(objFSO.GetExtensionName(.Path)) = g_strEXT)) Then
        GYO = GYO + 1
        Cells(GYO, 25).Value = .Name
      cntFound = cntFound + 1
      Else
      End If
    End With
  Next objFile
End Sub

▼かみちゃん さん:
>こんにちは。かみちゃん です。
>
>>Excel2003で使用していたマクロなのですが、Excel2007では
>>実行時エラー'445'オブジェクトはこの動作をサポートしていません。
>>というエラーメッセージが表示されます。
>
>Excel2007からは
>Application.FileSearch
>は、正式にサポートされなくなりました。
>http://support.microsoft.com/kb/920229/ja
>http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_130.html

【64358】Re:Excel2007でFileSearchエラー
発言  かみちゃん E-MAIL  - 10/1/31(日) 14:13 -

引用なし
パスワード
   こんにちは。かみちゃん です。

> 動くには動くんですが、いまいちです。

TextBox1_Changeイベントで動かすことが適当かどうかが疑問ですが、

> 一つの拡張子しか指定出来ない。
> '↓一度シートにロードしてからListBoxに張付けていますが、直接
> 'ListBoxにロードできないものか?

これらについて、対応するとすれば、一例として、以下のように修正します。

Option Explicit
Private g_strEXT As String
Dim vntFile() As Variant '★

Private Sub TextBox1_Change()
 Dim objFSO As FileSystemObject
 Dim cntFound As Long
 
 Set objFSO = New FileSystemObject

 g_strEXT = UCase("*.jpg;*.bmp;*.tif;*.gif;*.xls") '★

 cntFound = Sample_FileSearch_SUB(objFSO, objFSO.GetFolder(Trim(TextBox1.Text)), GYO, cntFound) '★
 
 With ListBox1
  .Clear
  If cntFound > 0 Then '★
   .List = vntFile '★
   MsgBox "ファイルがありました" '★
  Else '★
   MsgBox "ファイルがありませんでした" '★
  End If '★
 End With
End Sub

Function Sample_FileSearch_SUB(objFSO As FileSystemObject, _
                  ByVal objFolder As Folder, _
                  GYO As Long, cntFound As Long) As Long '★
 Dim objFile As File
 Dim v As Variant '★
 Dim i As Long '★
 
 v = Split(g_strEXT, ";") '★
 For Each objFile In objFolder.Files
  With objFile
   For i = 0 To UBound(v) '★
    If UCase(.Name) Like v(i) Then '★
     ReDim Preserve vntFile(cntFound) '★
     vntFile(cntFound) = .Name '★
     cntFound = cntFound + 1
     Exit For '★
    End If '★
   Next '★
  End With
 Next objFile
 
 Sample_FileSearch_SUB = cntFound '★

End Function

【64373】Re:Excel2007でFileSearchエラー
お礼  aki  - 10/1/31(日) 21:21 -

引用なし
パスワード
   かみちゃん さん ありがとうございました。
UCase("*.jpg;*.bmp;*.tif;*.gif;*.xls")で一度試してみたんですが、エラーが発生したため、UCaseでは、複数検索が出来ないと思っていました。
おかげさまで、マクロが早くなり簡潔なコードになりました。

▼かみちゃん さん:
>こんにちは。かみちゃん です。
>
>> 動くには動くんですが、いまいちです。
>
>TextBox1_Changeイベントで動かすことが適当かどうかが疑問ですが、
>
>> 一つの拡張子しか指定出来ない。
>> '↓一度シートにロードしてからListBoxに張付けていますが、直接
>> 'ListBoxにロードできないものか?
>
>これらについて、対応するとすれば、一例として、以下のように修正します。
>
>Option Explicit
>Private g_strEXT As String
>Dim vntFile() As Variant '★
>
>Private Sub TextBox1_Change()
> Dim objFSO As FileSystemObject
> Dim cntFound As Long
> 
> Set objFSO = New FileSystemObject
>
> g_strEXT = UCase("*.jpg;*.bmp;*.tif;*.gif;*.xls") '★
>
> cntFound = Sample_FileSearch_SUB(objFSO, objFSO.GetFolder(Trim(TextBox1.Text)), GYO, cntFound) '★
> 
> With ListBox1
>  .Clear
>  If cntFound > 0 Then '★
>   .List = vntFile '★
>   MsgBox "ファイルがありました" '★
>  Else '★
>   MsgBox "ファイルがありませんでした" '★
>  End If '★
> End With
>End Sub
>
>Function Sample_FileSearch_SUB(objFSO As FileSystemObject, _
>                  ByVal objFolder As Folder, _
>                  GYO As Long, cntFound As Long) As Long '★
> Dim objFile As File
> Dim v As Variant '★
> Dim i As Long '★
> 
> v = Split(g_strEXT, ";") '★
> For Each objFile In objFolder.Files
>  With objFile
>   For i = 0 To UBound(v) '★
>    If UCase(.Name) Like v(i) Then '★
>     ReDim Preserve vntFile(cntFound) '★
>     vntFile(cntFound) = .Name '★
>     cntFound = cntFound + 1
>     Exit For '★
>    End If '★
>   Next '★
>  End With
> Next objFile
> 
> Sample_FileSearch_SUB = cntFound '★
>
>End Function

3088 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free