Office: An die API Experten: Transparente Form ohne Titel und Rahmen

Gleitschirmflieger · 17. Oktober 2015

Hallo,

ich hoffe hier gibt es den einen oder anderen Experten was API betrifft.

Aufgabe:

Beim Start meiner Anwendung (Excel Workbook) soll für einige Sekunden ein Splash Screen erscheinen. Es soll ausschließlich ein Logo sichtbar sein.

Problem:

Ich benötige eine Transparente Userform ohne Titel und Rahmen auf der ich das Logo plaziere.

Bisherige Erkenntnis:

Die Lösung ist ein Aufruf verschiedener API Funktionen.
Ich habe diverse Code-Snippets gefunden die mir bereits Teillösungen liefern, scheitere jedoch daran diese in Kombination umzusetzten.

Mit diesem Code kann ich die komplette Userform inkl. Rahmen und Titel transparent machen, leider verschwinden auch alle Controls die sich auf der Userform befinden mit.

Code:

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2&

Public hWnd As Long

Private Sub UserForm_Initialize()
Dim bytOpacity As Byte
bytOpacity = 100 ' variable keeping opacity setting
hWnd = FindWindow("ThunderDFrame", Me.Caption)
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(Me.hWnd, 0, bytOpacity, LWA_ALPHA)
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mit diesem Code bekomme ich eine Userform ohne Titel.

Code:

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Private Sub UserForm_Initialize()
Dim hWnd As Long
hWnd = FindWindow(vbNullString, Me.Caption)
SetWindowLong hWnd, -16, &H84080080
DrawMenuBar hWnd
With Me
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleNone
End With
End Su
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mit diesem Code bekomme ich eine Userform ohne Rahmen.

Code:

Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub UserForm_Initialize()
Me.Width = 350: Me.Height = 350
CommandButton1.Left = (Me.Width - CommandButton1.Width) / 3
CommandButton1.Top = Me.Height * 0.6
End Sub

Private Sub UserForm_Activate()
Dim x As Long
Dim y As Long
Dim n As Long
Dim mWnd As Long
x = Me.Width
y = Me.Height
n = 4
mWnd = FindWindow(vbNullString, Me.Name)
SetWindowRgn mWnd, CreateRoundRectRgn(2, 2, x, y, n, n), True
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mit diesm Code bekomme ich eine Userform deren Hintergrud transparent ist, die Controls jedoch sichtbar bleiben. (Fast schon was ich brauche ...)
Code:

Private Declare Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLongA Lib "user32.dll" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLongA Lib "user32.dll" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const GWL_EXSTYLE = -20&
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const GC_CLASSNAME_USERFORM = "ThunderDFrame"

Private Sub UserForm_Initialize()
Dim lngHwnd As Long, lngStyle As Long
Dim lngBackColor As Long
lngBackColor = RGB(254, 254, 254)
BackColor = lngBackColor
lngHwnd = FindWindowA(GC_CLASSNAME_USERFORM, Caption)
lngStyle = GetWindowLongA(lngHwnd, GWL_EXSTYLE)
lngStyle = lngStyle Or WS_EX_LAYERED
Call SetWindowLongA(lngHwnd, GWL_EXSTYLE, lngStyle)
Call SetLayeredWindowAttributes(lngHwnd, lngBackColor, 0&, LWA_COLORKEY)
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Meine Versuche diese Code-Snippets so zu kombinieren, dass ich zum gewünschten Ergebnis komme scheitern seit gut einer Woche ... einzige Erkenntnis ist dass meine Logik und mein Gehirnschmalz bei API recht schnell an Grenzen stößt. *frown.gif*

Falls hier jemand seine Hilfe anbieten möchte/könnte wäre ich sehr dankbar.

Gruß,
Frank

:)

Gleitschirmflieger · 19. Oktober 2015

... noch eine Version der UserForm ohne Rahmen.
Das ist schon genau was ich brauche.
Jetzt muss ich den Hintergrung nur noch transbarent bekommen ... *rolleyes.gif*

