Archive for 2011年3月

Internet Explorer 9 の新機能

2011/03/26

Internet Explorer 9 の新機能を試してみました。
「最近開いた項目を [スタート] メニューとタスク バーに保存し表示する」にチェックが入っていないとカスタムジャンプリストが有効にならないのにちょっとハマりました…。

2011/04/03 追記:
msSiteModeActivateメソッドってバックグラウンドじゃないと動かなかったのね!
これで使い方が分かりました。

[参考Webページ]
「固定サイト: Windows 7 デスクトップの Internet Explorer 9 との統合」
http://msdn.microsoft.com/ja-jp/library/gg581716%28v=VS.85%29.aspx
「Adding Items to a Jump List Dynamically」
http://msdn.microsoft.com/en-us/library/gg491724%28v=vs.85%29.aspx
「DHTML Methods」
http://msdn.microsoft.com/en-us/library/ms533053%28v=VS.85%29.aspx
「意外にカンタン。 Internet Explorer 9 の新機能を 実装してみる」
http://cssnite.jp/shinagawa/vol01/CSSNite-Shinagawa-2-MS-Suzuki-PinnedSite.pdf

<!DOCTYPE html>
<html>
<head>
<title>Internet Explorer 9 Sample Page</title>
<meta charset="UTF-8">
<meta name="application-name" content="ショートカット名" />
<meta name="msapplication-tooltip" content="ツールチップ" />
<meta name="msapplication-navbutton-color" content="#6495ed" />
<meta name="msapplication-window" content="width=800;height=600" />
<meta name="msapplication-task" content="name=タスク1;action-uri=#;icon-uri=./ico/access.ico" />
<meta name="msapplication-task" content="name=タスク2;action-uri=#;icon-uri=./ico/excel.ico" />
<link rel="shortcut icon" href="./ico/favicon.ico">
<link rel="image_src" href="./ico/favicon.ico">
<script type="text/javascript">
 function $(e) {return document.getElementById(e);}
 window.onload = function() {
 //ピン留めサイトかどうかを判断
 try {
 if (window.external.msIsSiteMode()) {
 $("siteMode").innerText = "ピン留めサイトから起動されています。";
 } else {
 $("siteMode").innerText = "ピン留めサイトから起動されていません。";
 }
 } catch(ex) {
 //alert("Site Mode is not supported.");
 return;
 }
 //スタートメニューにWebサイトを追加
 $("addSiteMode").onclick = function () {
 window.external.msAddSiteMode();
 };
 //オーバーレイアイコンを表示
 $("siteModeSetIconOverlay").onclick = function () {
 window.external.msSiteModeSetIconOverlay("./ico/mess.ico", "ユーザーへの通知");
 };
 //オーバーレイアイコンを削除
 $("siteModeClearIconOverlay").onclick = function () {
 window.external.msSiteModeClearIconOverlay();
 };
 //タスクバーボタンを点滅させる
 $("siteModeActivate").onclick = function () {
 window.setTimeout("window.external.msSiteModeActivate()", 2000);
 };
 //カスタムジャンプリストの作成
 //※ [タスク バーと [スタート] メニューのプロパティ] → [最近開いた項目を [スタート] メニューとタスク バーに保存し表示する]要チェック
 $("siteModeCreateJumpList").onclick = function () {
 window.external.msSiteModeClearJumplist();
 window.external.msSiteModeCreateJumplist("カスタムジャンプリスト");
 window.external.msSiteModeAddJumpListItem("カスタムリスト3", "#", "./ico/ppt.ico");
 window.external.msSiteModeAddJumpListItem("カスタムリスト2", "#", "./ico/word.ico");
 window.external.msSiteModeAddJumpListItem("カスタムリスト1", "#", "./ico/project.ico");
 window.external.msSiteModeShowJumpList();
 };
 //カスタムジャンプリストの削除
 $("siteModeClearJumpList").onclick = function () {
 window.external.msSiteModeClearJumpList();
 };
 };
</script>
</head>
<body>
<p><span id="siteMode"></span></p>
<p><input id="addSiteMode" type="button" value="スタートメニューにWebサイトを追加"></p>
<p><input id="siteModeSetIconOverlay" type="button" value="オーバーレイアイコンを表示"></p>
<p><input id="siteModeClearIconOverlay" type="button" value="オーバーレイアイコンを削除"></p>
<p><input id="siteModeActivate" type="button" value="タスクバーボタンを点滅させる(ボタンクリック後ウィンドウをバックグラウンドにする事)"></p>
<p><input id="siteModeCreateJumpList" type="button" value="カスタムジャンプリストの作成"></p>
<p><input id="siteModeClearJumpList" type="button" value="カスタムジャンプリストの削除"></p>
</body>
</html>

