CreateEventProc()２回目実行するとEXCELが落ちる

質問

EXCELが落ちてしまう現象が解決できずに困っています。
詳しい方がいらっしゃったら教えて下さい。

データ数分ボタンを配置したいので、No.321427の質問を参考にコードを書きました。
EXCEL VBAで下記のコードのtest1()を実行するとEXCELが落ちてしまいます。
ちなみに、vInsertButton()の下側をコメントアウトして
ボタンを１つだけ配置すると正常に処理が完了します。
vInsertButton()の処理に問題がありましたら教えていただけませんでしょうか？
CreateEventProc()あたりに問題がありそうなのですが分かりません。

VISTA&EXCEL2007では、この現象は発生しませんでした。
WinXP&EXCEL2000とWinXP&EXCEL2003でこの現象が再現しました。
OfficeUpdateでは最新と表示されました。
よろしくお願いします。

-------------------------------------------------------------------------------------------------------

' 設定
' VBEのツール→参照設定で、 Microsoft Visual Basic Editor for Application Extensibility にチェックして下さい。

Option Explicit

Private Sub test1()

' ボタン追加
Call vInsertButton("button1", 2, 1)
Call vInsertButton("button2", 2, 2)

End Sub

' ボタン追加
Private Sub vInsertButton(ByVal strButtonName As String, ByVal iRow As Integer, ByVal iCol As Integer)

' ボタン追加
Dim objButton As OLEObject
With Worksheets("Sheet1")
Dim clButtonRange As Range
Set clButtonRange = .Range(.Cells(iRow, iCol), .Cells(iRow, iCol))
Set objButton = .OLEObjects.Add(classtype:="Forms.CommandButton.1", _
link:=False, displayasicon:=False, _
Left:=clButtonRange.Left, Top:=clButtonRange.Top, _
Width:=clButtonRange.Width, Height:=clButtonRange.Height)
objButton.Object.TakeFocusOnClick = False
objButton.Object.Caption = strButtonName
End With

'クリックイベントコード追加
With ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
Dim iLineCounter As Long
iLineCounter = .CreateEventProc("Click", objButton.Name)
.InsertLines iLineCounter + 1, "MsgBox ""abc"""
End With

End Sub

-------------------------------------------------------------------------------------------------------

回答No.1

Wendy02 · ベストアンサー

こんにちは。

>VISTA&EXCEL2007では、この現象は発生しませんでした。

バージョンに関わらず、そのコードでは、上手くできているとは思えません。一つのオブジェクトを入れるだけのコードだったはずです。

あくまでも、個人が使うものだと了解しています。もしも、他者の環境で使う場合は、フォームツールのほうが安全かと思います。（決して、ハングするのが原因ではありませんが、セキュリティの関係で、Application Extensibilityを入れる方法が好まれません。)

さて、コードのほうですが、原因は、イベントコード追加の時に、VBEditor に書き込むときに、Sheet1 モジュールが、Activate してしまい、その上にコードが走ろうとするので、ハングするのではないかと思います。

以下の場合は、二つに別けて、Control名を確保して、モジュールに一気にコードを書けばよいと思います。

'-----------------------------------------

Dim arNames(1) As String
Dim i As Long

Private Sub Main1()
i = 0
Erase arNames()
Call vInsertButton("button1", 2, 1)
Call vInsertButton("button2", 2, 2)
Call AddLines
End Sub

Private Sub vInsertButton(ByVal strButtonName As String, ByVal iRow As Integer, ByVal iCol As Integer)
　　' ボタン追加
Dim clButtonRange As Range
Dim objButton As OLEObject
　　With Worksheets("Sheet1")
　　　　Set clButtonRange = .Range(.Cells(iRow, iCol), .Cells(iRow, iCol))
　　　　Set objButton = .OLEObjects.Add(classtype:="Forms.CommandButton.1", _
　　　　link:=False, displayasicon:=False, _
　　　　Left:=clButtonRange.Left, Top:=clButtonRange.Top, _
　　　　Width:=clButtonRange.Width, Height:=clButtonRange.Height)
　　　　objButton.Object.TakeFocusOnClick = False
　　　　objButton.Object.Caption = strButtonName
　　End With
　　arNames(i) = objButton.Name
　　Set objButton = Nothing
　　i = i + 1
End Sub
Sub AddLines()
　　'クリックイベントコード追加
　　 Dim iLineCounter As Long
　　 Dim objName As Variant
　　For Each objName In arNames
　　With ThisWorkbook.VBProject.VBComponents("Sheet1").CodeModule
　　　　iLineCounter = .CreateEventProc("Click", objName)
　　　　.InsertLines iLineCounter + 1, "MsgBox ""abc"""
　　End With
　　Next objName
End Sub

お礼

無事動きました。
ありがとうございました。