Thema: Laufwerke im Dialog zur Auswahl anzeigen lassen

StandardModule: basMain

Sub GetDrives()
   Dim frmNew As Object
   Dim chb As MSForms.CheckBox
   Dim cmd As MSForms.CommandButton
   Dim arr() As String
   Dim iCounter As Integer, iDrive As Integer
   Dim iTop As Integer
   Dim sCode As String
   On Error Resume Next
   For iCounter = 65 To 90
      ChDrive Chr(iCounter)
      If Err > 0 Then
         Err.Clear
      Else
         iDrive = iDrive + 1
         ReDim Preserve arr(1 To iDrive)
         arr(iDrive) = Chr(iCounter)
      End If
   Next iCounter
   Application.VBE.MainWindow.Visible = False
   Set frmNew = ThisWorkbook.VBProject.VBComponents("frmDrives")
   If Err = 0 Then GoTo ERRORHANDLER
   On Error GoTo 0
   Set frmNew = ThisWorkbook.VBProject.VBComponents.Add(3)
   iTop = 5
   For iCounter = 1 To UBound(arr)
      Set chb = frmNew.Designer.Controls.Add("forms.CheckBox.1")
      With chb
         .Top = iTop
         .Left = 5
         .Width = 100
         .Caption = "Laufwerk " & arr(iCounter)
      End With
      iTop = iTop + 20
   Next iCounter
   Set cmd = frmNew.Designer.Controls.Add("forms.CommandButton.1")
   With cmd
      .Top = iTop
      .Left = 5
      .Width = 100
      .Height = 25
      .Caption = "OK"
      .Name = "cmdOK"
   End With
   iTop = iTop + 30
   Set cmd = frmNew.Designer.Controls.Add("forms.CommandButton.1")
   With cmd
      .Top = iTop
      .Left = 5
      .Width = 100
      .Height = 25
      .Caption = "Abbrechen"
      .Name = "cmdCancel"
   End With
   With frmNew
      .Properties("Width") = 118
      .Properties("Height") = iTop + 50
      .Properties("Caption") = "Laufwerke"
      .Properties("Name") = "frmDrives"
   End With
   sCode = "Private Sub cmdCancel_Click" & vbLf
   sCode = sCode & "   Unload Me" & vbLf
   sCode = sCode & "End Sub" & vbLf & vbLf
   sCode = sCode & "Private Sub cmdOK_Click" & vbLf
   sCode = sCode & "   Dim sCode as String" & vbLf
   sCode = sCode & "   Dim iCounter As Integer" & vbLf
   sCode = sCode & "   sCode = ""Ausgewählte Laufwerke: ""& vbLf" & vbLf
   sCode = sCode & "   For iCounter = 1 to " & UBound(arr) & vbLf
   sCode = sCode & "      If Controls(""CheckBox"" & iCounter).Value"
   sCode = sCode & " = True Then" & vbLf
   sCode = sCode & "         sCode = sCode & Controls(""CheckBox"""
   sCode = sCode & " & iCounter).Caption & vbLf" & vbLf
   sCode = sCode & "      End If" & vbLf
   sCode = sCode & "   Next iCounter" & vbLf
   sCode = sCode & "   MsgBox sCode" & vbLf
   sCode = sCode & "End Sub" & vbLf
   ThisWorkbook.VBProject.VBComponents("frmDrives").CodeModule.AddFromString sCode
ERRORHANDLER:
   VBA.UserForms.Add(frmNew.Name).Show
   ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(frmNew.Name)
End Sub

Beiträge aus dem Excel-Forum zu den Themen Dialog und CheckBox