Text tabelliert in MsgBox anzeigen

[volti]

Liebe Leserin, lieber Leser,

um mehrzeiligen Text spaltenweise in einer Messagebox anzuzeigen, ist die Excel-MsgBox ja eigentlich nicht geeignet.

Das Hinzufügen von entsprechenden Leerzeichen oder die Verwendung von Tabs führen wegen der unterschiedlichen Buchstabenbreiten nur teilweise zum Ziel.
Meistens sieht das hässlich aus. Die MsgBox macht halt was sie will.

Für mein derzeitiges Projekt wurde jedoch das Anzeigen mehrerer Auswertungen mit unterschiedlichen Spaltenanzahlen und Datenzeilen erforderlich.
Hierbei sollte sich die Anzeigebox auch der Datenmenge anpassen.

Meinen Lösungsweg stelle ich hier gern als Beispiel zur Verfügung:

Der der Msgbox übergebene Text wird in einem Array neu zusammengestellt und in mehreren Textlabels in der MsgBox angezeigt.
Das Hinzufügen einer Umrandung und Spacing sowie ein eigenes Icon ist hierbei optional.

PS: Die Messagebox kann leider nur eine maximale Breite bereitstellen, so dass der anzuzeigende Text u.U. ein wenig eingeschränkt ist.
Im Worstcase wird er automatisch umgebrochen und kann zu Anzeigefehlern führen.

Wer's ausprobieren möchte; hier ist code und Beispieldatei...

   

   

Viel Spaß beim Ausprobieren.

Code:

