最近のトラックバック

2018年11月
        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30  
無料ブログはココログ

パソコン・インターネット

2018年11月13日 (火)

◆Excel VBA(【IE操作】Google mapのルート情報(道路名)を取得するマクロ2)

前回、Google mapから道路名を取得するマクロを公開しました。
その方法として、Google map apiを使用してChromeにアクセスし、Excelの新規ブックに道路名を貼り付けるものでした。その後マクロを使用すると以下のようなエラーが発生するようになりました。

------------------------------------------
{
   "error_message" : "Keyless access to Google Maps Platform is deprecated. Please use an API key with all your API calls to avoid service interruption. For further details please refer to http://g.co/dev/maps-no-account",
   "routes" : [],
   "status" : "OVER_QUERY_LIMIT"
}
------------------------------------------
Google map apiの利用には"API key"が必要ですよというエラーだと思われます。 Google map apiの利用にはAPI keyが必要であり、有料で取得する必要があるということは認識していましたが、マクロから利用出来ていたので、必要なのはホームページ上で利用するときのみなのかなと勝手に判断していました。どうやら利用回数があるらしく、利用てきていたのは猶予期間だったのかもしれません。 そこで、Google map apiを使用しない別の方法を考えてみました。それは、Google mapのHTML構造を解析して、マクロからIEを操作してHTML情報からダイレクトに道路情報を取得するという方法です。 これは、VBAでIEを操作するなどとネット検索すればたくさんの情報がヒットするポピュラーな方法です。 当初、私もIE操作のマクロをたくさん作成しているので容易に取得できると思っていましたが、Google mapのHTMLは一筋縄ではいかないものでした。どうゆうことかというと、Google mapのソースを表示してみると分かりますが、左ペインの経路情報などは普通のHTMLタグの中には無かったからです。まぁ何が普通か置いておいて、"Script"タグの"OuterText"プロパティに含まれていました。さらにOuterTextの内容は膨大なテキスト量で、Google map独自の構造を持っているようで、実際のマップ上の表記と見比べながら構造を解析しました。

Keiro_source

その結果、  ・経由地(最大10個)  ・道路名  ・全ての経路案内情報 を抽出することに成功しました。

Keiro_info_2

2018年10月14日 (日)

◆Excel VBA(【IE操作】Google mapのタブタイトルをルート名に変更するマクロ)

自分は、GoogleマップのルートをExcelのハイパーリンクとして管理しているのですが、複数のルートをIEで表示する際に不満な点がありました。それは、IEのタブタイトルです。

Googleマップのタブのタイトル表記はルートの「開始位置、終了位置-Google マップ」となるようですが、開始位置が自宅などの場合、IEのタブが全て同じ表記になってしまい、タブタイトルだけではルートが判別できなくなります。

そこで、IEのタブ表記をルート名に変更するマクロを作成してみました。
Excel側にはルート名があり、ハイパーリンクにルートのURLが設定されている状態です。
セルを複数選択してマクロを実行すると、IE側のタブ表記がルート名になるという仕様です。

<Excel側>
Excel_link




<IE側>
(通常)
Ie_tab1

   

(マクロ実行結果)
Ie_tab2

 

 Sub m_ハイパーリンクを開く()
    Dim i As Integer
    Dim ie As Object
    Set ie = Nothing
    Set ie = CreateObject("internetexplorer.application")
    ie.Visible = True

    i = 0
    For Each oSel In Selection
        If ActiveSheet.Rows(oSel.Row).Hidden = True Then GoTo next_oSel
        If Cells(oSel.Row, oSel.Column).Hyperlinks.Count = 0 Then GoTo next_oSel
            
        lUrl = Cells(oSel.Row, oSel.Column).Hyperlinks(1).Address
        lTitle = Cells(oSel.Row, oSel.Column).Value
       
        i = i + 1
        If i = 1 Then
            ie.navigate lUrl
       
            Do While ie.busy Or ie.readyState <> 4
                DoEvents
            Loop
            time10 = DateAdd("s", 5, Now())
            Do While time10 > Now()
                DoEvents
            Loop
            ie.document.Title = lTitle
        Else
            ie.navigate2 lUrl, 2048
       
            time10 = DateAdd("s", 5, Now())
            Do While time10 > Now()
                DoEvents
            Loop

            For Each oIe In CreateObject("Shell.Application").Windows()
                If ie.hWnd = oIe.hWnd And oIe.document.Title Like "*Google マップ*" Then
                    oIe.document.Title = lTitle
                    Exit For
                End If
            Next
        End If

next_oSel:
    Next
   
p_exit:
    'ie.Quit
    Set oSel = Nothing
    Set oIe = Nothing
    Set ie = Nothing
   
