Excel 97でCALL関数をワークシート上から使ってみました。

2011/04/17

VBScriptからWindows API関数を呼び出す」でExcelのCALL関数を紹介しましたが、Excel 97でワークシート上から使ってみたのでスクリーンショットを掲載。

この関数がSUM関数やVLOOKUP関数などの関数と同様にワークシート上からも普通に使えるのはやはり危険ですね。
(2000以降ではワークシート上からの呼び出しができなくなっています。)

VBScriptからWindows API関数を呼び出す

2011/04/17

VBSからAPI関数を呼び出す方法として、別途作成したDLL経由で呼び出す方法や”SFC mini“、”DynaCall“といったツールを使う方法がありますが、わりとよく使われるのが『Excel経由でCALL関数を使って呼び出す』方法です。

Dim h

CreateObject("WScript.Shell").Run "notepad", 1, False
With CreateObject("Excel.Application")
  h = .ExecuteExcel4Macro("CALL(""user32"", ""FindWindowA"", ""JCJ"", ""Notepad"", 0)")
  If h = 0 Then WScript.Quit
  Call .ExecuteExcel4Macro("CALL(""user32"", ""SendMessageA"", ""JJJJJ"", " & h & ", 273, 65, 0)")
End With

上記コードを見るとExecuteExcel4MacroメソッドでExcel4.0マクロ関数を実行しているようですが、ここで使われているのが実は「CALL」関数です。この関数の引数でAPI関数名やDLL名を指定しているわけです。

CALL(モジュール名, プロシージャ名, タイプ, [引数 1], …, [引数 n])

CALL 関数」より

第一引数でモジュール名、第二引数で関数名、これはすぐ分かると思いますが、問題なのが第三引数。上記コードを見ると「JJJJJ」となっていて、これが一体何を表しているのかよく分からない人も多いだろうと思います。
そこでMicrosoftの説明ページを見てみると、下記のような記述があります。

“タイプ” の先頭の文字では、戻り値のデータ型を指定します。残りの文字では、すべての引数のデータ型を指定します。たとえば、戻り値が浮動小数点数、引数が整数と浮動小数点数である DLL 関数は、”タイプ” 引数として “BIB” を取ります。

この「JJJJJ」というのは戻り値と引数のデータ型を文字列で表しているわけです。

そこで、改めて上記コードが一体どのような処理を行っているのかというと、

1. メモ帳を起動します。
2. FindWindowでメモ帳のウィンドウハンドルを取得します。
3. 2.で取得したハンドルを元にウィンドウに対してSendMessageでWM_COMMAND(&H111(273))、wParam:&H41(65)を送り、メモ帳のバージョン情報を表示します。

といった処理を行っているわけです。

上記のようなVBSからAPI関数を呼び出す処理は、ウィンドウズスクリプトプログラマさんのブログ「Windows Script Programming」にて多数紹介されていますので、興味がある方は参考にされてはいかがでしょうか。

Excel 2010でページ設定(PageSetup)の動作を高速化する

2011/04/16

1年近く前につぶやいた話題ですが、今になっても取り扱っているサイトが少ないので今回記事を書いてみます。

Excel VBAでのページ設定(PageSetup)の動作が遅いことはよく知られたことで、これまでは高速化のためにExcel 4.0(XLM)マクロのPAGE.SETUP()が多くの場面で使われてきました。

Excel 2010では新たに「Application.PrintCommunication」プロパティが追加され、PageSetupプロパティを設定するコードの実行を高速化することができるようになりました。

実際にテストしたコードと結果は下記の通りです(テストしたブックは255シートで、1シートずつループで処理しています)。

Public Sub Test01()
'PrintCommunicationプロパティ無し
  Dim sht As Excel.Worksheet
  Dim t1 As Single, t2 As Single
  
  t1 = Timer
  For Each sht In ActiveWorkbook.Worksheets
    With sht.PageSetup
      .LeftMargin = Application.InchesToPoints(0.25)
      .RightMargin = Application.InchesToPoints(0.25)
      .TopMargin = Application.InchesToPoints(0.75)
      .BottomMargin = Application.InchesToPoints(0.75)
      .Orientation = xlLandscape
      .PaperSize = xlPaperLetter
      .FitToPagesWide = 1
      .FitToPagesTall = 1
    End With
  Next
  t2 = Timer
  MsgBox "Test01処理時間:" & t2 - t1 & "秒"
  Debug.Print t2 - t1
End Sub

