PCを更新した その２ ～ Windows認証編

前回の記事「PCを更新した その１ ～ 部品購入・交換編」の続編で、今回はWindows認証編である。

私の場合、10年前に購入した Windows 8.1 64bit DSP版 から （時期は忘れたが）Windows10 に無償アップデートしており、ライセンスはMSアカウントに紐つけていた。
今回、マザーボード、CPU、Cドライブまで総入替となるなので再認証が求められるのは想定内であるが、問題は私の経緯を辿った場合、再認証は認められるのかと言うことである。
事前にネットで調べたのだが、この再認証問題は諸説流布されており、認証される条件は謎のままである。

以下に私の場合の再認証作業の流れと結果を記載する。

1. 設定 - アカウント
   PC更新後、ライセンスの再認証が必要というメッセージ
   
   
   
2. 設定 - 更新とセキュリティ - ライセンス認証
   ハードウェアが変更されたことでエラー表示
   トラブルシューティングをクリック
   
   
   
3. 「このデバイス上のハードウェアを最近変更しました」をクリック
   
   
   
4. 「Windowsをライセンス認証できません」と表示
   「ダメかぁ～」と一瞬思ったが、よく見ると「現在、弊社のサーバーが利用できないためです」の文字が。
   こんなこともあるのか、と思いながら、数分開けて繰り返しでみたたが毎回同じ結果になるので、数時間開けて試すことにした。
   
   
   
5. 再度、トラブルシューティングをクリック
   今度はライセンス認証する画面がでてきた。これで安心と思いながら対象のデバイスを選択して「アクティブ化」をクリック。
   
   
   
6. また、「Windowsをライセンス認証できません」と表示
   今度は「再度ライセンスを認証することができません」とのこと。「やっぱりダメかぁ～」と落胆。
   
   
   
7. しかし、その後、ほとんど時間を開けずに何故か再認証に成功
   ライセンス認証の画面も以下のように元通り認証済みとなった。
   

以上である。めでたし、めでたし。

なお、現在、PC更新後数日使用したところだが、正直言ってPCの起動時間も通常操作の反応時間もほとんど変わらない気がする。
とりあえずしばらく使ってみて、気が向いたら Windows11 にアップしたいと思う。

では。

PCを更新した その１ ～ 部品購入・交換編

私の使用PCは、ちょうど10年前に以下の記事に書いた自作PCである。

PCを自作した　その１　～　パーツ購入編
PCを自作した　その２　～　組立編

ゲームはやらないのでグラボはなし、当時の価格コムでコスパの良いパーツを集めた結果、メイン部品は以下の構成となった。

• CPU： intel Core i5 4440 (4コア/4スレッド)
• マザーボード： ASUS H87-PRO
• メモリ： CFD　W3U1600HQ-4G ×2 (DDR3  8GB)
• Cドライブ： Crucial CT120M500SSD1(120GB, SATA接続 2.5inch SSD)

その後、Windows8.1から10へのアップグレード、ハードディスクや拡張ボードの増設などは行ってきたが、上記のメイン部品はそのままであった。この仕様で特に困ることはなかったのだが、

• この構成では Windows11には（裏技なしでは）アップグレードできない
• Cドライブの残容量が10%を切ってしまった
• 10年経って突然死されては困るのでメイン部品をそろそろ更新しておきたい

という理由で、今回、PCを更新することにした。

すべての部品を更新すればスッキリするのだが、それほどのニーズ、気力、お金もないため、今回は上記のメイン部品だけ更新することにし、OS(Windows10 Home)は現ライセンスを再認証、既存ハードディスク4台も今のドライブ構成のまま継続使用することにした。

まず、部品の選択である。
CPUは今であれば AMDの一択で迷うことはないが、CPU、マザーボード、メモリの選択においては、

• AM5ソケットでDDR5メモリ(B650チップセット)・・・高パフォーマンスだが高価
• AM4ソケットでDDR4メモリ(B550チップセット)・・・どちらもほどほど

のどちらのラインにするかを最初に決めなければならない。
ここはかなり迷ったが、やはり私のPC利用目的から考えて価格優先の後者を選択することにした。

そして、価格コムのランキングなどを参考に以下に決定した。（全てネットで購入）

	部品	メーカー	型番	主な仕様
1	CPU	AMD	Ryzen 5 5500GT BOX	3.6GHzクロック、6コア/12スレッド
2	マザーボード	MSI	MPG B550 GAMING PLUS	SATA×6ソケット、WiFiなし
3	メモリ	Crucial	CP2K16G4DFRA32A	DDR4 PC4-25600 16GB×2枚組
4	Cドライブ	EXCERIA	PLUS G3 SSD-CK1.0N4PLG3J	M.2 (Type2280) SSD 1TB

次に事前準備として現在のPCで以下を行った。

• 新しいマザーボードの最新BIOSイメージをUSBメモリに格納
  マザーボード発売開始時のBIOSでは Ryzen 5000シリーズには対応していないため、BIOSを更新する必要がある。このマザーボードはCPUやメモリなしでBIOSを更新できる FLASH BIOS の機能があるので、それを使うための準備である。
• 新しいSSDに現在の起動ドライブのイメージをコピー（クローン）
  現在のPCにはM.2 SSDが使える拡張ボードを付けているので、それを使ってPC更新前に現在のCドライブのイメージを新しいSSDにコピー（クローン）した。
  クローンソフトは EaseUS ToDo Backup Free 12.0 を使用（新しいバージョンではクローン不可）。クローンした直後は、新旧ドライブの容量の差分の約820GBの領域の真ん中に790MBの回復パーティションができ、前後を未割当領域に挟まれるという使い勝手の悪い配置になったので、それらを全て削除して1つの領域に統合した。
  
  クローン実行時のメッセージ
  
  　
  統合後のイメージ
  

新しい部品が揃ったところで交換作業に着手。
これまでも、ハードディスクや拡張ボードの増設などで何回もPCケースを開けることはあったが、マザーボードやCPUの交換は10年ぶりである。単なる部品交換作業自体は難しくないと想像していたが、今回は以下の点で苦労した。