Internet Explorer 9 の新機能テスト

広告

Visual Studio 2010でAccess 2010のVSTOアドインを作成する

2011/03/22

下図の通り、Visual Studio 2010ではAccessのアドイン作成がサポートされていません。

しかし、公式ではありませんがJoao Tito Livioさんが「Visual Studio 2010 – VSTO (VB) Access 2010 Template」にてVisual Basic用のプロジェクトを公開されていますので、これを利用すれば簡単にアドインを作成することができます。

上記サイトから「AccessAddIn1.zip」をダウンロードして解凍すると、Visual Basic用のプロジェクト一式が出力されます。

このプロジェクトにコードを追加することで、下図のようなアドインが簡単に作成できます。

Visual Studio 2008用のテンプレートは下記Webページから。

「Extra VSTO Project Templates for Visual Studio 2008」
http://vsto.codeplex.com/

Visual Studio 2010でVSTOアドインのインストーラー(msi)を作成する

2011/03/21

下記Webページを元にVisual Studio 2010でVSTOアドインのインストーラーを作成してみます。

「Deploying a Visual Studio 2010 Tools for Office Solution Using Windows Installer」
http://msdn.microsoft.com/en-us/vsto/ff937654.aspx

  1. 「新しいプロジェクト」から新規プロジェクトを作成します(今回は「Excel 2010 アドイン」(名前:SampleExcelAddIn))。
  2. メッセージボックスを表示するだけの簡単なコードを書き一旦ビルドします。
  3. ファイルメニューの「追加」から新しいプロジェクトを追加します。
  4. その他のプロジェクトの種類 > セットアップと配置 > Visual Studio インストーラー から「セットアップ プロジェクト」を選択し、名前を「SampleExcelAddInSetup」とします。
  5. ソリューション エクスプローラーから「SampleExcelAddInSetup」を右クリックし、メニューの「追加」から「プロジェクト出力」を選択します。
  6. 「プロジェクト出力グループの追加」ダイアログが表示されるので、プロジェクトが「SampleExcelAddIn」、「プライマリ出力」になっていることを確認して「OK」ボタンをクリックします。
  7. ソリューション エクスプローラーから「SampleExcelAddInSetup」を右クリックし、メニューの「追加」から「ファイル」を選択します。
  8. 手順2.でビルドしたアドインのReleaseフォルダから「SampleExcelAddIn.vsto」ファイルと
    「SampleExcelAddIn.dll.manifest」ファイルを選択して、「開く」ボタンをクリックします。
  9. ソリューション エクスプローラーのSampleExcelAddInSetup > 見つかった依存関係 から「Microsoft .NET Framework」と「*.Utilities.dll」以外を選択し、右クリックメニューから「除外」を選択します。
  10. ソリューション エクスプローラーから「SampleExcelAddInSetup」を右クリックし、メニューの「プロパティ」を選択します。
  11. プロパティ ページダイアログから「必須コンポーネント」をクリックします。
  12. 「必須コンポーネント」ダイアログが表示されるので、「必須コンポーネントをインストールするセットアップ プログラムを作成する(C)」「Microsoft .NET Framework 4 Client Profile (x86 および x64)」「Windows インストーラー 3.1」「必須コンポーネントをコンポーネントの開発元の Web サイトからダウンロードする(O)」をチェックして、「OK」ボタンをクリックします。
  13. プロパティ ページダイアログに戻るので、そのまま「OK」ボタンをクリックします。
  14. ソリューション エクスプローラーから「SampleExcelAddInSetup」を右クリックし、メニューの「表示」から「レジストリ」を選択します。
  15. 「HKEY_CURRENT_USER\Software」「HKEY_LOCAL_MACHINE\Software」以下にある「[Manufacturer]」キーを削除します。

  16. 「ユーザー/コンピューター ハイブ」以下に新しく「Software」キーを追加します。

  17. 手順16.で追加した「Software」キー以下に「Microsoft」キーを追加します。

  18. 同様に「Microsoft」キー以下に「Office\Excel\Addins\SampleExcelAddIn」キーを追加します。
  19. 「SampleExcelAddIn」キー内で右クリックし、メニューの「新規作成」から「文字列の値」を選択します。
  20. 追加した値の名前を「Description」にします。
  21. 同様の手順で「FriendlyName(文字列の値)」「LoadBehavior(DWORD値)」「Manifest(文字列の値)」を追加します。



  22. 「Description」「FriendlyName」「LoadBehavior」「Manifest」の値を次のようにします。
    • Description:SampleExcelAddIn
    • FriendlyName:SampleExcelAddIn
    • LoadBehavior:3
    • Manifest:[TARGETDIR]SampleExcelAddIn.vsto|vstolocal
    • ※ ([TARGETDIR]手順8.で追加したvstoファイル|vstolocal)




  23. ソリューション エクスプローラーから「SampleExcelAddInSetup」を右クリックし、メニューの「ビルド」を選択します。