Code:

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private wHandle As Long
Private Sub UserForm_Initialize()
Dim lStyle As Long
Dim frm As Long
If Val(Application.Version) >= 9 Then
wHandle = FindWindow("ThunderDFrame", Me.Caption)
Else
wHandle = FindWindow("ThunderXFrame", Me.Caption)
End If
If wHandle = 0 Then Exit Sub
lStyle = GetWindowLong(wHandle, GWL_STYLE)
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
SetWindowLong wHandle, -20, frm
SetWindowLong wHandle, GWL_STYLE, lStyle
DrawMenuBar wHandle
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Nepumuk · 19. Oktober 2015

Hallo,

das ist nicht so einfach denn ich muss das Userform pixelweise abtasten und die entsprechenden Pixel bei Bedarf löschen. Das dauert natürlich seine Zeit. Dafür wäre es möglich unregelmäßige Formen darzustellen.

R J · 19. Oktober 2015

...ich hab mal Deine Codes kombiniert...

Code:

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32.dll" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
Private Const LWA_COLORKEY = &H1
Private Const GC_CLASSNAME_USERFORM = "ThunderDFrame"
Private wHandle As Long

Private Sub UserForm_Initialize()
Dim lStyle As Long
Dim frm As Long
Dim lngHwnd As Long
Dim lngBackColor As Long
lngBackColor = RGB(254, 254, 254)
BackColor = lngBackColor

If Val(Application.Version) >= 9 Then
wHandle = FindWindow("ThunderDFrame", Me.Caption)
Else
wHandle = FindWindow("ThunderXFrame", Me.Caption)
End If
If wHandle = 0 Then Exit Sub
lStyle = GetWindowLong(wHandle, GWL_STYLE)
Me.Caption = ""
lStyle = lStyle And Not WS_SYSMENU
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_CAPTION
SetWindowLong wHandle, -20, frm
SetWindowLong wHandle, GWL_STYLE, lStyle
lngHwnd = FindWindowA(GC_CLASSNAME_USERFORM, Caption)

DrawMenuBar wHandle
Call SetLayeredWindowAttributes(lngHwnd, lngBackColor, 0&, LWA_COLORKEY)

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Gleitschirmflieger · 19. Oktober 2015

Hallo Nepumuk,

vielen Dank für Deine Antwort und Deine Beispieldatei.

Ich habe noch ein wenig rumexperimentiert und bin nah an dem gewünschten Ergebnis. Bin gerade noch auf der Suche nach dem Wert bzw der Variablen mit der ich den Rahmen der Form im API ansprechen kann.

Hier hier das fast schon perfekte Ergebnis:
http://www.ms-office-forum.net/forum...1&d=1445273572

Gleitschirmflieger · 19. Oktober 2015

Hey RJ,

... auch Dir vielen Dank für Deine Hilfe.
Gerade gestest, ... Titel und Rahmen sind weg, transparent ist die Userform aber leider nicht.
Ich schau mal ob ich das noch hinbekomme.
DANKE!

Nepumuk · 19. Oktober 2015

Hallo,

schneide den Rahmen einfach ab. Beispiel:

xlph · 19. Oktober 2015

Hallo,

die UF transparent erscheinen zu lassen ist doch nicht nötig.

Pass die Größe der UF dem Bild an.

Hier ein Bsp. mit Fortschhrittsanzeige.

Gleitschirmflieger · 19. Oktober 2015

Hallo,

(vorweg SORRY fuer die fehlenden Umlaute, hab zuhause nur US Tastatur *tongue.gif* )

@Nepumuk:

Deine Loesung fuehrt zum gewuenschten Ergebnis und ist somit gut.
Danke dafuer!
Wenn mich nicht das Gefuehl plagen wuerde, dass ich die UF nicht schon ohne Rahmen erstellen koennte ...
Ich bin eher der Typ der seinen Burger von vorneherein ohne Gurke bestellt anstatt sie dann runterzupfluecken *grins

