Temporäre tabellierte Abschlussmeldungsbox

[volti]

Wer's brauchen kann...

Liebe Leserin, lieber Leser,

nach Auswertungs- und Suchläufen o.ä. zeigt man ja gerne die Ergebnisse in einer MsgBox an.

Hierbei hat man häufig ein zweispaltiges Feld mit den Beschreibungen und jeweiliger Anzahl. Ggf. soll die Meldung auch nur für eine gewisse Zeit aktiv sein.
Schwierig hierbei ist es jedoch, die Werte sauber untereinander anzuzeigen und Zahlen ggf. rechtsbündig darzustellen.

Hier mal ein Beispiel, wie so etwas realisiert werden könnte.

   

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
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function SetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
' 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

Dim mhDlg   As LongPtr, miTimeOut   As Long
Dim mhTimer As LongPtr, miLang      As Long
Dim msTxt() As String, msTextlang() As String

Sub TabBox(ByVal sTxt As String, ByVal sCaption As String, _
           Optional iButton As Long, Optional iTimeOut As Long)
' Zeigt Text in Tabellenform in einer Messagebox an
  Dim sArrZl() As String, sArrSp() As String
  Dim iZl As Integer, iSp As Integer, iAnz As Integer, j As Integer, iLang As Integer
    
  miTimeOut = iTimeOut                                                  ' Laufzeit global machen
  
  sArrZl = Split(sTxt & " ", vbLf):     iAnz = UBound(sArrZl)           ' Text auf Zeilen aufsplitten
  sArrSp = Split(sArrZl(0), vbTab):     j = UBound(sArrSp)              ' Zeile auf Spalten aufsplitten
  ReDim msTxt(j): ReDim msTextlang(j)                                   ' Arrays einmalig dimensionieren
  
  For iZl = 0 To iAnz                                                   ' Alle Zeilen durchgehen
      sArrSp = Split(sArrZl(iZl) & String(j, vbTab), vbTab)             ' Zeile auf Spalten aufsplitten
      
      For iSp = 0 To j                                                  ' Alle Spalten durchgehen
          msTxt(iSp) = msTxt(iSp) & sArrSp(iSp) & IIf(iZl = iAnz, "", vbLf) ' Text für die Spalten kreieren
          If Len(sArrSp(iSp)) > Len(msTextlang(iSp)) Then
             msTextlang(iSp) = sArrSp(iSp)                              ' Längsten Text der Spalte merken
          End If
      Next iSp
  
  Next iZl
  miLang = Len(Join$(msTextlang)):   If miLang > 70 Then miLang = 70    ' Maximale Textbreite, ggf. anpassen
  mhTimer = SetTimer(0&, 0&, 10, AddressOf TabBox_CallBackProc)         ' Timer setzen
  MsgBox String(miLang, "e") & String(iAnz, vbLf) & "!", iButton, sCaption
  If mhTimer <> 0 Then KillTimer 0&, mhTimer                            ' Timer löschen
End Sub

Private Sub TabBox_CallBackProc()
' CallBack-Funktion für die TabBox
  Dim R As RECT
  Dim hStat As LongPtr, hFont As LongPtr
  Dim i As Integer, x As Long, w As Long, h As Long
 
  KillTimer 0&, mhTimer                                                 ' Timer löschen
  If miTimeOut > 0 Then mhTimer = SetTimer(0&, 0&, miTimeOut, AddressOf TabBox_TimeOutProc)
  
  mhDlg = GetActiveWindow                                               ' Handle der Dlg holen
  hStat = GetDlgItem(mhDlg, 65535)                                      ' Handle des Textfeldes ID=65535
  GetWindowRect mhDlg, R:  x = R.X1 + 8                                 ' Maße der Dialogbox holen
  GetWindowRect hStat, R:  x = R.X1 - x:  h = R.Y2 - R.Y1 + 5           ' Maße des Textfelds holen

' Schriftart des Textfeldes holen           &H31 = WM_GETFONT
  hFont = SendDlgItemMessageA(mhDlg, 65535, &H31, 0, 0)
  DestroyWindow hStat                                                   ' Textfeld entfernen

  For i = 0 To UBound(msTxt) ' 20 = Bereich um 20 Pixel horizontal verbreitern
      w = (R.X2 - R.X1 + 20) / miLang * Len(msTextlang(i))              ' Breite der Spalte errechnen
      hStat = CreateWindowExA(0, "STATIC", msTxt(i), _
              WS_TABBOX + IIf(i = 1, &H2, 0), _
              x, 33, w, h, mhDlg, 10000 + i, _
              Application.HinstancePtr, ByVal 0&)                       ' Weitere neue Labels erstellen
' Schriftart setzen                         &H30 = WM_SETFONT
      SendDlgItemMessageA mhDlg, 10000 + i, &H30, hFont, True           ' Schriftart zuordnen
      x = x + w                                                         ' Position für das nächste Textfeld
  Next i               ' 2 = ID des OK-Buttons
  SetDlgItemTextA mhDlg, 2, "Schließen"                                 ' Buttontext für OK-Button setzen
End Sub

Private Sub TabBox_TimeOutProc()
' TabBox schließen    &H10 = WM_CLOSE
  PostMessageA mhDlg, &H10, 0, 0
End Sub


' ############### Beispielaufruf #######################
Sub Aufruftest()
  Dim sMsg As String

  sMsg = "Anzahl der gefundenen Objekte" & vbTab & Format(5000, "##,##0") & vbTab & "   " & vbLf _
       & "   - davon Verzeichnisse" & vbTab & "125" & vbLf _
       & "   - davon Dateien" & vbTab & Format(4250, "##,##0") & vbLf _
       & "   - davon unidentifizierbar" & vbTab & "625" & vbLf & vbLf _
       & "erstelt am " & Date

  TabBox sTxt:=sMsg, sCaption:="Abschlussauswertung", iButton:=vbInformation, iTimeOut:=10000
End Sub

_________
viele Grüße
Karl-Heinz