Textbox oder Zellbereich an fester Position dauerhaft anzeigen

[volti]

Hallo liebe Leserin, lieber Leser,

zur dauerhaften Anzeige eines Textboxinhaltes oder eines Zellbereichs an fester Position auf dem Bildschirm (Bild) kann man sich ein eigenes Windows-Fenster erstellen und dann per Copy, also über die Zwischenablage, mit dem gewünschten Inhalt füllen.

Da es ein von Excel unabhängiges Fenster ist, bleibt es immer sichtbar, auch wenn das Registerblatt gewechselt wird oder Excel verschoben oder verkleinert wird.
Durch die Eigenschaft "allways on top" wird das Fenster nicht von anderen Fenstern verdeckt.

Die Funktionalität ist bewusst auf das bloße Anzeigen beschränkt, es sind also keine Button oder das Systemkreuz enthalten. Hierdurch kann der Code für weitergehendes Fensterhandling entfallen.
Bedeutet allerdings dann auch, dass das Fenster von VBA auch wieder ausgeschaltet werden muss.

Hinweis: Wird die Infobox mit Caption aufgerufen, kann sie vom User auch verschoben werden. Wegen des fehlenden Fensterhandlings wird sie jedoch, wenn sie über den Bildschirm hinausgeschoben wird, nicht neu gezeichnet.

In der Beispieldatei ist eine entsprechende Demo enthalten.

  CreateWindow_Textfeld.xlsb (Größe: 43,76 KB / Downloads: 5)

Und nun viel Spaß beim Ausprobieren...

Code:

Option Explicit
' Fenstererstellung und -handling
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 FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function DestroyWindow Lib "user32" ( _
        ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetWindowPos Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, _
        ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
' Zwischenablagefunktionen
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
        ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
        ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" ( _
        ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
' Bild einfügen
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
        ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" ( _
        ByVal hDestDC As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
        ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, _
        ByVal dwRop As Long) As Long

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Const WS_EX_MYWINDOW = &H40008  ' WS_EX_APPWINDOW + WS_EX_TOPMOST
'Private Const WS_MYWINDOW = &H90800000 ' WS_BORDER + WS_POPUP + _
 WS_VISIBLE
Private Const WS_MYWINDOW = &H90000000  ' WS_POPUP + WS_VISIBLE
Private Const WS_CAPTION = &HC00000

Private Sub Infobox(sCaption As String, vBer As Variant, Optional lStyle As Long = WS_CAPTION, _
                    Optional x As Long, Optional y As Long)
  Dim hwnd As LongPtr, hBmp As LongPtr, hDC As LongPtr, hTrgDC As LongPtr
  Dim R As RECT, iOffH As Long, iOffB As Long, cZoom As Currency
  
  If sCaption = "" Then Exit Sub                         ' Kein gültiger Caption angegeben =>raus
  
  If lStyle <> 0 Then iOffH = 46: iOffB = 4              ' Bei Höhe Caption berücksichtigen
  hwnd = FindWindowA("#32770", sCaption)                 ' Handle des gewünschten Fensters ermitteln
  Select Case TypeName(vBer)
  Case "String": If hwnd <> 0 Then DestroyWindow hwnd    ' Infobox schließen =>raus
  Case "Shape": cZoom = 1.34                             ' Ggf. Umrechnung anpassen
  Case "Range": cZoom = 1.67                             ' Ggf. Umrechnung anpassen
  End Select
  If cZoom = 0 Then Exit Sub
  vBer.Copy                                              ' Object, Bereich kopieren
  R.Right = vBer.WIDTH * cZoom: R.Bottom = (vBer.HEIGHT * cZoom)
  
  If hwnd = 0 Then                                       ' Neue Infobox starten
     If x = 0 Then _
        x = (GetSystemMetrics(0) - R.Right) \ 2          ' X-Position
     If y = 0 Then _
        y = (GetSystemMetrics(1) - R.Bottom) \ 2         ' Y-Position
     hwnd = CreateWindowExA(WS_EX_MYWINDOW, "#32770", _
            sCaption, WS_MYWINDOW Or lStyle, x, y, _
            R.Right + iOffB, R.Bottom + iOffH, 0&, 0&, _
            Application.HinstancePtr, ByVal 0&)
  End If
  
  OpenClipboard 0                                        ' Zwischenablage öffnen
  If IsClipboardFormatAvailable(2) Then ' CF_BITMAP      ' Ist Bitmap in Zwischenablage?
     hDC = GetDC(hwnd)                                   ' Device Context des Fensters holen
     hBmp = GetClipboardData(2) ' 2 = CF_BITMAP          ' Bitmap-Handle aus Zwischenablage
     hTrgDC = CreateCompatibleDC(hDC)                    ' DC kreieren
     SelectObject hTrgDC, hBmp                           ' Bitmap in Device Context selektieren
     BitBlt hDC, 0, 0, R.Right, R.Bottom, hTrgDC, 0, 0, &HCC0020 ' Pixel kopieren  &HCC0020 = SRCCOPY
     ReleaseDC hwnd, hDC                                 ' Device Context auflösen
     EmptyClipboard                                      ' Zwischenablage leeren
  End If
  CloseClipboard                                         ' Zwischenablage schließen
End Sub

' ################# Starten Updaten Schließen #################

' Anzeigebox öffnen
Sub Show_MsgBox2()
  Call Infobox("MeineAnzeigebox", Sheets("Tabelle3").Range("$F3:$I10"), WS_CAPTION)
End Sub

Sub Show_MsgBox()
With ActiveWindow.ActivePane
     Call Infobox("MeineAnzeigebox", Sheets("Tabelle3").Shapes("Gruppieren 2"), 0, _
          .PointsToScreenPixelsX(Range("H1").Left), _
          .PointsToScreenPixelsY(Range("H1").Top))
  End With
End Sub

' Anzeigebox positionieren
Sub Move_MsgBox()
  With ActiveWindow.ActivePane
       SetWindowPos FindWindowA("#32770", "MeineAnzeigebox"), 0, _
                    ByVal .PointsToScreenPixelsX(Range("H1").Left), _
                    ByVal .PointsToScreenPixelsY(Range("H1").Top), _
                    0, 0, &H1 ' SWP_NOSIZE = &H1
  End With
End Sub

' Anzeigebox schließen
Sub Destroy_MsgBox()
  Call Infobox("MeineAnzeigebox", "Schließen")
End Sub

_________
viele Grüße
Karl-Heinz