Option Explicit

Dim xlAppl As Object
Dim xlApplLiefNicht As Boolean
Dim xlWB As Object
Dim xlWBName As String

Dim xlUserForm As Object
Dim xlUserFormName As String

Private Sub Form_Initialize()

  On Error Resume Next
  Set xlAppl = GetObject(, "Excel.Application")
  If Err.Number <> 0 Then xlApplLiefNicht = True
  Err.Clear

End Sub

Private Sub cmdxlUserFormVBE_Click()

  Select Case cmdxlUserFormVBE.Caption
    Case Is = "&UserForm im VBE erstellen"
      Call xlUserFormDesign_Start
      cmdxlUserFormVBE.Caption = "&UserForm im VBE anzeigen"
      Me.Label2.Caption = "Die in der Excel-Arbeitsmappe '" & _
            xlWBName & "' neuerstellte UserForm kann im " & _
            "Excel-VB-Editor angezeigt werden !"

    Case Is = "&UserForm im VBE anzeigen"
      Call xlUserFormAnzeigen
      cmdxlUserFormVBE.Caption = "&UserForm im VBE erstellen"
      cmdxlUserFormVBE.Enabled = False
      Me.Label2.Caption = "Mit diesem Beispiel wird in Excel " & _
            "eine neue Arbeitsmappe geöffnet und im Excel-VB-" & _
            "Editor eine UserForm inkl. Code hinzugefügt."
  End Select

End Sub

Sub xlUserFormDesign_Start()

  On Error GoTo errorMsgExcel
  If xlAppl Is Nothing Then _
    Set xlAppl = CreateObject("Excel.Application")

  On Error GoTo errorMsgXLMappe
  Set xlWB = xlAppl.Workbooks.Add
  On Error GoTo 0

  xlWBName = xlAppl.ActiveWorkbook.Name

  Call xlUserFormDesign

  xlAppl.Application.Visible = True
  xlAppl.Run "UserFormAnzeigen"

  Exit Sub

errorMsgExcel:
  MsgBox "Konnte keine Verbindung zu Excel herstellen !", _
         16, "Problem"
  Exit Sub

errorMsgXLMappe:
  MsgBox "Es traten Probleme bei der Erstellung" & _
         " einer neuen Arbeitsmappe auf !", 16, "Problem"
    If xlApplLiefNicht Then xlAppl.Application.Quit
    Set xlAppl = Nothing
  Exit Sub

End Sub

Sub xlUserFormDesign()
  Dim xlLabelMsg As Object
  Dim xlCmdOK As Object
  Dim xlModul As Object

  Dim strCode As String
  Dim leerZ As String

  leerZ = "  "

  Set xlUserForm = _
     xlWB.VBProject.VBComponents.Add(vbext_ct_MSForm)
  xlUserFormName = xlUserForm.Name

  Set xlLabelMsg = xlUserForm.Designer.Controls.Add _
      ("Forms.Label.1", , True)
  With xlLabelMsg
    .Left = 9
    .Top = 12
    .Height = 20
    .Width = 180
    .Caption = "Ich bin die neuerstellte UserForm in der " & _
               "Excel-Arbeitsmappe '" & xlWBName & "'"
  End With

  Set xlCmdOK = xlUserForm.Designer.Controls.Add _
      ("Forms.CommandButton.1", "cmdOK", True)
  With xlCmdOK
    .Left = 129
    .Top = 42
    .Height = 18
    .Width = 60
    .Caption = "OK"
    .Default = True
  End With

  With xlUserForm.CodeModule
    .InsertLines 2, ""
    .InsertLines 3, "Private Sub UserForm_Initialize()"
    .InsertLines 4, leerZ & "Me.Height = 90"
    .InsertLines 5, leerZ & "Me.Width = 203"
    .InsertLines 6, leerZ & "Me.Caption = " & _
                            """eue UserForm in Excel"""
    .InsertLines 7, leerZ & "Me.StartUpPosition = 1"
    .InsertLines 8, leerZ & "Me.cmdOK.Accelerator = ""O"""
    .InsertLines 9, leerZ & "Me.cmdOK.Cancel = True"
    .InsertLines 10, "End Sub"

    .InsertLines 11, ""
    .InsertLines 12, "Private Sub cmdOK_Click()"
    .InsertLines 13, leerZ & "Unload Me"
    .InsertLines 14, "End Sub"
  End With

  Set xlModul = xlWB.VBProject.VBComponents.Add(vbext_ct_StdModule)
  strCode = _
     "Sub UserFormAnzeigen()" & vbCr & _
        leerZ & xlUserFormName & ".Show " & vbCr & _
     "End Sub"
  xlModul.CodeModule.AddFromString strCode

  xlWB.Saved = True

  Set xlModul = Nothing
  Set xlLabelMsg = Nothing
  Set xlCmdOK = Nothing

End Sub

Sub xlUserFormAnzeigen()

  xlAppl.Application.VBE.MainWindow.SetFocus
  xlWB.VBProject.VBComponents(xlUserFormName).Activate
  xlAppl.Application.VBE.MainWindow.Visible = True

End Sub

Private Sub cmdBeenden_Click()
  Dim wb As Excel.Workbook

  On Error Resume Next
  If Not xlAppl Is Nothing Then
    If xlAppl.Workbooks.Count > 0 Then
      With xlAppl
        For Each wb In xlAppl.Workbooks
          If LCase(wb.Name) = LCase(xlWBName) Then
            wb.Close SaveChanges:=False
          End If
        Next
      End With
    End If

    Set xlUserForm = Nothing
    Set xlWB = Nothing

    If xlApplLiefNicht Then xlAppl.Application.Quit
    Set xlAppl = Nothing
  End If

  Unload Me
  End

End Sub