End Sub

少し解説すると、セルのハイパーリンクの内容(URL)とルート名を取得し、一番最初であれば ie.navigate で普通に表示、二番目以降に表示する場合は ie.navigate2 でタブで表示していきます。
ポイントはie.document.Titleにルート名を設定するのが早すぎるとうまく表示されないようなので、5秒ほど待ってから設定するようにしています。この秒数はPCの性能やネット環境に依存するかもしれませんので必要に応じて調整してみてください。

2018年8月28日 (火)

◆Excel VBA(【Chrome操作】Google mapのルート情報(道路名)を取得するマクロ)

またまたExcel VBAネタです。

Dscn2347_2布引高原

'18/8/20~24で福島ツーリングに行ってきました。この間作成した、ルートを逆転するマクロ2点間の距離を求めるマクロを使って事前にツーリングルートを準備して行きました。その過程で、最近の台風や大雨で福島県内の道路が通行止めなどになっていることが判明しました。自分が作成したルートが実際に通行止めになっていないかどうか、重要な問題となりました。

福島県内の通行止めの情報はこちらから入手できます。自分のルートから道路名を取得出来れば比較検証できます。そこで以下のマクロを作成しました。結果、磐梯吾妻スカイラインの一部が通行止めなど事前に把握することが出来てマクロの有効性が確認出来ました。

■マクロA
Sub ルート道路名取得()
    If vbYes <> MsgBox("Chromeは起動していますか?", vbQuestion + vbDefaultButton2 + vbYesNo, "ルート道路名取得") Then Exit Sub
   
    Dim i As Integer, j As Integer
    Dim lUrl_A As String
    Dim lUrl_B As String
    Dim lUrl_C As String
    Dim lUrl_NEW As String
   
    Set oMyWb = ThisWorkbook
    Set oS = Selection
    Set oWb = Workbooks.Add
   
    oMyWb.Activate
    For Each oSel In oS
        If oSel.Value = "" Then GoTo next_oSel
        If ActiveSheet.Rows(oSel.Row).Hidden = True Then GoTo next_oSel
        If Cells(oSel.Row, oSel.Column).Comment Is Nothing Then GoTo next_oSel
        If Not (Cells(oSel.Row, oSel.Column).Comment.text Like "*経由地*") Then GoTo next_oSel
       
               
        '経由地情報取得
        lUrl_A = Cells(oSel.Row, oSel.Column).Comment.text
       
        '経由地情報を分解
        larr = Split(lUrl_A, vbCrLf)
       
        lSt = ""
        lEd = ""
        lUrl_C = ""
        If lUrl_A Like "*★*" Then
            lFlg = "&avoid=highways|tolls"    '高速道路も有料道路も使用しない
        Else
            lFlg = ""
        End If
        For i = 0 To UBound(larr)
            If larr(i) Like "・*" Then
                If i = 1 Then
                    lSt = "?origin=" & Replace(larr(i), "・", "")
                ElseIf i = UBound(larr) - 1 Then
                    lEd = "&destination=" & Replace(larr(i), "・", "")
                Else
                    lUrl_C = lUrl_C & "|" & Replace(larr(i), "・", "")
                End If
            End If
        Next
        If lUrl_C <> "" Then lUrl_C = "&waypoints=" & Mid(lUrl_C, 2)
        lUrl_NEW = "https://maps.googleapis.com/maps/api/directions/json" & lSt & lEd & lUrl_C & "&mode=driving" & lFlg
       
        'Chromeオープン
        Set oWs = oWb.Worksheets.Add
        oWs.Activate
        oWs.Name = oSel.Value & "_" & oSel.Row
        rtn = Shell("C:\Program Files (x86)\Google\Chrome\Application\chrome.exe" & " " & lUrl_NEW, vbNormalNoFocus)
   
        time10 = DateAdd("s", 2, Now())
        Do While time10 >= Now()
            SendKeys "^a^c"
            DoEvents
            If time10 < Now() Then Exit Do
        Loop
       
        AppActivate "Microsoft Excel"
       
        time10 = DateAdd("s", 1, Now())
        Do While time10 >= Now()
            oWs.Range("A1").Activate
            SendKeys "^v"
            SendKeys ""
            DoEvents
            If time10 < Now() Then Exit Do
        Loop
       
        oMyWb.Activate
       
       
next_oSel:
    Next
    Set rtn = Nothing
    Set oS = Nothing
    Set oSel = Nothing
    Set oUrl = Nothing
   
    Exit Sub
   
End Sub


