Option
Explicit
Sub
Test()
Const
myClassType
As
String
=
"Forms.CommandButton.1"
Const
myWidth
As
Single
= 120
Const
myHeight
As
Single
= 24
Dim
z
As
Integer
, i
As
Integer
, anz
As
Integer
Dim
myTop, myLeft
As
Single
Dim
oOle
As
OLEObject
z = CountIt()
If
z > 0
Then
myTop = NewTop(myHeight)
On
Error
Resume
Next
anz = InputBox(
"Anzahl neuer Buttons : "
,
CStr
(z) &
" Buttons vorhanden "
, 1)
If
Not
IsNumeric(anz)
Or
anz = 0
Then
Exit
Sub
On
Error
GoTo
0
For
i = 1
To
anz
Set
oOle = ActiveSheet.OLEObjects.Add _
(ClassType:=myClassType, _
Left:=myLeft, Top:=myTop, Width:=myWidth, Height:=myHeight)
If
AddMacro(oOle.Name) =
False
Then
oOle.Delete
myTop = myTop + myHeight + 2
myLeft = myLeft + myWidth + 10
Next
i
End
Sub
Private
Function
CountIt()
As
Integer
Dim
oOle
As
OLEObject
Dim
i
As
Integer
For
Each
oOle
In
ActiveSheet.OLEObjects
If
oOle.progID =
"Forms.CommandButton.1"
Then
i = i + 1
Next
oOle
CountIt = i
End
Function
Private
Function
NewTop(myHeight
As
Single
)
Dim
myTop
As
Single
Dim
oOle
As
OLEObject
For
Each
oOle
In
ActiveSheet.OLEObjects
If
oOle.progID =
"Forms.CommandButton.1"
Then
myTop = myTop + myHeight + 2
Next
oOle
NewTop = myTop
End
Function
Private
Function
AddMacro(myName
As
String
)
As
Boolean
Const
myLine1
As
String
=
"Private Sub CBX_Click()"
Const
myLine2
As
String
=
"End Sub"
On
Error
GoTo
fail:
Dim
VBProj
As
VBIDE.VBProject
Dim
VBComp
As
VBIDE.VBComponent
Dim
CodeMod
As
VBIDE.CodeModule
Dim
LineNum
As
Long
Const
DQUOTE =
""
""
Set
VBProj = ActiveWorkbook.VBProject
Set
VBComp = VBProj.VBComponents(ActiveSheet.Name)
Set
CodeMod = VBComp.CodeModule
With
CodeMod
LineNum = .CreateEventProc(
"Click"
, myName)
LineNum = LineNum + 1
.InsertLines LineNum,
" MsgBox "
& DQUOTE & myName & DQUOTE
End
With
fail:
If
Err.Number = 0
Then
AddMacro =
True
End
Function