Public Sub Test02()
'PrintCommunicationプロパティ有り
  Dim sht As Excel.Worksheet
  Dim t1 As Single, t2 As Single
  
  t1 = Timer
  Application.PrintCommunication = False
  For Each sht In ActiveWorkbook.Worksheets
    With sht.PageSetup
      .LeftMargin = Application.InchesToPoints(0.25)
      .RightMargin = Application.InchesToPoints(0.25)
      .TopMargin = Application.InchesToPoints(0.75)
      .BottomMargin = Application.InchesToPoints(0.75)
      .Orientation = xlLandscape
      .PaperSize = xlPaperLetter
      .FitToPagesWide = 1
      .FitToPagesTall = 1
    End With
  Next
  Application.PrintCommunication = True
  t2 = Timer
  MsgBox "Test02処理時間:" & t2 - t1 & "秒"
  Debug.Print t2 - t1
End Sub

上記結果を見ると確かにPrintCommunicationプロパティを設定した方が早く処理が終わっています。
下記Microsoftのページを見ると、Excel 4.0 マクロから新たに追加された機能への移行が推奨されているようです。

Excel 4.0 マクロを操作する
http://office.microsoft.com/ja-jp/excel-help/HA010336614.aspx
Migrating Excel 4 Macros to VBA
http://blogs.office.com/b/microsoft-excel/archive/2010/02/16/migrating-excel-4-macros-to-vba.aspx

Excel 2010を使用していて、PageSetupの遅さにお悩みの方は一度試してみてはいかがでしょうか?

Word 2010に一太郎コンバーターを導入する

2011/04/14

Word 2010 で廃止、変更される機能」にあるように、Word 2010では一太郎コンバーターが無くなり一太郎ファイルが開けなくなりました(今後コンバーターが提供されるようになる可能性はあります)。

そのかわりとしてよく用いられるのが一太郎ビューアですが、今回はWord 2010に無理矢理一太郎コンバーターを導入する方法を紹介します。

※ 下記に紹介する方法はWord 2007の一太郎コンバーターをWord 2010に導入する方法で、私の方では使用していないOffice 2007のディスクから一太郎コンバーターのみを抜き出して動作を確認しましたが、コンバーターのライセンスについては未確認です。もしかしたらライセンス違反になる可能性もありますので、取り扱いには十分ご注意ください。ライセンス違反であることが確認された場合には当記事も公開を停止します。

※ 下記の方法はWindows 7 Ultimate(64ビット版) + Office 2010(32ビット版)、Windows 7 Ultimate(32ビット版) + Office 2010(32ビット版)上で動作確認を行いました。Office 2010(64ビット版)上ではエラーが発生してコンバータの動作を確認することができませんでした。
 
[手順]
1. Office 2007のディスク内の「Office.ja-jp」フォルダにある「OfficeLR.cab」ファイルから下記のファイルのみを展開します。
(展開方法はWindows 7であれば右クリックメニュー「プログラムから開く」の「エクスプローラー」からファイルを取り出すことができます。また、cab形式に対応した解凍ソフトを用いることでもファイルを取り出すことができます。)

JWSPCNV.DLL_0001_1041
JXW7.DLL_0001_1041
JXW8.DLL_0001_1041
RTF_.DLL_0001_1041
TARO7.CNV_0001_1041
TARO8.CNV_0001_1041



2. 1.で取り出したファイルの名前をそれぞれ下記のように変更します(ファイル名の「_0001_1041」部分を削除します)。

JWSPCNV.DLL
JXW7.DLL
JXW8.DLL
RTF_.DLL
TARO7.CNV
TARO8.CNV

3. ファイルのプロパティから「読み取り専用」を解除します。

4. 下記テキストコンバーターフォルダにファイルを移動します。

32ビット版OS:C:\Program Files\Common Files\microsoft shared\TextConv
64ビット版OS:C:\program files (x86)\common files\microsoft shared\textconv

5.ファイル名を指定して実行」から下記コマンドを実行し、レジストリエディタを起動します。

32ビット版OS:regedit
64ビット版OS:%systemroot%\syswow64\regedit

※ 64ビット環境でのレジストリ編集に関しては「64 ビット バージョンの Windows でシステム レジストリを表示する方法」参照。

6. 下記のようにキーを設定します(キーやデータが存在しない場合は新規作成)。

[キー位置]
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Text Converters\Import\Ichitaro7
[データ:値]
Extensions(タイプ:文字列値):JFW JVW
Name(タイプ:文字列値):一太郎 7
Path(タイプ:文字列値):(手順 4. のテキストコンバーターフォルダのパス)\TARO7.CNV

[キー位置]
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Text Converters\Import\Ichitaro7\NoDialogs
[データ:値]
(既定):(空白)

[キー位置]
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Text Converters\Import\Ichitaro8
[データ:値]
Extensions(タイプ:文字列値):JTD JTT
Name(タイプ:文字列値):一太郎 8-13/2004-2006
Path(タイプ:文字列値):(手順 4. のテキストコンバーターフォルダのパス)\TARO8.CNV

[キー位置]
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Shared Tools\Text Converters\Import\Ichitaro8\NoDialogs
[データ:値]
(既定):(空白)




