カスタム検索
リボン関連

 

トップページ > リボン関連 > 右クリックメニューから短縮URLを取得する(Word 2010)

 

Sponsored Links

右クリックメニューから短縮URLを取得する(Word 2010)

今回はWord 2010ファイルの右クリックメニューからリンク先の短縮URLを取得する方法を紹介します。

 

1. Wordファイルを開きます。
2. 標準モジュールに下記コードを貼り付けて上書き保存した後、ファイルを閉じます。

Option Explicit

Public Sub button_onAction(control As IRibbonControl)
  Dim url As String
  Dim ret As String
  
  If Selection.Hyperlinks.Count < 1 Then Exit Sub
  url = Selection.Hyperlinks.Item(1).Address
  Select Case control.ID
    Case "btnBitly"
      ret = GetShortenedLinkBitly(url)
    Case "btnJmp"
      ret = GetShortenedLinkJmp(url)
    Case "btnGoogl"
      ret = GetShortenedLinkGoogl(url)
    Case "btnTinyURL"
      ret = GetShortenedLinkTinyUrl(url)
  End Select
  
  '結果をクリップボードにコピー
  'CreateObject("htmlfile").parentWindow.clipboardData.setData "text", ret
  With GetObject("new:1C3B4210-F441-11CE-B9EA-00AA006B1A69")
    .SetText ret
    .PutInClipboard
  End With
  MsgBox "短縮URL: " & ret & " をクリップボードにコピーしました。", vbInformation + vbSystemModal
End Sub

Private Function GetShortenedLinkBitly(ByVal target As String) As String
'bit.lyで短縮URL取得
  Dim ret As String
  Dim shortenedLink As String
  Dim elm As Object
  Const url As String = "http://bit.ly/?u="
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    '1回Sendしただけでは取得できないため2回Send
    .Open "GET", url & EncodeURL(target), False
    .Send
    .Open "GET", url & EncodeURL(target), False
    .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
    .Send
    ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) < 1 Then Exit Function
  
  shortenedLink = "" '初期化
  On Error Resume Next
  With CreateObject("htmlfile")
    .Open
    .Write ret
    .Close
    For Each elm In .getElementsByTagName("SPAN")
      If elm.ClassName = "shortenedLinkStateUnAuth_url" Then
        shortenedLink = elm.getElementsByTagName("INPUT")(0).Value
        Exit For
      End If
    Next
  End With
  On Error GoTo 0
  GetShortenedLinkBitly = shortenedLink
End Function

Private Function GetShortenedLinkJmp(ByVal target As String) As String
'j.mpで短縮URL取得
  Dim ret As String
  Dim shortenedLink As String
  Dim elm As Object
  Const url As String = "http://j.mp/?u="
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    '1回Sendしただけでは取得できないため2回Send
    .Open "GET", url & EncodeURL(target), False
    .Send
    .Open "GET", url & EncodeURL(target), False
    .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
    .Send
    ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) < 1 Then Exit Function
    
  shortenedLink = "" '初期化
  On Error Resume Next
  With CreateObject("htmlfile")
    .Open
    .Write ret
    .Close
    For Each elm In .getElementsByTagName("SPAN")
      If elm.ClassName = "shortenedLinkStateUnAuth_url" Then
        shortenedLink = elm.getElementsByTagName("INPUT")(0).Value
        Exit For
      End If
    Next
  End With
  On Error GoTo 0
  GetShortenedLinkJmp = shortenedLink
End Function

Private Function GetShortenedLinkGoogl(ByVal target As String) As String
'Google URL Shortenerで短縮URL取得
  Dim ret As String
  Dim shortenedLink As String
  Dim v As Variant
  Dim i As Long
  Const url As String = "http://goo.gl/api/shorten?url="
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "POST", url & EncodeURL(target), False
    .setRequestHeader "X-Auth-Google-Url-Shortener", "true"
    .Send
    ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) < 1 Then Exit Function
    
  shortenedLink = "" '初期化
  v = Split(ret, """")
  For i = LBound(v) To UBound(v)
    If InStr(v(i), "http") Then
      shortenedLink = v(i)
      Exit For
    End If
  Next
  GetShortenedLinkGoogl = shortenedLink
End Function

Private Function GetShortenedLinkTinyUrl(ByVal target As String) As String
'TinyURLで短縮URL取得
  Dim ret As String
  Dim shortenedLink As String
  Dim elm As Object
  Const url As String = "http://tinyurl.com/create.php?url="
  
  ret = "" '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url & EncodeURL(target), False
    .setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
    .Send
    ret = .responseText
  End With
  On Error GoTo 0
  If Len(ret) < 1 Then Exit Function
    
  shortenedLink = "" '初期化
  On Error Resume Next
  With CreateObject("htmlfile")
    .Open
    .Write ret
    .Close
    For Each elm In .getElementsByTagName("a")
      If InStr(elm.innerText, "Open") Then
        shortenedLink = elm.href
        Exit For
      End If
    Next
  End With
  On Error GoTo 0
  GetShortenedLinkTinyUrl = shortenedLink
End Function

Private Function EncodeURL(ByVal sWord As String) As String
'URLエンコード処理(64ビット版対応)
  Dim d As Object
  Dim elm As Object
  
  sWord = Replace(sWord, "\", "\\")
  sWord = Replace(sWord, "'", "\'")
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.body.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText = encodeURIComponent('" & sWord & "');", "JScript"
  EncodeURL = elm.innerText
End Function
3. 2.のファイルに下記XMLを設定します(Custom UI Editorは日本語に対応していませんので、「Custom UI Editor Toolの弱点」を参考にしてください)。
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
  <contextMenus>
    <contextMenu idMso="ContextMenuHyperlink">
      <menu id="menuGetShortenedLink" label="短縮URL取得" imageMso="HyperlinkEdit">
        <button id="btnBitly" label="bit.lyで取得" imageMso="HyperlinkCreate" onAction="button_onAction" />
        <button id="btnJmp" label="j.mpで取得" imageMso="HyperlinkCreate" onAction="button_onAction" />
        <button id="btnGoogl" label="Google URL Shortenerで取得" imageMso="HyperlinkCreate" onAction="button_onAction" />
        <button id="btnTinyURL" label="TinyURLで取得" imageMso="HyperlinkCreate" onAction="button_onAction" />
      </menu>
    </contextMenu>
  </contextMenus>
</customUI>
4. 3.のファイルをマクロを有効にして開きハイパーリンク上で右クリックメニューを表示すると、「短縮URL取得」メニューが表示されることが確認できます。

5. 短縮URL取得メニューにある「bit.lyで取得」「j.mpで取得」「Google URL Shortenerで取得」「TinyURLで取得」ボタンのいずれかをクリックすることで、それに応じた短縮URLを取得することができます。

※ このとき下図のようにWeb ページ エラーが発生した場合は、"今後、このメッセージを表示しない"にチェックを入れて「いいえ」ボタンをクリックしてください。

トップページ > リボン関連 > 右クリックメニューから短縮URLを取得する(Word 2010)