- 締切済み
VBScriptでのファイルコピー
こんにちは いつもお世話になります。 現在、「ファイルの指定ダイアログ」で選択されたファイルの中身（ファイル名） と「フォルダ指定ダイアログ（参照先）」で選択されたフォルダ（サブフォルダ含む） 内のファイルの名前を比較して、一致しているファイルを「フォルダ指定ダイアログ （保存先）」にコピーし、一致しないファイル名を同じく「フォルダ指定ダイアログ （保存先）」に出力するというツールを作成しています。 以下を実行させても、ファイルのコピーも出力もされないのですが、教えていただけます でしょうか。 宜しくお願い致します。 ---------------------------------------------------------------------- <html><head> <script language="VBScript"> 'Call Window.ResizeTo(500,200) Set objFso = CreateObject("Scripting.FileSystemObject") 'テキストファイル吐き出し場所 Const LIST_FILE = "C:\Documents and Settings\All Users\デスクトップ\NonFile.txt" '色々宣言 Dim objFso Dim inFolderName Dim outFolderName Dim inFileName Dim objTxIn Dim ListFile Dim CurrentFileName '色々定数 Const TristateTrue = -1 Const TristateFalse = 0 Const TristateUseDefault = -2 Const ForReading = 1 Const ForWriting = 2 Const ForAppending = 8 '参照フォルダをテキストに表示 '------------------------------------------------------------ sub inFolder() Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder( _ 0, "フォルダを選択してください", 0, "ssfDeskTop") If objFolder Is nothing Then MsgBox("フォルダを選択されませんでした。") Else pathFolder = objFolder.Items().Item().Path ifd.value = vbCr & pathFolder Set objFolder = nothing End If End sub '保存先フォルダの選択 '------------------------------------------------------------ sub outFolder() Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder( _ 0, "フォルダを選択してください", 0, "ssfDeskTop") If objFolder Is nothing Then 'MsgBox("フォルダを選択されませんでした。") Else pathFolder = objFolder.Items().Item().Path ofd.value = vbCr & pathFolder Set objFolder = nothing End If End sub '------------------------------------------------------------ Sub btn_onClick 'ファイルの有無チェック txOut="" inFileName = inFile.Value outFolderName = ofd.value If objFso.FileExists(inFileName) = True Then Set ListFile = objFso.OpenTextFile(inFileName,ForReading,false,TristateTrue) 'ファイルが無いとき Else MsgBox("ファイルが選択されていません。") End If Call iFolder(inFolderName) MsgBox("完了") End Sub 'サブフォルダ内ファイル検査→有 コピー/無 テキスト出力 '------------------------------------------------------------ Sub iFolder(inFolderName) CurrentFileName="" 'フォルダオブジェクト取得 outFolderName = ofd.value If inFolderName ="" then inFolderName = ifd.value Set fsoFolder = objFso.GetFolder(inFolderName) On Error Resume Next CurrentFileName = ListFile.ReadLine For Each fsoFile In fsoFolder.Files If fsoFile.Name = CurrentFileName Then fsoFile.Copy outFolderName,CurrentFileName,false Else set NoFile = objFso.CreateTextFile(LIST_FILE,True) NoFile.WriteLine(CurrentFileName) NoFile.Close End If fsoFile.Close Set fsoFile = Nothing Next For Each fsoSubFolder In fsoFolder.SubFolders Call iFolder(fsoSubFolder) Next End Sub </script> </head>
- k1227_001
- お礼率47% (8/17)
- Visual Basic
- 回答数2
- ありがとう数0
- みんなの回答 （2）
- 専門家の回答
みんなの回答
- redfox63
- ベストアンサー率71% (1325/1856)
ReadAllで読み込むと 全ての行がつながった内容になると思います たとえば a123.jpg b456.bmp c789.gif と言った内容のファイルの場合 txtIn = objTxt.ReadAll() とすると txtInは a.123.jpg + vbcrlf + b456.bmp + vbcrlf + c789.gif + vbcrlf といった具合だと思います これでは 期待した結果にならないだろうと思います Split関数で ファイル名ごとに切り出して使うなどの工夫が必要でしょう dim arFileName arFileName = Split(txtIn, vbcrlf ) と言った具合で分割できます
- redfox63
- ベストアンサー率71% (1325/1856)
『On Error Resume Next』をコメントアウトして エラー無く動作するのか確認します どうしても エラートラップで切り抜けなくては仕方が無い部分のみに On Error Resume Next と On Error Goto 0 を記述しましょう FolderオブジェクトまたはFileオブジェクトのCopyメソッドの引数は2つですよ CopyFileメソッドなら引数は3つですが 指定する親オブジェクトは FSOオブジェクトです
関連するQ&A
- VBScript 再帰処理について
こんにちは 以前も質問させていただいたのですが、再帰処理が上手くいかないので教えてください。 フォルダ指定ダイアログで取得したフォルダのサブフォルダ内のファイル名を 取得いたいのですが、Sub iFolder(inFolderName)内の inFolderName = ifd.valueの 部分で「Out of memory」となってしまいます。 参照ファイル内のファイル名と参照フォルダ（サブフォルダ含む）内の ファイル名を比較して一致しているファイルを保存先フォルダにコピー /一致しないファイル名をテキストで出力をいうことをしたいと思っています。 参照ファイルの中身は「123.jpg」や「456.JPG」などのファイル名だけになります。 以上、宜しくお願い致します。 <html> <head> <title>テスト</title> <HAT:APPLCATION BORDER="dialog" SCROLL="no" ICON="app.ico"> <script language="VBScript"> 'Call Window.ResizeTo(500,200) '参照フォルダをテキストに表示 sub inFolder() Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder( _ 0, "フォルダを選択してください", 0, "ssfDeskTop") If objFolder Is nothing Then 'MsgBox("フォルダを選択されませんでした。") Else pathFolder = objFolder.Items().Item().Path ifd.value = vbCr & pathFolder Set objFolder = nothing End If End sub '保存先フォルダの選択 sub outFolder() Set objShell = CreateObject("Shell.Application") Set objFolder = objShell.BrowseForFolder( _ 0, "フォルダを選択してください", 0, "ssfDeskTop") If objFolder Is nothing Then 'MsgBox("フォルダを選択されませんでした。") Else pathFolder = objFolder.Items().Item().Path ofd.value = vbCr & pathFolder Set objFolder = nothing End If End sub 'テキストファイル読込------------------------------------------- Sub btn_onClick 'ファイルの有無チェック txOut="" inFileName = inFile.Value Set objFso = CreateObject("Scripting.FileSystemObject") If objFso.FileExists(inFileName) = True Then '書き出し処理 Set objTxIn = objFso.OpenTextFile(inFileName) Do Until objTxIn.AtEndOfStream = True txDisp = objTxIn.ReadLine() txOut = txOut & txDisp & vbCr Loop disp1.value = txOut 'ファイルが無いとき Else MsgBox("ファイルがありません") End If call iFolder(inFolderName) End Sub 'サブフォルダ読込------------------------------------------- Sub iFolder(inFolderName) Dim fsoFolder Dim fsoSubFolder Dim fsoFile inFolderName = ifd.value Set objFso = CreateObject("Scripting.FileSystemObject") 'フォルダオブジェクト取得 Set fsoFolder = objFso.GetFolder(inFolderName) 'フォルダ内/ファイルループ For Each fsoFile In fsoFolder.Files 'ログに出力 disp2.value = fsoFile.Name Next 'フォルダ内/サブフォルダループ(サブフォルダが不要なら、このループは不要) For Each fsoSubFolder In fsoFolder.SubFolders 'サブフォルダで再帰 Call iFolder(fsoSubFolder) Next End Sub </script> </head> <body> 参照ファイル ： <input type="file" id="inFile" size="40"> <br /> 参照フォルダ ： <input type="text" id="ifd" size="40"> <input type="button" id="fd1" value="参照.."> <script for="fd1" event="onClick" language="VBS"> call inFolder() </script> <br /> 保存フォルダ ： <input type="text" id="ofd" size="40"> <input type="button" id="fd2" value="保存.." > <script for="fd2" event="onClick" language="VBS"> call outFolder() </script> <br /> <input type="button" id="btn" value="表示"> <br /> <textarea name="disp1" cols="30" wrap="virtual" rows="20"></textarea> <textarea name="disp2" cols="30" wrap="virtual" rows="20"></textarea> </body> </html>
- ベストアンサー
- Visual Basic
- ファイルを探すプログラムで c:\のみ動かない
ファイルを探すプログラムをネット頂き テストしたのですが c:\ のみ 動かず c:\*** は そのフォルダーから下を探します e:\ は 全てのフォルダーを探します。 ＷＩＮ８ ですが どこで間違ってるのでしょうか？ よろしくどうぞ Option Explicit Private g_dteDate As Date Private g_strEXT As String '参照設定 M-Scripting.Runtime Cells(1, 2).Value に 探すアドレス 記載 c:\ e:\ c:\*** など Sub Sample_FileSearch2() Dim vntF As Variant Dim objFSO As FileSystemObject Dim dteDate As Date Dim GYO As Long Dim cntFound As Long Set objFSO = New FileSystemObject ' FSO Rows("5:65536").ClearContents GYO = 4 ’ g_dteDate = DateAdd("m", Cells(3, 2).Value * -1, Date) 更新 不要 g_strEXT = UCase(Trim(Cells(2, 2).Value)) ' ルートフォルダから探索開始 Call Sample_FileSearch2_SUB(objFSO, _ objFSO.GetFolder(Trim(Cells(1, 2).Value)), GYO, cntFound) Set objFSO = Nothing ' 処理結果の表示 If cntFound = 0 Then MsgBox "見つかりません" Else MsgBox cntFound & "個見つかりました" End If End Sub '''******************************************************************************* ''' ファイル探索処理(再帰動作) '''******************************************************************************* Private Sub Sample_FileSearch2_SUB(objFSO As FileSystemObject, _ ByVal objFolder As Folder, _ GYO As Long, cntFound As Long) Dim objFolder2 As Folder Dim objFile As File ' サブフォルダの探索 For Each objFolder2 In objFolder.SubFolders ' サブフォルダ個々の探索(再帰動作) Call Sample_FileSearch2_SUB(objFSO, objFolder2, GYO, cntFound) Next objFolder2 ' このフォルダ内のファイルの探索 For Each objFile In objFolder.Files ' ここから条件判断 With objFile If (UCase(objFSO.GetBaseName(.Path)) = g_strEXT) Then GYO = GYO + 1 Cells(GYO, 1).Value = .Name Cells(GYO, 2).Value = .DateLastModified Cells(GYO, 3).Value = _ Left(.Path, Len(.Path) - Len(.Name) - 1) cntFound = cntFound + 1 End If End With Next objFile End Sub
- ベストアンサー
- Visual Basic
- エクセルのデータからフォルダを作成
エクセル選択・読み込み→フォルダ作成先指定・処理 →作成した空のフォルダを表示 という手順のプログラムです。 コモンダイアログで選んだエクセルのデータを元に、 新しいフォルダを作成したいと思っています。 エクセルには番号（一列目）、氏名（二列目）などが入っており 一人分の情報が一行目に、二人目の情報が二行目・・・という風に一行ずつに入っています。 指定した作成先に、そのエクセルで読み込んだ人数分だけ 空のフォルダを作成し、なおかつ一列目に入っていた番号を フォルダ名にしたいのですが、どうすればいいでしょうか。 途中まで作ってみましたが後が続きません。 よろしくお願いします。 Private Const BIF_RETURNONLYFSDIRS As Long = &H1 Dim objShell As New Shell Dim objFolder As Folder Private Sub Command1_Click() Set objShell = New Shell Set objFolder = objShell.BrowseForFolder(Me.hWnd, "フォルダを選択してください", BIF_RETURNONLYFSDIRS) If objFolder Is Nothing Then MsgBox "ファイルを開く作業をキャンセルします" Else End If Set objShell = Nothing End Sub
- ベストアンサー
- Visual Basic
- VBScriptでのフォルダ指定ダイアログについて
VBSciptでの「フォルダ指定ダイアログ」について教えてください。 「フォルダ指定ダイアログ」を利用して、保存元のフォルダと保存先の フォルダを選択し、特定ファイル(*.jpg)のコピーをするツールを作っています。 下記のプログラムで、「フォルダ指定ダイアログ」が表示されるのは 確認できたのですが、選択したフォルダの階層をテキストフォームに 表示させる方法を教えてください。（書き込みできませんのエラーになります。） --------------------------------------------------------- Dim objShell Dim objFolder ' オブジェクトの生成 Set objShell = CreateObject("Shell.Application") ' フォルダ選択ダイアログを表示 Set objFolder = objShell.BrowseForFolder(0, "フォルダを選択してください。", 0) Set objShell = Nothing --------------------------------------------------------- 以上、宜しくお願い致します。
- ベストアンサー
- Visual Basic
- Desktopのファイルを別フォルダにコピーしたい
Desktop上のあるZIPファイル（例；zzz.zip）を別のフォルダ（例；DドライブのFolder1）にコピーして解凍する場合、下記のVBSで実行できると思いますが、これをDesktopの階層が異なる（後述の xxxxx）不特定多数のPCで実施する場合、実行できない場合があります。 このためDesktopの階層が左右されないScriptにしたいのですが、模範Scriptを教えていただけないでしょうか。DesktopPathなどで対応すればできるのでは、と思いますが、なかなかうまくいきません。 使用PCのOSはWindows7（32ビット）です。 '------------------------------------------------------------- DIR_Source = "C:\xxxxx\Desktop\zzz.zip" DIR_Destination = "D:\Folder1" Const FOF_Silent = &H04 Const FOF_NoConfirmation = &H10 Set objShell = CreateObject("Shell.Application") Set FilesInZip = objShell.NameSpace(DIR_Source).items Set objFolder = objShell.NameSpace(DIR_Destination) If (Not objFolder Is Nothing) Then objFolder.CopyHere FilesInZip, FOF_NoConfirmation + FOF_Silent End If
- ベストアンサー
- Visual Basic
- VBScriptでファイルからgoogle検索
カレントディレクトリの.txtファイルを1行づつ読み込み、google検索したいのですが、ウィンドウが複数立ち上がってしまい1ウィンドウでタブで表示したいのですが上手くいきません。。と、テキストファイル名もタイトルタグで表示したいです。どなたかご存知でしたらご教授願います。以下、書きかけのソースになります。 ---------------------------------------------------------------------------------- use_ie Sub use_ie() 'Option Explicit 'On Error Resume Next Dim objFSO ' FileSystemObject Dim objFile ' ファイル読み込み用 Dim objWshShell ' WshShell オブジェクト If Err.Number = 0 Then Set objWshShell = WScript.CreateObject("WScript.Shell") Set objFSO = WScript.CreateObject("Scripting.FileSystemObject") If Err.Number = 0 Then For Each FLO In objFSO.GetFolder(objWshShell.CurrentDirectory).Files path = FLO.Path If Right(path, 4) = ".txt" Then Set objFile = objFSO.OpenTextFile(path, 1) Do While objFile.AtEndOfStream <> True Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True 'ie.Navigate "about:blank" 'ie.Document.Write "<title>path</title>" ie.Navigate "http://www.google.co.jp/" ',2048 '新規タブで開く waitIE ie ie.Document.getElementById("q").Value = objFile.ReadLine WScript.Sleep 100 ' 検索ボタンクリック ie.Document.all("btnG").Click waitIE ie strURL = "https://www.google.co.jp/" If ie.LocationURL = strURL Then ie.Quit Set ie = Nothing End If Loop objFile.Close End If Next Else WScript.Echo "ファイルオープンエラー: " & Err.Description End If Else WScript.Echo "エラー: " & Err.Description End If Set objFile = Nothing Set objFSO = Nothing Set objWshShell = Nothing Set ie = Nothing End Sub ' IEがビジー状態の間待ちます Sub waitIE(ie) Do While ie.Busy = True Or ie.readystate <> 4 WScript.Sleep 100 Loop WScript.Sleep 1000 End Sub
- 締切済み
- Visual Basic
- EXCEL2000 フォルダ内のファイルを検索
EXCEL2000 フォルダ内のファイルを検索 お分かりになる方がいましたらお力添えの程よろしくお願いします。 任意のフォルダ内で任意のファイルサーチが出来るマクロを実行したいのですが、ファイルサーチの値を全角、半角、大文字、小文字区別なく行いたいのです。 例えば,セル2,2に、topと入力したら、topもｔｏｐもTOPもＴＯＰも検索対象に引っかかり、セルに書き出して欲しいのです。 ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ Sub ファイル一覧2() Dim vntF As Variant Dim objFS As FileSearch Dim objFSO As FileSystemObject Dim GYO As Long Dim cntFound As Long Set objFS = Application.FileSearch ' FileSearch Set objFSO = New FileSystemObject ' FSO Rows("5:65536").ClearContents Application.ScreenUpdating = False GYO = 4 With objFS .NewSearch .LookIn = Trim(Cells(1, 2).Value) ' Search開始フォルダ .Filename = Trim(Cells(2, 2).Value) ' 探索ファイル式 .SearchSubFolders = True ' サブフォルダも探索 ' 処理開始 If .Execute() <> 0 Then For Each vntF In .FoundFiles With objFSO.GetFile(vntF) GYO = GYO + 1 Cells(GYO, 1).Value = .Name Cells(GYO, 2).Value = .DateLastModified Cells(GYO, 3).Value = _ Left(.Path, Len(.Path) - Len(.Name) - 1) cntFound = cntFound + 1 End With Next vntF End If End With Set objFS = Nothing Set objFSO = Nothing ' 処理結果の表示 If cntFound = 0 Then MsgBox "見つかりません" Else MsgBox cntFound & "個見つかりました" End If End Sub
- 締切済み
- Visual Basic
- VBScriptでフォルダ参照ダイアログを表示したい
HTMLファイルの中にVBScriptを記述しています。 内容はボタンが押されたら、フォルダ参照のダイアログ ボックスを表示したいのです。 開発環境は windows2000 IE6.02 スクリプトのところは以下のように記述しています。 Function Getfolder() Set Shell = CreateObject("Shell.Application") Set objFolder = Shell.BrowseForFolder(0, "フォルダを選択してね！", 1) if objFolder is Nothing then Msgbox("フォルダを選択してください") else Msgbox(objFolder.Items.Item.Path) end if End Function で、Set objFolder = Shell.BrowseForFolder(0, "フォルダを選択してね！", 1) のところで「書き込みできません」のエラーが表示されてしまいます。 どのようにすればフォルダ参照のダイアログボックスを表示できるのでしょうか？
- ベストアンサー
- その他（プログラミング・開発）
- VBScriptで検索結果をタブ表示したいです。
カレントディレクトリの.txtファイルを1行づつgoogle検索したいのですが、ウィンドウが複数立ち上がってしまい1ウィンドウでタブで表示したいのですが上手くいきません。。と、テキストファイル名もタイトルタグで表示したいです。どなたかご存知でしたらご教授願います。以下、書きかけのソースになります。 ---------------------------------------------------------------------------------- use_ie Sub use_ie() 'Option Explicit 'On Error Resume Next Dim objFSO ' FileSystemObject Dim objFile ' ファイル読み込み用 Dim objWshShell ' WshShell オブジェクト If Err.Number = 0 Then Set objWshShell = WScript.CreateObject("WScript.Shell") Set objFSO = WScript.CreateObject("Scripting.FileSystemObject") If Err.Number = 0 Then For Each FLO In objFSO.GetFolder(objWshShell.CurrentDirectory).Files path = FLO.Path If Right(path, 4) = ".txt" Then Set objFile = objFSO.OpenTextFile(path, 1) Do While objFile.AtEndOfStream <> True Set ie = CreateObject("InternetExplorer.Application") ie.Visible = True 'ie.Navigate "about:blank" 'ie.Document.Write "<title>path</title>" ie.Navigate "http://www.google.co.jp/" ',2048 '新規タブで開く waitIE ie ie.Document.getElementById("q").Value = objFile.ReadLine WScript.Sleep 100 ' 検索ボタンクリック ie.Document.all("btnG").Click waitIE ie strURL = "https://www.google.co.jp/" If ie.LocationURL = strURL Then ie.Quit Set ie = Nothing End If Loop objFile.Close End If Next Else WScript.Echo "ファイルオープンエラー: " & Err.Description End If Else WScript.Echo "エラー: " & Err.Description End If Set objFile = Nothing Set objFSO = Nothing Set objWshShell = Nothing Set ie = Nothing End Sub ' IEがビジー状態の間待ちます Sub waitIE(ie) Do While ie.Busy = True Or ie.readystate <> 4 WScript.Sleep 100 Loop WScript.Sleep 1000 End Sub
- 締切済み
- Visual Basic
- VBS 任意の名前でzip内のファイルを解凍したい
VBSを使ってzipファイルの解凍を行う際に、解凍ファイルを任意の名前にしたいです。 現在以下の内容のvbsでzipファイルを解凍しています。 --------------------------------------------------------------- zippath = "C:\新しいフォルダー\test.zip" savepath = "C:\新しいフォルダー" Set objShell = CreateObject("Shell.Application") Set FilesInZip = objShell.NameSpace(zippath).items Set objFolder = objShell.NameSpace(savepath) If (Not objFolder Is Nothing) Then objFolder.CopyHere FilesInZip, FOF_NOCONFIRMATION + FOF_SILENT End If --------------------------------------------------------------- 解凍自体は上手くいってるのですが、解凍したファイルの名前が統一されていない為、次の処理でスマートにファイルの指定ができません。 このファイル名を、 ・zipファイルと同じ名前(例えば「test.zip」なら「test.xlsx」など)にする。 ・任意の名前で解凍する。 ことは出来ないでしょうか。 ご回答よろしくお願いします
- ベストアンサー
- Visual Basic
補足
redfox63 さん お返事が遅くなり申し訳ありません。 「On Error Resume Next」をコメントアウトするとエラーで引っかかるため、 何点か書き直しコピーをすることはできるようになりました。ありがとうございました。 ただ、読込んだテキスト内のファイル名と指定したフォルダ内にあるファイル名を 比較して一致しているものをコピーということができませんでした。 <script language="VBScript"> 'Call Window.ResizeTo(500,200) Set objFso = CreateObject("Scripting.FileSystemObject") 'テキストファイル吐き出し場所 Const LIST_FILE = "C:\Documents and Settings\All Users\デスクトップ\NonFile.txt" '色々定数 Const TristateTrue = -1, TristateFalse = 0, TristateUseDefault = -2 Const ForReading = 1 ,ForWriting = 2, ForAppending = 8 '色々宣言 Dim objFso, objTxIn, objTxT Dim inFolderName 'コピー元フォルダ Dim outFolderName 'コピー先フォルダ Dim inFileName '読み込みテキスト '中略' '[表示]ボタンクリックで開始される処理 '------------------------------------------------------------ Sub btn_onClick 'ファイルの有無チェック inFileName = inFile.Value outFolderName = ofd.value If objFso.FileExists(inFileName) = True Then 'ログファイルがあったら削除 If objFso.FileExists(LIST_FILE) Then Call objFso.DeleteFile(LIST_FILE) End If '読込テキストファイルの準備 Set objTxT = objFso.OpenTextFile(inFileName) txIn = objTxT.ReadAll() 'ファイルが無いとき Else MsgBox("ファイルが選択されていません。") End If Call iFolder(inFolderName) MsgBox("完了") End Sub 'サブフォルダ内ファイル検査→有 コピー/無 テキスト出力 '------------------------------------------------------------ Sub iFolder(inFolderName) 'フォルダオブジェクト取得 outFolderName = ofd.value If inFolderName ="" then inFolderName = ifd.value Set fsoFolder = objFso.GetFolder(inFolderName) 'フォルダ内/ファイルループ For Each fsoFile In fsoFolder.Files If txIn = fsoFile.Name Then objFso.CopyFile fsoFile.Path, outFolderName & "\" Else 'NonFileの準備 Set objTxIn = objFso.OpenTextFile(LIST_FILE, 8, True,0) objTxIn.WriteLine() objTxIn.close End If Next 'フォルダ内/サブフォルダループ For Each fsoSubFolder In fsoFolder.SubFolders ' サブフォルダで再帰 Call iFolder(fsoSubFolder) Next End Sub