【VBScript】ドラッグ＆ドロップでフォルダを圧縮し、パスワードを本日の年月日に設定する

VBSスクリプトを使用して、フォルダを7-zipで圧縮し、パスワードを本日の年月日に設定する方法を紹介します。 毎日フォルダをパスワード付きに圧縮する作業は、パスワードを1つ1つ設定するのが面倒ということでVBSで作成しました。 このスクリプトを使用すると、ドロップしたフォルダを圧縮し、パスワードを本日の年月日に設定することができます。

このスクリプトを使用するためには、7-zipのコマンドライン版がインストールされていることが前提条件です。また、管理者権限が必要であることにも注意してください。

'------------------------------------------------------------------------------------------------------------------
' 現在の日付を取得
currentDate = Date()
' 年、月、日を取得
currentYear = Year(currentDate)
currentMonth = Month(currentDate)
currentDay = Day(currentDate)

' ドロップされたフォルダのパスを取得
Set objArgs = WScript.Arguments
If objArgs.Count = 1 Then
    sSource = objArgs(0)
    ' 圧縮先のファイルを設定
    sDestination = sSource & ".zip"
    
    ' シェルオブジェクトを作成
    Set oShell = CreateObject("WScript.Shell")

    ' 7-zipコマンドを実行
    oShell.Run """C:\Program Files\7-Zip\7z.exe"" a -tzip -p" & currentYear & currentMonth & currentDay & " """ & sDestination & """ """ & sSource & """", 0, True

Else
    ' フォルダがドロップされていない場合は、スクリプトを終了
    WScript.Quit
End If

このスクリプトはChatGPTを利用して作成しました。 プログラマがAIにとって代わる時代が来るのでしょうか。

【VBScript】フォルダ内のファイルを更新日付でフォルダ分けする

フォルダ内に溜まったファイルを手動で振分するのが面倒なのでVBSで自動で年月日フォルダに振分されるスクリプトを作成しました。 システム管理者の作業にはログファイルの管理などがあるかと思いますが、１つのフォルダに出力され続けるものが多いです。 ファイルが増えてくると目的のファイルを見つけにくくなるため整理する必要があります。大量のファイルを人力で振分するのは大変なので自動処理できるようにしました。

画像ファイルの整理などにも便利です。

【欲しかった機能】

フォルダドロップ

ファイルのあるフォルダ内にフォルダを作成

ファイルはコピーして移動（元ファイルを削除する場合は「.copy」を「.move」にする）

処理中の表示

Option Explicit

Dim Fs, sTargetFolder, oTarget, oFile
Dim sFdc, strYear, strMonth, strDay
Dim strYearFolder, strMonthFolder, strDayFolder
Dim Args  
'IE の宣言と初期化
Dim ie
initializeIe()
updateMsg "処理を開始します..."

Set Args = WScript.Arguments

If Args.Count <> 1 Then '処理できるのは１フォルダのみ
    WScript.Echo "当スクリプトに対象となる１フォルダをドラッグ&ドロップして処理を実行してください。"
    WScript.Quit    'スクリプトを終了
End If

'フォルダ判別
With CreateObject("Scripting.FileSystemObject") '以下の処理はEnd WithまでScripting.FileSystemObjectを使用
    If .FolderExists(Args(0)) = False Then  'ドラッグされたものを解析
        WScript.Echo "フォルダが見つかりません。" & vbCrLf & "あるいはフォルダではありません。"
        closeIe()
        WScript.Quit
    End If
End With

Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
For Each sTargetFolder In Args
If Fs.FolderExists(sTargetFolder) Then
 updateMsg (sTargetFolder & " のファイルを整理します。")
 Set oTarget=Fs.GetFolder(sTargetFolder)
 For Each oFile In oTarget.Files
  updateMsg (oFile)
  ' 移動先ディレクトリの存在チェックと作成
  ' YYYY年\MM月\DD日 という形式でフォルダを作成する。
  sFdc = oFile.DateLastModified
  strYear = mid(sFdc,1,4) 
  strMonth = mid(sFdc,6,2)
  strDay = mid(sFdc,9,2)
  strYearFolder = sTargetFolder & "\" & strYear & "年"
  If Not Fs.FolderExists(strYearFolder) Then
   Fs.CreateFolder(strYearFolder)
  End if
  strMonthFolder = strYearFolder & "\" & strMonth & "月"
  If Not Fs.FolderExists(strMonthFolder) Then
   Fs.CreateFolder(strMonthFolder)
  End If 
  'strDayFolder = strMonthFolder & "\" & strDay & "日"  '年月日でフォルダを作成する場合はここを有効にする
  'If Not Fs.FolderExists(strDayFolder) Then
   'Fs.CreateFolder(strDayFolder)
  'End If

  ' ファイルの移動
  updateMsg ("  -> " & Fs.BuildPath(strDayFolder, oFile.Name))
  If Fs.FileExists(Fs.BuildPath(strDayFolder, oFile.Name)) Then
   WScript.echo("  すでにファイルが存在しています。(" & Fs.BuildPath(strDayFolder, oFile.Name) & ")")
   '何もしない。
  Else
   'oFile.Move(strDayFolder & "\") '元データを削除する場合はここを有効にする
   'oFile.copy(strDayFolder & "\") '年月日でフォルダを作成する場合はここを有効にする
   oFile.copy(strMonthFolder & "\") '年月でフォルダを作成する場合はここを有効にする
   
  End If
 Next
End If
'WScript.echo("  移動しました。")
 WScript.echo("  コピーしました。")
' IE を終了させスクリプトを閉じる
closeIe()
WScript.Quit
Next
'------------------------------------------------------------------------------------------------------------------
 ' IE の初期化
Sub initializeIe()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Navigate("about:blank")
    .ToolBar = False
    .StatusBar = False
    ' 幅・高さの設定
    .Width = 900
    .Height = 200
    ' 画面右上に配置する。"parentWindow.screen" はパスカルケースで書くと認識されない
    .Top = 0
    .Left = .Document.parentWindow.screen.Width - 900
    .Document.Charset = "UTF-8"
    .Visible = True
    .Document.Title = "スクリプト実行中"
  End With
End Sub
'------------------------------------------------------------------------------------------------------------------
' メッセージを IE に追記する
' 
' 引数のメッセージを IE の最終行に追記する。
' 最終行が表示されるようにスクロール位置を最下部に設定する。
Sub updateMsg(value)
  With ie
    .Document.Body.innerHTML = .Document.Body.innerHTML & value & "<br>"
    .Document.Script.setTimeout "javascript:scrollTo(0," & .Document.Body.ScrollHeight & ");", 0
  End With
End Sub

' IE を終了する
Sub closeIe()
  ie.Quit
  Set ie = Nothing
End Sub

【Access】チェックボックス一括チェック

Accessの分割フォームで下段にテーブルが表示されフィルター機能などテーブルで使用できる機能が使えます。 フィルターをかけたテーブルのチェックリストに対して一括でチェックを入れることができないので、VBAで作成しました。 単純なコードで実現できるのでお試しください。

ちなみに今回はチェックボックスがtrueのものをレポート印刷するために作成しました。 印刷したいレコードだけフィルタで表示させコードを登録したボタンを押すという流れです。 ついでに一括でチェックを外すコードも書いておきます。

'----------------------
'一括印刷チェック
'----------------------
Private Sub Btn_check_Click()

    Dim rs As DAO.Recordset

    If Me.Dirty Then DoCmd.RunCommand acCmdSaveRecord    'アクティブなフォームの現在のレコードを保存
        Set rs = Me.Recordset.Clone    

    Do Until rs.EOF      '表示されているレコード全てに対してチェックボックスをtrue
        rs.Edit
        rs!印刷チェック = True
        rs.Update
        rs.MoveNext
    Loop
    
    Me.Refresh


End Sub


'----------------------
'印刷チェック解除
'----------------------
Private Sub Btn_clear_Click()
    
    Dim sql As String
        
    sql = "UPDATE 物品購入リスト "
    sql = sql & "SET [印刷チェック] = false;"
    
    DoCmd.SetWarnings False
        
    DoCmd.RunSQL sql
        
    DoCmd.SetWarnings True
    
    Me.Refresh
    
End Sub

【bat】最新ファイルだけをコピーする

定期的にCSVファイルなどを出力している場合、「○○_yyyymmdd.csv」という感じのファイル名で保存されることが多いかと思います。

その中で最新のファイルだけをコピーできると色々と仕事が捗る人用のバッチです。

特定のファイル名を含むファイルの中から日付が最新のものを検索し、特定のフォルダへコピーします。

毎月吐き出されるデータを加工して使用する場合は元データからコピーを取って作業するので、バッチを叩けば最新ファイルがコピーされるとわざわざ出力先からコピーして作業用のフォルダに張り付ける作業がなくなります。

出力データを色々な人が使用する場合は元データを加工すると大問題になってしまうので必ず自分の作業フォルダにコピーして使用しましょう。

例えばcsvファイルの場合は('dir /b /O:D %src%.')の%src%￥を[%src%￥.csv]とします。

echo off

setlocal
set src=コピー元の絶対パス
set cppath=コピー先の絶対パス

@echo  ファイルコピー中

for /F "tokens=1* delims=" %%a in ('dir /b /O:D %src%\.*') do set fname=%%a

copy /Y "%fname%" %cppath\%fname%


endlocal

【bat】ユーザーアカウントパスワード有効期限を無期限に設定するバッチ

Windows10ではログインする際のユーザーパスワードの有効期限がデフォルトで３ヶ月に設定されています。 組織内の端末を管理するときに毎回問い合わせが来るのも面倒なため、他でセキュリティを担保し、Windowsの パスワードの有効期限を無期限に設定します。

@echo off

rem このコマンドでユーザー'user名'のパスワードを無期限化

wmic UserAccount where Name='user名' set PasswordExpires=False

【bat】自宅と会社のネットワーク設定を切り替える

端末を自宅と会社両方で使用する場合、ネットワーク設定の変更が面倒なのでバッチファイルでワンクリックで変更できるように作成しました。 プロキシ設定のアドレスやポートなどをお使いの環境に合わせて入力してください。 ちなみにすでに会社で使用できる環境に設定されていることが前提です。

①会社の設定がされている状態で設定をダンプ処理。 ②ネットワークの設定を自動取得に変更。 ③自宅から会社に戻すときにダンプした情報を元に復元

といった流れで処理します。

@echo off

:■実行権限と引数で分岐

:管理者特権で実行しないとエラーになる処理
openfiles > NUL 2>&1

:上記処理がエラー（ユーザー権限）であれば一般権限で実行する処理に移動
if NOT %ERRORLEVEL% EQU 0 goto promotion

:■管理者権限で実行する処理

:startmenu
set NUM=
set Rtry=

rem プロキシを設定
set PROXYIPaddr=（プロキシのアドレス）
set PORT=（プロキシのポート）
set IntraAddr=（例外にするアドレス）
set DNS1=（会社のDNS）
CLS
echo 現在設定
ipconfig
echo =============メニュー=============
echo [1] 自宅ネットワークへ切り替え
echo [2] 会社ネットワークへ切り替え
echo [3] 現在の設定を確認する。
echo [4] この処理を終了する
echo ==================================

set /p NUM="実行する処理が記載された番号を入力してください >"
if "%NUM%"=="1" goto PT
if "%NUM%"=="2" goto INT
if "%NUM%"=="3" goto inetcpl
if "%NUM%"=="4" goto endMsg
goto NoNumber

:PT rem------------------------------------------------------------------------------------------
rem もし「%COMPUTERNAME%.nsh」ファイルが既に存在している場合、削除しておく
if exist C:\Users\%username%\%COMPUTERNAME%.nsh del C:\Users\%username%\%COMPUTERNAME%.nsh

rem 切り替え前にネットの設定をダンプ処理
netsh -c "interface ip" dump > C:\Users\%username%\%COMPUTERNAME%.nsh

rem 以下の「for」ループ内で変数を変化させるための宣言
setlocal enabledelayedexpansion
 
set BEFORE_STRING=はい
set AFTER_STRING=yes

set INPUT_FILE=C:\Users\%username%\%COMPUTERNAME%.nsh
set OUTPUT_FILE=C:\Users\%username%\%COMPUTERNAME%.nsh

setlocal enabledelayedexpansion
for /f "delims=" %%a in (%INPUT_FILE%) do (
set line=%%a
echo !line:%BEFORE_STRING%=%AFTER_STRING%!>>%OUTPUT_FILE%
)

endlocal

rem プロキシOFF
reg add "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings" /f /v ProxyEnable /t reg_dword /d 0
netsh winhttp reset proxy

rem  自宅ネットワーク設定読み込み
netsh interface ip set address "イーサネット" dhcp
netsh interface ip set address "Wi-Fi" dhcp
netsh interface ip set dns "イーサネット" dhcp
netsh interface ip set dns "Wi-Fi" dhcp
echo 設定が完了しました。


goto end


:INT rem------------------------------------------------------------------------------------------
echo　会社ネットワーク設定読み込み
rem 
netsh -f C:\Users\%username%\%COMPUTERNAME%.nsh
netsh interface ip set dns "イーサネット" static %DNS1% primary
netsh interface ip set dns "Wi-Fi" static %DNS1% primary

rem プロキシON
reg add "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Internet Settings" /f /v ProxyEnable /t reg_dword /d 1
netsh winhttp set proxy proxy-server ="%PROXYIPaddr%:%PORT%" %IntraAddr%" 
echo 設定が完了しました。

goto end

:inetcpl rem------------------------------------------------------------------------------------------
echo 現在の設定を表示します。
netsh interface ip show config
netsh winhttp show proxy

goto end

:NoNumber rem------------------------------------------------------------------------------------------
echo その番号はメニューにありません。
echo ...
pause
goto startmenu

:end rem------------------------------------------------------------------------------------------
rem もう一度処理をするかどうか確認し、処理しない場合終了します。
echo --------------------------------------------------------------
ipconfig 
echo 別のプロキシ関連処理を実行するには[Y]を
set /p Rtry="処理を終了するには[N]を入力しEnterキーを押下します。 >"
if /i %Rtry% == y (goto startmenu)
if /i %Rtry% == n (goto endMsg)
goto endMsg
。
:promotion
echo ユーザー権限です。

:管理者権限で自分自身を実行（昇格処理）
powershell start-process %~fs0 -verb runas

:endMsg
goto endMsg
:endMsg
set NUM=
set Rtry=
set PROXYIPaddr=
set PORT=
set IntraAddr=
echo %0 の動作が完了しました。

【VBScript】WordをExcelに一括変換する

WordをExcelに変換するには一旦HTML形式に変換保存後、HTMLファイルをExcelで保存します。 非常に手間がかかるので多量のファイルを変換するのは大変です。 ネット上にはWordからHTML、ExcelからHTMLはよく見つかりますが、WordからExcelがなかったので 作りました。

'------------------------------------------------------------------------------------------------------------------
Option Explicit
'IE の宣言と初期化
Dim ie
initializeIe()
updateMsg "処理を開始します..."
'---------------------------------------------------------------------------------------------------
'ドラッグ&ドロップされたフォルダの処理
Dim Args  

Set Args = WScript.Arguments
If Args.Count <> 1 Then '処理できるのは１フォルダのみ
    WScript.Echo "当スクリプトに対象となる１フォルダをドラッグ&ドロップして処理を実行してください。"
    WScript.Quit    'スクリプトを終了
End If

'フォルダ判別
With CreateObject("Scripting.FileSystemObject") '以下の処理はEnd WithまでScripting.FileSystemObjectを使用
    If .FolderExists(Args(0)) = False Then  'ドラッグされたものを解析
        WScript.Echo "フォルダが見つかりません。" & vbCrLf & "あるいはフォルダではありません。"
        closeIe()
        WScript.Quit
    End If
End With

'Wordファイルの有無チェック「IsExistsParticularFile」に処理渡した結果下で処理
If (IsExistsParticularFile(Args(0), "doc") = False) And (IsExistsParticularFile(Args(0), "docx") = False) Then
    WScript.Echo "指定したフォルダ内にWordファイルが見つかりませんでした。"
    closeIe()
    WScript.Quit
End If

' 処理…
updateMsg "HTML変換処理を実行しています..."
WScript.Sleep 5000  ' サンプル用・処理している風に少し止める

ConvertWordToHtml Args(0) 'WordToHtmlへWScript.Argumentsを渡して呼び出し。フォルダパスとかファイル名とか。

updateMsg "Excel変換処理を実行しています..."
WScript.Sleep 5000  ' サンプル用・処理している風に少し止める

ConvertHtmlToExcel Args(0) 'WordToExcelへWScript.Argumentsを渡して呼び出し。フォルダパスとかファイル名とか。

' 完了
updateMsg "スクリプト処理完了!"
WScript.Echo "処理が終了しました。"
' IE を終了させスクリプトを閉じる
closeIe()
WScript.Quit
'------------------------------------------------------------------------------------------------------------------
Private Sub ConvertWordToHtml(ByVal FolderPath)
'指定したフォルダ内のWordファイルをHTMLファイルに変換
Dim wdApp, wdDoc
Dim f

Const wdFormatHTML = 8 '保存時に使用するフォーマット番号を「wdFormatHTML」に設定（標準 HTML 形式）
Const wdDoNotSaveChanges = 0 '変更がない時に保留中の変更を保存しません。この２つは番号で記述すると何だこれとなるから定数設定する
Set wdApp = CreateObject("Word.Application")     'Wordのオブジェクトを作成
wdApp.Visible = False 'Wordアプリを非表示
  
If Right(FolderPath, 1) <> ChrW(92) Then FolderPath = FolderPath & ChrW(92) 'FolderPath末尾￥をつける処理 ChrW(92)は「￥」Chr 【ｷｬﾗｸﾀｰ】関数
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).Files 'ファイルの数だけ繰り返し処理
            Select Case LCase(.GetExtensionName(f)) 'ファイル形式が当てはまれば処理
        'Wordファイルのみ処理
            Case "doc", "docx"
                Set wdDoc = wdApp.Documents.Open(CStr(f)) 'Wordで対象ファイルを開く
                wdDoc.SaveAs FolderPath & .GetBaseName(f) & ".html", wdFormatHTML, , , False 'HTM形式で保存する
                wdDoc.Close wdDoNotSaveChanges '対象ファイル閉じる
                Set wdDoc = Nothing '変数の片付け
        End Select
    Next
End With
wdApp.Quit 'Wordアプリを終了
End Sub
'------------------------------------------------------------------------------------------------------------------

Private Sub ConvertHtmlToExcel(ByVal FolderPath)
'htmlからExcelに変換
Dim objExcel, fso, folder, subfolder, Exbook
Dim f
  
Set objExcel = CreateObject("Excel.Application") 'Excelのオブジェクトを作成
  
objExcel.Visible = False 'Excelアプリを非表示
If Right(FolderPath, 1) <> ChrW(92) Then FolderPath = FolderPath & ChrW(92) 'FolderPath末尾￥をつける処理 ChrW(92)は「￥」Chr 【ｷｬﾗｸﾀｰ】関数
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(FolderPath).Files
            Select Case LCase(.GetExtensionName(f))
        'htmlファイルのみ処理
            Case "html"
                Set Exbook = objExcel.Workbooks.Open(CStr(f))   'ファイルを開く
                Exbook.SaveAs FolderPath & .GetBaseName(f) & ".xlsx",51 'ここは保存形式をxlsx形式の保存だが番号のままConstで定義しといてもよい
                Exbook.Close '対象ファイル閉じる
                f.Delete  'htmlファイルを削除
                Set Exbook = Nothing
            End Select
        Next
    End With
objExcel.Quit 'Excel終了
'HTMLに変換するときにできたフォルダを削除
Set fso = WScript.CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(FolderPath) 'folderにドラッグ&ドロップしたFolderPathを格納
  
For Each subfolder In folder.subfolders 'folder.subfoldersサブフォルダの数だけ処理
    subfolder.Delete (True)        ' フォルダを削除
Next
Set fso = Nothing '変数の片付け
End Sub
'------------------------------------------------------------------------------------------------------------------

Private Function IsExistsParticularFile(ByVal FolderPath, ByVal FileExtension)
'指定したフォルダ内に特定の拡張子のファイルがあるかを調べる
Dim ret
Dim f
 
ret = False '初期化
With CreateObject("Scripting.FileSystemObject")
    For Each f In .GetFolder(FolderPath).Files
        Select Case LCase(.GetExtensionName(f))
        Case LCase(FileExtension)
            ret = True
            Exit For
        End Select
    Next
End With
IsExistsParticularFile = ret
End Function

'------------------------------------------------------------------------------------------------------------------
' IE の初期化
Sub initializeIe()
  Set ie = CreateObject("InternetExplorer.Application")
  With ie
    .Navigate("about:blank")
    .ToolBar = False
    .StatusBar = False
    ' 幅・高さの設定
    .Width = 300
    .Height = 200
    ' 画面右上に配置する。"parentWindow.screen" はパスカルケースで書くと認識されない
    .Top = 0
    .Left = .Document.parentWindow.screen.Width - 300
    .Document.Charset = "UTF-8"
    .Visible = True
    .Document.Title = "スクリプト実行中"
  End With
End Sub
'------------------------------------------------------------------------------------------------------------------
' メッセージを IE に追記する
' 
' 引数のメッセージを IE の最終行に追記する。
' 最終行が表示されるようにスクロール位置を最下部に設定する。
Sub updateMsg(value)
  With ie
    .Document.Body.innerHTML = .Document.Body.innerHTML & value & "<br>"
    .Document.Script.setTimeout "javascript:scrollTo(0," & .Document.Body.ScrollHeight & ");", 0
  End With
End Sub

' IE を終了する
Sub closeIe()
  ie.Quit
  Set ie = Nothing
End Sub