■マクロB
Sub 道路名一覧作成()
    Set oMyWs = ActiveSheet
    Set oWs = Worksheets.Add
   
    oMyWs.Activate
    lMaxRow = ActiveCell.SpecialCells(xlLastCell).Row
    lMaxCol = ActiveCell.SpecialCells(xlLastCell).Column
    For i = 1 To lMaxRow
        For j = 1 To lMaxCol
            If Cells(i, j).Value = "" Then GoTo next_j
            lVal = Replace(Replace(Cells(i, j).Value, "\u003c", " "), "b\u003e", " ")
            If Not (lVal Like "*県道*") And _
                Not (lVal Like "*国道*") And _
                Not (lVal Like "*自動車道*") And _
                Not (lVal Like "*街道*") Then GoTo next_j
                        
            If lVal Like "*県道*" Then
                lSt = InStr(lVal, "県道")
                lEd = InStr(lSt + 1, lVal, "号線") + 2
                lKendo = Mid(lVal, lSt, lEd - lSt)
               
                Set rtn = oWs.Columns("B").Find(lKendo, LookAt:=xlPart)
                If rtn Is Nothing Then
                    k = oWs.Cells(65000, "B").End(xlUp).Row + 1
                    oWs.Cells(k, "B").Value = lKendo
                    oWs.Cells(k, "A").Value = f_Todofuken(lVal)
                End If
            End If
            
            If lVal Like "*国道*" Then
                lSt = InStr(lVal, "国道")
                lEd = InStr(lSt + 1, lVal, "号線") + 2
                lKokudo = Mid(lVal, lSt, lEd - lSt)
               
                Set rtn = oWs.Columns("B").Find(lKokudo, LookAt:=xlPart)
                If rtn Is Nothing Then
                    k = oWs.Cells(65000, "B").End(xlUp).Row + 1
                    oWs.Cells(k, "B").Value = lKokudo
                    oWs.Cells(k, "A").Value = f_Todofuken(lVal)
                End If
            End If
            
            If lVal Like "*街道*" Then
                lSt = InStr(lVal, "街道")
                lSt = InStrRev(lVal, " ", lSt) + 1
                lEd = InStr(lSt + 1, lVal, "街道") + 2
                lKaido = Mid(lVal, lSt, lEd - lSt)
               
                Set rtn = oWs.Columns("B").Find(lKaido, LookAt:=xlPart)
                If rtn Is Nothing Then
                    k = oWs.Cells(65000, "B").End(xlUp).Row + 1
                    oWs.Cells(k, "B").Value = lKaido
                    oWs.Cells(k, "A").Value = f_Todofuken(lVal)
                End If
            End If
            
            If lVal Like "*自動車道*" Then
                lSt = InStr(lVal, "自動車道")
                lSt = InStrRev(lVal, " ", lSt) + 1
                lEd = InStr(lSt + 1, lVal, "自動車道") + 4
                lKosok = Mid(lVal, lSt, lEd - lSt)
               
                Set rtn = oWs.Columns("B").Find(lKosok, LookAt:=xlPart)
                If rtn Is Nothing Then
                    k = oWs.Cells(65000, "B").End(xlUp).Row + 1
                    oWs.Cells(k, "B").Value = lKosok
                    oWs.Cells(k, "A").Value = f_Todofuken(lVal)
                End If
            End If
            
next_j:
        Next
    Next
    oWs.Activate
    Set rtn = Nothing
    Set oMyWs = Nothing
    Set oWs = Nothing
End Sub

少し解説すると、
(1)マクロ実行の前提として、Excelのセルのコメントにルート情報が設定されていることが必須となります。例えばこんな感じ。ちなみに「・」で始まるのが経由地で10カ所あります。
Excel

(2)「福島ツーリング②」セルを選択した状態でマクロAを実行すると、google map apiを利用してルートの情報をchrome上に表示し、その内容をExcelの新規ブックに貼り付けます。

Chrome

Excel

(3)そこからマクロBを実行し、道路名のみを一覧化します。

Excel2

(4)最後に一覧と福島県の通行止め情報を目視で見比べて問題が無いか確認します。

現時点でいくつか改善が必要な点があります。
google map apiで取得できる情報は完ぺきではないため県道〇〇が福島県道なのか新潟県道なのか山形県道なのか判別できない場合があります。ですので上記(4)で人間が判断しています。

そして、なぜIEではなくchromeに表示するのかというと、IEでは日本語の経由地がうまく動作してくれないからと、ファイルのダウンロード画面が表示されてしまうからです。chromeでは問題なく動作します。

2018年8月18日 (土)

◆Excel VBA(【IE操作】Google mapの位置情報(緯度、経度)から2点間の距離を求めるマクロ)

今回も引き続きExcel VBAネタです。
今回は、タイトルの通り、Google map上の位置情報(緯度、経度)を与え2点間の距離を返す関数を作成してみました。

