MsgBox - Schriftart und -größe ändern

[volti]

Liebe Leserin, lieber Leser,

manchmal wird in Foren gefragt, ob man nicht die Schriftart und/oder die Schriftgröße einer MessageBox ändern kann.

Die Standardaussage hierzu: nein, das geht nicht, bau Dir eine Userform.

Dass es aber doch geht, möchte ich hier an drei Beispielen mal aufzeigen.

Über den Windows-Messageparameter WM_SETFONT kann man dem Textlabel der MsgBox einen anderen Font zuweisen, der u.a. die Schriftgröße, Schriftart, aber auch kursv, unterstrichen und fett bereitstellt.

Problem ist hier allerdings, dass bei größeren Fonts der Text u.U. nicht mehr in das Textlabel passt und ggf. abgeschnitten wird.
Die MsgBox formatiert ihre Größe ja stur nach eigenem Gusto. Ein Anpassung wäre nur mit einigem Mehraufwand möglich, da dann alles mit eigenm Code nachgeschliffen werden muss.

Über Verlängern des zu übergebenden Text mit Leerzeichen und/oder vbLF kann die MsgBox gezwungen werden, ihre Größe entsprechend zu verändern, bevor der Font verändert wird.
Hundertprozentig treffsicher ist das aber leider nicht. Aber da kann man ja tüfteln.

BTW: Die Schriftfarbe kann hiermit leider nicht verändert werden. Da wird man wohl den Text mit der gewünschten Farbe erneut schreiben müssen.

   

So, und nun viel Spaß und Erfolg beim Ausprobieren und Anwenden.

Code:

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59

' Timer Funktionen Private Declare PtrSafe Function SetTimer Lib "user32" ( _         ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _         ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr Private Declare PtrSafe Function KillTimer Lib "user32" ( _         ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long ' Messages Funktionen Private Declare PtrSafe Function SendMessageA Lib "user32" ( _         ByVal hwnd As LongPtr, ByVal wMsg As Long, _         ByVal wParam As LongPtr, lParam As Any) As LongPtr ' Fenster Funktionen Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _         ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _         ByVal nHeight As Long, ByVal nWidth As Long, _         ByVal nEscapement As Long, ByVal nOrientation As Long, _         ByVal fnWeight As Long, ByVal fdwItalic As Long, _         ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _         ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _         ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _         ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _         ByVal hObject As LongPtr) As Long Dim mhTimer As LongPtr, mhFont As LongPtr Sub MsgBoxSA(ByVal sTxt As String, Optional ByVal sCaption As String = "Excel", Optional iSG As Integer = 16, _             Optional sSA As String = "ARIAL", Optional iButton As Long) ' Schriftart einer Messagebox ändern   mhFont = CreateFontA(iSG, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, sSA)   If mhFont <> 0 Then mhTimer = SetTimer(0&, 0&, 10, AddressOf MsgBox_CallBack_Proc)   MsgBox sTxt & IIf(iSG > 16, String(Len(sTxt) \ 2, " "), ""), iButton, sCaption   If mhFont <> 0 Then DeleteObject mhFont: mhFont = 0 End Sub Private Sub MsgBox_CallBack_Proc() ' CallBack-Funktion für die MsgBox   KillTimer 0&, mhTimer                                                ' Timer löschen ' Schriftart setzen &H30 = WM_SETFONT   SendMessageA GetDlgItem(GetActiveWindow, 65535), &H30, mhFont, True  ' Font zuweisen End Sub ' _ ####################################################################################### Sub Lucida()   MsgBoxSA "Hier wird Lucida Handwriting verwendet und die Schrift ist auch größer geworden!", "Mein Lucida-Text", _           20, "Lucida Handwriting", vbInformation End Sub Sub Courier()   sTxt = "Hubert    Meier    München" & vbLf _       & "Antonius  Kurz      Hamburg" & vbLf _       & "Ulla      Hansmanns Frankfurt"   MsgBoxSA ByVal sTxt, "Mein Courier-Text", 20, "Courier", vbInformation End Sub Sub Symbol()   MsgBoxSA "Hallo, ich kann auch etwas Griechisches schreiben!  ", , 20, "Symbol", vbInformation End Sub

____________
viele Grüße ?
Karl-Heinz