Thema: Dialoggesteuerte Druckmehrblattauswahl

StandardModule: basMain

Sub PrintSheets()
   Dim frmNew As Object
   Dim wks As Worksheet
   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
   Application.VBE.MainWindow.Visible = False
   On Error Resume Next
   Set frmNew = ThisWorkbook.VBProject.VBComponents("frmWks")
   If Err = 0 Then GoTo ERRORHANDLER
   On Error GoTo 0
   Set frmNew = ThisWorkbook.VBProject.VBComponents.Add(3)
   iTop = 5
   For Each wks In Worksheets
      Set chb = frmNew.Designer.Controls.Add("forms.CheckBox.1")
      With chb
         .Top = iTop
         .Left = 5
         .Width = 100
         .Caption = "Blatt " & wks.Name
      End With
      iTop = iTop + 20
   Next wks
   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") = "Arbeitsblätter"
      .Properties("Name") = "frmWks"
   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 arr() as String" & vbLf
   sCode = sCode & "   Dim iArr as Integer" & vbLf
   sCode = sCode & "   Dim iCounter As Integer" & vbLf
   sCode = sCode & "   For iCounter = 1 to " & Worksheets.Count & vbLf
   sCode = sCode & "      If Controls(""CheckBox"" & iCounter).Value"
   sCode = sCode & " = True Then" & vbLf
   sCode = sCode & "         iArr = iArr + 1" & vbLf
   sCode = sCode & "         Redim Preserve arr(1 to iArr)" & vbLf
   sCode = sCode & "         arr(iArr) = Worksheets(iCounter).Name" & vbLf
   sCode = sCode & "      End If" & vbLf
   sCode = sCode & "   Next iCounter" & vbLf
   sCode = sCode & "   If iArr > 0 Then" & vbLf
   sCode = sCode & "      Unload Me" & vbLf
   sCode = sCode & "      For iCounter = 1 to iArr" & vbLf
   sCode = sCode & "         Worksheets(arr(iCounter)).PrintPreview" & vbLf
   sCode = sCode & "      Next iCounter" & vbLf
   sCode = sCode & "   Else" & vbLf
   sCode = sCode & "      Unload Me" & vbLf
   sCode = sCode & "   End If" & vbLf
   sCode = sCode & "End Sub" & vbLf
   ThisWorkbook.VBProject.VBComponents("frmWks").CodeModule.AddFromString sCode
ERRORHANDLER:
   VBA.UserForms.Add(frmNew.Name).Show
   ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(frmNew.Name)
   Set frmNew = Nothing
   Exit Sub
End Sub

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