ここ最近ずっとバイクで走行するための複数ルートの効率的なルート作成を考えていまして、Aルートを走った後にBルートへ行ったほうが近いのかCルートへ行ったほうが近いのかはたまたDルートか、google map上で試行錯誤していると楽しいのだけれど時間がかかってしまって一発で求められないものか!と。複数ルートの効率的な全体を取り纏めたルートを作成するのに頭を悩ませていました。

そこで、前回の記事で各ルートの緯度経度情報は取得できることが分かったので、各ルートの開始点と終了点の座標情報(ルート名、緯度、経度)を一覧化して、それぞれの距離を総当たりで求め、最短のルートを求めてみました。その際に作成したのが2点間の位置情報(緯度、経度)を与えてその距離を返す関数です。

数式自体はネットから拝借しました(一部数値を見直していますが)。この式は地球上の2点間を平面に近似しています。地球は厳密には楕円体ということで、3次元の複雑な式になるようですが、国土地理院の距離を求めるサイトと比較して近い値が得られるので良しとしました。
※私もよくわかっていないので説明が間違っていたらすみません。

以下に関数を示します。戻り値の単位はKmとなります。
'-----------------------------------------------------
' 位置情報(緯度、経度)を与えて2点間の距離を返す関数
'-----------------------------------------------------
'pMoto_Ido   ・・・自分の緯度
'pMoto_Keido ・・・自分の経度
'pSaki_Ido   ・・・相手の緯度
'pSaki_Keido ・・・相手の経度
Function f_Getkyori(ByVal pMoto_Ido As Double, ByVal pMoto_Keido As Double, ByVal pSaki_Ido As Double, ByVal pSaki_Keido As Double) As Double
    f_Getkyori = 6378.137 * _
        Application.WorksheetFunction.Acos( _
            Cos(Application.WorksheetFunction.Radians(pMoto_Ido)) * Cos(Application.WorksheetFunction.Radians(pSaki_Ido)) * _
            Cos(Application.WorksheetFunction.Radians(pSaki_Keido) - Application.WorksheetFunction.Radians(pMoto_Keido)) + _
            Sin(Application.WorksheetFunction.Radians(pMoto_Ido)) * Sin(Application.WorksheetFunction.Radians(pSaki_Ido)) _
        )

End Function

'-----------------------------------------------------
' テスト
'-----------------------------------------------------
Sub test_saitan()
    '東京駅と宗谷岬との距離
    MsgBox f_Getkyori(35.6811673, 139.7670516, 45.5229025, 141.9365949) & "Km"

    '東京駅と佐多岬との距離
    MsgBox f_Getkyori(35.6811673, 139.7670516, 30.9950472, 130.6615718) & "Km"
End Sub

■東京駅と宗谷岬との距離
(1)マクロ実行結果

Tokyosouya_vba

(2)国土地理院サイト

Tokyosouya

■東京駅と佐多岬との距離
(1)マクロ実行結果

Tokyosata_vba

(2)国土地理院サイト
Tokyosata

上記の関数を使って以下のようなルート表(イメージ)が出来たので、複数のルートを纏めた全体のルートが作りやすくなりました。表の前提として、各ルートには複数の経由地があって、各ルートの開始点と終了点のみを抽出しているということです。経由地が2から始まっているものがあるのは、1が自宅の場合、自宅を除外しているためです。終了点が自宅の場合も除外しています。

<ルート表イメージ>
ルート名  経由順  緯度・経度         | 最短ルート名  経由順  緯度・経度
----------------------------------------------------------------
Aルート    1         35.xxxx,139.xxxx  | Bルート          5         35.xxxx,140.xxxx
Aルート    8         35.xxxx,139.xxxx  | Bルート          5         35.xxxx,140.xxxx
Bルート    2         35.xxxx,140.xxxx  | Cルート          7         36.xxxx,139.xxxx
Bルート    5         35.xxxx,140.xxxx  | Cルート          1         36.xxxx,139.xxxx
Cルート    1         36.xxxx,139.xxxx  | Bルート          5         35.xxxx,140.xxxx
Cルート    7         36.xxxx,139.xxxx  | Bルート          2         35.xxxx,140.xxxx

見方としては、Aルートの経由地1も経由地8も共にBルートの経由地5が一番近いことが分かります。Bルートの経由地5はCルートの経由地1が一番近いことが分かります。
このことから、Aルート→Bルート→Cルートか、Cルート→Bルート→Aルートを作成すれば良いことが分かります。

各ルートに10カ所近い経由地が設定されている場合、単純に1つの全体ルートは作成できませんが、いくつかに分割して全体のルートを作成する手助けになります。

