Hallo Arno
Post by Thomas GahlerWerde ich dir heute oder morgen dann mal zusammenstellen.
prima, bin morgen auch online.
Also hier kommt was
Mach eine neues Projket
Erzeuge eine neue Userform (UserForm1)
Setze eine Textbox drauf (Textbox1)
Setze einen Commandbutton drauf (Commandbutton1)
Füge den nachstehenden Code in die entsprechenen Stellen ein
' --------- --------- --------- Start Modul1 --------- --------- ---------
Option Explicit
Public Const tgREGISTRY_KEY As String = "HKEY_CURRENT_USER\Software\Thomas
Gahler\CH4Makros\Word"
Public vDummy As Variant
Sub Demo()
UserForm1.Show
End Sub
' --------- --------- --------- Ende Modul1 --------- --------- ---------
' --------- --------- --------- Start
modRegistryUndINI --------- --------- ---------
Option Explicit
Private Const tgTEILSTRING_A255 As Integer = 5
Public Function funcGetPrivateProfileString( _
ByVal cDatei As String, _
ByVal CAbschnitt As String, _
ByVal CEintrag As String, _
ByVal CVorgabe As String) _
As Variant
'Die Funktion «funcGetPrivateProfileString» erweitert die Standardfunktion
'«PrivateProfileString» in sofern, dass ein Vorgabewert übergeben werden
'kann, welcher zurückgegeben wird falls der gesuchte Eintrag nicht gefunden
'wird.
Dim vWert As Variant
'Gesuchten Wert aus der Datei einlesen.
On Error Resume Next
vWert = System.PrivateProfileString(cDatei, CAbschnitt, CEintrag)
On Error GoTo 0
'Falls der Eintrag nicht vorhanden ist, Vorgabewert setzen.
If Len(vWert) = 0 Then
vWert = CVorgabe
End If
'Deutsche (Wahr, Falsch) String-Parameter in englische Boolean-Werte (True,
False) übersetzen.
If LCase$(vWert) = LCase$("Wahr") Then vWert = True
If LCase$(vWert) = LCase$("Falsch") Then vWert = False
If LCase$(vWert) = LCase$("True") Then vWert = True
If LCase$(vWert) = LCase$("False") Then vWert = False
funcGetPrivateProfileString = vWert
End Function
Public Function funcWritePrivateProfileString( _
ByVal cDatei As String, _
ByVal CAbschnitt As String, _
ByVal CEintrag As String, _
ByVal cWert As String)
'Wert in Datei schreiben.
System.PrivateProfileString(cDatei, CAbschnitt, CEintrag) = cWert
End Function
' --------- --------- --------- Ende
modRegistryUndINI --------- --------- ---------
' --------- --------- --------- Start
UserForm1 --------- --------- ---------
Option Explicit
'API-Call zum suchen des Handles des aktiven Fensters.
Private Declare Function GetActiveWindow Lib "user32" () As Long
'API-Call zum aufrufen des Dialoges «Farben» (CommenDialog),
'mit Definition der zugehörigen Datenstruktur.
Private Declare Function ChooseColorAPI Lib "comdlg32.dll" Alias
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As String
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Sub CommandButton1_Click()
Const tgBENUTZER_FARBEN As String = "÷o,ûè`»è`?æ"oíëtíÌ-éÜa°ûÐÄüâ-Öì'¶ñ·Î÷õ©ÇóÚµðìŠÎ"
Dim cc As CHOOSECOLOR
Dim CustomColors() As Byte
Dim lReturn As Long
Dim iZähler As Integer
Dim iPosition As Integer
Dim cBenutzerFarben As String
'Werte vorbelegen.
cBenutzerFarben = funcGetPrivateProfileString("", tgREGISTRY_KEY &
"\DokumentAssistent\Farbe", "BenutzerFarbenPalette", tgBENUTZER_FARBEN)
If Len(cBenutzerFarben) <> Len(tgBENUTZER_FARBEN) Then
cBenutzerFarben = cBenutzerFarben & String$(Len(tgBENUTZER_FARBEN) -
Len(cBenutzerFarben), Chr(0))
End If
'Das Format von 'lpCustColors' besteht aus 16 Farben welche mit 3 RGB-Werten
definert
'werden, jeder Wert wird mit einem 0 (Null) getrennt. Somit muss das Array
'CustomColors()'
'aus 64 Werten bestehen 16*(3+1) = 64 (also von 0 bis 63,
'xxx0yyy0...0zzz0').
'Benutzerdefinierte Farben zuerst auf schwarz setzen.
ReDim CustomColors(0 To 63) As Byte
For iZähler = LBound(CustomColors) To UBound(CustomColors)
CustomColors(iZähler) = 0
Next iZähler
'Benutzerdefinierte Farben mit den eigenen Werten belegen. Die Konstante
'bkBENUTZER_FARBEN'
'besteht nur aus den eigentlichen Werten ('xxxyyy...zzz') die 0 (Null)
wird in der
'FOR-Schleife hinzugefügt ('xxx0yyy0...0zzz0').
For iZähler = LBound(CustomColors) + 1 To UBound(CustomColors) + 1
If iZähler Mod 4 <> 0 Then
iPosition = iPosition + 1
CustomColors(iZähler - 1) = Asc(Mid$(cBenutzerFarben, iPosition,
1))
Else
CustomColors(iZähler - 1) = 0
End If
Next iZähler
'Datenstruktur der Funktion 'ChooseColorAPI' vorbelegen.
cc.lStructSize = Len(cc)
cc.hwndOwner = GetActiveWindow()
cc.hInstance = 0
cc.lpCustColors = StrConv(CustomColors, vbUnicode)
cc.flags = 0
'API-Call starten.
lReturn = ChooseColorAPI(cc)
If lReturn <> 0 Then
TextBox1.BackColor = cc.rgbResult
vDummy = funcWritePrivateProfileString("", tgREGISTRY_KEY &
"\DokumentAssistent\Farbe", "BenutzerFarbenHintergrund", cc.rgbResult)
'Benutzerdefinierte Farben aus Array auslesen.
cBenutzerFarben = ""
CustomColors = StrConv(cc.lpCustColors, vbFromUnicode)
For iZähler = LBound(CustomColors) + 1 To UBound(CustomColors) + 1
If iZähler Mod 4 <> 0 Then
cBenutzerFarben = cBenutzerFarben & Chr(CustomColors(iZähler -
1))
End If
Next iZähler
'Benutzerdefinierte Farben abspeichern.
If tgBENUTZER_FARBEN <> cBenutzerFarben Then
vDummy = funcWritePrivateProfileString("", tgREGISTRY_KEY &
"\DokumentAssistent\Farbe", "BenutzerFarbenPalette", cBenutzerFarben)
End If
End If
End Sub
' --------- --------- --------- Ende
UserForm1 --------- --------- ---------
Alles klar?
--
Thomas Gahler
MVP für WordVBA
Co-Autor von »Microsoft Word-Programmierung.
Das Handbuch« (MS Press)
- Windows XP (SP2), Office XP (SP3)