' 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 SendDlgItemMessageA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' Fenster Funktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CreateWindowExA Lib "user32" ( _
        ByVal dwExStyle As Long, _
        ByVal lpClassName As String, ByVal lpWindowName As String, _
        ByVal dwStyle As Long, _
        ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hWndParent As LongPtr, _
        ByVal hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" ( _
        ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
   X1 As Long       ' Left
   Y1 As Long       ' Top
   X2 As Long       ' Right
   Y2 As Long       ' Bottom
End Type
Private Const WS_TABBOX As Long = &H40000000 + &H10000000   ' WS_CHILD | WS_VISIBLE
Private Const miZR As Integer = 3                           ' für Borderzwischenabstand hier Breite einstellen
Private Const msRef As String = "e"                         ' Referenz für mittlere Buchstabenbreite
Private Const miMax As Integer = 70                         ' Msgbox bricht bei "e" nach maximal 70 Zeichen um ggf. anpassen


Dim miBorder As Long, miLang      As Long
Dim mhTimer  As LongPtr, hIcon    As LongPtr
Dim msTxt()  As String, miBreit() As Double

Sub TabBox(ByVal sTxt As String, ByVal sCaption As String, Optional iButton As Long, _
           Optional sSep As String = "|", Optional bBorder As Boolean, Optional sIcon As String)
' Zeigt Text in Tabellenform in einer Messagebox an, alternativ mit _
 Umrandung
' Vorbereitung der Daten und Spaltenbreiten
' Als Übergabe an die Msgbox nur ein Referenztext mit erster _
 Zeile=Breite + Anzahl vbLF=Höhe
  Dim sArrZl() As String, sArrSp() As String, T As String
  Dim sBorder As String, sLang() As String
  Dim iZl As Integer, iSp As Integer, iAnz As Integer, j As Integer, iLang As Integer
    
  If sTxt = "" Then Exit Sub
  miBorder = IIf(bBorder, &H800000, 0): sBorder = IIf(bBorder, " ", "") ' Umrandung gewünscht?
  sArrZl = Split(sTxt, vbLf): iAnz = UBound(sArrZl)                     ' Text auf Zeilen aufsplitten
  sArrSp = Split(sArrZl(0), sSep): j = UBound(sArrSp)                   ' Zeile auf Spalten aufsplitten
  ReDim msTxt(j): ReDim miBreit(j): ReDim sLang(j)                      ' Arrays einmalig dimensionieren
  
  For iZl = 0 To iAnz                                                   ' Alle Zeilen durchgehen
      sArrSp = Split(sArrZl(iZl) & sSep & sSep & sSep & sSep, sSep)     ' Zeile auf Spalten aufsplitten
      
      For iSp = 0 To j                                                  ' Alle Spalten durchgehen
          If UBound(sArrSp) < j Then
             T = sBorder & " " & sBorder                                ' Leerzelle
          Else
             T = sBorder & sArrSp(iSp) & sBorder                        ' Bei Border links u. rechts Leerzeichen
          End If
          msTxt(iSp) = msTxt(iSp) & T & IIf(iZl = iAnz, "", vbLf)       ' Text für die einzelnen Spalten kreieren
          If Len(T) > Len(sLang(iSp)) Then
             sLang(iSp) = T: miBreit(iSp) = Len(T)                      ' Längsten Text der Spalte merken
          End If
      Next iSp
  
  Next iZl
  miLang = Len(Join$(sLang)): If miLang > miMax Then miLang = miMax ' Maximale Textbreite
' Icon-Handle ermitteln
  If sIcon <> "" Then hIcon = ActiveSheet.OLEObjects(sIcon).Object.Picture.Handle
  mhTimer = SetTimer(0&, 0&, 10, AddressOf TabBox_CallBackProc)
  MsgBox String(miLang, msRef) & String(iAnz, vbLf) & "!", iButton, sCaption

End Sub

Private Sub TabBox_CallBackProc()
' CallBack-Funktion für die TabBox
  Dim R As RECT
  Dim hStat1 As LongPtr, hStat2 As LongPtr, hDlg As LongPtr, hFont As LongPtr
  Dim i As Integer, x As Long, w As Long, h As Long
 
  KillTimer 0&, mhTimer                                            ' Timer löschen
  hDlg = GetActiveWindow                                           ' Handle der Dlg holen
  If hIcon <> 0 Then SendDlgItemMessageA hDlg, 20, &H170, hIcon, 0 ' Optional Icon setzen
  hStat1 = GetDlgItem(hDlg, 65535)                                 ' ID des Labels holen
  GetWindowRect hDlg, R:    x = R.X1 + 8                           ' Maße der Dialogbox holen
  GetWindowRect hStat1, R:  x = R.X1 - x:  h = R.Y2 - R.Y1 + 5     ' Maße des Textfelds holen
' Schriftart holen                         &H31 = WM_GETFONT
  hFont = SendDlgItemMessageA(hDlg, 65535, &H31, 0, 0)
  DestroyWindow hStat1                                             ' Original Textbereich entfernen

  For i = 0 To UBound(msTxt) ' 20 = Bereich um 20 Pixel hor. verbreitern
      w = (R.X2 - R.X1 + 20) / miLang * miBreit(i)                 ' Breite der Spalte errechnen
      hStat2 = CreateWindowExA(0, "STATIC", msTxt(i), _
               WS_TABBOX + miBorder, x, 33, w, h, hDlg, _
               10000 + i, Application.HinstancePtr, ByVal 0&)      ' Weitere neue Labels erstellen
' Schriftart setzen                        &H30 = WM_SETFONT
      SendDlgItemMessageA hDlg, 10000 + i, &H30, hFont, True
      x = x + w + miZR                                             ' Nächstes Feld
  Next i
End Sub

_________
viele Grüße
Karl-Heinz

[Glausius]

Hallo Karl-Heinz,

das ist ja eine feine Sache, die du da für Alle bereitstellst - allerdings ist dir da ein Lapsus unterlaufen, den ich sehr gut von mir selbst kenne:
In der bereitgestellten Mustertabelle sind im VBA-Code drei Prozeduren, die sicherlich von dir nur zu Testzwecken eingebaut worden sind und mit der eigentlichen Vorlagen nichts zu tun haben (Sub Lucida(), Sub Courier() und Sub Symbol()) - oder hab ich recht?