これまでの試行錯誤よりも効率的に全体のルートを把握できて便利です。試しにAルートにBルートの経由地5をプロットしてみると最も近くに表示されますので実用上問題ないことが確認されました。

2018年8月 7日 (火)

◆Excel VBA(【IE操作】Google mapのルートを逆転させるマクロ)

今回は久しぶりのExcel VBAネタです。
前々から思っていたのですが、Google mapでルートを作成して、出来上がったルートを逆ルートで走行したくなることはありません?経由地が最大10カ所設定できるgoogle mapのルートを手で入れ替えするのが面倒くさい。一発で逆ルートにできる機能はないかなと。

普段は作成したルートを短縮URLにしてExcelで管理しているのですが、短縮URLを開くとオリジナルの長いURL(以下オリジナルURLと表記します)で表示されますね。そのURLを観察すると、経由地(緯度、経度や名称)が/(スラッシュ)で区切られている。このオリジナルURLから経由地を取り出して、逆順に入れ替えてgoogle mapのURLを再生成するVBAを作ればよいのではと考えました。一発とは言えませんが作業の流れは以下の通りです。

(1)Excel上で管理している短縮URLをクリックし、IEでルート表示する。

(2)表示されているオリジナルURLをコピーします。

(3)Excel上にあらかじめ用意したメモにペーストします。
最初、セル内にペーストしたのですがURLが長くなると切れてしまったからです。

(4)マクロを実行して、新たなメモに逆転したルートのURLを生成します。

(5)生成したURLをIEに貼り付けて逆転したルートを表示します。
必要に応じて短縮URLにする。

多少手間ですが、目的の逆転ルートのURLはできました。
興味があればソースを参考にしてみてください。

※2018/8/10追記
下記ソースのmod startからmod endまで修正しました。
実は前々から懸案だったのですが、高速道路を使用するかしないかのオプション情報が欠落してしまう問題があったのですが、まだ中途半端ですがとりあえずその問題を修正しました。内容に興味がある方はネットで”google map URL data=”などで検索してみてくださいね。



Sub ルート逆転()
    Dim lUrl_A As String
    Dim lUrl_B As String
    Dim lUrl_C As String
    Dim lUrl_NEW As String
   
    If Cells(ActiveCell.Row, ActiveCell.Column).Comment Is Nothing Then GoTo p_end
    lUrl = ActiveCell.Comment.text

    'オリジナルURLを分解
    lUrl = Mid(lUrl, InStr(lUrl, "dir/") + 4)
    lUrl_A = Mid(lUrl, 1, InStrRev(lUrl, "@") - 2)
    lUrl_B = Mid(lUrl, InStrRev(lUrl, "@"))
   
    larr = Split(lUrl_A, "/")
   
    'URL逆転
    lUrl_NEW = ""
    For i = UBound(larr) To 0 Step -1
        lUrl_C = lUrl_C & "/" & larr(i)
    Next
'mod start-------------
    If lUrl Like "*2m1!1b1!3e0" Then
        lUrl_NEW = "https://www.google.co.jp/maps/dir" & lUrl_C & "/data=!4m3!4m2!2m1!1b1"    '高速道路を使用しない
    Else
        lUrl_NEW = "https://www.google.co.jp/maps/dir" & lUrl_C
    End If
'mod end-------------
   
    'コメントに抽出(コメント操作の遊びあり)
    With Cells(ActiveCell.Row + 1, ActiveCell.Column)
        On Error Resume Next
        .ClearComments
        On Error GoTo 0
        .AddComment
        .Comment.Visible = True
        .Comment.text text:=lUrl_NEW
        .Comment.Shape.Width = 600
        .Comment.Shape.Height = 150
        .Comment.Shape.DrawingObject.Interior.ColorIndex = 35
        .Comment.Shape.DrawingObject.Font.Size = 8
        .Comment.Shape.DrawingObject.Font.Bold = True
       
    End With
p_end:
   
End Sub


<シート側>
Photo_2

<Google Map 正ルート>
A_2

<Google Map 逆ルート>
B_2

2017年7月 9日 (日)

最近Google Chromeが遅い件について

タイトルの通り、Google ChromeのYoutube再生において、これまで1080p 60HDで再生
できていたものが、最近240p とか144pで再生されてしまう現象が頻発するようになりました。

このままではストレスなので、ネットワーク環境が遅くなっているのか、PC自体が遅くなって
いるのかいろいろ原因を探ってみました。

まず、(1)ネットワークの測定サイトで下りの速度を計測してみました。
確かに光回線の割には30Mbpsしか出なかったりして、近所に光回線を使用する家庭
が増えて混んできたのかなぁとか考えました。これはどうしようもありません。

さらに、(2)Wi-Fiルータのファームウェアが古いのかと思い、最新に更新したりして
みました。しかし、改善されません。

