VBA UserForm: добавить TextBox или CommandButton и событие во время выполнения - PullRequest
Новая
       21

VBA UserForm: добавить TextBox или CommandButton и событие во время выполнения

1 голос
/ 31 марта 2011

Я был бы рад получить помощь! Я искал всю сеть, но я застрял!

Я давно программирую на VBA, но я все еще пытаюсь понять этот язык!

Я хочу создать пользовательскую форму VBA в MS Project 2007 VBA. Некоторые данные являются динамическими, и поэтому мне нужно добавить несколько текстовых полей во время выполнения.

Я добавил код, чтобы добавить их, и он работает вполне нормально.

Моя проблема заключается в добавлении событий в эти текстовые поля.

Мой пример - текстовое поле txtPath. Я создаю его с этим кодом: 

  Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
  With NewTextBox
      .name = "txtPath"
      .value = "Test"
      .top = m2w_style("top") + (m2w_style("height") * 1)
      .Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
      .Width = m2w_style("txtWidth")
      .height = m2w_style("height")
      .font.Size = m2w_style("fontsize")
      .font.name = m2w_style("font")
  End With

И я хочу реакции, если значение txtPath изменилось. Вот код:

Private Sub txtPath_Change () 'Событие не стреляет readProjectsFromConfig (Me.value) End Sub

Все веб-сайты, которые я просматривал и просматривал, показывают, что он должен работать таким образом, но событие просто не срабатывает.

Я обнаружил, что динамически создаваемое текстовое поле не отображается в том же месте в дереве «локального окна», как текстовые поля, созданные вручную.

Итак, я попытался, по крайней мере, получить значение текстового поля, и оно работает. 

Private Sub btnPath_Click()
  'txtPath.value = "Hello World!" ' Doesn't work. Dynamicly created text field seems not to exist but is visible in UserForm
  'Controls.Item("txtPath").value = "Hello World!" ' This works!
  Controls.Item("txtPath").value = GetDirectory("Pick the folder") ' Pick a folder and write it in the text field txtPath
End Sub

Вот полный код для тестирования: 

' Reference to Library
' Microsoft XML, v5.0 need to be activated.
' Go to menu: Tools->References
' Select Microsoft Scripting Runtime

Public m2w_config As Dictionary
Public m2w_style As Dictionary


Sub m2wVariables()
  ' Set global Variables for configuration in a kind of hash.
  Set m2w_config = New Dictionary
  Set m2w_style = New Dictionary

  'Styles for teh UserForm
  m2w_style("font") = "Arial"
  m2w_style("fontsize") = 10
  m2w_style("top") = 6
  m2w_style("left") = 6
  m2w_style("height") = 20
  m2w_style("btnHeight") = 8
  m2w_style("width") = 40
  m2w_style("lblWidth") = 40
  m2w_style("h1Width") = 400
  m2w_style("txtWidth") = 180
  m2w_style("btnWidth") = 72
  m2w_style("margin") = 6

  m2w_config("XMLDateFormat") = "YYYY-MM-DD"
  m2w_config("XMLConfigFileName") = "config.xml" ' should not be changeable
  m2w_config("AppPath") = ""
  m2w_config("Headline") = "" ' Headline in Website
  m2w_config("UpdateHref") = ""
  m2w_config("SubFolder") = "" ' Is it used?
  m2w_config("default_subfolder") = "" ' Is it used?

