Tipp 0366 UserForm-Einstellungen speichern (Tabelle)
Autor/Einsender:
Datum:
  Angie
13.10.2003
Entwicklungsumgebung:   Excel 97
Mit dem Tipp UserForm-Einstellungen speichern (INI-Datei) wird gezeigt, wie man die UserForm-Einstellungen in einer INI-Datei speichern und wieder einlesen kann. In Excel bietet es sich aber auch an, die UserForm-Einstellungen in einem Tabellenblatt zu speichern. Der Einfachheit halber werden hier die Einstellungen für die UserForms jeweils in einem eigenen Tabellenblatt gespeichert.
In diesem Beispiel wurde vorab zur Entwurfszeit für eine UserForm ein Tabellenblatt angelegt, in der auch eine Zeile mit Default-Werten zur Initialisierung der UserForm zur Verfügung steht. Beim ersten Aufruf der UserForm wird der Benutzername ermittelt und ggf. ein neuer Datensatz (Zeile) für den Benutzer angelegt (sind Default-Werte vorhanden, werden diese kopiert).
Im weiteren Verlauf werden die Initialisierungswerte aus der entsprechenden Zeile ausgelesen und beim Schließen der UserForm gespeichert. Hat der Benutzer keinen Benutzernamen angegeben (aus welchen Gründen auch immer!), so werden die Eingaben nicht gespeichert!
Für die vorhandene 2. UserForm wurde zur Entwurfszeit kein Tabellenblatt zum Einlesen und Speichern der UserForm-Einstellungen erstellt. In der Prozedur zum Initialisieren der UserForm-Einstellungen wird zunächst überprüft, ob ein entsprechendes Tabellenblatt vorhanden ist. Ist dies nicht der Fall, so wird ein neues Tabellenblatt hinzugefügt und beim Schließen der UserForm mit den Steuerelement-Namen und den gemachten Eingaben ergänzt.
Damit der Anwender das Tabellenblatt/die Tabellenblätter nicht so ohne Weiteres einsehen und/oder verändern kann, wurde/wird die Visible-Eigenschaft des Tabellenblatts im VB-Editor manuell bzw. per VBA auf xlSheetVeryHidden gesetzt.
 
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
 
Links zum Thema
UserForm-Einstellungen speichern (INI-Datei)
Hinweis
Die Ersatzfunktion für Office 97 für die in diesem Beispiel verwendete Replace-Funktion ist im Download-Beispiel enthalten.

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
Excel-Version
95
97
2000
2002 (XP)
2003
2007
2010


Download  (40,2 kB) Downloads bisher: [ 1377 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Dienstag, 31. Mai 2011