さらに、(3)PCのHDDの空き容量を増やし、デフラグを実施してみました。
Chromeの一時使用領域が不足していたり、HDDのアクセスが遅くなっていることが
原因かもしれないと考えたからです。しかし、改善されませんでした。

さらに、(4)Chromeが遅い原因をネット検索すると、不要なブックマークや拡張機能
を削除するだとか、閲覧履歴を削除するだとか、いろいろ設定を見直す内容が紹介
されていました。不要なものを削除してみましたが改善されませんでした。

その中で、(5)「Google Chromeの設定」⇒「詳細設定」⇒「Google Chrome を閉じた
際にバックグラウンド アプリの処理を続行する」をオフ
にするというものがありました。
これは、Chromeを終了してもChromeのプロセスが残ってしまい、知らず知らずのうちに
メモリを圧迫してPC全体のパフォーマンスが低下してしまうというのです。
この事象を回避するために上記の設定をオフにすると良いというものでした。
一時、この設定をオフにしていたのですが、オンにしてyoutubeを再生したところ
1080p 60HDで問題なく再生されるようになりました。

Chromeを終了してもプロセスは残りませんし、今後はオンのままでいきたいと思います。
解消されてよかったよかった。。。

ちなみに我が家の環境は以下の通り。
 PC :OS Windows8.1 64bit
        メモリ:8GB
        CPU:Intel Core i5
 Wi-Fi (速度:130Mbps)
 NTTフレッツ光
 Chrome Ver.61.0.3141.8(Official Build)

2012年2月11日 (土)

■Word VBA(検索文字列の行を選択 その2)

久しぶりのWord VBAネタです。「検索文字列の行を選択」記事で、繰り返し実行するにはどうすればよいでしょうかという問い合わせをいただきました。
Ifの部分をDo whileにすればよいと書きましたが、実際にやってみると結構変更する部分があったので以下の通り作成しました。サクっと作ったので変なロジックですがとりあえず動くので良しとします。
前回はExcelから操作するケースも作りましたが今回は割愛します。
Do Loopで無限ループしますが、処理の中で最初の検索位置に戻ったらループを抜けるようしました。
それと、検索文字を含む行全体を選択するロジックでしたが、今回はわざと検索文字のみを選択するようにしてあります。これは、一行の中に、検索文字が複数存在する場合に一行選択してしまうと最初の検索文字しか検索しないからです。それでも構わない場合は、コメント部分を外せば良いです。

Sub test1()
    lmoji = InputBox("検索する文字を入力してください。", "検索文字入力", "年度")
    If lmoji = "" Then End
   
    Do
        With Selection.Find
            .Forward = True
            .ClearFormatting
            .MatchWholeWord = True
            .MatchCase = False
            .Wrap = wdFindContinue
   
            If .Execute(FindText:=lmoji, Forward:=True, Format:=True) = True Then
                '位置取得
                Set myRange = Selection.Range
                With myRange
                    '行
                    aa = .Information(wdFirstCharacterLineNumber)
                    '桁
                    bb = .Information(wdFirstCharacterColumnNumber)
                    '頁
                    pp = .Information(wdActiveEndPageNumber)
                End With
            
                '一行選択
'                Selection.HomeKey unit:=wdLine, Extend:=wdMove
'                Selection.EndKey unit:=wdLine, Extend:=wdExtend
                lVal = Selection
            End If

            If a = aa And b = bb And p = pp Then Exit Do
            MsgBox lVal & ": " & aa & " 行 " & bb & " 桁  " & pp & " 頁"
            
            
            If a = "" Then a = aa
            If b = "" Then b = bb
            If p = "" Then p = pp
            
            .Parent.Move Count:=2
            
        End With
    Loop

    Selection.Find.ClearFormatting
    Set myRange = Nothing
End Sub

2011年11月26日 (土)

◆Outlook VBA(メール誤送信防止のためのチェックあれこれ その4)

メール誤送信防止のためのチェックについて、機能を追加してみました。
追加した機能は、送信先のアドレス(To,Cc,Bcc)に自ドメイン以外のアドレスが含まれていた場合、その旨知らせるメッセージを表示するというものです。
以下の要領で実装します。

(1)ThisOutlookSessionのソース(記事:その2)に以下の1文を追加
      ・
      ・
      ・
      lSubject = Item.Subject     '件名
      lBody = Item.Body           '本文
→   gSendname = Item.Session.CurrentUser.Address '送信者
   
      '件名チェック
      ・
      ・
      ・
(2)標準モジュールのソース(記事:その3)に以下の1文を追加
  Public gTitle As String
  Public gAddress
  Public gTempFile
  Public SendFlg As Boolean