End Sub

  Private Sub UserForm_Activate()

      Dim LabelArr As Variant
      Dim ProbNameArr As Variant
      Dim TempForm As Object
      Dim NewButton As MSForms.CommandButton
      Dim NewLabel As MSForms.Label
      Dim NewTextBox As MSForms.TextBox
      Dim e As Variant
      Dim x As Integer
      Dim page As String
      'Dim Line As Integer
      'Dim MyScript(4) As String

      m2wVariables


      ' Setup userform
      '~~~~~~~~~~~~~~~~

        'This is to stop screen flashing while creating form
        Application.VBE.MainWindow.Visible = False

        ' Setup tab Website
        '===================
          page = "Website"
          Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
          With NewLabel
              .name = "lblHeadlinePath"
              .Caption = "This is the local path where the website shall be stored."
              .top = m2w_style("top") + (m2w_style("height") * 0)
              .Left = m2w_style("left")
              .Width = m2w_style("h1Width")
              .height = m2w_style("height")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
          End With

          Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
          With NewLabel
              .name = "lblPath"
              .Caption = "Path:"
              .top = m2w_style("top") + (m2w_style("height") * 1)
              .Left = m2w_style("left")
              .Width = m2w_style("lblWidth")
              .height = m2w_style("height")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
          End With

          Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
          With NewTextBox
              .name = "txtPath"
              .value = "Test"
              .top = m2w_style("top") + (m2w_style("height") * 1)
              .Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
              .Width = m2w_style("txtWidth")
              .height = m2w_style("height")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
          End With

          'Add event onClick
          ' This is completely weird, it actualy writes code.
          ' My intention is to add an event at runtime.
          With ThisProject.VBProject.VBComponents("msp2web_SettingsForm").CodeModule
            .insertlines .CountOfLines + 1, "Sub txtPath_Change()" & vbCrLf & "MsgBox Me.txtPath.Value" & vbCrLf & "End Sub"
            Debug.Print Now & " This macro has code lines " & .CountOfLines
          End With


          Dim btnName As String
          btnName = "btnPath"
          'Set NewButton = Me.InfoMultiPage(page).Controls.Add("Forms.commandbutton.1", btnName) ' Add dynamicly - but I'm too stupid to add an event action to an dynamicly created button...
          Set NewButton = Me.InfoMultiPage(page).Controls.Item(btnName)
          With NewButton
              .Caption = "Browse..."
              .top = m2w_style("top") + (m2w_style("height") * 1)
              .Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin") + m2w_style("txtWidth") + m2w_style("margin")
              .Width = m2w_style("lblWidth")
              .height = m2w_style("btnHeight")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
              .AutoSize = True
          End With


        ' Setup Tab Project
        '===================
        page = "Project"
        LabelArr = Array("Hallo", "Welt", "Model Year")
        ProbNameArr = Array("Hallo", "Welt", "Model Year")

        'Create 10 Labels just for testing - works fine
        'For x = 0 To 9
        x = 0
        For Each e In LabelArr
            Set NewLabel = Me.InfoMultiPage(page).Controls.Add("Forms.label.1")
            With NewLabel
              .name = "FieldLabel" & x + 1
              .Caption = e
              .top = m2w_style("top") + (m2w_style("height") * x)
              .Left = m2w_style("left")
              .Width = m2w_style("lblWidth")
              .height = m2w_style("height")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
            End With
            x = x + 1
        Next

        'Create 10 Text Boxes
        'For x = 0 To 9
        x = 0
        For Each e In ProbNameArr
            Set NewTextBox = Me.InfoMultiPage(page).Controls.Add("Forms.textbox.1")
            With NewTextBox
              .name = "MyTextBox" & x + 1
              .top = m2w_style("top") + (m2w_style("height") * x)
              .Left = m2w_style("left") + m2w_style("lblWidth") + m2w_style("margin")
              .Width = m2w_style("lblWidth")
              .height = m2w_style("height")
              .font.Size = m2w_style("fontsize")
              .font.name = m2w_style("font")
            End With
            x = x + 1
        Next

    End Sub

    Private Sub btnPath_Click()
      'txtPath.value = "Hello World!" ' Doesn't work. Dynamicly created text field seems not to exist but is visible in UserForm
      'Controls.Item("txtPath").value = "Hello World!" ' This works!
      Controls.Item("txtPath").value = GetDirectory("Pick the folder") ' Pick a folder and write it in the text field txtPath
    End Sub

    Private Sub txtPath_Change() ' Event doesn't shoot
      readProjectsFromConfig (Me.value)
    End Sub


    Private Sub Refresh_Click()
      readProjectsFromConfig (Controls.Item("txtPath").value)
    End Sub

Кто-нибудь подскажет, как создавать основанные на коде (во время выполнения) текстовые поля и кнопки команд и добавлять к ним события?

Ответы [ 2 ]

2 голосов
/ 31 марта 2011

См. Ответ Гэри на аналогичный вопрос о SO. Вы можете сделать это, используя класс и объявив его WithEvents.

Вы получаете только общий обработчик событий, но вы можете переключать действия в зависимости от вызывающего элемента управления.

Тим

1 голос
/ 31 марта 2011

Когда я хочу динамически добавлять элементы управления в пользовательскую форму, я просто иду по пути добавления элементов управления в созданный мной класс withevents, аналогично тому, что найдено здесь .

...