• マザーボードのBIOSアップデート
  ネット上では「うまくいかない」といった話も見受けるのでかなり緊張して慎重に行ったが、「手順」通りに実施し一発で成功した。
• マザーボードのコネクタ接続
  老化により10年前より目が悪くなっており、特に Power SWやLEDなどの細かい1, 2pin端子の接続には相当な時間を費やした。いやはや、情けない・・・
• CPUクーラーの取り付け
  今回はCPUに付属していた標準クーラーを利用したのだが、このクーラーは4隅のネジでマザーボードに留めるようになっている。しかし、マザーボード側のネジの受け口となる部分がマザーボードとは独立した金属板になっており、クーラーを取り付ける際にはマザーボードのウラからその金属板を手で押さえつける必要があった。今回は先にマザーボードをケースに取り付けてからCPUクーラーを取り付けようとしたのだが、最初はこの金属板がマザーボードの下に落ちていたためその存在に気付かず、ネジをいくら回しても一向にネジが噛むことがなく相当な時間格闘してしまった。
• M.2 SSDの取り付けネジ
  SSDを取り付けようとした時にネジがないのに気付いた。マザーボードの箱の中を探したがやはりない。（説明書をよく読んでいれば付属品として記載されているのでもっとよく探したのだが・・・・）。
  結局、翌日になって説明書の間に挟まっているのを発見したのだが危うくネットでポチるところであった。それにしても何とネジの小さいことか。

部品の取り付けが完了したので、いよいよOSの起動である。
電源ONから、BIOSの起動、OSのログオン画面の登場までかなり時間がかかった気がしたが、これも一発でうまくいった。ログオンしても以前と同じドライブ構成で以前と全く同じように使える。

最後の難関は Windows 10 のライセンス認証である。
「PCを更新した その２ ～ Windows認証編」へ続く。

最後に一句
「ひさびさの PC自作で 老い感じ」

では。

不良（容量偽装？）のMicroSDカードにあたってしまった

先日、雑誌の読み放題のサブスクである楽天マガジンに入会し、それに合わせて タブレット Lenovo Tab M10 Plus (3rd Gen)を購入した。
それらの使い勝手はもう少し使い込んでみて記事にしようと思うが、今回は、タブレット用に購入した MicroSDカードが不良だった話である。

購入した時に、ちょうど某大手ECショッピングモールで年4回開催の割引セールを実施していたので、128GBの MicroSDカードを探したところ、 以前から馴染みのあった Kingston の MicroSDが 20%引きのお手頃価格だったので、思わずポチってしまった。

そして届いたのが以下である。

パッケージ（破れは私が開封した跡である）
　

本体
　

メーカ名のないパッケージを見た瞬間、嫌な予感がしたが、本体を見て更に不安が倍増した、
なんと、Kingston ではなく、Kington であった。（ガ～～ン！！）

確かに、購入したショップの商品画像も Kington であった。また商品名や説明には「スマホ用 マイクロ SDカード」と書いてあるだけで、どこにも kington や kingston とは書かれていない。これは私の確認不足と言われても仕方がない。
なお、Windows の エクスプローラのプロパティでは、容量は128GBと正しく表示された。

もしかしてちゃんとした商品かも知れない・・・
と淡い期待をもって容量偽装チェックソフト H2testw で確認してみた。

その結果が以下である。

　

メッセージ全文

Warning: Only 127993 of 127994 MByte tested.
The media is likely to be defective.
29.2 GByte OK (61444662 sectors)
95.6 GByte DATA LOST (200685002 sectors)
Details:5.8 MByte overwritten (12032 sectors)
0 KByte slightly changed (< 8 bit/sector, 0 sectors)
95.6 GByte corrupted (200672970 sectors)
5.8 MByte aliased memory (12032 sectors)
First error at offset: 0x000000005f540000
Expected: 0x000000005f540000
Found: 0x000000005f540200
H2testw version 1.3
Writing speed: 16.2 MByte/s
Reading speed: 11.2 MByte/s
H2testw v1.4

結局、正常に読み書きできたのは、128GB中の29GBだけということである。読み書きの速度も10MB/s台とかなり遅い。

早速、この結果をショップに伝えたところ、不良品なので返金するとの回答があり、後日、全額返金された。
ただ、そのショップではこのやりとりから1か月後の現時点でもまだ Kington の MicroSDカードを販売中である。

もちろん、私は自分のケースしか知らないので、たまたまこの個体が不良だったのか、Kington自体が容量偽装なのかはわからない。

メルカリなどでも、本件と同じパッケージデザインの大容量カードが多数格安で販売されているが、容量偽装チェックは必須である。

では。

REGZA全録サーバー D-M430 システムメンテナンスの長時間化

私は全録機として、REGZA D-M430を愛用している。

D-M430に関する過去記事は、以下を参照。

REGZAサーバー D-M430改造計画　～ハードディスク換装～
REGZAサーバー D-M430改造計画　～ファン騒音対策（その１）～
REGZAサーバー D-M430改造計画　～ファン騒音対策（完結編）～
REGZA全録サーバ D-M430改造機が故障した
全録REGZA D-M430 故障 ～ 再生、録画、電源ランプが5回点滅

最後の記事は、2022年8月のもので、全録開始後、数時間で勝手に停止するという不具合に関するものであった。
今回もその3ヶ月後に、同じ個体で発生した別の不具合に関する報告となる。

症状は、記事の件名の通り、システムメンテナンス（以下、「メンテナンス」と記載）が1時間で終わらないというものである。
D-M430は全録機とは言うものの、1日24時間すべてでの録画はできず、24時間中の予めメンテンナンス時間として指定した1時間は一切の録画ができない仕様となっている。（私の場合はAM6～7時を指定）
この時間になると、D-M430は自動でメンテナンス作業を開始し、その間はハードディスク（以下、「HDD」と記載）がアクセスしっぱなしとなる。（当然、録画時間帯もHDDにアクセスしっぱなしとなるが、外付けHDDのアクセスランプで見る限り、録画時間帯は点滅となるが、メンテナンス時間帯は点灯状態となる。）

ある程度HDD内に過去の録画番組が溜まると約30分～45分程度を要するため、恐らく古い番組の削除の他に、HDDのデフラグをやっているのではないかと推測する。

