最近のトラックバック

2019年4月
  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        
無料ブログはココログ

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

2019年1月11日 (金)

◆Excel (Excelが起動エラー(異常終了)を起こす件について)

2019年1月のWindows Updateを実施したところ、Excel2010が起動エラーを起こして終了してしまう事象が発生した。エラーは以下の通り。

「Microsoft Excel は動作を停止しました(問題が発生したため、プログラムが正しく動作しなくなりました。プログラムは閉じられ、解決策がある場合はWindowsから通知されます)」

原因は明らかにWindows Updateだ。こいつを実施した直後から異常終了が発生したからだ。

ネットで調べたら、Windows Updateの「KB4461627」が原因ということが分かった。
早速、アンインストールを行い無事Excelが起動するようになった。

削除手順は、「コントロールパネル」→「Windows Update」→「更新履歴を表示」→「インストールされた更新プログラム」→検索フィールドに「KB4461627」入力→一覧表示された「KB4461627」を右クリックし→「アンインストール」実行

こちらのサイトが役に立った。ありがとうございました。

ちなみにExcel2010のみの事象らしい。
年明け早々から仕事に支障が出るじゃねーか!!ふざけるなよMicrosoft!
適当な仕事してるんじゃねーよ!

2018年11月17日 (土)

◆Excel VBA(【IE操作】Google mapのルート情報(道路名)を取得するマクロ3(緯度経度から住所取得関数))

やりました!解決しました!ずっと懸案だった道路名の問題が。
前回前々回で懸案だった県道○○号線は取得できるが何県の県道かという問題。
県道の座標位置(緯度、経度)から住所を取得するマクロを作成して解決しました。

Google mapに緯度、経度を渡すとピンポイントに表示してくれることが判明したので、そのHTML情報(Metaタグ)から住所を抜き出しています。緯度経度を渡すと、その住所と、都道府県名を返す関数になります。

■緯度経度を渡すと、その都道府県名と、住所を返す関数
Function f_IE_座標から都道府県名取得(ByVal pIdoKeido As String, ByRef pTodofuken, ByRef pJusho) As Boolean
    Dim ie As Object
    Set ie = Nothing
    Set ie = CreateObject("internetexplorer.application")
    ie.Visible = False
 
    lUrl = "https://www.google.co.jp/maps/place/" & pIdoKeido & "/"
    ie.navigate lUrl
    Do While ie.busy Or ie.readyState <> 4
        DoEvents
    Loop
 
    f_IE_座標から都道府県名取得 = False
    pTodofuken = ""
    pJusho = ""
    GoSub p_GetInfo
 
p_exit:
    ie.Quit
    Set oTg = Nothing
    Set ie = Nothing
    Exit Function
 
'---------------------
p_GetInfo:
    lTag = "Meta"
    For t = 0 To ie.document.GetElementsByTagname(lTag).Length - 1
        Set oTg = ie.document.GetElementsByTagname(lTag)(t)
        If fKenmei(oTg.Content, lVal) Then
            pTodofuken = lVal
            pJusho = oTg.Content
            f_IE_座標から都道府県名取得 = True
 
            Return
        End If
    Next
 
    Return
End Function

■テスト
Sub test座標から都道府県名()
    If f_IE_座標から都道府県名取得("35.2587277,138.9733733", a, b) Then
        MsgBox a & "," & b
    End If
End Sub

Jusho_map

この関数を使用して、これまでの処理を改良し、経路案内情報から道路名と住所を抽出する方法に改めて完成したのが以下の結果です。

Keiro_info2

Google mapのHTML情報から緯度、経度を抽出するのが困難でしたが何とか成功しました。あぁなんと晴れやかな気分なのか。あとついでといってはなんですが、高速を使うか、有料道路を使うかといったオプション設定情報も併せて抽出しています。
これですべての懸案事項が解決しました。
めでたしめでたし。

2018年11月13日 (火)

◆Excel VBA(【IE操作】Google mapのルート情報(道路名)を取得するマクロ2(API キーを使わない方法))

前回、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が必要であり、有料で取得する必要があるということは認識していましたが、マクロから利用出来ていたので、ホームページ上でAPIを利用するときのみ必要なのかなと勝手に判断していました。どうやら利用回数があるらしく、利用出来ていたのは猶予期間だったのかもしれません。
そこで、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.11.17追記 何県の県道なのか、その3で解決しました!!

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カ所あります。経由地は、スラッシュ(/)で区切られているGoogle mapのURLから取り出しています。

Excel

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

Chrome

Excel

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

Excel2

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

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

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

2018.11.13追記

Google Map APIを使わない方法はその2

 

2018.11.17追記 何県の県道かはその3で解決しました!!

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をプロットしてみると最も近くに表示されますので実用上問題ないことが確認されました。ただここでお断りしておくと、この2点間の距離はあくまでも直線距離ということで、Google map上のルートの距離とは異なることです。ルート上の2点間の距離ということであれば、Google map apiを駆使して求めることになるかと思います。

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にする。→興味がある方はこちらの(3)を参考に。


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

<シート側>
Photo_2

<Google Map 正ルート>
A_2

<Google Map 逆ルート>
B_2

※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

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

より以前の記事一覧