Option Explicit
Private WithEvents objCmd As MSForms.CommandButton
Private WithEvents objTxt As MSForms.TextBox
Private WithEvents objChk As MSForms.CheckBox
Private WithEvents objOpt As MSForms.OptionButton
Private WithEvents objLst As MSForms.ListBox
Private WithEvents objCmb As MSForms.ComboBox
Private WithEvents objSpn As MSForms.SpinButton
Private WithEvents objScr As MSForms.ScrollBar
Public Function SetObject(objCntrl As MSForms.Control) As Object
Set SetObject = Nothing
If TypeOf objCntrl Is MSForms.CommandButton Then
Set objCmd = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.TextBox Then
Set objTxt = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.CheckBox Then
Set objChk = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.OptionButton Then
Set objOpt = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.ListBox Then
Set objLst = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.ComboBox Then
Set objCmb = objCntrl
Set SetObject = Me
ElseIf TypeOf objCntrl Is MSForms.ScrollBar Then
Set objScr = objCntrl
Set SetObject = Me
End If
End Function
Private Sub objCmd_Click()
Dim objCntrl As MSForms.Control
Dim rng As Range
Dim intAnswer As Integer
Select Case objCmd.Tag
Case "entry", "entryClose"
If objUFrm.Controls("txt1") = "" Then
If MsgBox("Die Laufende Nummer fehlt!" & Space(25) & vbLf & vbLf & _
"Soll der Eintrag neu angelegt werden?", 36, "Frage") <> 6 Then Exit Sub
objUFrm.Controls("txt1") = CStr(Application.Max(wksData.Range("A:A")) + 1)
End If
Set rng = wksData.Range("A:A").Find(objUFrm.Controls("txt1").Text)
If Not rng Is Nothing Then
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Locked Then
wksData.Cells(2, CDbl(objCntrl.Tag)).Copy wksData.Cells(rng.Row, CDbl(objCntrl.Tag))
objCntrl.Text = wksData.Cells(rng.Row, CDbl(objCntrl.Tag)).Text
Else
If IsNumeric(objCntrl.Text) Then
wksData.Cells(rng.Row, CDbl(objCntrl.Tag)) = IIf(IsDate(objCntrl.Text), _
CDate(objCntrl.Text), CDbl(objCntrl.Text))
Else
End If
End If
End If
Next
Else
Set rng = wksData.Cells(wksData.Cells(65536, 1).End(xlUp).Row + 1, 1)
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Locked Then
wksData.Cells(2, CDbl(objCntrl.Tag)).Copy wksData.Cells(rng.Row, CDbl(objCntrl.Tag))
objCntrl.Text = wksData.Cells(rng.Row, CDbl(objCntrl.Tag)).Text
Else
If IsNumeric(objCntrl.Text) Then
wksData.Cells(rng.Row, CDbl(objCntrl.Tag)) = IIf(IsDate(objCntrl.Text), _
CDate(objCntrl.Text), CDbl(objCntrl.Text))
Else
wksData.Cells(rng.Row, CDbl(objCntrl.Tag)) = objCntrl.Text
End If
End If
End If
Next
End If
wksData.Range(wksData.Cells(1, 1), wksData.Cells(wksData.Cells(65536, 1).End(xlUp).Row, _
wksData.Cells(1, 256).End(xlToLeft).Column)).Sort _
Key1:=wksData.Range("A2"), _
Order1:=xlAscending, _
Header:=xlGuess, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
objUFrm.Controls("spin1").Min = Application.Max(wksData.Range("A:A")) + 1
If objCmd.Tag = "entryClose" Then Unload objUFrm
writeInfo
Case "new"
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Tag = "1" Then
objCntrl.Text = CStr(Application.Max(wksData.Range("A:A")) + 1)
Else
objCntrl.Text = ""
End If
End If
Next
objUFrm.Controls("txt2").SetFocus
writeInfo
Case "delete"
If IsError(Application.Match(CDbl(objUFrm.Controls("txt1").Text), wksData.Range("A:A"), 0)) Then Exit Sub
intAnswer = MsgBox("Einträge auch in der Tabelle löschen?" & Space(55) & vbLf & vbLf & _
vbTab & "[ Ja ]" & vbTab & vbTab & "Formular + Tabelle löschen" & vbLf & _
vbTab & "[ Nein ]" & vbTab & vbTab & "Nur Formular löschen" & vbLf & _
vbTab & "[Abbrechen]" & vbTab & "Abbrechen" & vbLf, 547, "Löschen")
If intAnswer = 2 Then Exit Sub
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Tag <> "1" Then
objCntrl.Text = ""
End If
End If
Next
objUFrm.Controls("txt2").SetFocus
If intAnswer = 6 Then
Set rng = wksData.Range("A:A").Find(objUFrm.Controls("txt1").Text)
If Not rng Is Nothing Then
wksData.Rows(rng.Row).Delete
End If
End If
writeInfo
Case "close"
Unload objUFrm
Case Else
End Select
End Sub
Private Sub objScr_Change()
Dim rng As Range
Dim objCntrl As MSForms.Control
objScr.Min = Application.Max(wksData.Range("A:A")) + 1
objUFrm.Controls("txt1").Text = objScr.Value
Set rng = wksData.Range("A:A").Find(objScr.Value)
If Not rng Is Nothing Then
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Tag <> "1" Then objCntrl.Text = wksData.Cells(rng.Row, CDbl(objCntrl.Tag)).Text
End If
Next
Else
For Each objCntrl In objUFrm.Controls
If TypeOf objCntrl Is MSForms.TextBox Then
If objCntrl.Tag <> "1" Then objCntrl.Text = ""
End If
Next
End If
writeInfo
End Sub
Private Sub objTxt_Change()
If objTxt.Name = "txt1" And objTxt <> "" Then
If CDbl(Val(objTxt)) > Application.Max(wksData.Range("A:A")) + 1 Then objTxt.Text = Application.Max(wksData.Range("A:A")) + 1
objUFrm.Controls("spin1").Value = Val(objTxt)
End If
End Sub
Private Sub objTxt_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If objTxt.Name = "txt1" Then
Select Case KeyAscii
Case 48 To 59
Case Else
KeyAscii = 0
End Select
End If
End Sub
UserForm1:
Option Explicit
Const cntWidth As Double = 135
Dim arrControls() As clsControls
Private Sub UserForm_Activate()
Dim rng As Range
Dim lngTop As Long, lngLeft As Long, maxTop As Long, maxLeft As Long, intCount As Integer
Dim lblNew As MSForms.Label, txtNew As MSForms.TextBox, cmdNew As MSForms.CommandButton
Dim frmNew As MSForms.Frame, scrNew As MSForms.ScrollBar
Dim n As Integer
n = -1
lngTop = 15
lngLeft = 5
Me.Height = Application.Height - 300
Me.Width = Application.Width - 650
Me.StartUpPosition = 0
Me.Top = Application.Top + 40
Me.Left = Application.Left + 600
maxTop = Me.Height - 108
Set frmNew = Me.Controls.Add("Forms.Frame.1")
With frmNew
.Name = "Frame1"
.Top = 5
.Left = 5
.Width = Me.Width - 15
.Height = maxTop
.TabStop = False
.SpecialEffect = fmSpecialEffectSunken
Set lblNew = .Controls.Add("Forms.Label.1")
With lblNew
.Caption = ""
.Name = "lblinfo"
.Top = lngTop
.Left = lngLeft + cntWidth + 6
.WordWrap = False
.Font.Size = 11
.Enabled = False
.AutoSize = True
End With
lngTop = lngTop + 24
For Each rng In wksData.Rows(1).Cells
If rng <> "" And rng.PrefixCharacter <> "'" Then
intCount = intCount + 1
Set lblNew = .Controls.Add("Forms.Label.1")
Set txtNew = .Controls.Add("Forms.TextBox.1")
With lblNew
.Name = "lbl" & CStr(intCount)
.Top = lngTop
.Left = lngLeft
.Width = cntWidth
.WordWrap = True
.Caption = rng.Text & ":"
.TextAlign = fmTextAlignRight
.ForeColor = &H404040
End With
With txtNew
.Top = lngTop
.Left = lngLeft + cntWidth + 3
.Width = cntWidth
maxLeft = .Left + .Width
.Text = rng.Offset(Val(Me.Tag), 0).Text
.Tag = rng.Column
.Name = "txt" & CStr(intCount)
.Locked = rng.Offset(1, 0).HasFormula
.BackColor = IIf(.Locked, &H8000000F, &HFFFFFF)
.TabStop = Not .Locked
If .Tag = "1" Then
If .Text = "" Then .Text = Application.Max(wksData.Range("A:A")) + 1
.Width = .Width - 15
Set scrNew = Me.Controls("Frame1").Add("Forms.ScrollBar.1")
With scrNew
.Name = "spin1"
.Orientation = fmOrientationVertical
.Min = Application.Max(wksData.Range("A:A")) + 1
.Max = 1
.Value = Val(txtNew.Text)
.Height = txtNew.Height
.Width = 15
.Top = txtNew.Top
.Left = txtNew.Left + txtNew.Width
.ForeColor = &H80000015
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject scrNew
End If
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject txtNew
lngTop = lngTop + 24
If lngTop > maxTop - 36 Then
lngTop = 39
lngLeft = lngLeft + cntWidth * 2 + 18
End If
End If
Next
If maxLeft + 10 > .Width Then
.ScrollBars = fmScrollBarsHorizontal
.ScrollWidth = maxLeft + 24
End If
End With
lngTop = maxTop + 18
lngLeft = 15
Set cmdNew = Me.Controls.Add("Forms.CommandButton.1")
With cmdNew
.Caption = "Eintragen"
.ForeColor = &H9900&
.Name = "cmdEntry"
.Top = lngTop
.Left = lngLeft
.Width = 110
.Height = 22
.Tag = "entry"
.TakeFocusOnClick = False
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject cmdNew
Set cmdNew = Me.Controls.Add("Forms.CommandButton.1")
With cmdNew
.Caption = "Eintragen & Schliessen"
.ForeColor = &H9900&
.Top = lngTop + 30
.Left = lngLeft
.Width = 110
.Height = 22
.Tag = "entryClose"
.TakeFocusOnClick = False
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject cmdNew
Set cmdNew = Me.Controls.Add("Forms.CommandButton.1")
With cmdNew
.Caption = "Neu"
.ForeColor = &HFF0000
.Top = lngTop
.Left = lngLeft + 120
.Width = 110
.Height = 22
.Tag = "new"
.TakeFocusOnClick = False
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject cmdNew
Set cmdNew = Me.Controls.Add("Forms.CommandButton.1")
With cmdNew
.Caption = "Löschen"
.ForeColor = &HFF
.Top = lngTop + 30
.Left = lngLeft + 120
.Width = 110
.Height = 22
.Tag = "delete"
.TakeFocusOnClick = False
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject cmdNew
Set cmdNew = Me.Controls.Add("Forms.CommandButton.1")
With cmdNew
.Caption = "Schliessen"
.Top = lngTop + 30
.Left = lngLeft + 250
.Width = 110
.Height = 22
.Tag = "close"
.TakeFocusOnClick = False
.TabStop = False
End With
n = n + 1
ReDim Preserve arrControls(n)
Set arrControls(n) = New clsControls
arrControls(n).SetObject cmdNew
writeInfo
Me.Controls("txt2").SetFocus
End Sub
Private Sub UserForm_Initialize()
Set objUFrm = Me
Set wksData = ActiveSheet
End Sub
Private Sub UserForm_Terminate()
Set objUFrm = Nothing
Set wksData = Nothing
End Sub