|
Option Explicit
Private Declare Function GetPrivateProfileSection Lib "kernel32" _
Alias "GetPrivateProfileSectionA" (ByVal Section As String, _
ByVal Buffer As String, ByVal Size As Long, ByVal FileName _
As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" _
Alias "WritePrivateProfileStringA" (ByVal Section As String, _
ByVal Key As String, ByVal Setting As String, ByVal FileName _
As String) As Long
Private Const INI_DELIMITER As String = "="
Private Const TXT_DELIMITER As String = "~|~"
Public Function GetUserDataINI(ByVal UserFrm As Object) As Boolean
Dim strINIFileName As String
Dim strINISection As String
Dim varSettings As Variant
Dim intUBound As Integer
Dim i As Integer
Dim ctl As Control
Dim varValue As Variant
strINIFileName = GetINIFileName
If Len(strINIFileName) = 0 Then
Exit Function
Else
If Len(Dir(strINIFileName, vbNormal)) = 0 Then
Exit Function
End If
End If
strINISection = UserFrm.Name
varSettings = GetINISection(strINIFileName, strINISection)
If UBound(varSettings) = -1 Then Exit Function
On Error Resume Next
intUBound = UBound(varSettings, 2)
For i = 0 To intUBound
Set ctl = UserFrm.Controls(varSettings(0, i))
If Not ctl Is Nothing Then
varValue = varSettings(1, i)
If TypeOf ctl Is MSForms.TextBox Then
If InStr(1, varValue, TXT_DELIMITER) Then
#If VBA6 Then
varValue = VBA.Replace(varValue, _
TXT_DELIMITER, Chr$(13) + Chr$(10), 1)
#Else
varValue = Replace(varValue, _
TXT_DELIMITER, Chr$(13) + Chr$(10), 1)
#End If
End If
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
Set ctl = Nothing
End If
Next
On Error GoTo 0
Erase varSettings
GetUserDataINI = True
End Function
Private Function GetINIFileName() As String
Dim strPath As String
Dim strFilename As String
Dim nPos As Long
strPath = ActiveWorkbook.Path
If Len(strPath) <> 0 Then
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
strFilename = ActiveWorkbook.Name
#If VBA6 Then
nPos = VBA.InStrRev(strFilename, ".")
#Else
nPos = InStrRev(strFilename, ".")
#End If
If nPos > 0 Then
strFilename = Left$(strFilename, nPos - 1)
End If
GetINIFileName = strPath & strFilename & ".ini"
End If
End Function
Private Function GetINISection(ByVal FileName As String, _
Section As String) As Variant
Const BufferSize = 32767
Dim strBuffer As String
Dim lngRetVal As Long
Dim varItems As Variant
Dim varItem As Variant
Dim varSettings() As String
Dim intUBound As Integer
Dim i As Integer
strBuffer = Space$(BufferSize)
lngRetVal = GetPrivateProfileSection( _
Section, strBuffer, BufferSize, FileName)
If lngRetVal = 0 Then
ReDim varSettings(-1 To -1)
GetINISection = varSettings
Exit Function
End If
#If VBA6 Then
varItems = VBA.Split(Left$(strBuffer, lngRetVal), Chr$(0))
#Else
varItems = Split(Left$(strBuffer, lngRetVal), Chr$(0))
#End If
If Len(varItems(UBound(varItems))) = 0 Then
intUBound = UBound(varItems) - 1
Else
intUBound = UBound(varItems)
End If
ReDim varSettings(0 To 1, 0 To intUBound)
For i = 0 To intUBound
#If VBA6 Then
varItem = VBA.Split(varItems(i), INI_DELIMITER, 2)
#Else
varItem = Split(varItems(i), INI_DELIMITER, 2)
#End If
varSettings(0, i) = varItem(0)
varSettings(1, i) = varItem(1)
Next
GetINISection = varSettings
End Function
Public Sub SaveUserDataINI(ByVal UserFrm As Object)
Dim strINIFileName As String
Dim strINISection As String
Dim ctl As Control
Dim varValue As Variant
strINIFileName = GetINIFileName
If Len(strINIFileName) = 0 Then
MsgBox "Die UserForm-Einstellung konnten nicht " & _
"gespeichert werden !", _
vbOKOnly + vbInformation, Title:="VB-fun-Demo"
Exit Sub
End If
strINISection = UserFrm.Name
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), TXT_DELIMITER, 1)
#Else
varValue = Replace(varValue, _
Chr$(13) + Chr$(10), TXT_DELIMITER, 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
SaveINISetting strINIFileName, strINISection, _
ctl.Name, CStr(varValue)
End If
Next
End Sub
Private Sub SaveINISetting(ByVal FileName As String, _
ByVal Section As String, ByVal Key As String, _
ByVal Setting As String)
Dim lngRetVal As Long
lngRetVal = WritePrivateProfileString( _
Section, Key, Setting, FileName)
End Sub
|
|