変換.tokyo | henkan.tokyo

【VBS】更新日が指定日数以上経過したファイルを再帰的に削除する


■【VBS】更新日が指定日数以上経過したファイルを再帰的に削除する

更新日が指定日数以上経過したファイルを再帰的に削除するVBScriptです。

下記のWebサイト「jfmillet40」を参考に、フォルダ指定方法をアレンジしました。
https://sites.google.com/site/jfmillet40/home/vbscript/memo

更に「DaysOfDeletion」の値をInputboxを使って入力させるようにすれば、汎用性のあるツールになります。


■サンプルコード

Option Explicit

'更新日が何日以上前のファイルを削除するか?
Const DaysOfDeletion = 90

'削除処理をする対象フォルダ
Dim TargetFolderPath

'-----------------------------------
' オブジェクト定義
'-----------------------------------

Dim fso
Dim subf

Dim FileName ' ファイル名
Dim FolderName ' フォルダ名
Dim FDate ' ファイルの更新日

'-----------------------------------
' メイン処理
'-----------------------------------

Dim StartMsg
Dim EndMsg

'フォルダのパスを取得
TargetFolderPath = InputBox("削除対象ファイルの保存先フォルダを指定してください。","【90日経過したファイルを一括削除】保存先フォルダは?")

Set fso = CreateObject("Scripting.FileSystemObject")
Set subf = fso.GetFolder(TargetFolderPath)

If Len(TargetFolderPath) = 0 Then
WScript.Quit
Else
Call FileDel(subf)
End If

EndMsg = MsgBox("「" & TargetFolderPath & "」フォルダ内の" & DaysOfDeletion & "日以上前のファイルを削除しました。",vbOKOnly ,"古いファイルの削除")

'-----------------------------------
' 指定フォルダ直下のファイル削除処理
'-----------------------------------

Dim SubFolder1

Sub FileDel(SubFolder1)

For Each FileName In SubFolder1.Files 'フォルダ内のファイル名を取得

' ファイルの更新日を取得
fdate = FileName.DateLastModified

' 更新日から削除するか否かを判定
if DateDiff("d", fdate, date) >= DaysOfDeletion then
' ファイル削除
fso.DeleteFile FileName
end if

Next

'サブフォルダがある際の処理
Call FolderCheck(SubFolder1)

End Sub

'-----------------------------------
' サブフォルダがある際の処理
'-----------------------------------

Dim SubFolder2

Sub FolderCheck(SubFolder2)

For Each FolderName In SubFolder2.Subfolders 'サブフォルダ名を取得

'サブフォルダ内のファイル削除処理
Call FileDel(FolderName)

Next

End Sub

'-----------------------------------
' オブジェクト開放
'-----------------------------------

set fso = Nothing


■サンプルVBSダウンロード
こちらから


■VBSを作成するのに参考となる書籍
[商品価格に関しましては、リンクが作成された時点と現時点で情報が変更されている場合がございます。]

VBScriptポケットリファレンス改訂版 (Pocket reference) [ アンク ]
価格:2030円(税込、送料無料) (2018/9/15時点)

楽天で購入


【Excel VBA】「Yahoo路線情報」の乗り換え案内を使って、複数分の移動時間・運賃を一括検索する

 
■【Excel VBA】「Yahoo路線情報」の乗り換え案内から、複数分の移動時間・運賃を一括検索する

例えばオフィスを移転するような場合、人事の担当者は、スタッフの交通費がどれくらい増減するのか等を気にすると思います。
そこで「Yahoo路線情報」の乗り換え案内の情報を自動的に取得、複数名分の移動時間・運賃を一括で検索し、リスト表示するというExcel VBAをご紹介致します。

今回、こちらのWebサイト「VBA(マクロ)で仕事を楽しく効率化」の情報を参考にさせていただきました。
http://officevba.info/norikaevba/



■VBAの動作