さて、不具合に話を戻す。
最近、メンテナンスが既定枠の1時間どころか、いつまでたっても終わらない現象がでてきた。毎回発生するので、このままでは通常使用できない状態である。）
現象を以下に整理する。

1. 中断させようとして、リモコンで電源をOFFにすると電源ランプは消えるが外付けHDDはアクセスしっぱなしの状態。
2. 本体の電源ボタン長押しで強制シャットダウンすると外付けHDDのアクセスも停止し、以降は正常な状態になる。
3. 中断させないまま全録の予約時間帯になると全録動作に切り替わり録画は行われる。ただし、録画中にタイムシフトの番組表を表示しようとすると異常に時間がかかる。（数分待てば表示されるが、実用的なレベルではない。）
4. 全録中に本体の電源ボタン長押しで強制シャットダウンすると、以降は正常な状態になる。
5. 電源長押しをしない場合は、録画終了時間で通常通り終了（電源OFF状態になる）。ただし、通常の電源ON操作をやっても「起動中」のまま進まず。電源長押しで強制シャットダウンすると通常に戻る。ただし、この後、１度手動で電源ON/OFFしておかないと、全録時間帯になっても録画は始まらない。

何とも不可解でやっかいな現象である。

ググってみると、同様の事象として、唯一以下の記事を見つけた。
この方は、ファームウェアをバージョンアップしたところ「不具合が解消されたっぽい」とのことだが、私の場合は既に最新バージョンが当たっている状態だ。

2020_1109_REGZAサーバー D-M430

　
仕方なく、いろいろと試してみた。

• 内蔵HDDの番組全消去
  「はじめての設定」でシステム全体の初期化を行うと、内蔵/外付けHDDの全ての録画番組が消去されるので、まずは内蔵HDDの不調を疑い録画済み番組を削除してみる。
  
  【保存番組の削除】
  HDD管理メニューで内蔵HDDの番組消去を実施。これで個別に保存した番組は消去される。（タイムマシンでの録画番組は消去されない）
  
  
  【タイムマシン録画番組の削除】
  タイムマシン録画チャンネルメニューで、タイムマシン録画するチャンネルの設定を変更する。
  「設定完了」ボタンを押す前に、6つの録画チャンネルの設定を変更（一旦解除し再登録を含む）しても、チャンネル番号と録画先が以前と同じであればそのチャンネルの録画番組は削除されないので、一旦、011==>012などにチャンネルを変換して「設定完了」ボタンを押して削除する。（必要であれば、再度元の設定に戻して「設定完了」ボタンを押す。）
  
  
  
  ==> 残念ながら問題は解消ぜす。
  
  
• 外付けHDDの登録解除（その１）
  HDD管理メニューより、外付けHDDの登録を一旦解除した後、再登録を実施。（外付けHDDの録画番組は消えてしまう。）
  
  
  ==> 残念ながら問題は解消ぜす。
  
  
• 外付けHDDの登録解除（その２）
  HDD管理メニューより、外付けHDDの登録を一旦解除した後、メンテナンスを実施したところ20分程度で終了。その後に再登録を実施。
  ==> 正常な状態に戻った。と、喜んでいたところ、数日後に再発。（涙）
  
  
• 外付けHDDのローレベルフォーマット
  外付けHDDが怪しそうなのでWindows PCに接続して調査。
  CrystalDiskInfoでは「正常」であったが、NTFSでフォーマットしようとするとエラーで失敗してしまう。不良セクタが発生しているのかも知れない。
  それを解消するため、ローレベルフォーマット（全セクタへのゼロフィル）を試みる。具体的には、このHDDは WesternDigital社の製品だったので、Data Lifeguard Diagnostic で Erase を実施してみた。結果は特にエラーもなく終了。
  
  ==> その後、D-M430に接続して2ヶ月程度使用しているが、特に問題は発生していない。　めでたし、めでたし。

では。

エクスプローラからファイル一覧を出力するVBScript（検索結果もOK）

本記事では、Windowsのファイルエクスプローラで表示・選択されているファイルの一覧（ファイル名、パス、サイズ、更新日時）をクリップボードに張り付ける方法について記載している。
これは、エクスプローラで検索した結果に対しても有効である。

実は、これは、以前の記事「エクスプローラでファイル名をクリップボードにコピーする」で紹介した内容の改良版で、前回との違いなどを最初に記載しているが、手っ取り早く試したい人は、【導入手順】から読んでほしい。

【前回記事内容と今回の変更点】

前回は（今回も同じであるが）以下の方法で実現している。

step1．対象ファイルを選択した状態でエクスプローラの右クリックメニュー　→「送る」で特定のバッチファイルを選択
step2．バッチファイルが実行され、ファイルの情報をクリップボードへコピー
step3．（人が）テキストファイルやExcelに貼り付け

また、出力する情報別に、以下の３種類のバッチファイルを用意していた。

1. ファイル名のみのの一覧（テキスト形式）
2. パス、ファイル名、更新日時、ファイルサイズ　の一覧（Excelに張り付けられるようTAB区切り）
3. tree情報（Dosコマンドの tree の実行結果）

自分でも日々の業務の中で使用しており、特に 2 は重宝して使っていた。
エクスプローラ内のファイルの一覧を表示するのであれば、Dosコマンドの Dir でも何とかなるが（それでも Excel に貼って2次加工したい場合はひと手間必要）、エクスプローラで検索した結果の一覧を更新日時やサイズと合わせて出力する場合はこれ以外の方法はないと思う。

ところが、これまで使っていて、うまく動作しないケースを発見した。ファイル名やフォルダ名に全角空白が含まれる場合で、なぜか、全角空白で名称が分断され、２つのファイルやフォルダが存在するように誤動作してしまう。

この原因調査のためググってみたところ、以下の記事を発見した。

ファイル名に=;,や全角空白を使うときは、半角空白も併せて使うべし。
ファイルエクスプローラからバッチファイルへドラッグ＆ドロップして正しいファイル名を得る方法

結果的には、これはバッチファイルの仕様（バグ？）でどうしようもないようである。それも、ファイル名やフォルダ名に一緒に半角空白が入っていればOKという謎仕様である。

