使用vba通过单击事件将图像添加到userForm

时间：2014-06-10 15:56:58

标签： vba powerpoint-vba

我创建了一个userForm来创建调查。它看起来像是在开头：

enter image description here

点击＆＃34旁边的十字;添加答案＆＃34;您可以添加更多行，因为它可以在其他图像中看到：

enter image description here

我遇到的问题是我必须添加新行中复选框旁边的小箭头。如果用户需要更改它们的位置，那么这些是上下移动答案。所以我必须添加代码来移动它们。

我在每一行中创建的元素都是按照以下方式完成的：

Private Sub addAnswer_Click()
Image5.top = Image5.top + 21
CheckBox1.top = CheckBox1.top + 21
CheckBox2.top = CheckBox2.top + 21
Image7.height = Image7.height + 21
Image3.top = Image3.top + 21
Label1.top = Label1.top + 21
Label4.top = Label4.top + 21
Image2.top = Image2.top + 21
tablet.top = tablet.top + 21
chart.top = chart.top + 21
Label8.top = Label8.top + 21
Label9.top = Label9.top + 21
LabelOrizontal.top = LabelOrizontal.top + 21
LabelVertical.top = LabelVertical.top + 21
LabelNet.top = LabelNet.top + 21
LabelRound.top = LabelRound.top + 21
LabelPoints.top = LabelPoints.top + 21
Orizontal.top = Orizontal.top + 21
Vertical.top = Vertical.top + 21
Net.top = Net.top + 21
Points.top = Points.top + 21
Round.top = Round.top + 21
ExcelBox.top = ExcelBox.top + 21

OKButton.top = OKButton.top + 21
CancelButton.top = CancelButton.top + 21
'Me.MultiPage1.height = Me.MultiPage1.height + 21
Image1.height = Image1.height + 21

'height = 418 + 21 * (valueNum - 1)
If valueNum = 2 Then
    With Me
        'This will create a vertical scrollbar
        .MultiPage1.Pages(0).ScrollBars = fmScrollBarsVertical

        'Change the values of 2 as Per your requirements
        '.ScrollHeight = .InsideHeight
        '.ScrollWidth = .InsideWidth * 9
    End With
End If
Me.MultiPage1.Pages(0).ScrollHeight = Me.MultiPage1.Pages(0).InsideHeight + 21 * (valueNum - 1)
valueNum = valueNum + 1
Set cCntrl = Me.MultiPage1.Pages(0).Controls.Add("Forms.TextBox.1", "textBox" & valueNum, True)
    With cCntrl
        .width = 156
        .height = 18
        .top = 108 + (valueNum - 1) * 21
        .left = 48
        .TabIndex = tabInd
        .ZOrder (0)
    End With
Set cCntrl1 = Me.MultiPage1.Pages(0).Controls.Add("Forms.TextBox.1", "AnsLabBox" & valueNum, True)
    With cCntrl1
        .width = 144
        .height = 18
        .top = 108 + (valueNum - 1) * 21
        .left = 210
        .TabIndex = tabInd + 1
        .ZOrder (0)
    End With

tabInd = tabInd + 3
Set cCntrl3 = Me.MultiPage1.Pages(0).Controls.Add("Forms.CheckBox.1", "open" & valueNum, True)
    With cCntrl3
        .left = 24
        .width = 11
        .height = 18
        .BackColor = "&H8000000E"
        .top = 108 + (valueNum - 1) * 21
        .ZOrder (0)
    End With


'''''''Here starts the important part for the question!!!
Set cCntrl3 = Me.MultiPage1.Pages(0).Controls.Add("Forms.Image.1", "down" & valueNum - 1, True)
    With cCntrl3
        .left = 12
        .width = 12
        .height = 6
        .BackColor = "&H8000000E"
        .top = 116 + (valueNum - 2) * 21
        .Picture = LoadPicture(addInPath & "\fixContent\triangleDown.jpg")
        .BorderStyle = fmBorderStyleNone
        .PictureSizeMode = fmPictureSizeModeStretch
        .ZOrder (0)
    End With