プログラムの基本的な流れは以下の通りです。
@InternetExplorerを開く
A「Yahoo路線情報」のページ(http://transit.yahoo.co.jp/)に移動する
B出発地・目的地・時間・その他新幹線を使用するか、特急を使用するかなどの条件を入力(〇印を付ける)する
C「Yahoo乗換案内で検索」ボタンをクリックする
D表示されたページから必要な情報を収集し、Excelシートに転記する
E上記A〜Dを繰り返す
FInternetExplorerを終了する



■サンプルコード

Option Explicit
Dim colSh As Object
Dim win As Object
Dim strTemp As String
Dim IE As InternetExplorer
Dim objIE(5) As InternetExplorer
Dim objIE2 As InternetExplorer
Dim txtInput(16) As HTMLInputElement
Dim txtInput2(20) As HTMLSelectElement
Dim button(10) As HTMLInputElement
Dim Form
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub 集計()
Dim x As Long
IE立ち上げ
x = 4
Do Until x > Cells(60000, 3).End(xlUp).Row
乗り換え案内検索 (x)
乗り換え案内結果集計 (x)
IE繰り返し
x = x + 1
Loop
IE終了
End Sub

Private Sub IE立ち上げ()
'@InternetExplorerを開く
Set IE = CreateObject("InternetExplorer.application")
IE.Visible = True
'AYahoo乗り換え検索のページ("http://transit.yahoo.co.jp/")に移動
IE.navigate ("http://transit.yahoo.co.jp/")
Do While IE.Busy Or IE.readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Private Sub 乗り換え案内検索(i As Long)
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
If InStr(win.document.Title, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'B出発地・目的地・時間・その他新幹線を使用するか、特急を使用するかなどの条件入力
'B-1 出発地の入力
Set txtInput(1) = objIE(0).document.getElementById("sfrom")
txtInput(1).Value = Cells(i, 3).Value
'B-2 到着地の入力
Set txtInput(2) = objIE(0).document.getElementById("sto")
txtInput(2).Value = Cells(i, 4).Value
'B-3 新幹線を利用するか
Set txtInput(3) = objIE(0).document.getElementById("sexp")
If Cells(i, 8).Value = "○" Then
txtInput(3).Checked = True
Else
txtInput(3).Checked = False
End If
'B-4 有料特急を利用するか
Set txtInput(4) = objIE(0).document.getElementById("exp")
If Cells(i, 9).Value = "○" Then
txtInput(4).Checked = True
Else
txtInput(4).Checked = False
End If
'B-5 出発時間での検索
Set txtInput(5) = objIE(0).document.getElementById("tsDep")
If Cells(i, 5).Value = "出発" Then
txtInput(5).Checked = True
End If
'B-6 到着時間での検索
Set txtInput(6) = objIE(0).document.getElementById("tsArr")
If Cells(i, 5).Value = "到着" Then
txtInput(6).Checked = True
End If
'B-7 日時の入力
Set txtInput2(0) = objIE(0).document.getElementById("y")
txtInput2(0).Value = Year(Cells(i, 6))
Set txtInput2(1) = objIE(0).document.getElementById("m")
txtInput2(1).Value = Format(Month(Cells(i, 6)), "00")
Set txtInput2(2) = objIE(0).document.getElementById("d")
txtInput2(2).Value = Format(Day(Cells(i, 6)), "00")
Set txtInput2(3) = objIE(0).document.getElementById("hh")
txtInput2(3).Value = Format(Hour(Cells(i, 7)), "00")
Set txtInput2(4) = objIE(0).document.getElementById("mm")
txtInput2(4).Value = Format(Minute(Cells(i, 7)), "00")
'B-8 検索結果表示順の選択
Set txtInput2(5) = objIE(0).document.getElementsByName("s")(0)
If Cells(i, 10).Value = "到着が早い順" Then
txtInput2(5).Value = "0"
ElseIf Cells(i, 10).Value = "乗り換え回数順" Then
txtInput2(5).Value = "2"
ElseIf Cells(i, 10).Value = "料金が安い順" Then
txtInput2(5).Value = "1"
End If
'C検索ボタンをクリック
Set Form = objIE(0).document.getElementById("searchModuleSubmit")
Form.Click
Sleep 1000
Do While objIE(0).Busy Or objIE(0).readyState <> READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Sub 乗り換え案内結果集計(i As Long)
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
If InStr(win.document.Title, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'D表示されたページから必要な情報を収集
Set txtInput(7) = objIE(0).document.getElementsByClassName("small")(0)
Cells(i, 11).Value = txtInput(7).innerText
Cells(i, 11).Value = Replace(Replace(Cells(i, 11), "(", ""), ")", "")
Set txtInput(8) = objIE(0).document.getElementsByClassName("small")(1)
Cells(i, 13).Value = txtInput(8).innerText
Cells(i, 13).Value = Replace(Replace(Cells(i, 13), "(", ""), ")", "")
Set txtInput(9) = objIE(0).document.getElementsByClassName("small")(2)
Cells(i, 15).Value = txtInput(9).innerText
Cells(i, 15).Value = Replace(Replace(Cells(i, 15), "(", ""), ")", "")
Set txtInput(10) = objIE(0).document.getElementsByClassName("fare")(0)
Cells(i, 12).Value = txtInput(10).innerText
Set txtInput(11) = objIE(0).document.getElementsByClassName("fare")(1)
Cells(i, 14).Value = txtInput(11).innerText
Set txtInput(12) = objIE(0).document.getElementsByClassName("fare")(2)
Cells(i, 16).Value = txtInput(12).innerText
End Sub

Private Sub IE繰り返し()
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
strTemp = win.document.body.innerText
If InStr(strTemp, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'E-1 Yahoo乗り換え検索のページ("http://transit.yahoo.co.jp/")に移動
objIE(0).navigate ("http://transit.yahoo.co.jp/")
Sleep 1000
Do While objIE(0).Busy Or objIE(0).readyState < READYSTATE_COMPLETE
DoEvents
Sleep 1
Loop
Sleep 1000
End Sub

Private Sub IE終了()
Set colSh = CreateObject("Shell.Application")
For Each win In colSh.Windows
If TypeName(win.document) = "HTMLDocument" Then
strTemp = win.document.body.innerText
If InStr(strTemp, "乗換案内") > 0 Then
Set objIE(0) = win
Exit For
End If
End If
Next
'FInternetExplorerを終了
objIE(0).Quit
End Sub


■サンプルVBAダウンロード
こちらから

■VBAからIEを操作するのに参考となる図書




【VB】フォームが最大化された時の位置とサイズを設定


■【VB】フォームが最大化された時の位置とサイズを設定


フォームが最大化された時の位置とサイズを設定するには、MaxmizedBounds プロパティを使用します。
MaximumSize プロパティが MaxmizedBounds プロパティの Size より小さい場合は、MaxmumSize の大きさになりますので注意してください。



■サンプルコード

' 最大化した時の位置を X=32, Y=16 に、サイズを 512 x 256 に設定する

Me.MaximizedBounds = New Rectangle(32, 16, 512, 256)


' Point 構造体と Size 構造体で指定しても良い

Me.MaximizedBounds = New Rectangle(New Point(32, 16), New Size(512, 256))