ビルドが成功すれば作業終了です。
セットアッププロジェクトの「Release」フォルダに出力された「setup.exe」を実行すると、アドインのインストールが始まります。






インストール後Excelを起動すると、インストールしたアドインが機能していることが確認できます。

今回は行っていませんが、起動条件やカスタム動作の設定を行うことでインストーラの動作をより細かく設定することができます。

Google Translate API(v1)で翻訳するマクロ

2011/03/14

参照Webページ:
http://code.google.com/intl/ja/apis/language/translate/overview.html
http://code.google.com/intl/ja/apis/language/translate/v1/getting_started.html#translatableLanguages

Option Explicit

Public Sub Sample()
  With CreateObject("WScript.Shell")
    .Popup TranslateText("This is a pen.") '結果を日本語で表示
    .Popup TranslateText("This is a pen.", "zh") '結果を中国語で表示
    .Popup TranslateText("これはペンです。", "ar") '結果をアラビア語で表示
  End With
End Sub

Public Function TranslateText(ByVal target As String, Optional ByVal destLang As String = "ja") As String
'Google Translate API(v1)で翻訳(翻訳元言語:自動認識 , 翻訳先言語:destLangで指定(標準では日本語(ja)))
  Dim url As String
  Dim js As String
  Dim ret As String
  
  destLang = StrConv(destLang, vbNarrow)
  destLang = LCase$(destLang)
  If ChkLang(destLang) = False Then
    MsgBox "翻訳先言語が対応していません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal
    Exit Function
  End If
  target = EncodeURL(target)
  
  js = "" '初期化
  url = "https://ajax.googleapis.com/ajax/services/language/translate?v=1.0&q=" & target & "&langpair=%7C" & destLang
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .Send
    js = .responseText
  End With
  On Error GoTo 0
  If Len(js) < 1 Then Exit Function
  
  ret = GetTranslatedText(js)
  If Len(ret) < 1 Then ret = "Error"
  
  TranslateText = ret
End Function

Private Function EncodeURL(ByVal sWord As String) As String
'URLエンコード
  Dim d As Object
  Dim elm As Object
  
  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

Private Function GetTranslatedText(ByVal js As String) As String
'JSONデータから訳語取得
  Dim d As Object
  Dim elm As Object
    
  js = "(" & js & ")"
  Set d = CreateObject("htmlfile")
  Set elm = d.createElement("span")
  elm.setAttribute "id", "result"
  d.body.appendChild elm
  d.parentWindow.execScript "document.getElementById('result').innerText=eval(" & js & ").responseData.translatedText;"
  
  GetTranslatedText = elm.innerText
End Function

