[[20110614152804]]　『ファイル名の変わるファイル指定2』（初心者なーくん）　ページの最後に飛ぶ

『ファイル名の変わるファイル指定2』（初心者なーくん）

 いつもお世話になります。
 以前に、『ファイル名の変わるファイル指定』 （初心者なーくん）で
 教えてもらったマクロで教えて欲しい事があります。

 Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As  Range)
  With Target
    If (.Column = 6 Or .Column = 8) And .Count = 1 Then
      If .Value = "PDF" Or .Value = "DXF" Then
        FileModule Target
      End If
    End If
  End With
 End Sub

 Sub FileModule(myRng As Range)
 ' Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\標準\"  '・・・・・（１） 
  Const FindRootFolder As String = "C:\test\"                                            '・・・・・（４）
  Dim FindFileName     As String
  Dim FoundPath        As String
  Dim FileSaveName     As String
  Dim Ans              As Long

  FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cells(4).Value & "*." & myRng.Value
  UserForm1.Show vbModeless
  FoundPath = GetDirAll(FindRootFolder, FindFileName)
  Unload UserForm1
  If FoundPath = "" Then
    MsgBox "該当ファイルがありません。", vbExclamation
  Else
    Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
                 "ファイル名 ： " & FoundPath & vbLf & vbLf & _
                 "ファイルを開く" & vbTab & "： はい" & vbLf & _
                 "ファイルを保存" & vbTab & "： いいえ" & vbLf & _
                 "処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
                 "を押してください。", vbYesNoCancel)
    Select Case Ans
      Case vbYes
        ThisWorkbook.FollowHyperlink FoundPath
      Case vbNo
        FileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(FoundPath), "\", 2)(0)), _
                           fileFilter:=myRng.Value & "ファイル, *." & myRng.Value)
        If FileSaveName <> "False" Then
          FileCopy FoundPath, FileSaveName
        End If
    End Select
  End If
  End Sub

  Private Function GetDirAll(DirFolder As String, FindFileName As String) As String
  Const bufPath  As String = "C:\myDirBuffer.txt"
  Dim strCommand As String
  Dim n          As Long
  Dim buf()      As Byte
  Dim AryBuf     As Variant
  strCommand = "Dir " & DirFolder & " /S/B > " & bufPath
  CreateObject("WScript.Shell").Run "Cmd /C " & strCommand, 7, True
  n = FreeFile()
  Open bufPath For Binary As n
    If LOF(n) = 0 Then Exit Function
    ReDim buf(1 To LOF(n))
    Get #n, , buf
  Close n
  Kill bufPath
  AryBuf = Split(StrConv(buf, vbUnicode), vbCrLf)
  For Each C In AryBuf
    If StrConv(C, vbLowerCase) Like StrConv("*" & FindFileName, vbLowerCase) Then
      GetDirAll = C
      Exit For
    End If
  Next C
  End Function

 これで、
  Const FindRootFolder As String = "C:\test\"                                         '・・・・・（４）
 の時は問題なく検索ができ、
  Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\標準\"   '・・・・・（１） 
 では、
    MsgBox "該当ファイルがありません。", vbExclamation
 となります。

 １．（１）の状態でマクロを走らした後、（１）をコメントアウトして、（４）の状態でマクロを走らすと
    MsgBox "該当ファイルがありません。", vbExclamation
 となります。（４）の状態では問題なく検索できるのに一旦"該当ファイルがありません。"となるとどうにもなりません。
 一度ファイルを閉じ、開きなおして（４）ですると検索できます。
 なぜですか？どうか教えて下さい。

 Excel2003,WindowsXP
 （初心者なーくん）

 久しぶりなコードですね。
 え～っと、私のちょんぼだと思いますが

  Open bufPath For Binary As n
    If LOF(n) = 0 Then Exit Function
    ReDim buf(1 To LOF(n))
    Get #n, , buf
  Close n

 のコードのここで
    If LOF(n) = 0 Then Exit Function
 中身が無い時にExitしてしまってるので
 Close n
 を通らないためにリダイレクトで出力したファイルが開いたままで
 書き込みできない状態になってしまっていますね。（すみません）

 GetDirAllファンクションの該当部分を

  Open bufPath For Binary As n
    If LOF(n) <> 0 Then
      ReDim buf(1 To LOF(n))
      Get #n, , buf
    End If
  Close n

 のように書き換えてみてください。
 あと、補足ですがデスクトップのパスは
 Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\標準\"
 とすると、PCやユーザーによって違うので

 Dim FindRootFolder As String
 FindRootFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\標準\"

 とするのが一般的です。
 （ｍｏｍｏ）

 （ｍｏｍｏ）さん、また覗いていただいてありがとうです。

 >のように書き換えてみてください。
 できました。

 >Dim FindRootFolder As String
 >FindRootFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\標準\"
 >とするのが一般的です。
 了解です。（以前にも教えてもらっていましたね。）

 ですが、やっぱり　"該当ファイルがありません。"
 となります。

 今、新発見した事があります。
  Const FindRootFolder As String = "C:\te st\" 
 とフォルダ名にスペースがあると　"該当ファイルがありません。"
 となります。
 本番のフォルダにも途中のフォルダ名にスペースがあります。
 Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\標準\"
 これも　Documents and Settings　にスペースがあるし・・・。
 教えていただいたマクロはフォルダ名にスペースがあると"該当ファイルがありません。"
 になりますか？
 （初心者なーくん）

 そうですね、コマンドラインだとスペースがあると見つからないですね。
 対策としては

 >strCommand = "Dir " & DirFolder & " /S/B > " & bufPath

 の1行を

  If DirFolder Like "* *" Then
    ChDrive Split(DirFolder, ":")(0)
    ChDir DirFolder
    strCommand = "Dir " & " /S/B > " & bufPath
  Else
    strCommand = "Dir " & DirFolder & " /S/B > " & bufPath
  End If

 にしてみてください。

 内容は、もしスペースが入っていたらカレントディレクトリを変更して
 カレントディレクトリに対してDirを打つようにしています。
 （ｍｏｍｏ）

 あ、良く考えたら

 >strCommand = "Dir " & DirFolder & " /S/B > " & bufPath
 を
  strCommand = "Dir """ & DirFolder & """ /S/B > " & bufPath

 にするだけで大丈夫なはずです。
 パスを""で囲む。です
 （ｍｏｍｏ）

 ありがとうございます。 
両方出来ました。また１つ便利になりました。(前回モヤモヤしてたのがスッキリしました)

 理解できるにはまだまだ時間がかかりそうです。
 "" & DirFolder & ""　でどう言う意味になるんですか？

 （初心者なーくん）

 出来ましたか。よかったです。

 >"" & DirFolder & ""　でどう言う意味になるんですか？

 こんなコードで試してみるとわかりますかね？

  Sub test()
  Dim a As String
  a = "TEST"

  MsgBox "普通は　" & a & "　と表示されます"
  MsgBox "今度は　""" & a & """　何か増えていますよね？"
  End Sub

 「"」を付け加えるのに「""」と２つ続けるのがＶＢＡでの決まりなのです。
 （ｍｏｍｏ）

 （ｍｏｍｏ）さん、ありがとうです。

 >そうですね、コマンドラインだとスペースがあると見つからないですね。
 >対策としては
 >あ、良く考えたら
 >>strCommand = "Dir " & DirFolder & " /S/B > " & bufPath
 >を
 >strCommand = "Dir """ & DirFolder & """ /S/B > " & bufPath
 >にするだけで大丈夫なはずです。

 >普通は　TEST　と表示されます
 >今度は　"TEST"　何か増えていますよね？
 "TEST"とする事でスペースを認識させれるんですか？

 （初心者なーくん）

 私用で返信が遅れました。

 VBAでというより、Shellを使っているのでＤＯＳコマンドでの扱いになります。
 ＤＯＳでは""で挟むことでディレクトリ名などのスペースが使えます。
 （ｍｏｍｏ）

（ｍｏｍｏ）さん、ありがとうです。

 （初心者なーくん）

コメント返信：

[ 一覧(最新更新順) ]

[[20110614152804]] 『ファイル名の変わるファイル指定2』（初心者なーくん） ページの最後に飛ぶ

[[20110614152804]]　『ファイル名の変わるファイル指定2』（初心者なーくん）　ページの最後に飛ぶ