そこで、バッチファイルの使用は諦め、１と２を VBScript で書き直したのが今回の記事である。VBScript はどの Windowsにも実装されているので、利用にあたって特に設定を変更したり何かのモジュールを導入する必要はない。

【導入手順】

Step1.

以下のリンクを右クリックし、メニューから「名前を付けてリンク先を保存」や「対象をファイルに保存」などを選択して VBScript ファイルをダウンロードし、ファイル名の最後の「.txt」を削除して（拡張子をvbsにして）保管したいフォルダに保存する。
それぞれ、上記の 1, 2 に対応しているので、どちらか一方でも問題ない。
文字コードは SJISを使っているため ブラウザ上で表示した場合は文字化けするので注意。

「1_copy_filenames.vbs.txt」をダウンロード
「2_copy_file_info_for_Excel.vbs.txt」をダウンロード

なお、「2_copy_file_info_for_Excel.vbs.txt」については、テキストエディタでファイルの先頭で定義されている定数を変更することで、以下のカスタマイズが可能である。（デフォルトで問題なければそのままで良い。）

• fol_level_q = 0

フォルダが選択されている場合、サブフォルダ以下を階層的に調査するかを指定する。
　　　　 0:調査しない
　　　　 1:調査する
　　　　-1:毎回確認画面でどちらかを指定する

• Const def_fol_level = 20
  　　　
  　　　調査する場合の階層レベルを指定する。
  　　　　-1:制限なし
  　　　　 0:サブフォルダは調査しない
  　　　　 n:N階層まで調査
  
  　　　　通常 -1 でも問題ないが、シンボリックリンクなどがある場合に無限ループに陥る可能性があるので初期値は20にしている
  　　　　
• Const fol_output = 1

　　　フォルダ自身の情報を1行として出力するかを指定
　　　　 1：出力する
　　　　 0：出力しない（ファイルの情報のみを出力する）
　　　　 　

Step2.

Step1.で保存したバッチファイルのショートカットを SendToフォルダの直下に作成し、お好みで名称を判りやすいものに変更する。

SendToフォルダは、右クリックメニューで「送る」を選択した時に表示されるファイルを格納する場所で、エクスプローラ上部のパスが表示されるところに「shell:sendto」と入力して開くことができる。
私の場合（OSはWindows10 Home）は以下のフォルダである。
C:\Users\ユーザ名\AppData\Roaming\Microsoft\Windows\SendTo

　
【利用方法と実行例】

エクスプローラ上で対象ファイルやフォルダを選択し（複数選択可）、右クリック → 送る から 実行するVBScriptを選択して実行する。
その後、「1_copy_filenames.vbs」であればテキストエディタなどへ、「2_copy_file_info_for_Excel.vbs」であれば Excelの空シートに貼り付ける。

以下が貼り付けイメージである。

• サンプルのファイル構成（青背景の4つを選択した状態で右クリック）

　　E:\PROGRAM FILES (X86)\MOZILLA FIREFOX
　　├─Accessible.tlb
　　├─AccessibleHandler.dll
　　├─AccessibleMarshal.dll
　　└─uninstall
　　　　├─helper.exe
　　　　├─shortcuts_log.ini
　　　　├─uninstall.log
　　　　└─uninstall.update　

• 1_copy_filenames.vbs の実行結果
  　
  　　E:\Program Files (x86)\Mozilla Firefox  <= 1行目はパス
  　　Accessible.tlb
  　　AccessibleHandler.dll
  　　AccessibleMarshal.dll
  　　uninstall
  　
• 2_copy_file_info_for_Excel.vbs の実行結果
  • fol_level_q = 1 （サブフォルダを調査）で実行した場合
  • fol_level_q = 0 の場合は、6行目以降は表示されない

　 

もう１つ、検索結果についての貼り付け例を示す。

• エクスプローラでの検索結果
  • Firefox のインストールフォルダ内で "log"を検索し4ファイルがヒット

• 2_copy_file_info_for_Excel.vbs の実行結果
  • 検索結果の4ファイルとも選択して実行

では。

outlookメールの添付ファイル名を検索するVBScriptを作成してみた

今回は、自分の仕事で使う目的で作成した「outlookを操作するVBScriptシリーズ」の恐らく最終回である。

これまでのこのシリーズの出し物は以下の通りである。

• outlookのメール一覧をExcelに貼り付けるためのVBScriptを作ってみた
• outlookからメールと添付ファイルを出力する（その２）
• outlookメールの添付ファイルを削除するVBScriptを作ってみた

今回は、outlookの添付ファイルを検索し、ファイル名の中に、指定した文字列を含むものを検索するスクリプトである。

使い方は、以下の通りである。

まず、事前準備として、本記事の最後に添付されている「search_for_attached_files_in_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で検索対象のメールを選択した状態で（もちろん複数選択可）、このvbsファイルをダブルクリックして実行するだけである。

実行すると「ファイル名の一部を指定してください。」というメッセージと入力ウィンドウが現れるので検索文字列を入力すると、検索完了後に、

• １件でも見つかった場合は「N件のファイルが見つかりました。情報をクリップボードにコピーしました。」
• １件も見つからなかった場合は「該当ファイルは見つかりませんでした。」

のいずれかを表示し終了する。

前者の場合は、Ctrl-v などの貼り付け操作で、Excelやテキストエディタなどにクリップボードの内容を貼りつけると

見つかった添付ファイル名,  該当メールの受信日時,  件名,  送信者

の一覧（各項目はタブ区切り）を見ることができる。

留意事項としては以下の通り。

• 一度に入力できる検索文字列は１つだけで、ファイル名の中に、その文字列を完全一致で含むものだけがヒットする。
• 実行中にoutlookへのアクセス許可を求める以下のダイアログが表示された場合は「許可」を選択する。
  

以下がスクリプトである。

---

Option Explicit

Dim objOA, objSelection, objItm, objAtt, objWS
Dim I, MySrch, MyCnt, Mystring

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
End If

MySrch = InputBox("選択されたメールの添付ファイル名を検索します。" & vbCrLf & "ファイル名の一部を指定してください。")

If Len(MySrch) = 0 Then
 WScript.Quit