Private Function ChkLang(ByVal lng As String) As Boolean
'対応言語チェック
  Dim LngList(55) As String
  Dim ret As Boolean
  Dim i As Long
  
  LngList(0) = "af" 'AFRIKAANS
  LngList(1) = "ar" 'ARABIC
  LngList(2) = "be" 'BELARUSIAN
  LngList(3) = "bg" 'BULGARIAN
  LngList(4) = "ca" 'CATALAN
  LngList(5) = "cs" 'CZECH
  LngList(6) = "cy" 'WELSH
  LngList(7) = "da" 'DANISH
  LngList(8) = "de" 'GERMAN
  LngList(9) = "el" 'GREEK
  LngList(10) = "en" 'ENGLISH
  LngList(11) = "es" 'SPANISH
  LngList(12) = "et" 'ESTONIAN
  LngList(13) = "fa" 'PERSIAN
  LngList(14) = "fi" 'FINNISH
  LngList(15) = "fr" 'FRENCH
  LngList(16) = "ga" 'IRISH
  LngList(17) = "gl" 'GALICIAN
  LngList(18) = "hi" 'HINDI
  LngList(19) = "hr" 'CROATIAN
  LngList(20) = "ht" 'HAITIAN_CREOLE
  LngList(21) = "hu" 'HUNGARIAN
  LngList(22) = "id" 'INDONESIAN
  LngList(23) = "is" 'ICELANDIC
  LngList(24) = "it" 'ITALIAN
  LngList(25) = "iw" 'HEBREW
  LngList(26) = "ja" 'JAPANESE
  LngList(27) = "ko" 'KOREAN
  LngList(28) = "lt" 'LITHUANIAN
  LngList(29) = "lv" 'LATVIAN
  LngList(30) = "mk" 'MACEDONIAN
  LngList(31) = "ms" 'MALAY
  LngList(32) = "mt" 'MALTESE
  LngList(33) = "nl" 'DUTCH
  LngList(34) = "no" 'NORWEGIAN
  LngList(35) = "pl" 'POLISH
  LngList(36) = "pt" 'PORTUGUESE
  LngList(37) = "pt-pt" 'PORTUGUESE_PORTUGAL
  LngList(38) = "ro" 'ROMANIAN
  LngList(39) = "ru" 'RUSSIAN
  LngList(40) = "sk" 'SLOVAK
  LngList(41) = "sl" 'SLOVENIAN
  LngList(42) = "sq" 'ALBANIAN
  LngList(43) = "sr" 'SERBIAN
  LngList(44) = "sv" 'SWEDISH
  LngList(45) = "sw" 'SWAHILI
  LngList(46) = "th" 'THAI
  LngList(47) = "tl" 'TAGALOG
  LngList(48) = "tl" 'FILIPINO
  LngList(49) = "tr" 'TURKISH
  LngList(50) = "uk" 'UKRAINIAN
  LngList(51) = "vi" 'VIETNAMESE
  LngList(52) = "yi" 'YIDDISH
  LngList(53) = "zh" 'CHINESE
  LngList(54) = "zh-cn" 'CHINESE_SIMPLIFIED
  LngList(55) = "zh-tw" 'CHINESE_TRADITIONAL
  
  ret = False ' 初期化
  For i = LBound(LngList) To UBound(LngList)
    If lng = LngList(i) Then
      ret = True
      Exit For
    End If
  Next
  
  ChkLang = ret
End Function

ExportAsFixedFormatでPDFを作成する

2011/03/07

2年近く前に書いたコードを掲載してみます。

Sub Sample()
  Const FilePath As String = "M:\Test.pdf"
   
  'ブックごとPDF化
  ThisWorkbook.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  'シートごとPDF化
  'ActiveSheet.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  '選択した範囲のみPDF化
  'Selection.ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
  '範囲が飛び飛びだった場合:連続したセル範囲/1ページ のPDF作成
  'ActiveSheet.Range("A1,B3,C5").ExportAsFixedFormat xlTypePDF, FilePath, xlQualityStandard
End Sub

「ExportAsFixedFormat Method [Excel 2007 Developer Reference]」
http://msdn.microsoft.com/en-us/library/bb238907.aspx

動的にJavaScriptを実行する

2011/03/07

JavaScriptを動的に書き出す」参照。

Public Sub Sample()
  Dim d As Object
  Dim oDiv As Object
  
  Set d = CreateObject("htmlfile")
  Set oDiv = d.createElement("div")
  oDiv.innerHTML = "&nbsp;<script defer>alert(document.parentWindow.clientInformation.userAgent);</script>"
  d.body.appendChild oDiv
End Sub

APIで郵便番号から住所を取得する(2)

2011/03/07

今回はGroove Technologyが提供しているAPIで住所検索してみます。
郵便番号から住所、住所から郵便番号の取得が可能。

Option Explicit
Option Base 1

Private Type Address
  zipcode As String '郵便番号
  add As String '住所
  addk As String '住所(カナ)
End Type

Public Sub Sample()
  Dim ad() As Address, ad2() As Address
  Dim count As Long, count2 As Long
  Dim i As Long, j As Long
  
  '郵便番号による住所検索
  ad() = AddressByZipCodeOrAddress("111")
  On Error Resume Next
  count = UBound(ad)
  If Err.Number <> 0 Then
    MsgBox "住所を取得できませんでした。", vbCritical + vbSystemModal
    Err.Clear
    Exit Sub
  End If
  On Error GoTo 0
  For i = LBound(ad) To count
    Debug.Print ad(i).zipcode, ad(i).add, ad(i).addk
  Next
  
  Debug.Print "--------------------"
  
  '住所の一部による住所検索
  ad2() = AddressByZipCodeOrAddress("沖縄県那覇市首里", 2)
  On Error Resume Next
  count2 = UBound(ad2)
  If Err.Number <> 0 Then
    MsgBox "住所を取得できませんでした。", vbCritical + vbSystemModal
    Err.Clear
    Exit Sub
  End If
  On Error GoTo 0
  For j = LBound(ad2) To count2
    Debug.Print ad2(j).zipcode, ad2(j).add, ad2(j).addk
  Next