以上で作業は終了です。
以降Wordで一太郎ファイルが開けるようになります。


ドラッグされたマネージドDLLをRegAsmで登録するスクリプト

2011/04/07

supermabさんのブログの記事「Excel から使うマネージDLL を作る。」、ここまで丁寧に解説されたサイトは少ないので非常に参考になります。
ただ、記事中にも書かれていますがDLLの登録・登録解除がどうしても手間になってしまいます。

XPであれば特に大きな問題は無いのですが、Vista以降UACが絡んでくる都合上、一工夫する必要がありそうです。
では具体的にどうするか?パッと思いつくのは「runas」付きでShellExecuteメソッドを実行する方法。
早速試してみました。

'*********************************************************
' ドラッグされたマネージドDLLをRegAsmで登録するスクリプト
' 
' 2011/04/05 kinuasa
'*********************************************************

Option Explicit

Dim Args
Dim FSO
Dim f
Dim DllFilePath
Dim WindowsFolderPath
Dim FrameworkFolderPath
Dim SubFrameworkFolderPath
Dim RegAsmFilePath
Dim ArgStr
Const Opt = " /tlb /codebase" 'RegAsmに渡すオプション
Const MsgTitle = "RegAsm実行"

RegAsmFilePath = "" '初期化

Set Args = WScript.Arguments
If Args.Count < 1 Then
  MsgBox "DLLを当スクリプトファイルにドラッグ&ドロップして処理を実行してください。", 16, MsgTitle
  WScript.Quit
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Select Case LCase(FSO.GetExtensionName(Args(0)))
  Case "dll"
    DllFilePath = Args(0)
  Case Else
    MsgBox "DLLを当スクリプトファイルにドラッグ&ドロップして処理を実行してください。", 16, MsgTitle
    WScript.Quit
End Select
Set Args = Nothing

'.NET Frameworkフォルダのパス取得
WindowsFolderPath = FSO.GetSpecialFolder(0).Path
If Right(WindowsFolderPath, 1) <> "\" Then WindowsFolderPath = WindowsFolderPath & "\"
FrameworkFolderPath = WindowsFolderPath & "Microsoft.NET\Framework\"
If FSO.FolderExists(FrameworkFolderPath) <> True Then
  MsgBox ".NET Frameworkフォルダが見つかりませんでした。" & vbCrLf & _
         "処理を中止します。", 16, MsgTitle
  WScript.Quit
End If
'RegAsm.exeのパス取得
With CreateObject("ADODB.Recordset")
  .Fields.Append "Path", 200, 255
  .Open
  For Each f In FSO.GetFolder(FrameworkFolderPath).SubFolders
    .AddNew
    .Fields("Path").Value = f.Path
    .Update
  Next
  .Sort = "Path DESC" 'Framework各バージョンフォルダ名を降順ソート
  .MoveFirst
  Do Until .EOF
    SubFrameworkFolderPath = .Fields(0)
    If Right(SubFrameworkFolderPath, 1) <> "\" Then SubFrameworkFolderPath = SubFrameworkFolderPath & "\"
    If FSO.FileExists(SubFrameworkFolderPath & "RegAsm.exe") Then
      If MsgBox("[" & SubFrameworkFolderPath & "RegAsm.exe]で登録しますか?", vbYesNo, MsgTitle) = vbYes Then
        RegAsmFilePath = SubFrameworkFolderPath & "RegAsm.exe"
        Exit Do
      End If
    End If
    .MoveNext
  Loop
  .Close
End With
Set FSO = Nothing
If Len(RegAsmFilePath) < 1 Then
  MsgBox "[RegAsm.exe]が見つかりませんでした。" & vbCrLf & _
         "処理を中止します。", 16, MsgTitle
  WScript.Quit
End If

ArgStr = """" & DllFilePath & """" & Opt
CreateObject("Shell.Application").ShellExecute RegAsmFilePath, ArgStr, "", "runas" 'runas付きで実行
'*************************************************************
' ドラッグされたマネージドDLLをRegAsmで登録解除するスクリプト
' 
' 2011/04/05 kinuasa
'*************************************************************

Option Explicit

Dim Args
Dim FSO
Dim f
Dim DllFilePath
Dim WindowsFolderPath
Dim FrameworkFolderPath
Dim SubFrameworkFolderPath
Dim RegAsmFilePath
Dim ArgStr
Const Opt = " /tlb /u" 'RegAsmに渡すオプション
Const MsgTitle = "RegAsm実行"

RegAsmFilePath = "" '初期化

Set Args = WScript.Arguments
If Args.Count < 1 Then
  MsgBox "DLLを当スクリプトファイルにドラッグ&ドロップして処理を実行してください。", 16, MsgTitle
  WScript.Quit
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
Select Case LCase(FSO.GetExtensionName(Args(0)))
  Case "dll"
    DllFilePath = Args(0)
  Case Else
    MsgBox "DLLを当スクリプトファイルにドラッグ&ドロップして処理を実行してください。", 16, MsgTitle
    WScript.Quit
