- ベストアンサー
ファイルをまちうけして別フォルダにコピーする
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" _ (ByVal lpszPath As String) As Long Private Sub Command1_Click() Dim P as string,P1 as string Dim Hiduke as string Hiduke=year(date) & month(date) & day(date) _ & hour(time) &second(time) P = "c:\FOLD1\DATA.TXT" P1="C:\FOLD1\Back\Hiduke & "data.txt" Do If PathFileExists(P) Then filecopy P,P1 kill P End if Loop End Sub 以上のように実行するとすぐビジー状態になる。 data.txtは短くて30秒、長くて30分単位に作成される どうしたらビジー状態にならないようになるのですか
- akaricyan
- お礼率58% (14/24)
- Visual Basic
- 回答数3
- ありがとう数2
- みんなの回答 （3）
- 専門家の回答
質問者が選んだベストアンサー
＞ Hiduke=year(date) & month(date) & day(date) _ & hour(time) &second(time) Hiduke=Format(Now(),"yymmddhhmmss") が簡単かと思います。 ＞ P1="C:\FOLD1\Back\Hiduke & "data.txt" ファイル名が、Hidukedata.txt になりますよね。 P1="C:\FOLD1\Back\" & Hiduke & "data.txt" 等にすべきかとおもいますが・・・。 ＞タイマー監視とはどういう使い方になるのですか？ 一定間隔でタイマーイベントを発生させて、そのイベントを受け取って任意の動作（今回はファイルチェック＆コピー）を実行するようにすると、パソコンの負荷も軽くなると思います。 タイマーの使い方や注意などは下記サイトを参考にしてください。 数秒単位でファイルチェックできるようにすれば大丈夫ではないでしょうか。
その他の回答 (2)
- hana-hana3
- ベストアンサー率31% (4940/15541)
＞以上のように実行するとすぐビジー状態になる。 Do ： Loop って、どうやって脱出（終了）するのでしょうか？ これが繰り返されている限り、ビジーになってしまうと思いますが？ ＞短くて30秒、長くて30分単位に作成される タイマー監視の方が良いのでは？ ＶＢＡ使いですが、他にも何点か不備があるように思います。 ループ外でフォルダ名を決定していますので、正常に動いても、全て同じフォルダに上書きされてしまうように思いますが・・・。
お礼
ありがとうございます。 ここの部分 Hiduke=year(date) & month(date) & day(date) _ & hour(time) &second(time) P = "c:\FOLD1\DATA.TXT" P1="C:\FOLD1\Back\Hiduke & "data.txt" Do～Loopのなかに書かなければなりませんよね パソコンをつけた時から切断するまで実行したいので このようになりました。 タイマー監視とはどういう使い方になるのですか？
- ggandt
- ベストアンサー率41% (5/12)
ビジーになるというのは、ウインドウが真っ白になり、終了ボタンなどが効かなくなる、という意味でいいですか？ Loop の 前の行に DoEvents を入れればいいのではないでしょうか。
関連するQ&A
- フォルダの中にファイルがあるかどうかを読み取りたい
vbaです。 ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ Option Explicit Sub test() Dim 検索フォルダ As String Dim 検索ファイル名 As String 検索フォルダ = "C:\Users\Public" 検索ファイル名 = "新しいテキスト ドキュメント.txt" If 検索フォルダの中に検索ファイル名がある Then MsgBox 検索ファイル名 & "は存在します" End If End Sub ・・・・・・・・・・・・・・・・・・・・・・・・・・・・・ こんな感じで、フォルダの中にファイルがあるかどうかを読み取りたいのですが これ以上どういうコードを書けばいいかわかりません。 「フォルダの中にファイルがあるかどうか」がわかれば、出来そうな気がするのですが ご教授いただけますか？
- ベストアンサー
- その他（プログラミング・開発）
- ファイル名がテキストボックスにうまく表示できない
お世話になります。 filelistboxで選択したファイル名を選択した順に テキストボックスに表示させたいのですが、ファイル名の 後に改行コードを入れても改行して表示してくれません。 何が原因なんでしょうか？よろしく御教授願います。 例 aaa.txtを選択、テキストボックスに表示させ、 その後bbb.txtを選択するとテキストボックスの表示が ”aaa.txt‥bbb.txt”となる --------- aaa.txt（改行） bbb.txt --------- と表示したい。 （コード） Dim fname As String Private Sub File1_Click() fname = Dir1.Path & "\" & File1.FileName End Sub Private Sub Command3_Click() Call macappend End Sub Private Sub macappend() 'text1に選択マクロを追加 Dim macbuff1 As String Dim macbuff2 As String macbuff2 = Text1.Text macbuff1 = fname + Chr(13) + Chr(11) macbuff2 = macbuff2 + macbuff1 Text1.Text = macbuff2 End Sub
- ベストアンサー
- Visual Basic
- 別フォルダに保存してあるテキストファイルを重複して強制保存したい
別フォルダに保存してあるテキストファイルを重複して強制保存したいのですが、 Sub wsave() '書き出し後の保存 Dim myOldName As String Dim myNewName As String Sheets("AAA").Range("B2").Select If Selection = "" Then Exit Sub Else myOldName = Sheets("AAA").Range("H11") & "HPlist.txt" '変更元ファイル myNewName = Sheets("AAA").Range("H11") & Range("H16") '変更後のファイル名 If Len(Dir(myOldName)) > 0 Then Application.DisplayAlerts = False Name myOldName As myNewName Application.DisplayAlerts = True End If End If Application.Quit End Sub このままではエラー「既に同名のファイルが存在しています」と成り保存されないのです。 どなたかよい方法を教えていただけませんでしょうか？
- ベストアンサー
- Visual Basic
- エクセルでプロシージャが終了しません。
ユーザーフォームのボタンをクリックしたら、特定のセルに現在の時刻を入力するマクロを作っています。 入力するところまではうまくいったのですが、プロシージャが終了しないので保存することができません。 どこが違うのかわからないので、わかる方よろしくお願いいたします。 Private Sub cmd1_Click() Dim hiduke As Date Dim hiduke2 As Integer hiduke = Now() hiduke2 = CInt(Day(hiduke)) If chk1.Value = True Then Cells(4, 1).Select Do Until ActiveCell.Value = hiduke2 ActiveCell.Offset(1, 0).Select Loop ActiveCell.Offset(0, 2).Value = hiduke Else Cells(4, 1).Select Do Until ActiveCell.Value = hiduke2 ActiveCell.Offset(1, 0).Select Loop ActiveCell.Offset(0, 8).Value = hiduke End If End Sub
- ベストアンサー
- オフィス系ソフト
- ダイアログボックスからフォルダ名を取得し、フォルダ内のCSVファイルを
ダイアログボックスからフォルダ名を取得し、フォルダ内のCSVファイルをすべてアクセスのテーブルにインポート使用と思っています。 ところがCSVファイルの数の分だけ、１つめのCSVファイルの中身が繰り返しインポートされてしまっています。 どの部分に誤りがあるのでしょうか？ お知恵を拝借できますでしょうか・・・。 コードは以下になります。 Private Sub cmd06_Click() Dim MyFile As String Dim MyName As String Dim MyName02 As String Dim strFolderName As String strFolderName = GetFolderName() 'フォルダ選択ダイアログを表示 If Len(strFolderName) > 0 Then '選択結果を評価 MyFile = strFolderName & "\*.csv" '【拡張子csvのファイルのみ取得】 MyName = Dir(MyFile, vbNormal) MyName02 = "\" & MyName Do While MyName <> "" If MyName <> "." And MyName <> ".." Then If GetAttr(strFolderName & "\" & MyName) <> vbDirectory Then DoCmd.TransferText acImportFixed, "T03_インポート定義", "T03_全CSVデータ", strFolderName & MyName02, False, "" '【取得したファイルをインポート】 End If End If MyName = Dir Loop Else MsgBox "フォルダは選択されませんでした" End If MsgBox "データのインポートが終了しました" End Sub
- ベストアンサー
- その他MS Office製品
- VB6 テキストファイルへの保存方法
みなさん教えてください。 いまＶＢ６．０で、テキストボックス（textbox1）に入力するデータ（数値）を名前を指定するテキストファイルに内容を保存したいと考えています。 これをやろうと、下記のように構文を作成したのですが、何故かうまくいきません。 みなさんアドバイスを頂けないでしょうか。 宜しくお願いします。 Private Sub Command1_Click() Dim StrFN As String Dim sw As System.Io.StreamWriter 'テキストファイルを上書きで保存する StrFN = Application.GetSaveAsFilename("", "測定データ(*.txt),*.txt,全てのファイル(*.*),*.*", , "測定データファイル名指定") 'ダイアログ表示 If Dir(StrFN) <> "" Then If vbYes <> MsgBox("同名ファイルがあります。" & vbLf & _ "上書きしますか？", vbYesNo) Then Exit Sub End If End If sw = StrFN '書込み sw.Write (textbox1.Text) sw.Close () End Sub
- ベストアンサー
- Visual Basic
- Excelのユーザーフォームで別のファイルに転記
Excel2007です。 マクロを含んだデータファイルがあるのですが、マクロブックとデータブックは分割した方がよいと言われて今分割の方法を試しています。 「マクロブック.xlsm」にマクロを記述し、「商品在庫Data.xlsm」にデータが格納されています。 （まだ試験中で完全に分割できていないのでデータブックもxlsm形式ですが） マクロブックのユーザーフォームから「商品在庫Data.xlsm」ファイルの「商品マスタ」というシートに転記したいのですが、どうやっても「商品在庫Data.xlsm」で「商品マスタ」シートを指定して転記できません。 ユーザーフォームのコードは下記のような内容です。 「HinTouroku」コマンドボタンを押した時に商品マスタシートに内容が転記されるようになっています。 Option Explicit Private Sub HinTouroku_Click() '商品登録 Dim lRow As Long Dim s1 As String, s2 As String Dim Ctrl As Control With Workbooks("商品在庫Data.xlsm") Worksheets ("商品マスタ") lRow = .Range("A" & Rows.Count).End(xlUp).Row s1 = .Cells(lRow, "A").Value s2 = txtHinId.Text If s1 = s2 Then MsgBox "商品IDが重複しています" Exit Sub End If lRow = lRow + 1 .Cells(lRow, "a").Value = txtHinId.Text .Cells(lRow, "b").Value = txtSyohinmei.Text .Cells(lRow, "c").Value = txtHinRyaku.Text End With For Each Ctrl In Me.Controls If Ctrl.Name Like "txt*" Then Ctrl.Value = "" End If Next End Sub Private Sub TourokuClr_Click() '入力フォームのクリア Dim myCtrl As Control For Each myCtrl In Controls If TypeName(myCtrl) = "TextBox" Then _ myCtrl.Value = vbNullString Next End Sub Private Sub TourokuCls_Click() 'フォームを閉じる Unload Me End Sub http://vbaexcel.seesaa.net/category/7604114-2.html このサイトを参考にしながら書いてみたのですがどうしてもシートの指定ができず… どのように記述すればよいのでしょうか？
- ベストアンサー
- オフィス系ソフト
- サブフォルダ内のファイル名取得について
Windows7 Access 2013環境です。 USB接続したハードディスク内のファイルリストを作成しようとしています。 ハードディスクはNTFSフォーマットです。 ボタン1をクリックしたとき、テーブル1をソースにしたフォーム1に ファイル名を書き出していくようにしました。 ドライブ内のサブフォルダを選択すると、プログラムは正常に作動するのですが ドライブ直下を指定すると、実行時エラー 70 "書き込みできません" が発生します。 NTFSのアクセス権は、管理者でログインしているので、システム関連のフォルダ System Volume Information $RECYCLE.BIN 以外は問題ありません。 どこに問題があるのでしょうか。もし、システム関連のフォルダが 引っかかっているとしたら、その回避方法についても 具体的にご教授願います。 ↓エラー箇所↓ -------------------------------------------------------------- For Each subfolder In folder.SubFolders -------------------------------------------------------------- ↓作成したプログラム↓ -------------------------------------------------------------- Private Sub ボタン_1_Click() Dim dlg As FileDialog Dim fold_path As String Dim strTargetDir As String DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec Set dlg = Application.FileDialog(msoFileDialogFolderPicker) If dlg.Show = False Then Exit Sub fold_path = dlg.SelectedItems(1) strTargetDir = fold_path Call FolderSearch(strTargetDir) MsgBox "終了" Set dlg = Nothing Else End If End Sub Public Sub FolderSearch(strTargetDir As String) Dim fso As Object Dim folder As Object Dim subfolder As Object Dim file As Object Dim objFilsSys As Object Dim objDrive As Object Dim strDriveLetter As String Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(strTargetDir) strDriveLetter = Left(strTargetDir, 1) Set objFileSys = CreateObject("Scripting.FileSystemObject") Set objDrive = objFileSys.GetDrive(strDriveLetter) For Each subfolder In folder.SubFolders ←エラー箇所 FolderSearch subfolder.Path Next subfolder For Each file In folder.Files With file Me.ボリューム名 = objDrive.VolumeName Me.ファイル名 = file.Name Me.ファイルパス = folder.Path Me.ファイルサイズ = folder.Size DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec End With Next file Set objDrive = Nothing Set fso = Nothing Set folder = Nothing End Sub
- ベストアンサー
- その他(データベース)
- リストボックスの内容を テキストファイルに出力
エクセル vba初心者です。 (1)ini fileからデータを取得 (2)その内容のリストボックスに表示 (3)リストボックス内容をテキストボックスに出力 (2)、(3)がわかりません。 なんとなくやってたら余計にわからなくなりました。助けてください。 Private Sub CommandButton1_Click() '読込み(1)を押した時の処理 Dim listbox As String Dim strL_Data As String '取得した値 Dim n As Integer n = FreeFile ListBox1.Clear Open "C:\filepath.ini" For Input As #n Do While Not EOF(n) Line Input #n, listbox ListBox1.AddItem listbox Loop Close #n End Sub Private Sub CommandButton2_Click() '書込み(1)を押した時の処理 Dim listbox As String Dim strL_Data As String '取得した値 Dim n As Integer n = FreeFile Open "c:\example.txt" For Output As #n Print #n, strL_Data Close #n End Sub よろしくお願いいたします。
- 締切済み
- Visual Basic
- ファイルを読み込んだらVBがフリーズする
↓のコードだと、ファイルを読み込んだ時点でVBがフリーズします（平気なファイルも一部ある）。原因と解決法を教えてください。 Private Sub Command1_Click() CommonDialog1.Filter = "テキスト(*.txt)|*.txt|すべて(*.*)|*.*" CommonDialog1.FilterIndex = 1 CommonDialog1.Flags = cdlONFileMustExist CommonDialog1.CancelError = True On Error Resume Next CommonDialog1.ShowOpen If (Err = 0) Then FileRead CommonDialog1.FileName End If On Error GoTo 0 End Sub Private Sub FileRead(FL As String) Dim FileNo As Integer Dim strDAT As String Dim strELM As String Dim pot1 As Integer, pot2 As Integer Dim pDB1 As Integer, pDB2 As Integer FileNo = FreeFile() Open FL For Input As #FileNo While Not EOF(FileNo) Line Input #FileNo, strDAT strDAT = strDAT & ":" pot1 = InStr(strDAT, ":") While pot1 > 0 strELM = Left(strDAT, pot1) pot2 = InStr(strELM, "OPEN") While pot2 > 0 pDB1 = InStr(strELM, Chr(&H22)) If pDB1 > 0 Then '前の『"』の位置 pDB2 = InStr(pDB1 + 1, strELM, Chr(&H22)) If pDB2 > 0 Then RichTextBox1.Text = RichTextBox1.Text & _ Mid(strELM, pDB1 + 1, pDB2 - pDB1 - 1) & vbCrLf End If End If pot2 = InStr(pDB2 + 1, strELM, "OPEN") Wend strDAT = Mid(strDAT, pot1 + 1) pot1 = InStr(strDAT, ":") Wend Wend Close #FileNo End Sub
- ベストアンサー
- Visual Basic
お礼
無事、解決しました。ありがとうございました。 いまVBに取り組んでいます。また、質問すると思いますが、よろしくお願い致します。