|
Option Explicit
Private Const UF_INIT_WKS As String = "Init_"
Private Const UF_DEFAULT_VALUES As String = "Default Values"
Public Sub GetUserData(ByVal UserFrm As Object)
Dim wksUFInit As Object
Dim strWKSName As String
Dim nRowValues As Long
Dim nCols As Integer
Dim i As Integer
Dim ctl As Control
Dim varValue As Variant
On Error Resume Next
strWKSName = UF_INIT_WKS & UserFrm.Name
Set wksUFInit = ActiveWorkbook.Sheets(strWKSName)
If wksUFInit Is Nothing Then
Set wksUFInit = AddINIWorksheet(ActiveWorkbook, strWKSName)
If wksUFInit Is Nothing Then Exit Sub
Else
If Not UCase(TypeName(wksUFInit)) = "WORKSHEET" Then
Exit Sub
End If
End If
On Error GoTo 0
nRowValues = GetRowUserValues(wksUFInit, UF_DEFAULT_VALUES)
If nRowValues = 0 Then Exit Sub
nCols = wksUFInit.Cells(1, wksUFInit.Columns.Count). _
End(xlToLeft).Column
If nCols = 1 Then Exit Sub
On Error Resume Next
With wksUFInit
For i = 2 To nCols
varValue = Trim$(.Cells(1, i).Value)
If Len(varValue) > 0 Then
Set ctl = UserFrm.Controls(varValue)
If Not ctl Is Nothing Then
varValue = .Cells(nRowValues, i).Value
If Len(varValue) > 0 Then
If TypeOf ctl Is MSForms.TextBox Then
ctl.Text = varValue
ElseIf TypeOf ctl Is MSForms.ListBox Or _
TypeOf ctl Is MSForms.ComboBox Then
If IsNumeric(varValue) Then
ctl.ListIndex = Int(varValue)
End If
Else
If IsNumeric(varValue) Then
ctl.Value = Int(varValue)
End If
End If
End If
Set ctl = Nothing
End If
End If
Next
End With
On Error GoTo 0
Set wksUFInit = Nothing
End Sub
Private Function AddINIWorksheet(ByVal WB As Workbook, _
vsWKSName As String) As Worksheet
Dim wks As Worksheet
Dim intWKSIndex As Integer
Application.ScreenUpdating = False
With WB
intWKSIndex = .ActiveSheet.Index
Set wks = .Worksheets.Add(After:=.Sheets(.Sheets.Count))
.Sheets(intWKSIndex).Activate
End With
Application.ScreenUpdating = True
If Not wks Is Nothing Then
wks.Name = vsWKSName
wks.Visible = xlSheetVeryHidden
Set AddINIWorksheet = wks
End If
End Function
Private Function GetRowUserValues(ByVal WS As Worksheet, _
Optional ByVal DefaultVal As Variant) As Long
Dim strUserName As String
Dim rngCell As Range
Dim lngRow As Long
Dim lngRowNew As Long
Dim lngRowDef As Long
Dim rngRange As Range
strUserName = Trim$(Application.UserName)
If Len(strUserName) = 0 Then
If Not IsMissing(DefaultVal) Then
strUserName = DefaultVal
Else
Exit Function
End If
End If
With WS.Columns(1)
Set rngCell = .Find(strUserName, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not rngCell Is Nothing Then
lngRow = rngCell.Row
Else
If strUserName <> UF_DEFAULT_VALUES Then
lngRowNew = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
If lngRowNew < .Rows.Count Then
Set rngCell = .Find(UF_DEFAULT_VALUES, _
LookIn:=xlValues, LookAt:=xlWhole)
If Not rngCell Is Nothing Then
lngRowDef = rngCell.Row
Set rngRange = WS.Rows(lngRowDef)
rngRange.Copy WS.Cells(lngRowNew, 1)
Application.CutCopyMode = False
End If
WS.Cells(lngRowNew, 1).Value = strUserName
lngRow = lngRowNew
Else
MsgBox "Zu viele Benutzer !!!"
End If
End If
End If
End With
GetRowUserValues = lngRow
End Function
Public Sub SaveUserData(ByVal UserFrm As Object)
Dim wksUFInit As Worksheet
Dim strWKSName As String
Dim nRowValues As Long
Dim strCtlName As String
Dim ctl As Control
Dim varValue As Variant
Dim intCol As Integer
Dim intColNext As Long
Dim rngCell As Range
Dim rngRange As Range
On Error Resume Next
strWKSName = UF_INIT_WKS & UserFrm.Name
Set wksUFInit = ActiveWorkbook.Worksheets(strWKSName)
If wksUFInit Is Nothing Then
Exit Sub
End If
On Error GoTo 0
nRowValues = GetRowUserValues(wksUFInit)
If nRowValues = 0 Then Exit Sub
For Each ctl In UserFrm.Controls
If TypeOf ctl Is MSForms.TextBox Or _
TypeOf ctl Is MSForms.OptionButton Or _
TypeOf ctl Is MSForms.CheckBox Or _
TypeOf ctl Is MSForms.ListBox Or _
TypeOf ctl Is MSForms.ComboBox Then
If TypeOf ctl Is MSForms.TextBox Then
varValue = ctl.Text
If InStr(1, varValue, Chr$(13) + Chr$(10)) Then
#If VBA6 Then
varValue = VBA.Replace(varValue, _
Chr$(13) + Chr$(10), Chr$(10), 1)
#Else
varValue = Replace(varValue, _
Chr$(13) + Chr$(10), Chr$(10), 1)
#End If
End If
ElseIf TypeOf ctl Is MSForms.ListBox Or _
TypeOf ctl Is MSForms.ComboBox Then
varValue = Int(ctl.ListIndex)
Else
varValue = Int(ctl.Value)
End If
If Len(varValue) > 0 Then
strCtlName = ctl.Name
With wksUFInit.Rows(1)
Set rngCell = .Find(What:=strCtlName, LookIn:=xlValues, _
LookAt:=xlWhole)
If Not rngCell Is Nothing Then
intCol = rngCell.Column
Else
intCol = 0
End If
End With
If intCol > 1 Then
wksUFInit.Cells(nRowValues, intCol).Value = varValue
Else
With wksUFInit
intColNext = .Cells(1, .Columns.Count). _
End(xlToLeft).Column + 1
If intColNext < .Columns.Count Then
.Cells(1, intColNext).Value = strCtlName
.Cells(nRowValues, intColNext).Value = varValue
If TypeOf ctl Is MSForms.TextBox Then
If ctl.MultiLine Then
Set rngRange = .Columns(intColNext)
rngRange.WrapText = True
Set rngRange = Nothing
End If
End If
End If
End With
End If
End If
End If
Next
Set wksUFInit = Nothing
End Sub
|
|