２段階認証、面倒くさい

2段階認証が増えてきているこの頃、ログインした後にメーラーに切り替えてコードをコピーして貼り付ける作業、何気に面倒。しかもタイムアウトが短いサイトだと何度も入力することになったりする。何とかできないかとやってみた。

方針

特定メールのみを受信して処理するメーラーを作って処理するというツールを作ったことはあるけど、面倒なのでそこまではやらない。

やるべきことは対象のメールを読んでパスコードを探し出しコピーペーストするのだけど、ペーストはあきらめて、クリップボードにコピーするまでという方針にする。使っているメーラーがoutlookなので、あまり使ったことのないoutlookのVBAを使用してみます。

ソース説明

outlook で、 Alt + F11を押してVBEを起動して下のソースを貼り付ける。

このソースでは2つのメールアドレスから来たメールについてパスコードを探し出す関数を呼び出します。パスコードを探し出す関数では文字列からパスコードの直前を探し出してクリップボードにコピーする関数を呼び出します。

増減は適当にどうぞ。

できる限り条件を絞って余計なメールは処理しないように注意が必要かと思います。

vbaでクリップボードにコピーするくらいすぐできると思ったのだが、テキストボックスオブジェクトを作成してそこに文字を入力してコピーするという何ともキモイ感じですが、探してもこんな方法しかないらしいので仕方なし。

まとめ

ログインボタンを押して、少し待つとメールを受信して、パスコードがクリップボードにセットされるので、CTRL + Vで張り付ける。

たまに発動しない時があるみたいだけど、その時は再送するかあきらめてメーラーからコピーする。

それなりに動いてるし、使ったことのないoutlookのVBAも使えて満足したのでこれでいいか。

ソース

ThisOutlookSession

ここからーーーーーーーー

Const REPLY_SENDER1 = "no-reply@hogehoge.com"
Const REPLY_SENDER2 = "no-reply@mogumogu.com"

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim objItem As Object
Dim objMail As MailItem
'
Set objItem = Session.GetItemFromID(EntryIDCollection)
' 受信メールが通常のメールだったら
If objItem.MessageClass = "IPM.Note" Then
Set objMail = objItem
' 差出人のアドレスが特定のアドレスなら、メール内の文字列をコピー
If objMail.SenderEmailAddress = REPLY_SENDER1 Then
ReplyToAddressInBody1 objMail
ElseIf objMail.SenderEmailAddress = REPLY_SENDER2 Then
ReplyToAddressInBody2 objMail
End If
End If
End Sub

'本文からパスコードを取得して、クリップボードにコピーその１
Private Sub ReplyToAddressInBody1(objMail As MailItem)
Dim strBody As String
Dim i As Integer

Dim strPass As String
Dim fAddr As Boolean
Dim C As String

' 本文からメールアドレスを取得する
strBody = objMail.Body

i = InStr(strBody, "________________________________")
If i < 0 Then Exit Sub

'パスコードを取得
strPass = Mid(strBody, i + Len("________________________________") + 4, 6)

’クリップボードにコピー
Call SetCB(strPass)

End Sub

'本文からパスコードを取得して、クリップボードにコピー
Private Sub ReplyToAddressInBody2(objMail As MailItem)
Dim strBody As String
Dim i As Integer

Dim strPass As String
Dim fAddr As Boolean
Dim C As String

If objMail.Subject = "認証コードの発行" Then

' 本文からメールアドレスを取得する
strBody = objMail.Body
i = InStr(strBody, "この認証コードを")
If i < 0 Then Exit Sub

'パスコードを取得
strPass = Mid(strBody, i - 10, 6)

'クリップボードにコピー
Call SetCB(strPass)
End If

End Sub

ーーーーーーここまで

標準モジュールを作成して、以下を貼り付けます。

ここからーーーーーー

Public Sub SetCB(ByVal strSet As String)
'クリップボードにstrSetを貼り付ける
'文字化け対策のためTextBoxを使用
With CreateObject("Forms.TextBox.1")
.MultiLine = True '複数行入力可
.Text = strSet
.SelStart = 0
.SelLength = .textlength
.Copy
End With
End Sub

ーーーーーーここまで