→ Public gSendname
      ・
      ・
      ・
(3)ユーザフォームにLabel5を追加。一応警告なのでForeColorは赤にしてみました。
(4)ユーザフォームのソース(記事:その3)の宛先処理を以下に変更
      ・
      ・
      ・
    '宛先
    ldomain = Split(gSendname, "@")
   
    U1.Label3.Caption = U1.Label3.Caption & " 件数:" & gAddress.Count
    Dim lcnt As Integer
    lcnt = 0
    OutFlg = False
    For Each oAddress In gAddress
        lcnt = lcnt + 1
        If Not (oAddress.Address Like "*" & ldomain(1)) Then
            OutFlg = True
        End If
        U1.ListBox1.AddItem Format(lcnt, "00") & "." & oAddress.Name & " 【" & oAddress.Address & "】"
    Next
    If OutFlg = True Then
        U1.Label5.Caption = "自ドメイン (" & ldomain(1) & ") 以外のアドレスが含まれています。"
    Else
        U1.Label5.Caption = ""
    End If
      ・
      ・
      ・

で、実行した結果が以下のようになります。自ドメインは自分の送信者アドレスから抽出しています。
そのドメインと宛先のアドレスのドメインが異なったらメッセージを表示するというしくみです。
Domain_chk_2

2011年10月30日 (日)

◆Outlook VBA(メール誤送信防止のためのチェックあれこれ その3)

メール誤送信防止チェックの最終回です。今回は標準モジュールとフォームです。

(1)Outlookを起動したら、
(2)Alt+F11を押下してMicrosoft Basic Editorを表示します。
(3)どこでも良いですがProject1(VbaProject.OTM)上で右クリックし、メニュー「挿入」→「標準モジュール」を選択し、以下の標準モジュールの内容をコピペします。
(4)(3)と同様に右クリックし、メニュー「挿入」→「ユーザフォーム」を選択。追加されたフォームを下記の画像の通りに作成します。右クリックし、「コードの表示」を選択し、以下のユーザフォームの内容をコピペします。

'------------------------------
' 標準モジュール
'------------------------------
Public gTitle As String
Public gAddress
Public gTempFile
Public SendFlg As Boolean

Sub m_SendCheck(Optional ByVal dummy As String)
    U1.Show
End Sub

User_form

'------------------------------
' ユーザフォーム
'------------------------------
Private Sub CommandButton1_Click()
    SendFlg = False
    Unload U1
End Sub

Private Sub CommandButton2_Click()
    SendFlg = True
    Unload U1
End Sub

Private Sub UserForm_Initialize()
    '件名
    If gTitle <> "" Then
        U1.TextBox1.Text = gTitle
    Else
        U1.TextBox1.Text = "**** 件名なし ****"
    End If
   
    '宛先
    U1.Label3.Caption = U1.Label3.Caption & " 件数:" & gAddress.Count
    Dim lcnt As Integer
    lcnt = 0
    For Each oAddress In gAddress
        lcnt = lcnt + 1
        U1.ListBox1.AddItem Format(lcnt, "00") & "." & oAddress.Name & " 【" & oAddress.Address & "】"
    Next
   
    '添付ファイル
    U1.Label4.Caption = U1.Label4.Caption & " 件数:" & gTempFile.Count
    lcnt = 0
    If gTempFile.Count > 0 Then
        For Each oTempFile In gTempFile
            lcnt = lcnt + 1
            U1.ListBox2.AddItem Format(lcnt, "00") & "." & oTempFile.FileName
        Next
    Else
        U1.ListBox2.AddItem "**** 添付ファイルなし ****"
       
    End If
   
    Set oAddress = Nothing
    Set oTempFile = Nothing
   
End Sub

それでは解説です。
まず標準モジュールのPublic変数は前回解説したThisOutlookSessionモジュール内で設定した内容を
ユーザフォームに渡すものです。またSendFlgは送信か否かを受け取るフラグ変数です。
処理の内容は単にユーザフォームを表示(show)するだけです。
なぜThisOutlookSessionでやらないのかというと、このPublic変数がThisOutlookSession内で定義出来無かった
ので、変数定義だけではつまらないのでm_SendCheckを書いたという理由です。