End If

MyCnt = 0
Mystring = ""
For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 For Each objAtt In objItm.Attachments
  If InStr(1,objAtt.FileName,MySrch,1) > 0 Then
   MyCnt = MyCnt + 1
   Mystring = Mystring & vbCrLf & objAtt.FileName & vbTab & objItm.ReceivedTime & vbTab & objItm.Subject & vbTab & objItm.Sender
  End If
 Next
Next

If MyCnt > 0 Then
 Mystring = "ファイル名" & vbTab & "受信日時" & vbTab & "件名" & vbTab & "送信者" & Mystring
 MsgBox(MyCnt & "件のファイルが見つかりました。情報をクリップボードにコピーしました。")
 Set objWS = CreateObject("WScript.Shell")
 objWS.Exec("clip").StdIn.Write Mystring
Else
 MsgBox("該当ファイルは見つかりませんでした。")
End If

---

ファイルのダウンロードは、以下のリンクを右クリックで「保存」（ファイルの文字コードは SJIS）

ダウンロード - search_for_attached_files_in_outlook.vbs

では。

outlookメールの添付ファイルを削除するVBScriptを作ってみた

今回も、自分の仕事で使う目的で作成した、outlookを操作するVBScriptシリーズである。

これまで、以下のVBScriptをアップしてきた。

• outlookのメール一覧をExcelに貼り付けるためのVBScriptを作ってみた
• outlookからメールと添付ファイルを出力する（その２）

私の場合、会社のメールサーバの容量が限られているので、定期的にサーバ上のメールを削除し、過去メールはデータファイル（pstファイル）にバックアップしている。
その際、データファイルの容量を極力小さくするため、サイズが大きく、かつ保存する必要のない添付ファイルは個別に削除しているのだが、そのためには以下の操作をメールの数だけ繰り返す必要がある。

1. 対象メールを開く
2. 添付ファイルを右クリックして削除
3. メールを保存

そこで今回は、メールの添付ファイルを削除するVBScriptを作成してみた。

使い方は、以下の通りである。
まず、事前準備として、本記事の最後に添付されている「delete_attached_files_in_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で対象メールを選択した状態で（複数選択可）このファイルをダブルクリックし、確認ダイアログに回答するだけである。VBスクリプトなので、VBAと違いoutlookに組み込む必要はない。
途中で「１ファイルづつ確認しながら削除しますか？」と聞いてくるので、ここで「はい」を選択すると添付ファイル毎に メール件名、添付ファイル名、サイズ が表示されるので個別に削除するか否かを指定でき、「いいえ」を選択すると個別の確認はなく全添付ファイルが削除される。
また、outlookへのアクセス許可を求める以下のダイアログが表示された場合は「許可」を選択する。

　

以下がスクリプトである。

---

Option Explicit

Dim objOA, objSelection, objItm, objAtt, objAtts
Dim I, MyDlt, MyMsg, MyCnt, MyCnfm, MyChng, MyIdx

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
Else
 MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが削除されます。良いですか？"
 MyCnt = 0
 For I = 1 To objSelection.Count
  set objItm = objSelection.Item(I)
  If objItm.Attachments.count > 0 Then
   MyCnt = MyCnt +1
   MyMsg = MyMsg & vbCrLf & Right(Space(5) & MyCnt, 5) & ": "& objItm.Subject
  End If
 Next
 If (MyCnt = 0) Then
  MsgBox "添付ファイル付きのメールが1通も選択されていません。"
  WScript.Quit
 Else
  If MsgBox(MyMsg, vbYesNo) = vbNo Then
   WScript.Quit
  End If
 End If 
End If

MyCnfm= MsgBox ("１ファイルづつ確認しながら削除しますか？", vbYesNoCancel)
If MyCnfm = vbCancel Then
 WScript.Quit
End If

For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 Set objAtts = objItm.Attachments
 If objAtts.Count > 0 Then
  MyChng = vbNo
  MyIdx = 1
  While objAtts.Count > MyIdx - 1
   set objAtt = objAtts.Item(MyIdx)
   If MyCnfm = vbYes Then
    MyDlt = MsgBox ("以下のファイルを削除しますか？" & vbCrLf & "　メール件名[" & objItm.Subject & "]" & vbCrLf & "　ファイル名[" & objAtt.FileName & "]" & vbCrLf & "　サイズ[" & Round(objAtt.Size/1024) & "KB]", vbYesNoCancel)
    If MyDlt = vbCancel Then
     WScript.Quit
    ElseIf MyDlt = vbYes Then
     objAtts.Remove(MyIdx)
     MyChng = vbYes
    Else 'MyDlt = vbNo
     MyIdx = MyIdx + 1
    End If
   Else
    objAtts.Remove(MyIdx)
    MyChng = vbYes
   End If
  Wend
  If MyChng = vbYes Then
   '既読に変更
   objItm.UnRead = False
   '変更を保存
   objItm.Save
  End If
 End If
Next

---

ファイルのダウンロードは以下のリンクを右クリックで「保存」を選択（ファイルの文字コードは SJIS）

ダウンロード - delete_attached_files_in_outlook.vbs

では。

outlookからメールと添付ファイルを出力する（その２）

以前の記事「outlookからメールと添付ファイルを抽出するVBScriptを作ってみた」で、outlookからメールと添付ファイルを取り出すVBScriptを紹介した。

そのバージョンでは、あらかじめ対象メールをoutlookの指定フォルダにコピーしておかなければならなかったが、今回、その改良版としてoutlook上で選択されたメールを対象とするように仕様変更したので紹介する。
なお、私が試した環境は、Windows7とoutlook2010の組合せのみである。

主な機能は以下の通りである。

• outlookのメールを、msgファイルとして、Windowsの指定フォルダに出力する。ファイル名は「YYYYMMDD_HHMMSS_メール件名.msg」で YYYYMMDD HHMMSS はメールの受信日時である。
• オプションで、メールの添付ファイルを同じフォルダ直下の「添付_YYYYMMDD_HHMMSS_メール件名」というフォルダの下に出力することも選択可能。更に、オプションで、添付ファイル出力後、メールの添付ファイルを削除し、代わりに「添付ファイルを出力したフォルダのパスを記載したテキストファイル（ファイル名「元の添付ファイルの保存先フォルダ.txt」）」をメールに添付することも可能。