End Select
Set Args = Nothing

'.NET Frameworkフォルダのパス取得
WindowsFolderPath = FSO.GetSpecialFolder(0).Path
If Right(WindowsFolderPath, 1) <> "\" Then WindowsFolderPath = WindowsFolderPath & "\"
FrameworkFolderPath = WindowsFolderPath & "Microsoft.NET\Framework\"
If FSO.FolderExists(FrameworkFolderPath) <> True Then
  MsgBox ".NET Frameworkフォルダが見つかりませんでした。" & vbCrLf & _
         "処理を中止します。", 16, MsgTitle
  WScript.Quit
End If
'RegAsm.exeのパス取得
With CreateObject("ADODB.Recordset")
  .Fields.Append "Path", 200, 255
  .Open
  For Each f In FSO.GetFolder(FrameworkFolderPath).SubFolders
    .AddNew
    .Fields("Path").Value = f.Path
    .Update
  Next
  .Sort = "Path DESC" 'Framework各バージョンフォルダ名を降順ソート
  .MoveFirst
  Do Until .EOF
    SubFrameworkFolderPath = .Fields(0)
    If Right(SubFrameworkFolderPath, 1) <> "\" Then SubFrameworkFolderPath = SubFrameworkFolderPath & "\"
    If FSO.FileExists(SubFrameworkFolderPath & "RegAsm.exe") Then
      If MsgBox("[" & SubFrameworkFolderPath & "RegAsm.exe]で登録解除しますか?", vbYesNo, MsgTitle) = vbYes Then
        RegAsmFilePath = SubFrameworkFolderPath & "RegAsm.exe"
        Exit Do
      End If
    End If
    .MoveNext
  Loop
  .Close
End With
Set FSO = Nothing
If Len(RegAsmFilePath) < 1 Then
  MsgBox "[RegAsm.exe]が見つかりませんでした。" & vbCrLf & _
         "処理を中止します。", 16, MsgTitle
  WScript.Quit
End If

ArgStr = """" & DllFilePath & """" & Opt
CreateObject("Shell.Application").ShellExecute RegAsmFilePath, ArgStr, "", "runas" 'runas付きで実行

上記スクリプトにDLLファイルをドラッグ&ドロップ。
tlbファイルを出力されて、VBAからでも使うことが出来ました。
なかなか上手くいっていそうです。

上記スクリプトをZip形式で圧縮したのがコチラ

インストールされているウィルス対策ソフトの情報を列挙するVBScript

2011/04/06

使い道は不明です。

Option Explicit

Dim colItems
Dim oItem

On Error Resume Next
Set colItems = CreateObject("WbemScripting.SWbemLocator") _
              .ConnectServer(".", "root\SecurityCenter2") _
              .ExecQuery("Select * from AntiVirusProduct")
For Each oItem In colItems
  WScript.Echo "displayName:" & oItem.displayName
  WScript.Echo "instanceGuid:" & oItem.instanceGuid
  WScript.Echo "pathToSignedProductExe:" & oItem.pathToSignedProductExe
  WScript.Echo "pathToSignedReportingExe:" & oItem.pathToSignedReportingExe
  WScript.Echo "productState:" & oItem.productState
Next
Set colItems = Nothing

If Err.Number <> 0 Then
  Set colItems = CreateObject("WbemScripting.SWbemLocator") _
                .ConnectServer(".", "root\SecurityCenter") _
                .ExecQuery("Select * from AntiVirusProduct")
  For Each oItem In colItems
    WScript.Echo "companyName:" & oItem.companyName
    WScript.Echo "displayName:" & oItem.displayName
    WScript.Echo "enableOnAccessUIMd5Hash:" & oItem.enableOnAccessUIMd5Hash
    WScript.Echo "enableOnAccessUIParameters:" & oItem.enableOnAccessUIParameters
    WScript.Echo "instanceGuid:" & oItem.instanceGuid
    WScript.Echo "onAccessScanningEnabled:" & oItem.onAccessScanningEnabled
    WScript.Echo "pathToEnableOnAccessUI:" & oItem.pathToEnableOnAccessUI
    WScript.Echo "pathToUpdateUI:" & oItem.pathToUpdateUI
    WScript.Echo "productUptoDate:" & oItem.productUptoDate
    WScript.Echo "updateUIMd5Hash:" & oItem.updateUIMd5Hash
    WScript.Echo "updateUIParameters:" & oItem.updateUIParameters
    WScript.Echo "versionNumber:" & oItem.versionNumber
  Next
  Set colItems = Nothing
  Err.Clear
End If
On Error GoTo 0

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