次に、ユーザフォームです。
まずフォームの作成について何点か補足します。
件名を表示するTextBoxのBorderStyleプロパティでは1を定義しています。
そして、EnabledプロパティにはFalseを定義しています。この設定は処理とは関係有りません、私の趣味です。
■宛先と■添付ファイルのLabelですが、ロジックで件数情報を付加していますので横長に定義しましょう。
キャンセルボタンのCancelプロパティ、Defaultプロパティは共にTrueを設定しています。
今回の誤送信防止チェックのコンセプトはEnterキーで間違って送信しないように、意識的にデフォルトボタンは「いいえ」か「キャンセル」にしています。
次にロジックですが、UserForm_Initializeでフォームを初期表示した際の処理と、送信ボタン、キャンセルボタンが押下された時の処理があるだけです。
宛先のメールアドレスはアドレスと表示名を両方表示できるようにしています。
件名と添付ファイルが存在しない場合は、文言で無いことが一目で分かるようにしています。
あとは大したことはしていませんので解説は不要でしょう。

以上でプログラムの説明が終わりました。
この機能を利用すればある程度チェックが働きますので誤送信防止に寄与するでしょう。私自身も重宝しています。よかったら利用してみてください。
<関連記事>
その1
その2

最後に、以下のサイトを参考にさせて頂きました。ありがとうございました。
http://d.hatena.ne.jp/fyts/20070813/outlook

2011年10月29日 (土)

◆Outlook VBA(メール誤送信防止のためのチェックあれこれ その2)

前回からの続きです。メール誤送信を防ぐために作成した4つの機能について、プログラムを説明していきます。今回はThisOutlookSessionです。

(1)Outlookを起動したら、
(2)Alt+F11を押下してMicrosoft Basic Editorを表示します。
(3)ThisOutlookSessionモジュールに以下の内容をコピペします。

Private Sub Application_Itemsend(ByVal Item As Object, Cancel As Boolean)
    Dim lSubject As String
    Dim lBody As String
    Const cMongon As String = "添付|別添|別紙"    '本文と件名をチェックしたい文言を|で区切って指定する
    Const cCheck As String = "xlsx|xlsm"           '添付ファイルの拡張子をチェックしたい拡張子を|で区切って小文字で指定する
   
    lSubject = Item.Subject '件名
    lBody = Item.Body '本文
   
    '件名チェック
    If Trim(lSubject) = "" Then
        If vbNo = MsgBox("件名が未入力です。本当に送信しますか?", vbYesNo + vbDefaultButton2 + vbExclamation, "件名チェック") Then
            Cancel = True
            Exit Sub
        End If
    End If
   
    '添付ファイル存在チェック
    lLoop = Split(cMongon, "|")
    lTempFlg = False
    For i = 0 To UBound(lLoop)
        If lSubject & lBody Like "*" & lLoop(i) & "*" And Item.Attachments.Count = 0 Then
            lTempFlg = True
            lVal = lLoop(i)
            Exit For
        End If
    Next
    If lTempFlg = True Then
        If vbNo = MsgBox("本文または件名に「" & lVal & "」という文言が含まれています。" & vbCrLf & _
            "添付ファイルを忘れている可能性がありますが送信しますか?", vbYesNo + vbDefaultButton2 + vbExclamation, "添付ファイル存在チェック") Then
            Cancel = True
            Exit Sub
        End If
    End If
   
    '添付ファイル拡張子チェック
    If Item.Attachments.Count > 0 Then
        lLoop2 = Split(cCheck, "|")
        For i = 0 To UBound(lLoop2)
            For Each oAt In Item.Attachments
                If StrConv(oAt.FileName, vbLowerCase) Like "*" & lLoop2(i) Then
                    If vbNo = MsgBox("添付ファイルの中に送信不可の拡張子(" & lLoop2(i) & ")が含まれている可能性があります。" & vbCrLf & _
                                    "本当に送信しますか?", vbYesNo + vbDefaultButton2 + vbExclamation, "添付ファイルチェック") Then
                        Cancel = True
                        Set oAt = Nothing
                        Exit Sub
                    End If
                End If
            Next
        Next
    End If
   
   
    '宛先確認
    gTitle = Item.Subject
    Set gAddress = Item.Recipients
    Set gTempFile = Item.Attachments
   
    Call m_SendCheck
    Cancel = SendFlg
   
End Sub

解説ですが、Application_Itemsendは送信ボタンを押下したときに発生するイベントです。引数のItemは送信しようとしているメールの情報が入っているオブジェクト型の変数です。引数のCancelはプログラムの中でTrueを設定すれば送信中止、Falseを設定すれば送信をコントロールする変数です。
プログラムの中身ですが、cMongonに添付ファイルをチェックする際に使用する文言を定義しておく変数です。他に適切な文言があれば追加してみてください。cCheckには送信前にチェックしたいファイル拡張子を追加してみてください。あとは、順番に件名未入力チェック、添付ファイル忘れチェック、拡張子チェック、宛先確認ダイアログ表示となります。

宛先確認ダイアログは標準モジュールのm_SendCheckを呼び出すことになりますが、長くなりましたので次回とします。それではまた。

より以前の記事一覧