使い方は、以下の通りである。
まず、事前準備として、本記事の最後に添付されている「export_from_outlook.vbs」を任意の場所に置いておく。
あとは、outlook上で対象メールを選択した状態で（複数選択可）、このファイルをダブルクリックするだけである。VBスクリプトなので、VBAと違いoutlookに組み込む必要はない。

ダブルクリック後の手順をもう少し説明する。

1. ダブルクリックすると「n 通のメールが選択されています。続けますか？」ときいてくるので「はい」を選択する。
2. 以下のダイアログが表示されるので、出力先（格納先）フォルダを選択する。なお、ダイアログの下の「フォルダー(F):」にフルパスを直接貼り付けても良い。
   
   
   
   
3. 「添付ファイルを取り出しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。
   「いいえ」を選択した場合は msgファイルのみ、「はい」を選択した場合は msgファイルに加え添付ファイルも抽出される。
4. 3で「はい」を選択した場合、「添付ファイルを削除しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。「はい」を選択した場合、元のメールの添付ファイルは削除されるので注意。
5. 4で「はい」を選択した場合、「保存先フォルダを記載したテキストファイルを添付しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかを選択する。ここで「はい」を選択した場合、元の添付ファイルは削除されるが、代わりに添付ファイルを出力したフォルダのパスを記載したテキストファイルが添付される。なお、いずれの場合も、元が添付ファイル付きメールの場合、抽出された msgファイルには添付ファイルが含まれている。
6. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。
   
    
   
   

手順は以上である。

以下がスクリプトである。

---

Option Explicit

Dim objOA, objSelection, objShell, objFolder, objFSO, objItm, objAtt, objWss, objTxt
Dim MyDate, MyFileName, MyFolder, MySubFolder, MyMsgPath, YNCont, YNExt, YNDel, YNRplc, ENVtmp, MyTmpTxt, MyMsg, MyCnt, I

Const olMSG = 3
Const ErrReject = -2147467260

'添付ファイル格納サブフォルダ名の接頭語
Const PreWord = "添付_"
'元の添付ファイルの保存先フォルダを記載した添付ファイル名
Const AttFileName = "元の添付ファイルの保存先フォルダ.txt"

Set objOA = CreateObject("Outlook.Application")

Set objSelection = objOA.ActiveExplorer.Selection
If objSelection.Count = 0 Then
 MsgBox "メールが選択されていません。"
 WScript.Quit
Else
 YNCont = MsgBox(objSelection.Count & " 通のメールが選択されています。続けますか？", vbYesNo)
 If YNCont = vbNo Then
  WScript.Quit
 End If
End If

Set objShell = WScript.CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder( 0 , "フォルダを選択して下さい" , &h4050 , &h11)

If (objFolder Is Nothing) Then
 WScript.Quit
End If
MyFolder = objFolder.Items.Item.Path

'MsgBox "MyFolder = " & MyFolder

Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(MyFolder)) Then
 MsgBox("存在しないフォルダが指定されました")
 WScript.Quit
End If

MyCnt = 0
For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 If objItm.Attachments.count > 0 Then
  MyCnt = MyCnt + 1
 End If
Next

YNExt = vbNo
If MyCnt > 0 Then
 YNExt = MsgBox("添付ファイルを取り出しますか？", vbYesNoCancel)
 If YNExt = vbCancel Then
  WScript.Quit
 ElseIf YNExt = vbYes Then
  YNDel = MsgBox("添付ファイルを削除しますか？", vbYesNoCancel)
  If YNDel = vbCancel Then
   WScript.Quit
  ElseIf YNDel = vbYes Then
   YNRplc = MsgBox("保存先フォルダを記載したテキストファイルを添付しますか？", vbYesNo)
   If YNRplc = vbYes Then
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが置き換えられます。良いですか？"
   Else
    MyMsg = "★★警告★★" & vbCrLf & "以下のメールの添付ファイルが削除されます。良いですか？"
   End If
   MyCnt = 0
   For I = 1 To objSelection.Count
    set objItm = objSelection.Item(I)
    If objItm.Attachments.count > 0 Then
     MyCnt = MyCnt +1
     MyMsg = MyMsg & vbCrLf & Right(Space(5) & MyCnt, 5) & ": "& objItm.Subject
    End If
   Next
   If MsgBox(MyMsg, vbYesNo) = vbNo Then
    WScript.Quit
   End If 
  End If
 End If
End If

Set objWss = WScript.CreateObject("WScript.Shell")
ENVtmp = objWss.expandEnvironmentStrings("%TMP%")