End Sub

Private Function AddressByZipCodeOrAddress(ByVal param As String, Optional ByVal mode As Long = 1) As Address()
'郵便番号もしくは住所の一部から住所を取得
'引数 mode 1:郵便番号 , 2:住所の一部(漢字、ひらがな、カタカナ)
  Dim ad() As Address
  Dim oXML As Object, oNode As Object
  Dim url As String, tmpZipcode As String
  Dim count As Long, i As Long
  
  url = "http://groovetechnology.co.jp/ZipSearchService/v1/zipsearch?format=xml&ie=UTF-8&oe=UTF-8"
  Select Case mode
    Case 1
      url = url & "&zipcode=" & param
    Case 2
      url = url & "&word=" & EncodeURL(param)
    Case Else
      MsgBox "不正なパラメータです。" & vbCrLf & "処理を中止します。", vbCritical + vbSystemModal
      Exit Function
  End Select
  
  count = 0: i = 1 '初期化
  On Error Resume Next
  Set oXML = Nothing
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .Send
    Set oXML = .responseXML
  End With
  Err.Clear
  On Error GoTo 0
  If oXML Is Nothing Then Exit Function
  If Len(oXML.XML) < 1 Then Exit Function
  count = oXML.SelectNodes("/groovewebservice/address").Length
  If count < 1 Then Exit Function
  
  ReDim ad(count)
  For Each oNode In oXML.SelectNodes("/groovewebservice/address")
    tmpZipcode = oNode.SelectSingleNode("zipcode").Text
    tmpZipcode = Left$(tmpZipcode, 3&) & "-" & Right$(tmpZipcode, 4&)
    ad(i).zipcode = tmpZipcode
    ad(i).add = oNode.SelectSingleNode("prefecture").Text & _
                oNode.SelectSingleNode("city").Text & _
                oNode.SelectSingleNode("town").Text
    ad(i).addk = oNode.SelectSingleNode("prefecture_yomi").Text & _
                 oNode.SelectSingleNode("city_yomi").Text & _
                 oNode.SelectSingleNode("town_yomi").Text
    i = i + 1
  Next
  
  AddressByZipCodeOrAddress = ad()
End Function

Private Function EncodeURL(ByVal sWord As String) As String
  Dim d As Object
  Dim elm As Object
  
  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

Yahoo!知恵袋Web APIをVBScriptから呼び出す

2011/03/07

Yahoo!知恵袋Web APIをVBScriptから呼び出してみます。
※ 要アプリケーションID

Option Explicit

ShowChiebukuroList "2078297489", "open" 'Yahoo!知恵袋(Office系(Word、Excel))回答受付中の質問を列挙

Sub ShowChiebukuroList(ByVal CategoryId, ByVal Condition)
  Dim oXML
  Dim oNode
  Dim url
  Const AppID = "(アプリケーションID)" 'アプリケーションID
  
  Select Case LCase(Condition)
    Case "open", "vote", "solved"
    Case Else
      WScript.Echo "パラメータを確認してください。"
      Exit Sub
  End Select
  
  url = "http://chiebukuro.yahooapis.jp/Chiebukuro/V1/getNewQuestionList?output=xml&condition=" & Condition & "&sort=-updateddate&results=20&category_id=" & CategoryId & "&appid=" & AppID
  Set oXML = Nothing '初期化
  On Error Resume Next
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", url, False
    .Send
    Set oXML = .responseXML
  End With
  Err.Clear
  On Error GoTo 0
  If oXML Is Nothing Then
    WScript.Echo "XMLが取得できませんでした。処理を中止します。"
    Exit Sub
  End If
  If oXML.getElementsByTagName("Error").Length > 0 Then
    WScript.Echo "エラーが発生しました。処理を中止します。"
    Exit Sub
  End If
  
  WScript.Echo "--------------------"
  For Each oNode In oXML.SelectNodes("/ResultSet/Result")
    WScript.Echo "質問内容:" & oNode.SelectSingleNode("Content").Text
    WScript.Echo "回答数:" & oNode.SelectSingleNode("AnsCount").Text
    WScript.Echo "お礼コイン枚数:" & oNode.SelectSingleNode("Coin").Text
    WScript.Echo "カテゴリ:" & oNode.SelectSingleNode("Category").Text
    WScript.Echo "URL:" & oNode.SelectSingleNode("QuestionUrl").Text
    WScript.Echo "更新日時:" & oNode.SelectSingleNode("UpdatedDate").Text
    WScript.Echo "--------------------"
  Next
End Sub