|
Sorry für die Unübersicht.... Im Internetexplorer wurden mir die Editor Buttons nicht angezeigt
Hier ordentlicher:
clsControls:
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 'Auswertung der ButtonClicks je nach Button-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 'Konstante der Steuerelement-Breite
Dim arrControls() As clsControls 'Verweis auf das Klassenmodul
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 'Zähler für Steuerelemente-Array
lngTop = 15 'Ausrichtung "oben" für Steuerelemente
lngLeft = 5 'Ausrichtung "links" für Steuerelemente
Me.Height = Application.Height - 300 'UF-Höhe anpassen
Me.Width = Application.Width - 650 'UF-Breite anpassen
Me.StartUpPosition = 0 'Startverhalten
Me.Top = Application.Top + 40 'Ausrichtung "oben"
Me.Left = Application.Left + 600 'Ausrichtung "links"
maxTop = Me.Height - 108 'Hilfsvariable zur Steuerelement-Ausrichtung
Set frmNew = Me.Controls.Add("Forms.Frame.1") 'Rahmen hinzufügen
With frmNew 'Rahmen formatieren
.Name = "Frame1"
.Top = 5
.Left = 5
.Width = Me.Width - 15
.Height = maxTop
.TabStop = False
.SpecialEffect = fmSpecialEffectSunken
Set lblNew = .Controls.Add("Forms.Label.1") 'Label zur Anzeige der Datensatznummer
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 'Zellen in Zeile 1 durchlaufen
If rng <> "" And rng.PrefixCharacter <> "'" Then
'Wenn Zelle mit Überschrift und ohne Prefix ('), dann
intCount = intCount + 1
Set lblNew = .Controls.Add("Forms.Label.1") 'Label hinzufügen
Set txtNew = .Controls.Add("Forms.TextBox.1") 'Textbox hinzufügen
With lblNew 'Label formatieren
.Name = "lbl" & CStr(intCount)
.Top = lngTop
.Left = lngLeft
.Width = cntWidth
.WordWrap = True
.Caption = rng.Text & ":"
.TextAlign = fmTextAlignRight
.ForeColor = &H404040
End With
With txtNew 'Textbox formatieren
.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") 'Zu erster Textbox SpinButton hinzufügen
With scrNew 'SpinButton formatieren
.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) 'SpinButton in der Klasse registrieren
Set arrControls(n) = New clsControls
arrControls(n).SetObject scrNew
End If
End With
n = n + 1
ReDim Preserve arrControls(n) 'Textbox in der Klasse registrieren
Set arrControls(n) = New clsControls
arrControls(n).SetObject txtNew
lngTop = lngTop + 24
If lngTop > maxTop - 36 Then 'Je nach Höhe des UF Steuerelement-Ausrichtung anpassen
lngTop = 39
lngLeft = lngLeft + cntWidth * 2 + 18
End If
End If
Next 'Umkehrpunkt der Schleife
If maxLeft + 10 > .Width Then 'Bei Bedarf Scrollbar zum Rahmen hinzufügen
.ScrollBars = fmScrollBarsHorizontal
.ScrollWidth = maxLeft + 24
End If
End With
lngTop = maxTop + 18
lngLeft = 15
'Ab hier werden die CommandButtons hinzugefügt
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()
'Objektvariablen des UF und der Tabelle zuweisen
Set objUFrm = Me
Set wksData = ActiveSheet
End Sub
Private Sub UserForm_Terminate()
'Objektvariablen leeren
Set objUFrm = Nothing
Set wksData = Nothing
End Sub
|