VBA动态平添事件

2013-01-01

VBA动态添加事件我想做一个九宫格，每个单元格都是由Label动态生成，我想给Label添加鼠标事件，可写完了以后

VBA动态添加事件
我想做一个九宫格，每个单元格都是由Label动态生成，我想给Label添加鼠标事件，可写完了以后发现只有最后一个单元格有事件，求教各位高手怎么搞定？
定义事件的类


Private WithEvents m_Cell As MSForms.Label
Private m_Form As myframe

Public Sub AddCell(ByVal frmLayout As myframe, ByVal cell As MSForms.Label)
    Set m_Cell = cell
    Set m_Form = frmLayout
End Sub

Private Sub m_Cell_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    m_Form.CellMouseDown m_Cell, Button, Shift, X, Y
End Sub

窗体代码

Private myCells As Collection

Public Sub UserForm_Initialize()
    SetRoomsLayout
End Sub

Private Sub SetRoomsLayout()
    Set myCells = New Collection
    Dim vLeft As Integer, vTop As Integer, tLeft As Integer, tTop As Integer
    Dim i As Integer, j As Integer, key As String
    tLeft = (myframe.Width - 50 * 3) / 2
    tTop = (myframe.Height - 50 * 3) / 2
    For i = 0 To 2
        For j = 0 To 2
            key = i * 100 + j
            vLeft = 0
            vTop = 0
            Dim lblFix As Label
            Set lblFix = myframe.Controls.Add(ProgID_Label, "lblFix_" & key, True)
            If (i <> 0) Then
                vLeft = 50 * i
            End If
            If (j <> 0) Then
                vTop = 50 * j
            End If
            With lblFix
                .Height = 50
                .Width = 50
                .Left = vLeft + tLeft
                .Top = vTop + tTop
                .TextAlign = fmTextAlignCenter
                .BackStyle = fmBackStyleOpaque

                .BorderStyle = fmBorderStyleSingle
                .SpecialEffect = fmSpecialEffectFlat
            End With
            Dim cell As New clsCell
            cell.AddCell vForm, lblFix
            vForm.AddCell key, cell
        Next
    Next
End Sub

Public Sub AddCell(ByVal vKey As String, ByVal vCell As clsCell)
    myCells.Add vCell, vKey
End Sub

Public Sub CellMouseDown(ByVal cell As MSForms.Label, ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MsgBox X
End Sub

[解决办法]
给你贴段动态添加 Checkbox及事件的代码。

 
        MyCodeLine(3) = "End Sub"
        For i = 1 To 3
            '2?è????t′ú??
            ThisWorkbook.VBProject.VBComponents(Me.CodeName).CodeModule.InsertLines i, MyCodeLine(i)
        Next
    End If
    Application.ScreenUpdating = True
End Sub

热点排行