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

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形式で圧縮したのがコチラ。

広告