@xlph

Auch eine super Loesung, ... und vor allem ohne laestige API Schnoerksel.
Wenn man einfach nur ein rechteckiges Bild als Splash verwenden will ist das perfekt!
Auch Dir vielen Dank fuer Deine Loesung!

Meine Vision, bzw mein Vorhaben:

Der Splash soll ein Schriftzug sein, dessen Buchstaben "erhaben" in der Mitte des Bildschirms erscheinen oder eben ein Logo welches wie ausgestanzt wirkt.

Ich weiss, SchnickSchnack *rolleyes.gif*

Aber ich habs hinbekommen!
Hier die (sogar recht schlanke und elegante) Loesung:

Folgenden Code einfach in das Code-Modul einer UserForm kopieren, im Eigenschaftsfenster der UserForm unter "Bild" bzw "Picture" ein Gif mit transparentem Hintergrund laden, ... fertig ist der LOGO-SPLASH.

Code:

Option Explicit

Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
#If Win64 Then
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As Long
#Else
Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const LWA_COLORKEY = &H1
Private Const TRANSPARENT_COLOUR = 255
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const GWL_STYLE As Long = -16
Private Const WS_CAPTION = &HC00000
Private lngHwnd As Long
Private lngStyle As Long
Private lngRetVal As Long

Private Sub UserForm_Initialize()
Me.StartUpPosition = 2
Me.BackColor = TRANSPARENT_COLOUR
lngHwnd = FindWindow("ThunderDFrame", Me.Caption)
lngStyle = 0
lngStyle = GetWindowLong(lngHwnd, GWL_STYLE) And Not WS_CAPTION
lngRetVal = SetWindowLong(lngHwnd, GWL_STYLE, lngStyle)
lngRetVal = SetWindowLong(lngHwnd, GWL_EXSTYLE, WS_EX_APPWINDOW Or WS_EX_LAYERED)
lngRetVal = SetLayeredWindowAttributes(lngHwnd, TRANSPARENT_COLOUR, 0&, LWA_COLORKEY)
DrawMenuBar lngHwnd
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Hier noch meine Beispieldatei:

xlph · 19. Oktober 2015

yap, effektvoll *cool.gif*

ASE · 19. Oktober 2015

Hallo Gleitschirmflieger,
ist eine tolle Sache, gefällt mir super. Wie bekommst Du es hin das das Pic ohne Hintergrund bleibt?

Gleitschirmflieger · 19. Oktober 2015

Hallo ASE,

das Bild muss ein GIF-Format sein.
Im Gegensatz zu .jpg und .bmp kann ein .gif Bild einen transparenten Hintergrund haben.
Es gibt auch andere Formate die das unterstützen (. png) aber Deine UserForm bzw. der VB-Editor akzeptiert soweit ich weiß nur .bmp und .gif.

Wie Du .gif-Bilder mit transparentem Hintergrund erstellst, kannst Du bei Google erfragen bzw. gibt es jede Menge Tutorials dazu auf YouTube.
Als kostenloses und gutes Tool hierzu empfehle ich GIMP.

Gruß,
Frank

PS: ... und ein "Servus" vom Würzburger an den fränkischen Landsmann *wink.gif*

drzwockel · 19. Oktober 2015

...

ein wirklich sehr schöner Effekt ... das passt!

Office: An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen

An die API Experten: Transparente Form ohne Titel und Rahmen - Similar Threads - API Experten Transparente

Seit O365 Problem mit Callback-Funktion

Aktuelle Daten aus dem Internet per API/VBA in Excel ziehen

API Excel Zugriff (via Daten abrufen)

Daten von Website (mit API?) in Excel einfügen und aktualisieren

REST API ansprechen + JSON

MS Project - API Aufrufe

Graph Api Berechtigungs Probleme beim Abrufen der Emailadressen aller Nutzer