With ActivePresentation.VBProject.VBComponents("surveyCreation").CodeModule
    X = .CountOfLines
    .InsertLines X + 1, "Private Sub down" & valueNum - 1 & "_Click()"
    .InsertLines X + 2, "goDown " & valueNum - 1
    .InsertLines X + 3, "End Sub"
End With
Set cCntrl3 = Me.MultiPage1.Pages(0).Controls.Add("Forms.Image.1", "up" & valueNum, True)
    With cCntrl3
        .left = 12
        .width = 12
        .height = 6
        .BackColor = "&H8000000E"
        .top = 111 + (valueNum - 1) * 21
        .Picture = LoadPicture(addInPath & "\fixContent\triangleUp.jpg")
        .BorderStyle = fmBorderStyleNone
        .PictureSizeMode = fmPictureSizeModeStretch
        .ZOrder (0)
    End With
With ActivePresentation.VBProject.VBComponents("surveyCreation").CodeModule
    X = .CountOfLines
    .InsertLines X + 1, "Private Sub up" & valueNum & "_Click()"
    .InsertLines X + 2, "goUp " & valueNum
    .InsertLines X + 3, "End Sub"
End With
Set cCntrl3 = Me.MultiPage1.Pages(0).Controls.Add("Forms.Image.1", "delete" & valueNum, True)
    With cCntrl3
        .left = 480
        .width = 12
        .height = 12
        .BackColor = "&H8000000E"
        .top = 110 + (valueNum - 1) * 21
        .Picture = LoadPicture(addInPath & "\fixContent\cross.jpg")
        .BorderStyle = fmBorderStyleNone
        .PictureSizeMode = fmPictureSizeModeStretch
        .ZOrder (0)
    End With
With ActivePresentation.VBProject.VBComponents("surveyCreation").CodeModule
    X = .CountOfLines
    .InsertLines X + 1, "Private Sub delete" & valueNum & "_Click()"
    .InsertLines X + 2, "deleteRow " & valueNum
    .InsertLines X + 3, "End Sub"
End With
If Not comboVisi Then
    cCntrl2.Visible = False
End If
End Sub

因为你可以看到我创建了元素，我还在surveyCreation中添加了一些代码（点击事件）（女巫是用户形式）

还定义了deleteRow，goUp和goDown方法。但它永远不会进入点击事件。第一次单击事件（针对第一个图像中出现的箭头所做的那些事件）是先前定义的，它们正在工作但不是我使用我创建的代码定义的那些事件。那么我可以让它们起作用吗？

1 个答案:

答案 0 :(得分：0)

作为评论的后续内容，以下是您尝试做的事情的一个工作示例：

课堂答案 

Option Explicit

Public Key As String
Public Answer As String
Public AnswerLabel As String

班级答案控件 

Option Explicit

Public WithEvents Answer As MSForms.TextBox
Public WithEvents AnswerLabel As MSForms.TextBox
Private WithEvents Remove As MSForms.CommandButton
Private WithEvents MoveUp As MSForms.Label
Private WithEvents MoveDown As MSForms.Label

Private p_Parent As Object
Private p_rowKey As String
Private p_Answers As Answers
Private p_data As Answer

Const padding = 5
Const tbWidth = 100


Public Sub AddRow(top As Double, left As Double, parent As Answers, container As Object, RowKey As String)

    Set p_Parent = container
    Set p_Answers = parent
    p_rowKey = RowKey

    Set Answer = p_Parent.Controls.Add("forms.textbox.1", "tb1" + RowKey)
    Set AnswerLabel = p_Parent.Controls.Add("forms.textbox.1", "tb2" + RowKey)
    Set Remove = p_Parent.Controls.Add("forms.commandbutton.1", "cb" + RowKey)
    Set MoveUp = p_Parent.Controls.Add("forms.Label.1", "lb1" + RowKey)
    Set MoveDown = p_Parent.Controls.Add("forms.Label.1", "lb2" + RowKey)

    With MoveUp
        .left = left
        .top = top
        .Caption = "up"
        .Width = 35
    End With

    With MoveDown
        .left = left + 20 + padding
        .top = top
        .Caption = "Down"
        .Width = 35
    End With

    With Answer
        .left = left + (35 * 2) + (padding * 2)
        .top = top
        .Width = tbWidth
    End With

    With AnswerLabel
        .left = left + (50 * 2) + (padding * 2) + padding + tbWidth
        .top = top
        .Width = tbWidth
    End With

    With Remove
        .left = left + (50 * 2) + (padding * 2) + padding + (tbWidth * 2) + padding
        .top = top
        .Height = AnswerLabel.Height
        .Caption = "X"
    End With