For I = 1 To objSelection.Count
 set objItm = objSelection.Item(I)
 
 MyDate = objItm.ReceivedTime
 MyDate = Replace(MyDate, "/", "")
 MyDate = Replace(MyDate, ":", "")
 MyDate = Replace(MyDate, " ", "_")

 MyFileName = MyDate & "_" & objItm.Subject

 '使用禁止文字を置換する
 MyFileName = Replace(MyFileName, "?", "？")
 MyFileName = Replace(MyFileName, ":", "：")
 MyFileName = Replace(MyFileName, "/", "／")
 MyFileName = Replace(MyFileName, "\", "￥")
 MyFileName = Replace(MyFileName, "*", "＊")
 MyFileName = Replace(MyFileName, """", "”")
 MyFileName = Replace(MyFileName, "<", "＜")
 MyFileName = Replace(MyFileName, ">", "＞")
 MyFileName = Replace(MyFileName, "|", "｜")
 
 MyMsgPath= MyFolder & "\" & MyFileName & ".msg"
 
' MsgBox MyMsgPath
 
 Err.clear
 On Error Resume Next

 objItm.SaveAs MyMsgPath , olMSG
 
 If (Err.Number = ErrReject) Then
  MsgBox "終了します"
  WScript.Quit
 End If

 On Error Goto 0

 If (YNExt = vbYes) and (objItm.Attachments.count > 0) Then
  
  MySubFolder = MyFolder & "\" & PreWord & MyFileName

  If objFSO.FolderExists(MySubFolder) = True Then
   MsgBox "フォルダ " & MySubFolder & " は既に存在しています。"
  Else
   objFSO.CreateFolder(MySubFolder)
  End If

  For Each objAtt In objItm.Attachments
   objAtt.SaveAsFile MySubFolder & "\" & objAtt.FileName
  Next
  
  If YNDel = vbYes Then
   Set objAtt = objItm.Attachments
   While objAtt.Count > 0
    objAtt.Remove 1
   Wend
   '既読に変更
   objItm.UnRead = False
   '変更を保存
   objItm.Save
   
   If YNRplc = vbYes Then
    MyTmpTxt = ENVtmp & "\" & AttFileName
    Set objTxt = objFSO.OpenTextFile(MyTmpTxt, 2, true)
    objTxt.Write(MySubFolder)
    objTxt.Close
    objItm.Attachments.Add(MyTmpTxt)
    objItm.Save
    objFSO.DeleteFile MyTmpTxt, True
   End If
  End If
 End If
Next

---

ファイルのダウンロードは以下のリンクを右クリックで「保存」を選択（ファイルの文字コードは SJIS）

ダウンロード - export_from_outlook.vbs

どうぞご自由に。

outlookのメール一覧をExcelに貼り付けるためのVBScriptを作ってみた

前回の記事で、outlookから msgファイルと添付ファイルを抽出するVBScriptを公開したが、その応用編として、メールの件名や内容の一覧をExcelに貼り付けるVBScriptを作成したので公開する。
スクリプトの大半は前回のものの流用であるが、添付ファイルやWindowsのフォルダを扱わないのでこちらの方がシンプルである。

それでは、まず仕様から。

• outlook上の特定メールフォルダに格納されているメールを対象とする。従って、実行前に対象メールを「特定メールフォルダ」にコピーする必要がある。
  【2019年5月2日追記】
  対象メールを「outlookで選択されているメール」に改良したバージョンを作成したので、興味のある方は本記事の文末を参照。
• 本スクリプトではExcelへの貼り付け自体は行わず、タブ区切りの一覧をクリップボードにコピーするまでを行う。従って、本スクリプトを実行した後、Excelの任意のセルを選択して貼り付け操作をすれば一覧がExcelに展開される。
• 貼り付けられる項目は、受信日時、件名、送信者、本文 とした。

以下、本スクリプトの利用手順である。

1. 対象ファイルを outlookの受信フォルダ直下の「export」フォルダにコピーする。フォルダ名はスクリプトの10行目で定義しており変更は可能だが、事前に決めておく必要がある。
2. 本スクリプトをダブルクリックで実行する。
3. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。
   
   　
4. Excelの任意のセルを選択し、貼り付け操作（Control-vなど）を行う。
   　

テストした環境は Windows7と Office2010の組合せのみなのであしからず。
スクリプト（コードはSJIS）は以下のリンクからご自由に。（右クリックして保存）

「outlook2tsv.vbs」をダウンロード

読みにくいが、内容は以下の通り。

---

Option Explicit

Dim objOA, objNS, objOLFolder, objItm, objWS
Dim Mystring

Const olFolderInbox = 6
Const ErrNoOLFolder = -2147221233

'outlook の対象フォルダ名（受信トレイの下）
Const oLFolderName = "export"

Mystring = "受信日時" & vbTab & "件名" & vbTab & "送信者"& vbTab & "本文" & vbCrLf

Set objOA = CreateObject("Outlook.Application")
Set objNS = objOA.GetNamespace("MAPI")

Err.clear
On Error Resume Next

Set objOLFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(oLFolderName)

If (Err.Number = ErrNoOLFolder) Then
  MsgBox "指定した outlook のフォルダ " & oLFolderName & " が存在しません"
  WScript.Quit
End If

On Error Goto 0

For Each objItm In objOLFolder.Items
  Mystring = Mystring & objItm.ReceivedTime & vbTab & objItm.Subject & vbTab & objItm.Sender & vbTab & """" & objItm.Body & """" & vbCrLf
Next

Set objWS = CreateObject("WScript.Shell")
objWS.Exec("clip").StdIn.Write Mystring

---

では。

【2019年5月2日追記】

以下の改良を行ったバージョンを作成したので、興味のある方は下記リンクから。（右クリックして保存）

• 対象メールを「outlookの特定メールフォルダ下にあるメール」から「outlook上で選択されているメール」に変更
• メール本文がHTML形式の場合、異常終了する不具合に対応（ただし、HTML形式の場合、 "?"などの不正文字が残ることがある）

ダウンロード - export_mails_from_outlook_in_tsv_format.vbs

outlookからメールと添付ファイルを抽出するVBScriptを作ってみた

会社ではメーラとして outlookを使っている。
個人的には検索のアホさを始めとした、もろもろの使い勝手の悪さに辟易しているが、会社の標準なので付き合わざるを得ない。

特に最近面倒くささを感じていたのがメールのダウンロード（抽出）だ。エクスプローラにドラッグ＆ドロップすればメールファイル（msgファイル）が作成されるのだが

• 添付ファイルは個別にコピペする必要がある。
• msgファイルの名称がメール件名となるので、返信を繰り返したメールだと全て同じファイル名になり、いちいちリネームする必要がある。
• ファイル名を見ただけでは受信日時がわからない

といった不満がある。多分 outlookマクロを作成すれば解決できるのかも知れないが、会社では勝手にマクロを組み込むのは不可である。

いろいろとググってみると、VBScriptでも outlookの操作が可能のようである。VBScriptは Windowsで動作するスクリプト言語で個人的には全く馴染みがないが、

• Windowsであれば、何の事前準備も不要でダブルクリックで実行できる
• Officeの操作も可能
• 細かな文法やテクニックを知らなくても、Web上で公開されているコードを組み合わせれば何とかなりそう

という点がメリットである。

と言うことで、休み時間などを利用して半月ほどで一通り使えそうなものができたので、公開することにした。

まず、仕様は自分の好みで以下とした。

• outlook上の特定メールフォルダに格納されているメールを抽出対象とする。従って、抽出前に対象メールを「特定メールフォルダ」にコピーする必要がある。outlook上で対象メールを右クリックして抽出できれば一番良いのだが、これは VBScriptを使う限りは無理だと思う。
  【2019年5月2日追記】
  抽出対象メールを、「特定メールフォルダに格納されているメール」から「outlookで選択されているメール」に改良したバージョンを作成したので、興味のある方は本記事の文末を参照。
• msgファイルだけを抽出するか、添付ファイルも抽出するかを選択可能とした。
• 抽出した msgファイルの名称は「YYYYMMDD_HHMMSS_件名.msg」となる。ここで、YYYYMMDD_HHMMSSはメールの受信日時である。
• 添付ファイルは、「A_YYYYMMDD_HHMMSS_件名」という名称のサブフォルダの下にオリジナルのファイル名で格納される。頭の「A_」はスクリプトの15行目で定義しており変更可能である。
• メール件名には使えるが Windowsのフォルダ名には使えない特殊記号「?:/\*"<>|」は全角文字に変換される。

以下、本スクリプトを使った、outlookからメール（msgファイル）と添付ファイルを抽出する手順である。

1. 対象メールを outlookの受信フォルダ直下の「export」フォルダにコピーする。このメールフォルダ名はスクリプトの12行目で定義しており変更は可能だが、事前に決めて作成しておく必要がある。
2. 本スクリプトをダブルクリックで実行する。
3. 以下のダイアログが表示されるので、抽出先（格納先）フォルダを選択する。なお、ダイアログの下の「フォルダー(F):」にフルパスを直接貼り付けても良い。
   
   
   
   
4. 「添付ファイルを取り出しますか？」というダイアログが表示されるので「はい」「いいえ」のいずれかのボタンをクリックする。
   「いいえ」を選択した場合は msgファイルのみ、「はい」を選択した場合は msgファイルに加え添付ファイルも抽出される。なお、いずれの場合も、元が添付ファイル付きメールの場合、抽出された msgファイルを開けば添付ファイルも含まれている。
5. outlookへのアクセス許可を求める以下のダイアログが表示されるので、「許可」を選択する。
   

これで指定した抽出先フォルダに msgファイルや添付ファイルが格納される。

テストした環境は Windows7と Office2010の組合せのみなのであしからず。
スクリプト（コードはSJIS）は以下のリンクからご自由に。（右クリックして保存）
　⇒　改良版を作成したので原則そちらを利用していただきたい。文末の【2019年5月2日追記】参照。

「outlook2msg.vbs」をダウンロード

読みにくいが、内容は以下の通り。
なお、姉妹編として、メールの件名や内容の一覧をExcelに貼り付けるVBスクリプトも公開したので、興味のあある方はココへ。

---

Option Explicit

Dim objOA, objNS, objOLFolder, objShell, objFolder, objFSO, objItm, objAtt
Dim MyDate, MyFileName, MyFolder, MySubFolder, MyMsgPath, MyYesNo

Const olFolderInbox = 6
Const olMSG = 3
Const ErrNoOLFolder = -2147221233
Const ErrReject = -2147467260

'outlook の対象フォルダ名（受信トレイの下）
Const oLFolderName = "export"

'添付ファイル格納サブフォルダ名の接頭語
Const PreWord = "A_"

Set objOA = CreateObject("Outlook.Application")
Set objNS = objOA.GetNamespace("MAPI")

Err.clear
On Error Resume Next

Set objOLFolder = objNS.GetDefaultFolder(olFolderInbox).Folders(oLFolderName)

If (Err.Number = ErrNoOLFolder) Then
MsgBox "指定した outlook のフォルダ " & oLFolderName  & " が存在しません"
WScript.Quit
End If

On Error Goto 0

Set objShell = WScript.CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder( 0 , "フォルダを選択して下さい" , &h4050 , &h11)

If (objFolder Is Nothing) Then
WScript.Quit
End If

MyFolder = objFolder.Items.Item.Path
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(MyFolder)) Then
MsgBox("存在しないフォルダが指定されました")
WScript.Quit
End If

MyYesNo = MsgBox("添付ファイルを取り出しますか？", vbYesNoCancel)
If MyYesNo = vbCancel Then
WScript.Quit
End If

For Each objItm In objOLFolder.Items

MyDate = objItm.ReceivedTime
MyDate = Replace(MyDate, "/", "")
MyDate = Replace(MyDate, ":", "")
MyDate = Replace(MyDate, " ", "_")

MyFileName = MyDate & "_" & objItm.Subject

'使用禁止文字を置換する
MyFileName = Replace(MyFileName, "?", "？")
MyFileName = Replace(MyFileName, ":", "：")
MyFileName = Replace(MyFileName, "/", "／")
MyFileName = Replace(MyFileName, "\", "￥")
MyFileName = Replace(MyFileName, "*", "＊")
MyFileName = Replace(MyFileName, """", "”")
MyFileName = Replace(MyFileName, "<", "＜")
MyFileName = Replace(MyFileName, ">", "＞")
MyFileName = Replace(MyFileName, "|", "｜")

MyMsgPath= MyFolder & "\" & MyFileName & ".msg"

Err.clear
On Error Resume Next

objItm.SaveAs MyMsgPath , olMSG

If (Err.Number = ErrReject) Then
  MsgBox "終了します"
  WScript.Quit
End If

On Error Goto 0

If (MyYesNo = vbYes) and (objItm.Attachments.count > 0) Then

  MySubFolder = MyFolder & "\" & PreWord & MyFileName

  If objFSO.FolderExists(MySubFolder) = True Then
   MsgBox "フォルダ " & MySubFolder & " は既に存在しています。"
  Else
   objFSO.CreateFolder(MySubFolder)
  End If

  For Each objAtt In objItm.Attachments
   objAtt.SaveAsFile MySubFolder & "\" & objAtt.DisplayName
  Next

End If

Next

---

【2019年5月2日追記】

以下の改良を行ったバージョンをアップしたので、興味のある方は ココへ。

• 対象メールを「outlookの特定メールフォルダ下にあるメール」から「outlook上で選択されているメール」に変更
• 添付ファイル抽出と同時に、元のメールの添付ファイルを削除するオプションを追加