ChooseColor x64
frose
versuche mich gerade an der Farbauswahl-Funktion aus dem Buch "Das
Excel-VBA Codebook" von Melanie Breden und Michael Schwimmer.
Da ich die 64-Bit Variante von Excel installiert habe funktioniert die
Funktion (natürlich) nicht!
Dabei reicht es nicht, nur den Declare mit PtrSafe zu versehen, es
gibt noch Probleme mit dem Datenformat Long und LongPtr.
Leider reichen meine VBA/API-Kenntnisse nicht aus, um die Funktion
auch auf meinem x64-System zum Laufen zu bekommen, kann jemand helfen?
Hier die Originalfunktion:
-------------------------------------------------------------------------------------------------------------------------------
Option Explicit
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Declare Function CHOOSEMYCOLOR _
Lib "comdlg32.dll" Alias "ChooseColorA" ( _
pChoosecolor As CHOOSECOLOR _
) As Long
Sub TestChooseColor()
Dim strColor As String
Dim lngRGB As Long
Dim bytR As Byte
Dim bytG As Byte
Dim bytB As Byte
lngRGB = ColorDialog()
'Überprüfen, ob Fehlerwert zurückgeliefert wurde
If lngRGB = &HFFFFFFFF Then Exit Sub
'In einen Hexstring mit den letzten 6 Stellen umwandeln
strColor = String(6 - Len(Hex(lngRGB)), _
Asc("0")) & Hex(lngRGB)
'Die einzelnen Farbanteile extrahieren
bytR = CByte("&H" & Right(strColor, 2))
bytG = CByte("&H" & Mid(strColor, 3, 2))
bytB = CByte("&H" & Left(strColor, 2))
MsgBox "RGB-Farbe = " & lngRGB & " (" & strColor & ")" & _
vbCrLf & "Rotanteil = " & bytR & _
vbCrLf & "Grünanteil = " & bytG & _
vbCrLf & "Blauanteil = " & bytB
End Sub
Public Function ColorDialog() As Long
Dim udtChoosecolor As CHOOSECOLOR
Dim alngCustomColors(1 To 16) As Long
' Funktion mit Fehlerwert vorbelegen
ColorDialog = &HFFFFFFFF
'Die benutzerdefinierten Farben vorbelegen
alngCustomColors(1) = RGB(255, 0, 0) 'Rot
alngCustomColors(2) = RGB(0, 255, 0) 'Grün
alngCustomColors(3) = RGB(0, 0, 255) 'Blau
alngCustomColors(4) = RGB(255, 255, 255) 'Weiß
alngCustomColors(5) = RGB(0, 0, 0) 'Schwarz
alngCustomColors(6) = RGB(255, 0, 0) 'Rot
alngCustomColors(7) = RGB(0, 255, 0) 'Grün
alngCustomColors(8) = RGB(0, 0, 255) 'Blau
alngCustomColors(9) = RGB(255, 255, 255) 'Weiß
alngCustomColors(10) = RGB(0, 0, 0) 'Schwarz
alngCustomColors(11) = RGB(255, 0, 0) 'Rot
alngCustomColors(12) = RGB(0, 255, 0) 'Grün
alngCustomColors(13) = RGB(0, 0, 255) 'Blau
alngCustomColors(14) = RGB(255, 255, 255) 'Weiß
alngCustomColors(15) = RGB(0, 0, 0) 'Schwarz
alngCustomColors(16) = RGB(255, 0, 0) 'Rot
' Zeiger als Wert auf die benutzerdefinierten Farben
udtChoosecolor.lpCustColors = VarPtr(alngCustomColors(1))
' Größe der Struktur in Bytes
udtChoosecolor.lStructSize = Len(udtChoosecolor)
'Den Dialog aufrufen
If CHOOSEMYCOLOR(udtChoosecolor) <> 0 Then
' Farbe wurde gewählt
' Den gewählten RGB Wert zurückgeben
ColorDialog = udtChoosecolor.rgbResult
End If
End Function
-------------------------------------------------------------------------------------------------------------------------------
Danke im Voraus
Michael Schwimmer
Am Thu, 9 Sep 2010 03:35:43 -0700 (PDT) schrieb frose:
> Da ich die 64-Bit Variante von Excel installiert habe funktioniert die
> Funktion (natürlich) nicht!
>
> Dabei reicht es nicht, nur den Declare mit PtrSafe zu versehen, es
> gibt noch Probleme mit dem Datenformat Long und LongPtr.
Ich kann mangels 64 Bit-Version leider nichts testen. Ich habe mich jetzt
mal auf der Microsoft-Seite
http://msdn.microsoft.com/de-de/library/ee691831.aspx
umgeschaut.
Demnach könnte folgende Deklaration mit beiden Versionen funktionieren:
#If VBA7 Then
' http://msdn.microsoft.com/de-de/library/ee691831.aspx
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As Long
lpCustColors As LongPtr
flags As Long
lCustData As Long
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function CHOOSEMYCOLOR _
Lib "comdlg32.dll" Alias "ChooseColorA" ( _
pChoosecolor As CHOOSECOLOR _
) As Long
#Else
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Declare Function CHOOSEMYCOLOR _
Lib "comdlg32.dll" Alias "ChooseColorA" ( _
pChoosecolor As CHOOSECOLOR _
) As Long
#End If
Die Namen, welche mit h oder lp beginnen, stehen für Pointer und sollten
den Datentyp LongPtr erhalten.
Viele Grüße
Michael
Michael Schwimmer
ein kleiner Nachtrag
Am Thu, 9 Sep 2010 19:21:08 +0200 schrieb Michael Schwimmer:
> Private Type CHOOSECOLOR
> lStructSize As Long
> hwndOwner As LongPtr
> hInstance As LongPtr
> rgbResult As Long
> lpCustColors As LongPtr
> flags As Long
> lCustData As Long
> lpfnHook As LongPtr
> lpTemplateName As String
> End Type
Ich weiß momentan noch nicht, wie es die 64-Bit Version mit der Ausrichtung
der Elemente in einem UDT nimmt. Es kann sein, dass die LongPtr bei VBA7 an
8-Byte Speicheradressen ausgerichtet sind, so dass zwischen einem
(einzelnen) Long und einem LongPtr 4 Füllbytes eingeschoben werden, also in
dem obigen UDT hinter lStructSize und rgbResult.
In der 32-Bit Version werden bei einem Long, Integer, Long 2 Bytes zwischen
dem Integer und dem Long geschoben, konsequenterweise sollte ähnliches dann
auch in der 64-Bit Welt gelten.
Also bei folgender Zeile besser ein lenB verwenden:
' Größe der Struktur in Bytes
udtChoosecolor.lStructSize = LenB(udtChoosecolor)
Viele Grüße
Michael
frose
danke für die schnelle Antwort, leider funktioniert es (noch) nicht.
Das Programm wird jetzt zwar fehlerfrei kompiliert und ausgeführt,
aber der Dialog öffnet sich nicht:
'Den Dialog aufrufen
If CHOOSEMYCOLOR(udtChoosecolor) <> 0 Then
Grüße
Frank
Michael Schwimmer
ich habe mir jetzt mal unter
folgendes
Office 2010 Help Files: Win32API_PtrSafe with 64-bit Support
heruntergeladen.
Die korrekte 64-Bit Deklaration gamäß der Datei Win32API_PtrSafe.TXT lautet
demnach:
Private Type CHOOSECOLOR
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
rgbResult As Long
lpCustColors As LongPtr
flags As Long
lCustData As LongPtr
lpfnHook As LongPtr
lpTemplateName As String
End Type
Private Declare PtrSafe Function CHOOSEMYCOLOR Lib "comdlg32.dll" Alias
"ChooseColorA" (pChoosecolor As CHOOSECOLOR) As Long
Viele Grüße
Michael
frose
ja, es funktioniert jetzt!
Vielen Dank und bis zum nächsten Mal.
Viele Grüße aus Rietberg
Frank
Michael Schwimmer
Am Sat, 11 Sep 2010 03:18:05 -0700 (PDT) schrieb frose:
> Hallo Michael,
> ja, es funktioniert jetzt!
freut mich, dass es klappert ;-)
Und vielen Dank für die Rückmeldung.
Viele Grüße
Michael