End Sub

Private Sub Answer_Change()
    p_data.Answer = Answer.Text
End Sub

Private Sub AnswerLabel_Change()
    p_data.AnswerLabel = AnswerLabel.Text
End Sub

Private Sub Class_Terminate()

    p_Parent.Controls.Remove Answer.Name
    p_Parent.Controls.Remove AnswerLabel.Name
    p_Parent.Controls.Remove MoveUp.Name
    p_Parent.Controls.Remove MoveDown.Name
    p_Parent.Controls.Remove Remove.Name

End Sub

Private Sub MoveDown_Click()
    p_Answers.MoveDown p_data.Key
End Sub

Private Sub MoveUp_Click()
    p_Answers.MoveUp p_data.Key
End Sub

Private Sub Remove_Click()
    p_Answers.Remove p_data.Key, p_rowKey
End Sub
Public Property Set data(data As Answer)
    Set p_data = data
    Answer.Value = data.Answer
    AnswerLabel.Value = data.AnswerLabel
End Property

类答案 

Option Explicit

Private answerList As Collection
Private rowList As Collection
Private no_rows As Long
Public parent As Object

Public Sub MoveUp(Key As String)

    Dim ans As Answer
    Dim x As Long: x = 1

    Set ans = answerList(Key)

    For Each ans In answerList
        If ans.Key = Key Then Exit For
        x = x + 1
    Next ans

    answerList.Remove Key

    If x = 1 Then x = 2 'The item may already be at the top
    answerList.Add ans, ans.Key, x - 1

    Rebind

End Sub
Public Sub MoveDown(Key As String)

    Dim ans As Answer
    Dim x As Long: x = 1

    Set ans = answerList(Key)

    For Each ans In answerList
        If ans.Key = Key Then Exit For
        x = x + 1
    Next ans

    answerList.Remove Key


    If x >= answerList.Count Then
        answerList.Add ans, ans.Key
    Else
        answerList.Add ans, ans.Key, x + 1
    End If

    Rebind
End Sub
Public Sub MoveToTop(Key As String)

    Dim ans As Answer
    Set ans = answerList(Key)

    answerList.Remove Key
    answerList.Add ans, ans.Key, 1
'Rebind our data to our interface
    Rebind

End Sub
Public Sub Remove(Key As String, RowKey As String)

    Dim ans As Answer
    Dim x As Long: x = 1

    answerList.Remove Key

    Rebind

    rowList.Remove rowList.Count
    no_rows = no_rows - 1
End Sub
Public Sub Add(newAnswer As Answer)
    AddRow
    answerList.Add newAnswer, newAnswer.Key
    Set rowList(rowList.Count).data = newAnswer
End Sub
Private Sub AddRow()

    Dim rowControls As AnswerControls
    Set rowControls = New AnswerControls

    rowControls.AddRow 20 * no_rows, 1, Me, parent, "r" & no_rows
    rowList.Add rowControls, "r" & no_rows

    no_rows = no_rows + 1

End Sub
Private Sub Class_Initialize()
    Set answerList = New Collection
    Set rowList = New Collection
    no_rows = 1
End Sub

Private Sub Rebind()

    Dim ans As Answer
    Dim x As Long
    x = 1
    For Each ans In answerList
        Set rowList(x).data = ans
        x = x + 1
    Next ans

End Sub

用户表单中的简单实现：

Option Explicit

Dim d As Answers
Private Sub UserForm_Click()
    Dim a As New Answer
    a.Key = Rnd * 10
    d.Add a
End Sub
Private Sub UserForm_Initialize()
    Set d = New Answers
    Set d.parent = Me
End Sub
相关问题
最新问题