Clever-Excel-Forum - Workshops und Anleitungen

Userform transparent machen und Kopf und Rahmen entfernen

Wed, 18 Feb 2026 09:47:24 +0000

Hallo Forum,

kann man eine Userform auch transparent machen?

Ja, das kann man ganz einfach bewerkstelligen.
Indem man den Style der Userform auf WS_EX_LAYERED stellt und eine Farbe zuweist, deren Pixel dann transparent dargestellt werden.

Hier mal ein ganz einfacher, stark reduzierter Code als Beispiel.
Bitte beachten, dass der Hintergrund der Userform mit einer Farbe aus der Palette versehen wird und keine Systemfarbe verwendet wird.

Code:

Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" Alias "GetWindowLongPtrA" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hWnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, _
        ByVal dwFlags As Long) As Long

Private Sub UserForm_Activate()
' GWL_EXSTYLE = (-20&), WS_EX_LAYERED = &H80000, LWA_COLORKEY  = &H1
  SetWindowLongA GetActiveWindow, -20, _
  GetWindowLongA(GetActiveWindow, -20) Or &H80000
  SetLayeredWindowAttributes GetActiveWindow, BackColor, 0, 1
End Sub

Wer zusätzlich noch den Kopf und den Rahmen entfernen möchte, muss noch etwas mehr Aufwand betreiben.
Hier ein Beispiel, bei dem nur noch ein Textfeld und eine Schaltfläche sichtbar sind.
Die Userform wird zusätzlich noch an die gerade aktive Excelzelle platziert. So könnte man alle möglichen Spezialanwendungen programmieren.

Userform_TransparenteUserform.xlsb (Größe: 52,4 KB / Downloads: 4)

Code:

Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" Alias "GetWindowLongPtrA" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" (ByVal hWnd As LongPtr, _
         ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
 Private Declare PtrSafe Function GetWindowLongA Lib "user32" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
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 SetLayeredWindowAttributes Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, _
        ByVal dwFlags As Long) As Long
Private Declare PtrSafe Function SetWindowRgn Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Private Declare PtrSafe 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 LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CreateRectRgnIndirect Lib "gdi32" (lpRect As RECT) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
        ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type


Private Sub UserForm_Activate()
  Dim R As RECT, oCell As Range
  Dim hRegion As LongPtr, hWndUF As LongPtr
  Const GWL_EXSTYLE   As Long = (-20&)
  Const GWL_STYLE     As Long = (-16)
  Const WS_EX_LAYERED As Long = &H80000
  Const LWA_COLORKEY  As Long = &H1
  Const WS_CAPTION    As Long = &HC00000
  
  hWndUF = GetActiveWindow                      ' Userform: Handle holen
  SetWindowLongA hWndUF, GWL_STYLE, GetWindowLongA(hWndUF, GWL_STYLE) And Not WS_CAPTION
  SetWindowLongA hWndUF, GWL_EXSTYLE, GetWindowLongA(hWndUF, GWL_EXSTYLE) Or WS_EX_LAYERED
  SetLayeredWindowAttributes hWndUF, Me.BackColor, 0&, LWA_COLORKEY
  DrawMenuBar hWndUF                            ' Userform neu zeichnen
  
  GetWindowRect hWndUF, R                       ' Userform: Koordinaten holen
  R.Bottom = R.Bottom - R.Top - 8:  R.Top = 4   ' Bereich zurecht
  R.Right = R.Right - R.Left - 8:   R.Left = 4  ' schneiden
  hRegion = CreateRectRgnIndirect(R)            ' Eine Region erstellen
  SetWindowRgn hWndUF, hRegion, 1&              ' Region scharf schalten
  DeleteObject hRegion                          ' Region löschen
  
  Set oCell = ActiveCell                        ' Bindezelle setzen
  With ActiveWindow.ActivePane
       SetWindowPos hWndUF, 0&, _
                    .PointsToScreenPixelsX(oCell.Left - 3), _
                    .PointsToScreenPixelsY(oCell.Top - 3), _
                    0&, 0&, &H1 ' &H1 = SWP_NOSIZE
  End With

  Me.TextBox1.Value = ActiveCell.Value
End Sub

_________
viele Grüße
Karl-Heinz

Daten anonymisieren

Fri, 15 Aug 2025 13:39:49 +0000

[Daten anonymisieren Teil 1]

Hallöchen zusammen,

zur besseren Veranschaulichung von Problemen und gewünschten Lösungen ist oftmals eine Bereitstellung von Daten hilfreich oder erforderlich. Die Helfer können so, ohne die Dateien nachzubauen, mit der Lösungsfindung beginnen, eventuelle Lösungsansätze mit den bereitgestellten Daten testen und den gewünschten Lösungen vergleichen.

Der Datenschutz gebietet, dass das natürlich nicht mit Originaldaten, insbesondere Firmen - und Mitarbeiterdaten, geschieht. Bereitgestellte Dateien sollten daher immer entsprechend anonymisierte Daten enthalten. Daten werden dabei willkürlich ersetzt, sodass im Gegensatz zu einer Verschlüsselung eine Entschlüsselung nicht möglich sein sollte.

Die Ersetzung sollte natürlich so erfolgen, dass keine Rückschlüsse auf die Originaldaten möglich sind. Einfach nur Buchstaben durcheinander zu bringen reicht da z.B. nicht. hzine lässt sicher den Namen Heinz vermuten ...

Die Anonymisierung kann man manuell durchführen oder auch makrogestützt. Hier in diesem ersten Teil stelle ich kurz eine Formellösung anhand Vor- und Nachnamen in 5 Schritten vor.

Anton

Freitag

Anton

Name01

Freitag

NachName01

Name01

NachName01

Berta

Schön

Berta

Name02

Schön

NachName02

Name02

NachName02

Caesar

Glöckner

Caesar

Name03

Glöckner

NachName03

Name03

NachName03

Anton

Freitag

Dieter

Name04

Leden

NachName04

Name01

NachName01

Dieter

Leden

Heinrich

Name05

Booter

NachName05

Name04

NachName04

Heinrich

Booter

Name05

NachName05

Berta

Schön

Schritt 1

Name02

NachName02

Schritt 2

Schritt 3

Zelle	Formel
M1	=SVERWEIS(A1;G$1:H$5;2;FALSCH)
N1	=SVERWEIS(B1;J$1:K$5;2;FALSCH)

Verwendete Systemkomponenten: [Windows (64-bit) NT 10.00] / MS Excel 365

Diese Tabelle wurde mit Tab2Html (v2.7.2) erstellt. ©Gerd alias Bamberg

Schritt 1
Eindeutige Listen der Vornamen und Nachnamen erzeugen (hier Spalten G und J)
Schritt 2
Neben Vornamen und Nachnamen Name01 bzw. Nachname01 usw. eintragen (hier Spalten H und K)
Schritt 3
Mit SVERWEIS ein Abbild der Originalliste mit den Ersatznaman und -vornamen erzeugen (hier Spalten M und N)
Schritt 4
Originale ersetzen. Dazu die erzeugten Daten kopieren und mit Inhalte einfügen - Werte einfügen (hier nicht dargestellt, da Spalten A und B damit überschrieben werden)
Schritt 5
Hilfsdaten löschen (hier Spalten M und N)

Externe formatierte Listbox mit Bildern und Zwischenüberschriften

Thu, 27 Mar 2025 11:50:51 +0000

Liebe Leserin, lieber Leser,

obwohl ich selbst bisher noch keine Listbox im Einsatz hatte, möchte ich heute trotzdem mal das spannnende Thema formatierte Listbox mit Bildern aufgreifen und hier in diesem Workshop einige Beispiele hierzu geben.
Denn die Listbox scheint mir das beliebteste Control zu sein.
Listboxen werden ja meistens in eine Userform eingebettet. Ob hier mit Bordmitteln Bilder hinzugefügt werden können, weiß ich derzeit leider nicht.

Für eine schnelle Auswahl aus einer Listbox ohne Userform bietet sich ohnehin wieder die Einbettung in eine fertige Dialogbox an. Die Wahl fiel wieder auf die Inputbox.
Diese bringt schon einige Funktionalitäten von Haus aus mit und lässt sich mit ein paar API-Funktionen leicht manipulieren.

Hierzu beschaffen wir uns z.B. über den Timer das Handle (interner Zeiger auf die Inputbox) und können nun loslegen mit unserer Manipulation.

Wir fügen der Inputbox eine Listbox hinzu und legen sie über die vorher ausgeblendete Editbox.
Optional können wir die beiden Buttons "OK" und "Abbrechen" nach unten unter die Listbox verschieben, so dass der Platz optiomal genutzt werden kann.

Nach dem Hinzufügen der gewünschten Elemente ist unsere Listboxdialogbox auch schon fertig.
Mit der Auswahl eines Elements wird dessen Text in die Originaleditbox überführt. Damit überlassen wir der Inputbox das Managen der Rückgabe und haben keine Arbeit damit.

Der hier gezeigte bzw. der in der Beispieldatei enthaltene Code zeigt, wie man

eine Listbox in die Inputbox eingebettet
den Font der Listbox ändern kann
kleine BitMaps den Elementen hinzufügt
die Farben des Selektionsbalkens ändern kann
MultiSelect realisiert und ggf. mehrere Spalten anlegt
andersfarbige Zwischenüberschriften in fetter Schrift darstellt und die Items aus der Auswahl ausschließt

Hier ein paar Ansichten:

  Inputbox_Listbox.png (Größe: 51,58 KB / Downloads: 39)

Achtung: Dieser Beispielcode verwendet die BitMaps aus einem Dateiordner. Es funktioniert daher nur, wenn die in der beigefügten Zip-Datei enthaltenen Dateien in den vorher angelegten Ordner ThisWorkbook.Path & "\Bitmaps\" extrahiert wurden.
Oder Du änderst den Code entsprechend ab.

PS. In der anliegenden Datei findest Du auch noch einige andere Beispiele, von der einfachen codesparenden Minimalversion bis zur mehrfabigen Version mit Multiselect.

  Inputbox_Listbox_CEF.xlsb (Größe: 155,5 KB / Downloads: 0)

  BitMaps_Flaggen.zip (Größe: 27,07 KB / Downloads: 0)

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

Code:

Private Const ciHoch   As Long = 300        ' Dlg-Höhe
Private Const cx       As Long = 18         ' BitMap-Breite
Private Const cy       As Long = 12         ' BitMap-Höhe

' GDI-Funktionen
Private Declare PtrSafe Function GetSysColorBrush Lib "user32" ( _
        ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function GetSysColor Lib "user32" ( _
        ByVal nIndex As Long) As Long

' 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

' Window-Funktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
       ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
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 Const WS_LB1           As Long = &H50010000 ' WS_CHILD or WS_VISIBLE or WS_TABSTOP
Private Const WS_LB2           As Long = &HA00000   ' WS_SCROLL + WS_BORDER
Private Const LB_ADDSTRING     As Long = &H180
Private Const LB_GETTEXT       As Long = &H189

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 Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1

' Sub-Classing-Funktionen
Private Declare PtrSafe Function CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hWnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" ( _
         ByVal hWnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const GWL_WNDPROC As Long = (-4)

Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal lpString As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Const WS_LB3 As Long = &H51       ' LBS_NOTIFY + LBS_OWNERDRAWFIXED + LBS_HASSTRINGS
Private Type Rect
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type DRAWITEMSTRUCT
   CtlType    As Long
   CtlID      As Long
   Nr         As Long           ' original itemID
   itemAction As Long
   itemState  As Long
   hwndItem   As LongPtr
   hDC        As LongPtr
   rcItem     As Rect
   itemData   As LongPtr
End Type

Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
        Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function FillRect Lib "user32" ( _
       ByVal hDC As LongPtr, lpRect As Rect, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" ( _
       ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function SetTextColor Lib "gdi32" ( _
       ByVal hDC As LongPtr, ByVal crColor As Long) As Long
Private Declare PtrSafe Function DrawTextA Lib "user32" ( _
       ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, _
       lpRect As Rect, ByVal wFormat As Long) As Long
Private Declare PtrSafe Function DrawState Lib "user32" Alias "DrawStateA" ( _
       ByVal hDC As LongPtr, ByVal hBrush As LongPtr, _
       ByVal lpDrawStateProc As LongPtr, _
       ByVal lParam As LongPtr, ByVal wParam As LongPtr, _
       ByVal n1 As Long, ByVal n2 As Long, _
       ByVal n3 As Long, ByVal n4 As Long, ByVal un As Long) As Long
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
       ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" ( _
       ByVal hObject As LongPtr) As Long
Private Const LB_SETITEMHEIGHT As Long = &H1A0
       
' #### Wird nur benötigt, wenn BitMaps aus Datei geladen werden ####
Private Const csPfad As String = "#PATH#\Bitmaps\#.bmp"                  ' <<<< Pfad ggf. anpassen >>>>
Private Declare PtrSafe Function LoadImageA Lib "user32" ( _
        ByVal hInst As LongPtr, ByVal lpsz As String, ByVal un1 As Long, _
        ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
Private Const LB_SETITEMDATA  As Long = &H19A
Private Const LB_GETITEMDATA  As Long = &H199
Private Const LB_GETCOUNT     As Long = &H18B

Dim mhTimer As LongPtr, mlpOldProc As LongPtr
Dim mhLB    As LongPtr, mhBmp  As LongPtr
Dim msArr() As String

Private Function ListboxEx(sMsgTxt As String, sCaption As String, _
                           sLBElemente As String, Optional sDefault As String) As Variant
' Anzeigen einer Inputbox als ListBox mit Bildern
  msArr = Split(sLBElemente, ",")                                       ' Array mit Elementen global
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ListBoxHookProc)             ' Timer setzen
  ListboxEx = InputBox(sMsgTxt, sCaption, sDefault)                     ' (Excel)-Inputbox starten
End Function

Private Sub ListBoxHookProc()
' Setzt die Hooking-Prozedur für die Listbox
  Dim i As Long, hDlg  As LongPtr, sBmpDatei As String

  KillTimer 0&, mhTimer: mhTimer = 0                                    ' Timer löschen
 
  hDlg = GetActiveWindow    ' 4900 = Edit_ID                            ' Handle der Inputbox
  ShowWindow GetDlgItem(hDlg, 4900), 0                                  ' Editbox ausblenden
  
' Dlg-Größe anpassen und Button verschieben
  SetWindowPos hDlg, 0, 0, 0, 510, ciHoch, SWP_NOMOVE                   ' Dlg-Größe anpassen

' Eine ListBox erstellen, mit Elementen füllen  und anzeigen  <<<< Maße ggf. anpassen >>>>
  mhLB = CreateWindowExA(0&, "Listbox", "", WS_LB1 + WS_LB2 + WS_LB3, _
                         12, 48, 350, ciHoch - 100, _
                         hDlg, 0, Application.HinstancePtr, 0&)
' Elemente einfügen
  For i = 0 To UBound(msArr)
      SendMessageA mhLB, LB_ADDSTRING, 1, ByVal msArr(i)                ' Item-Text einsetzen
      sBmpDatei = Replace(csPfad, "#PATH#", ThisWorkbook.Path)
      sBmpDatei = Replace(sBmpDatei, "#", Split(msArr(i))(0))           ' BMP-Datei ermitteln
' Bitmap laden                IMAGE_BITMAP = &H0        &H10 = LR_LOADFROMFILE
      mhBmp = LoadImageA(0, ByVal sBmpDatei, &H0, 0, 0, &H10)           ' Bitmap aus Datei
      If mhBmp <> 0 Then SendMessageA mhLB, LB_SETITEMDATA, i, ByVal mhBmp
  Next i

' Inputbox hooken
  mlpOldProc = SetWindowLongA(hDlg, GWL_WNDPROC, AddressOf WindowProc)  ' Alte Prozeduradresse retten
End Sub

Private Function WindowProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim bSel  As Boolean, i As Long, l As Long, R As Rect
  Dim sText As String * 255
  Dim tDrawItemSet     As DRAWITEMSTRUCT

  With tDrawItemSet
' .hwndItem entspricht dem LB-Handle, hwnd entspricht dem Dlg-Handle
     Select Case uMsg
     Case &H2B ' WM_DRAWITEM
       
          CopyMemory tDrawItemSet, ByVal lParam, LenB(tDrawItemSet)     ' Pointer in Struktur kopieren
          
          If .Nr = &HFFFFFFFF Then Exit Function                        ' Liste ist leer =>raus
          R = .rcItem
          SendMessageA .hwndItem, LB_GETTEXT, .Nr, ByVal sText          ' Item-Text holen
         
          bSel = (.itemState And 1)                                     ' 1 = ODS_SELECTED
          If bSel Then SetWindowTextA GetDlgItem(hWnd, 4900), sText     ' Editbox mit selektiertem Item updaten
         
' 5=COLOR_WINDOW, 13=COLOR_HIGHLIGHT, 8=COLOR_WINDOWTEXT, 14=COLOR_HIGHLIGHTTEXT
          FillRect .hDC, R, GetSysColorBrush(IIf(bSel, 13, 5))          ' Hintergrund zeichnen
          SetBkMode .hDC, 1                                             ' Hintergrund auf TRANSPARENT = 1 setzen
          SetTextColor .hDC, GetSysColor(IIf(bSel, 14, 8))              ' Schriftfarbe setzen
          R.Left = cx + 10             ' &H24 = DT_SINGLELINE + DT_LEFT + DT_VCENTER
          DrawTextA .hDC, sText, 255, R, &H24                           ' Text schreiben
         
' BitMap: Handle holen und zeichnen,
          mhBmp = SendMessageA(.hwndItem, LB_GETITEMDATA, .Nr, ByVal 0)
          DrawState .hDC, 0, 0, mhBmp, 0, 3, R.Top + 4, 0, 0, &H4       ' &H4 = DST_BITMAP
     
     Case &H2  ' WM_DESTROY
          For i = 0 To CLng(SendMessageA(mhLB, LB_GETCOUNT, 0, 0)) - 1
              mhBmp = SendMessageA(mhLB, LB_GETITEMDATA, i, ByVal 0)    ' BitMap-Handle holen
              DeleteObject mhBmp                                        ' BitMap-Handle löschen
          Next i
          SetWindowLongA hWnd, GWL_WNDPROC, mlpOldProc                  ' InputBox unhooken
     End Select
  End With
  WindowProc = CallWindowProcA(mlpOldProc, hWnd, uMsg, wParam, ByVal lParam) ' Andere Messages weiterleiten

End Function

' #####################################################################
Sub AufrufListboxCEF()
  MsgBox ListboxEx("Bitte wähle ein Land aus!", "Land auswählen", _
            "Dänemark,Deutschland,England,Island,Italien,Niederlande,Norwegen,Portugal,Schweden", 2)
End Sub

_________
viele Grüße
Karl-Heinz

ComboBoxEx32 - externe Combobox mit Bilder

Sat, 22 Mar 2025 12:00:54 +0000

Liebe Leserin, lieber Leser,

bei der Auswahl eines Eintrages aus einer ComboBox wäre manchmal ein zusätzliches Entscheidungskriterium in Form eines erklärendes Bildes schön.

Zur Realisierung so eines Vorhabens gibt es ja u.a. die Klasse ComboboxEx32.

Hier mal ein Beispiel, wie man so eine ComboBoxEx32 z.B. in ein Fenster (hier die Inputbox) einbauen kann.

Im hier gezeigten Code wird die gesamte Inputbox "gekapert", um die gemachte Selektion zurückzugeben.
Die Bilder werden aus einem Verzeichnis geladen.

In der anliegenden Datei sind noch zwei etwas abweichende Varianten enthalten. Ein Beispiel zeigt, wie man die Bilder auch im Excelblatt vorhalten kann.

Letztendlich können hier aber nicht alle möglichen Variationen gezeigt werden....

Inputbox_ComboboxEx32.png (Größe: 11,42 KB / Downloads: 48)

Inputbox_ComboBoxEx32_CEF.xlsb (Größe: 99,22 KB / Downloads: 5)

Code:

' InputBox-Hooking, Elemente aus String, nur Bitmaps aus Dateien
Option Explicit

Private Const ciMaxItems As Long = 15                        ' Maximal anzuzeigende Items/Zeilen

' 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

' Window-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 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 CallWindowProcA Lib "user32" ( _
        ByVal lpPrevWndFunc As LongPtr, _
        ByVal hwnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
#If Win64 Then
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" Alias "SetWindowLongPtrA" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#Else
 Private Declare PtrSafe Function SetWindowLongA Lib "user32" ( _
         ByVal hwnd As LongPtr, ByVal nIndex As Long, _
         ByVal dwNewLong As LongPtr) As LongPtr
#End If

Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
Private Declare PtrSafe Function SetWindowTextA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpString As String) As Long
Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function ShowWindow Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long

' ComboBoxEx- und ImageList-Funktionen
Private Type COMBOBOXEXITEM
   mask           As LongPtr
   iItem          As Long
   pszText        As String
   cchTextMax     As Long
   iImage         As Long
   iSelectedImage As Long
   iOverlay       As Long
   iIndent        As Long
   lParam         As LongPtr
End Type

Private Declare PtrSafe Function InitCommonControlsEx Lib "COMCTL32" ( _
        lpInitCtrls As INITCOMMONCONTROLS_STRUCT) As Long

Private Type INITCOMMONCONTROLS_STRUCT
  dwSize As Long
  dwICC As Long
End Type
Dim CCInit As INITCOMMONCONTROLS_STRUCT

Private Declare PtrSafe Function ImageList_Create Lib "COMCTL32" ( _
        ByVal MinCx As Long, ByVal MinCy As Long, _
        ByVal flags As Long, ByVal cInitial As Long, _
        ByVal cGrow As Long) As LongPtr
Private Declare PtrSafe Function ImageList_Add Lib "COMCTL32" ( _
        ByVal himl As LongPtr, ByVal hbmImage As LongPtr, _
        ByVal hbmMask As LongPtr) As Long
Private Declare PtrSafe Function ImageList_Destroy Lib "COMCTL32" ( _
        ByVal himl As LongPtr) As Long
Private Declare PtrSafe Function LoadImageA Lib "user32" ( _
        ByVal hInst As LongPtr, ByVal lpsz As String, ByVal un1 As Long, _
        ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
        
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
        
Dim mhImgList As LongPtr, mhDlg As LongPtr, mlpOldProc  As LongPtr
Dim mhWndEdit As LongPtr, mhCBE As LongPtr, mhTimer     As LongPtr
Dim miDefault As String, msPfad As String, msItems() As String

Private Function InputBoxEx(sMsgTxt As String, sCaption As String, _
                            sCBElemente As String, Optional iDefault As Long) As Variant
' Anzeigen einer Inputbox als ComboboxEx mit Bildern
  
  msPfad = ThisWorkbook.Path & "\Bitmaps\#.bmp"                             ' Bilderpfad <<< gf. anpassen >>>
  
  msItems = Split("," & sCBElemente, ",")                                   ' Range mit Elementen global
  miDefault = iDefault                                                      ' Default-Item global machen
  mhTimer = SetTimer(0&, 0&, 10, AddressOf ComboBoxExHookProc)              ' Timer setzen
  InputBoxEx = InputBox(sMsgTxt, sCaption, "")                              ' (Excel)-Inputbox starten
  If mhImgList <> 0 Then ImageList_Destroy mhImgList                        ' ImageListe löschen
  mhImgList = 0
End Function


Private Sub ComboBoxExHookProc()
' Setzt die Hooking-Prozedur für die ComboBoxEx
  Dim i As Integer, iItemAnz As Long, sArr() As String, sBmpDatei As String
  Dim hBmp As LongPtr, iImage As Long, cx As Long, cy As Long, iHoehe As Long
  Dim cbI  As COMBOBOXEXITEM
  Const WS_CBE_STYLE As Long = &H50010003    ' WS_CHILD + WS_VISIBLE + CBS_DROPDOWNLIST + WS_TABSTOP
  
  KillTimer 0&, mhTimer: mhTimer = 0                                        ' Timer löschen
 
  mhDlg = GetActiveWindow                                                   ' Handle der Inputbox
  mhWndEdit = GetDlgItem(mhDlg, 4900)  ' 4900 = Edit_ID                     ' Handle der Editbox
  ShowWindow mhWndEdit, 0                                                   ' Editbox ausblenden

  With CCInit                                                               ' ComboboxEx-Klasse zuweisen
     .dwSize = LenB(CCInit)
     .dwICC = &H200         ' &H200 = ICC_COMBOEX_CLASSES
  End With
  If InitCommonControlsEx(CCInit) = 0 Then Exit Sub                         ' ComboBoxEx registrieren

  iItemAnz = UBound(msItems)
  If iItemAnz > ciMaxItems Then iItemAnz = ciMaxItems

' Eine ComboboxEx erstellen, mit Elementen füllen  und anzeigen

' <<<< Hier die BitMap-Größe der Bilder und Höhe der CB32 einstellen >>>>
  cx = 18: cy = 12: iHoehe = iItemAnz * ((cy + 2) * 2 + 1)
  
' <<<< Hier die Position und Größe der ComboBoxEx einstellen >>>>
  mhCBE = CreateWindowExA(0&, "ComboboxEx32", "", WS_CBE_STYLE, _
                          14, 105, 460, iHoehe, _
                          mhDlg, 0, Application.HinstancePtr, 0&)
  
  mhImgList = ImageList_Create(cx, cy, &H0, 1, 0) ' &H0 = ILC_COLOR         ' Image-Liste erstellen
  SendMessageA mhCBE, &H402, 0, ByVal (mhImgList)  ' &H402 = CBEM_SETIMAGELIST ' Image-Liste setzen
      
' Elemente einfügen
  On Error Resume Next
  For i = 1 To UBound(msItems)
      sBmpDatei = Replace(msPfad, "#", Left$(msItems(i), 3))                ' BMP-Datei ermitteln
' Bitmap laden               IMAGE_BITMAP = &H0        &H10 = LR_LOADFROMFILE
      hBmp = LoadImageA(0, ByVal sBmpDatei, &H0, 0, 0, &H10)

      If hBmp <> 0 Then
         cbI.mask = &H7   ' CBEIF_TEXT + CBEIF_IMAGE + CBEIF_SELECTEDIMAGE
         iImage = ImageList_Add(mhImgList, hBmp, 0)                         ' Bitmap in Image-Liste
         If msPfad & " " Like "*:*" Then DeleteObject hBmp                  ' Bitmap ggf. wieder löschen
       Else
         cbI.mask = &H1   ' CBEIF_TEXT
         iImage = 0
       End If
       
       cbI.pszText = msItems(i)                                             ' Text übernehmen
       cbI.cchTextMax = Len(msItems(i))
       cbI.iImage = iImage
       cbI.iSelectedImage = iImage
       cbI.iItem = -1
' Item einfügen                 &H401 = WM_USER + 1 = CBEM_INSERTITEM
       Call SendMessageA(mhCBE, &H401, 0, cbI)

  Next i
  On Error GoTo 0
  miDefault = IIf(miDefault < 1 Or miDefault >= iItemAnz, 1, miDefault)     ' Defaultselektion korrigieren
  SendMessageA mhCBE, &H14E, miDefault - 1, ByVal 0 ' &H14E = CB_SETCURSEL  ' Item selektieren
  SetWindowTextA mhWndEdit, msItems(miDefault)                              ' Editbox damit updaten

' InputBox hooken                    -4 = GWL_WNDPROC
  mlpOldProc = SetWindowLongA(mhDlg, -4, AddressOf WindowProc)              ' Alte Prozeduradresse retten
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  
' Hier die Message WM_COMMAND (&H111) für den OK-Button (ID=1) rausfischen und die Editbox updaten
  If uMsg = &H111 And wParam = 1 Then                         ' &H14E = CB_SETCURSEL
     SetWindowTextA mhWndEdit, msItems(CLng(SendMessageA(mhCBE, &H147, 0, 0)) + 1)
  End If
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, ByVal lParam) ' Andere Messages weiterleiten
End Function


' #####################################################################
Sub AufruftestComboboxEx2()
  MsgBox InputBoxEx("Bitte wähle ein Land aus!", "Land auswählen", "Deutschland,England,Frankreich,Island,Italien,Kanada,Norwegen,Portugal,Spanien", 3)
End Sub

_________
viele Grüße
Karl-Heinz

Projekt Coole MessageBox

Mon, 16 Sep 2024 14:00:08 +0000

Liebe Leserin, lieber Leser,

die Messagebox ist gedacht für das schnelle temporäre Anzeigen von Informationen oder dem einfachen Abfragen einer Entscheidung zu einem Sachverhalt.

Oft wird jedoch in Foren gefragt, ob man denn die Schriftart größer machen könnte oder vielleicht das Icon oder die Schaltflächenbeschriftungen ändern könnte.

Hier heißt es oft: Nein, das geht nicht.

Dass das alles aber doch geht, will ich hier mit diesem Projekt Coole MsgBox mal aufzeigen.

Grundsätzlich kann man mit VBA die Excel-MsgBox, die API-Messagebox, die MessageBoxIndirekt oder die MsgBoxTimeOut verwenden.
Zu vielen Themen lassen sich ja auch schon Beiträge hier in diesem Forum finden.

Dieser Workshop befasst sich ausschließlich mit der internen Excel-MsgBox und es können folgende spannende Dinge damit angestellt werden:

Nutzen des Hilfebuttons für eigene Zwecke
Bis zu vier Buttons möglich mit individuellen Buttontexten
Systemkreuzklick gibt einen eigenen Text zurück, damit sind fünf Rückgaben möglich
Individuelles Icon in der MsgBox setzbar
Schriftfarbe, Schriftgröße und Schriftart sowie fett/kursiv setzbar für das Textfeld
MsgBox-Hintergrund: Farbe, Struktur oder eigenes Bild setzbar
Transparente Msgbox: möglich, aber darauf wurde bislang verzichtet
MsgBox positionierbar und auch Größenänderung möglich, ggf. Autozentrierung auf dem Bildschirm
Alle Buttons einzeln mit Textfarbe und/oder Hintergrundfarbe versehbar
Alle Buttons einzeln verschiebbar und auch Größenänderung möglich
Timeout setzbar: Nach Timeout eigener Rückgabetext z.B. "TimeOut!"
CountDown setzbar: Nach Timeout eigener Rückgabetext z.B. "TimeOut!"
Formatierung der Titelleiste und des Rahmens

Die hier vorgestellte "Coole MsgBox" kann das alles.
Aber es ist viel Code und wenn man weniger benötigt wäre auch weniger Code von Vorteil.
Deshalb findest Du in der anliegenden Datei jede Menge Beispiele mit Code, jeweils angepasst an die gewünschten Bedürfnisse.
Dass man noch viel mehr machen kann und das nicht alles hier gezeigt werden kann, versteht sich von selbst.

Klick Dich einfach mal durch die angezeigten Buttons und verwende genau den benötigten Code.

Start
Vom User wird zunächst immer die MsgBoxEx aufgerufen.
Da der Code mit Aufruf der Excel-MsgBox nicht weiterläuft, benötigen wir hierfür einen Trick. Man kann sich z.B. in die entsprechende Prozedur einhooken.

In diesem Workshop wird aber ausschließlich mit dem Timer gearbeitet, der nach wenigen mSek unsere Callback-Funktion MsgBoxCallbackProc aufruft.
Hier wird zunächst das Handle zur MsgBox ermittelt. Dann können bereits alle Elemente mit neuen Texten versehen, die MsgBox oder die Buttons verschoben werden oder ein neues Icon gesetzt werden.

Für weitere Dinge, u.a. auch das Abfangen von Buttonklicks, Mausbewegungen usw., hooken wir uns in die Meldungsschleife der Excel-MsgBox ein und leiten alle Messages an unsere eigene Prozedur WindowProc um.

So, jetzt genug der Schreiberei. Die Codes sind komplett kommentiert und geben dem interessierten User hoffentlich einen Einblick, wie es funktionieren kann. Es führen ja noch mehr Wege nach Rom.

MsgBox-Cool-Workshop-CEF.xlsb (Größe: 1,39 MB / Downloads: 13)

Viel Spaß und Erfolg beim Anwenden und Tüfteln...

PS: Fragen, Funktionsfehler und Anregungen bitte in der Rubrik Diskussionen zu den Beispielen anbringen. Es ist noch neu und wenig getestet....

_________
viele Grüße
Karl-Heinz

Ein- Auszippen, Löschen und Auflisten ohne Zip-Programm

Tue, 26 Mar 2024 13:15:28 +0000

Liebe Leserin. lieber Leser,

manchmal möchte man ein oder mehrere Dateien oder ganze Ordner in eine ZIP-Datei einzippen.
Insbesondere für das Masseneinzippen von Dateien in ggf. sogar mehrere ZIP-Dateien (z.B. für das Berichtswesen) nach Vorgaben (z.B. eine Excelliste) wäre eine automatische Lösung sehr willkommen oder sogar unerlässlich.

Hierfür gibt es das eine oder andere Programm, z.B. der PKZip Commandliner.

Wer jedoch keine Fremdsoftware verwenden kann, will oder darf, dem bietet sich noch eine VBA-Möglichkeit über die Shell.Application
Nachfolgend möchte ich mal mögliche Methoden für das Einzippen, das Auszippen, das Auflisten und das Löschen von Dateien aufzeigen.

Das funktioniert ganz gut. Es darf jedoch eine unschöne Besonderheit hierbei nicht unerwähnt bleiben.
Die Aktionen laufen asynchron zum VBA-Code ab.
Das heißt, man weiß nicht, wann die Aktionen abgeschlossen sind.
Beim Ablaufen in einer Schleife könnten Fehlermeldungen in Form einer Dialogbox auftauchen, die erstens vom User weggeklickt werden müssen und zweitens das Einzippen der Datei dann verhindern.
Eine ausreichende Zeitvorgabe z.B. durch Sleep kann das Problem beheben, kostet dann aber wieder unnütze Zeit.

Einzippen

Code:

Sub Zip_Zufügen(ByVal sZipDateiname As String, ByVal sZipPfad As String, Optional bNeu As Boolean)
' Fügt Datei(en) gemäß Zip-Muster (mit *) zu einer ZIP-Datei hinzu
  Dim iFF As Integer, Chr0Data(18) As Byte, i As Integer
  Dim oZiel As Object, oQuel As Object, oItem As Object, hWnd As LongPtr
  Dim sPfad As String, sZIPMuster As String, sFail As String
    
' Zip-Muster bearbeiten
   sPfad = Left(sZipPfad, InStrRev(sZipPfad, "\"))      ' Quellpfad extrahieren
   sZIPMuster = Mid(sZipPfad, Len(sPfad) + 1)           ' ZIP-Muster extrahieren
   
' Vorhandene ZIP-Datei ggf. vorher löschen
  If Dir$(sZipDateiname) <> "" And bNeu Then Kill sZipDateiname
   
' Zunächst eine leere ZIP-Datei anlegen, falls noch nicht vorhanden
  If Dir$(sZipDateiname) = "" Then
     iFF = FreeFile
     Open sZipDateiname For Binary Access Write As #iFF ' Datei öffnen
     Put #iFF, , "PK" & Chr$(5) & Chr$(6)               ' ZIP-Kennung schreiben
     Put #iFF, , Chr0Data                               ' Grunddaten schreiben
     Close #iFF                                         ' Datei schließen
  End If

' Zu zippende Datei(en) ermitteln
  miDlgAnz = 0
  With CreateObject("Shell.Application")
       Set oZiel = .Namespace((sZipDateiname))          ' Zielobjekt setzen
       
       If Right$(sZipPfad, 1) = "\" Then                ' Ordner einzippen
          oZiel.CopyHere .Namespace((sZipPfad))
       
       Else                                             ' Datei  einzippen
          With .Namespace((sPfad))                      ' Quellobjekt setzen
              For Each oItem In .Items
                  If oItem.Name Like sZIPMuster Then    ' Wenn Item passt
                     mhTimer = SetTimer(0&, 0&, 10, AddressOf ZipErsetzProc)
                     oZiel.CopyHere oItem               ' Jetzt Datei hinzufügen
                     Sleep 100: DoEvents
                  End If
              Next oItem
          End With
       End If
  End With
  Sleep 500
  Call EnumWindows(AddressOf DlgZuProc, 0)              ' Alle evtl. Fehlermeldungen schließen
End Sub

Sub Test_Ordner_einzippen()
   Zip "D:\MyZip.zip", "D:\Ziptest\"
End Sub

Falls die Zielzipdatei nicht vorhanden ist, wird zunächst automatisch eine leere ZIP-Datei angelegt. Diese enthält lediglich die PK-Kennung und ein paar Platzhalter.
Anschließend werden entweder der übergebende Ordner oder in einer Schleife die Dateien entsprechend dem übergebenden Muster eingezippt.
Das kann problemlos mit oder ohne Anzeige einer Fortschrittsanzeige ablaufen oder im Problemfall mit den o.a. schon angesprochenen Fehlermeldungen.
PS: Einzippen
einer
Datei oder eines Ordners ist in der Regel immer problemlos.

Um Nachfragen der Ersetzung bei bereits vorhandenen Dateien zu vermeiden, kann optional die ZIP-Datei vorher gelöscht werden.

Die Beantwortung der Nachfrage kann man aber auch automatisieren.
Wer möchte kann diese Funktion dafür einsetzen:

Code:

Private Sub ZipErsetzProc()
' Führt einen Mausklick in der "Datei Kopieren"-Dlgbox durch
  Dim PT As POINTAPI, R As RECT
  
  KillTimer 0&, mhTimer: mhTimer = 0                            ' Timer löschen
  mhDlg = FindWindowA("#32770", "Datei kopieren")               ' Handle der Ersetzen-Dlgbox
  If mhDlg <> 0 Then
     GetWindowRect mhDlg, R                                     ' Dlg-Position holen
     SetCursorPos R.Left + 200, R.Top + 250                     ' Cursor positionieren
     mouse_event &H6, 0, 0, 0, 0                                ' Mausklick Down und Up
  End If
End Sub

Sollten Fehlermeldungen aufgetreten sein, können diese vom Programm auch automatisch geschlossen werden.
Sie könnten sonst im Hintergrund verschwinden und dauerhaft im Arbeitsspeicher dahindämmern.
Das Schließen übernimmt dieser Code:

Code:

Private Function DlgZuProc(ByVal hWnd As LongPtr, lParam As LongPtr) As Long
' Schließt alle ZIP-Fehlermeldungs-DlgBoxen beim Durchscannen aller Fenster
  Dim sText As String * 64
  
  GetWindowTextA hWnd, sText, 64                        ' Fenstertext holen
  If sText Like "ZIP-komprimierte Ordner - Fehler*" Then _
     PostMessageA hWnd, &H10, 0&, 0&                    ' &H10=WM_CLOSE
  DlgZuProc = 1                                         ' Nächstes Fenster
End Function

Extrahieren
Mit dem nachfolgend gezeigten Code können die Dateien aus der gewählten ZIP-Datei in einen beliebigen Ordner ausgezippt werden.
Der Zielordner muss vorhanden sein.
Falls das nicht der Fall sein sollte, wird er über die API-Funktion

Code:

Sub Zip_Extract(ByVal sZipDatei As String, ByVal sZielPfad As String)
' Alle Dateien aus einer sZipDatei nach sZielPfad extrahieren
  If Dir$(sZipDatei) <> "" Then                         ' Ist Zip-Datei vorhanden?
     SHCreateDirectoryExW 0&, StrPtr(sZielPfad), 0&     ' Ggf. Zielordner erstellen
     With CreateObject("Shell.Application")
         .Namespace((sZielPfad)).CopyHere .Namespace((sZipDatei)).Items
     End With
  End If
End Sub

ZIP-Inhalt anzeigen
Den Inhalt einer ZIP-Datei kann man sich mit dem u.a. Code ausgeben lassen.
Hierbei ist zu beachten, dass dieses die einfachste Art der Ausgabe ist. Lies hierzu auch diesen Artikel.
Weitere umfangreichere Methoden findest Du auch in der beigefügten Datei.

Code:

Sub Zip_Liste()
' Inhalt aus einer Zip-Datei auslesen
  Dim vZipDatei As Variant, oItem As Object
 
  vZipDatei = Application.GetOpenFilename("ZIP-Dateien (*.zip), *.zip")
  If vZipDatei = "" Then Exit Sub

  With CreateObject("Shell.Application").Namespace(vZipDatei)
      For Each oItem In .Items
          Debug.Print oItem.Name
      Next oItem
  End With
End Sub

Löschen
Zum Löschen einer Datei aus einer ZIP-Datei kann der nachfolgend gezeigte Code verwendet werden.
Nachteilig wirkt sich hier die Nachfragedialogbox aus, die der Nutzer beantworten muss bevor es weiter geht.
Das Problem wurde aber mit ein paar API-Funktionen automatisiert und damit gelöst.

Code:

Sub Zip_Loeschen(ByVal sZipDatei As String, ByVal sZIPMuster As String)
' Datei(en)(sZIPMuster) aus einer sZipDatei entfernen
' Die Dialogbox-Abfrage wird automatisch in der ZipDeleteProc beantwortet
  Dim oItem As Object
  
  With CreateObject("Shell.Application").Namespace((sZipDatei)) ' Quellobjekt referenzieren
       For Each oItem In .Items
           If oItem.Name Like sZIPMuster Then                   ' Wenn Item passt...
              mhTimer = SetTimer(0&, 0&, 100, AddressOf ZipDeleteProc)
              oItem.InvokeVerb "Delete"                         ' Jetzt Datei löschen
              Sleep 100: DoEvents                               ' 100ms warten
           End If
       Next oItem
  End With
End Sub
Private Sub ZipDeleteProc()
  KillTimer 0&, mhTimer: mhTimer = 0                            ' Timer löschen
  mhDlg = FindWindowA("#32770", "Datei löschen")                ' Handle der Abfrage-Dlgbox
  If mhDlg <> 0 Then SendDlgItemMessageA mhDlg, 6, &HF5, 0&, 0& ' &HF5=BM_CLICK  6=ja, 2=nein
End Sub

Declares
Die verwendeten Funktionen aus der Windows-API müssen vor ihrem Einsatz noch deklariert werden. Diese Declares sind als erstes im Modul vor allen Funktionen zu platzieren.

Code:

Option Explicit
Private Declare PtrSafe Function SetCursorPos Lib "User32" ( _
        ByVal x As Long, ByVal y As Long) As Long
Public Declare PtrSafe Sub mouse_event Lib "User32" (ByVal dwflags As Long, _
        ByVal dx As Long, ByVal dy As Long, _
        ByVal cButtons As Long, ByVal dwExtraInfo As LongPtr)
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Declare PtrSafe Function GetWindowRect Lib "User32" ( _
        ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

Private Declare PtrSafe Function EnumWindows Lib "User32" ( _
         ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "User32" () As LongPtr
Private Declare PtrSafe Function GetWindowTextA Lib "User32" ( _
        ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare PtrSafe Function SHCreateDirectoryExW Lib "Shell32.dll" ( _
        ByVal hWnd As LongPtr, ByVal pszPath As LongPtr, ByVal psa As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "User32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
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 Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
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
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
Dim mhTimer As LongPtr, mhDlg As LongPtr, miDlgAnz As Long
Dim miBusy As Long

_________
viele Grüße
Karl-Heinz

Zip-Datei-Analysen2023.xlsb (Größe: 64,91 KB / Downloads: 5)

Einlesen von Text- und CSV-Dateien - mal nicht mit PQ

Mon, 26 Feb 2024 15:06:22 +0000

Hallöchen,

mittels VBA gibt es verschiedene Möglichkeiten, Textdateien einzulesen. Oftmals handelt es sich um CSV-Dateien, in denen Daten spaltenweise durch Komma oder Semikolon getrennt - je nach Systemeinstellung - enthalten sind. In den Versionen ab 2010 / 2013 gibt es die Möglichkeit, die Daten mittels Powerquery einzulesen und dabei gleich verschiedene Operationen, z.B. Typumwandlungen, Zusammenfassungen von Daten und Spalten und vieles mehr, auszuführen.
Zuweilen besteht jedoch immer noch die Anforderung, Daten per VBA einzulesen und zu verarbeiten.

Hier sind nun einige Beispielcodes dargestellt, um CSV-Dateien einzulesen. Die Beispiele lassen sich mit wenig Aufwand auch für andere Textdateien umprogrammieren - hier geht es vor allem um den Import der Daten entsprechend der Trennzeichen in einzelne Spalten und Zeilen.
Dabei werden hier die Daten komplett in einem Zug eingelesen und innerhalb der Makros in Arrays übernommen und erst am Ende in die Tabelle eingefügt.
Die Beispiele sind reichlich kommentiert, sollten Fragen, Hinweise oder Verbesserungsvorschläge auftreten, können die im Forum diskutiert und beantwortet werden.
Die eingelesenen Daten werden jeweils versetzt entsprechend den Beispieldaten eingetragen.

Beispieldaten:

	D	E	F
1	Wer	Was	Anzahl
2	ich	auto	1
3	du	Bike	2
4	er	Kutsche	3
5	sie	Roller	1

... in einer CSV semikolasepariert und einer zweiten Datei kommasepariert

Hier nun die Beispiele:

Read_Text_File_to_Array.xlsm (Größe: 32,81 KB / Downloads: 0)
01_02.zip (Größe: 346 Bytes / Downloads: 0)

1) Einlesen mit dem FileSystemObject und ReadAll
(einziges Beispiel, in dem die Spalten nicht aufgeteilt werden)

Code:
Sub Read_TxtFile_to_Array()
'Textfile direkt in 1D Array uebernehmen
'mit Scripting.FileSystemObject, Late Binding
'2D Array mit Delimiter siehe andere Beispiele
'Variablendeklarationen
Dim objFSO As Object, objFile As Object
Dim strFile$, arrTxt
'Pfad+Dateiname zuweisen
strFile = "C:\Test\01_ich.csv"
'FSO setzen
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Dateiobjekt oeffnen / zuweisen
Set objFile = objFSO.OpenTextFile(strFile, 1)
'komplettes File in Array einlesen
arrTxt = Split(objFile.Readall, vbNewLine)
'Array ausgeben.
Worksheets("TxtToArr").Range("A1").Resize(UBound(arrTxt) + 1, 1).Value = Application.Transpose(arrTxt)
End Sub

2) Einlesen mit Open... For Input und Input/LOF

Code:
Sub Read_TxtFileDelim_to_array_1()
'Textfile direkt in Array uebernehmen
'mit Open ... For Input und Input
'Variablendeklarationen
Dim strDelim$, strFile$, strCont$
Dim iCnt1%, iCnt2%, iFree%
Dim arrLines() As String, arrData() As String, arrTmp() As String
Dim lRow&, lColumn&
'Trennzeichen festlegen
strDelim = ";"
'Pfad+Dateiname zuweisen
strFile = "C:\Test\01_ich.csv"
'Startzeile festlegen
lRow = 0
'Filenummer fuer Oeffnen der Datei ermitteln und zuweisen
iFree = FreeFile
'Datei zum Einlesen oeffnen
Open strFile For Input As iFree
'Datei komplett einlesen
strCont = Input(LOF(iFree), iFree)
'Datei schliessen
Close iFree
'Zeilen trennen
arrLines() = Split(strCont, vbNewLine)
'Schleife ueber alle "Zeilen" im Array
For iCnt1 = LBound(arrLines) To UBound(arrLines)
  'wenn in der Zeile was steht, dann
  If Len(Trim(arrLines(iCnt1))) <> 0 Then
    'Zeile in Spalten trennen
    arrTmp = Split(arrLines(iCnt1), strDelim)
    'Spaltenzahl ermitteln und zuweisen
    lColumn = UBound(arrTmp)
    'temp. A. entsprechend Spalten neu dimensionieren
    ReDim Preserve arrData(lColumn, lRow)
    'Schleife ueber Spalten des temp.A.
    For iCnt2 = LBound(arrTmp) To UBound(arrTmp)
      'Daten in die entsprechende Array-"Zelle" uebernehmen
      arrData(iCnt2, lRow) = arrTmp(iCnt2)
    'Ende Schleife ueber Spalten des temp.A.
    Next
  'Ende wenn in der Zeile was steht, dann
  End If
'Zeilenzaehler hochsetzen
lRow = lRow + 1
'Ende Schleife ueber alle "Zeilen" im Array
Next
'Daten im Blatt ausgeben, ab D1 (iCnt1 + 1, iCnt2 + 4)
Worksheets("TxtToArr").Cells(1, 4).Resize(lRow - 1, iCnt2).Value = WorksheetFunction.Transpose(arrData())
End Sub

3) Einlesen mit ADO und getrows
(Semikolonsepariert)

Code:
Sub Read_TxtFileDelimSemi_to_array_2()
'Textfile direkt in Array uebernehmen,
'zu beachten: Version fuer semikolaseparierte Datei
'Splitten der csv mit ";" getrennt (bei abweichender Standardeinstellung z.B. ",")
'Hinweis: mmit Systemumstellung, schema.ini im Dateiverzeichnis,
'Registry-Hack oder anderen Maßnahmen kann man das Splitten einsparen
'mit ADO ... und SQL
'benoetigte Verweise:
'Microsoft ActiveX Data Objects 2.x Library (latest) or 6.x
'Variablendeklarationen
Dim rs As New ADODB.Recordset, conn As New ADODB.Connection
Dim strPath$, strFile$, strDelim$, strCont$, strSQL$
Dim iCnt1%, iCnt2%
Dim lRow&, lColumn%
Dim arrHead, arrLines, arrTmp, arrData() As String
'Trennzeichen festlegen
strDelim = ";"
'Pfad+Dateiname festlegen
strPath = "C:\\Test\\": strFile = "01_ich.csv"
'Startzeile festlegen
lRow = 0
'Verbindungsstring festlegen
'32 bit
'conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & ";Extended Properties=""text;HDR=Yes;FMT=Delimited()"";"
'64 bit
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""text;HDR=Yes;FMT=CustomDelimited(;)"";"
'Datenabfrage
strSQL = "SELECT * FROM [01_Ich.csv]"
'Mit dem Recordset
With rs
  'Connection + Einstellungen
  .ActiveConnection = conn
  .CursorType = adOpenKeyset
  .LockType = adLockOptimistic
  'Verbindung mit SQL-Abfrage oeffnen
'  .Open "SELECT * FROM [01_Ich.csv]"
  .Open strSQL ', conn
  'Ergebnis ausgeben, Spaltenbezeichnungen (Ueberschriften) und Daten
  'AO geht davon aus, dass oben die Spaltenbezeichnungen stehen
  arrHead = Split(.Fields(0).Name, strDelim)
  arrLines = WorksheetFunction.Transpose(.GetRows)
  'Datenabfrage schliessen
  .Close
'Ende Mit dem Recordset
End With
'Verbindung schliessen
conn.Close
'Schleife ueber alle "Zeilen" im Array
For iCnt1 = LBound(arrLines, 1) To UBound(arrLines, 1)
  'wenn in der Zeile was steht, dann
  If Len(Trim(arrLines(iCnt1, 1))) <> 0 Then
    'Zeile in Spalten trennen
    arrTmp = Split(arrLines(iCnt1, 1), strDelim)
    'Spaltenzahl ermitteln und zuweisen
    lColumn = UBound(arrTmp)
    'temp. A. entsprechend Spalten neu dimensionieren
    ReDim Preserve arrData(lColumn, lRow)
    'Schleife ueber Spalten des temp.A.
    For iCnt2 = LBound(arrTmp) To UBound(arrTmp)
      'Daten in die entsprechende Array-"Zelle" uebernehmen
      arrData(iCnt2, lRow) = arrTmp(iCnt2)
    'Ende Schleife ueber Spalten des temp.A.
    Next
  'Ende wenn in der Zeile was steht, dann
  End If
'Zeilenzaehler hochsetzen
lRow = lRow + 1
'Ende Schleife ueber alle "Zeilen" im Array
Next
'Spaltenueberschriften eintragen, ab H1
Worksheets("TxtToArr").Cells(1, 9).Resize(1, UBound(arrHead) + 1).Value = arrHead
'Daten im Blatt ausgeben, ab H2
Worksheets("TxtToArr").Cells(2, 9).Resize(UBound(arrData, 2) + 1, UBound(arrData, 1) + 1).Value = WorksheetFunction.Transpose(arrData)
End Sub

4) Einlesen mit ADO und getrows
(Kommasepariert)

Code:
Sub Read_TxtFileDelimComma_to_array_3()
'Textfile direkt in Array uebernehmen,
'zu beachten: Version fuer commaseparierte Datei
'mit ADO ... und SQL
'benoetigte Verweise:
'Microsoft ActiveX Data Objects 2.x Library (latest) or 6.x
'Variablendeklarationen
Dim rs As New ADODB.Recordset, conn As New ADODB.Connection
Dim strPath$, strFile$
Dim iCnt%
Dim arrHead, arrLines
'Pfad+Dateiname festlegen, 2. Beispielfile ist Kommagetrennt!
strPath = "C:\\Test\\": strFile = "02_ich.csv"
'Verbindungsstring festlegen
'32 bit
'conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strPath & ";Extended Properties=""text;HDR=Yes;FMT=Delimited()"";"
'64 bit
conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strPath & ";Extended Properties=""text;HDR=Yes;FMT=CustomDelimited(,)"";"
'Datenabfrage
strSQL = "SELECT * FROM [02_Ich.csv]"
'Mit dem Recordset
With rs
  'Connection + Einstellungen
  .ActiveConnection = conn
  .CursorType = adOpenKeyset
  .LockType = adLockOptimistic
  'Verbindung mit SQL-Abfrage oeffnen
  .Open strSQL
  'Ergebnis ausgeben, Spaltenbezeichnungen (Ueberschriften) und Daten
  'AO geht davon aus, dass oben die Spaltenbezeichnungen stehen
  'Kopfarray dimensionieren - Kopfnamen werden gesondert ausgelesen!
  ReDim arrHead(.Fields.Count - 1)
  'Schleife ueber alle Kopfnamen (Feldnamen)
  For iCnt = 0 To UBound(arrHead)
    'Kopfname uebernehmen
    arrHead(iCnt) = .Fields.Item(iCnt).Name
  'Ende Schleife ueber alle Kopfnamen (Feldnamen)
  Next
  'Daten uebernehmen
  arrLines = WorksheetFunction.Transpose(.GetRows)
  'Datenabfrage schliessen
  .Close
'Ende Mit dem Recordset
End With
'Verbindung schliessen
conn.Close
'Spaltenueberschriften eintragen, ab L1
Worksheets("TxtToArr").Cells(1, 14).Resize(1, UBound(arrHead) + 1).Value = arrHead
'Daten im Blatt ausgeben, ab J2
Worksheets("TxtToArr").Cells(2, 14).Resize(UBound(arrLines, 1), UBound(arrLines, 2)).Value = (arrLines)
End Sub

5) Einlesen mit dem und TextStream/Readall

Code:
Sub Read_TxtStream_ToArray()
'einige Konstanten - zur Info und Verwendung
Const ForReading = 1, ForWriting = 2, ForAppending = 8
'Format = Systemvorgabe, Unicode, ASCII
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
'Variablendeklarationen
Dim objFSO As Object, objFile As Object, objTxtStr As Object
Dim strFile$, strDelom$, arrLines, arrTmp, arrData() As String
'Pfad+Dateiname zuweisen
strFile = "C:\Test\01_ich.csv"
'Trennzeichen festlegen
strDelim = ";"
'FSO setzen
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Dateiobjekt  zuweisen
Set objFile = objFSO.GetFile(strFile)
'Dateiobjekt oeffnen
Set objTxtStr = objFile.OpenAsTextStream(ForReading, TristateUseDefault)
'Dateiinhalt auslesen und an Array zuweisen
arrLines = Split(objTxtStr.Readall, vbNewLine)
'Dateiobjekt schliessen
objTxtStr.Close
'Startzeile festlegen
lRow = 0
'Schleife ueber alle "Zeilen" im Array
For iCnt1 = LBound(arrLines) To UBound(arrLines)
  'wenn in der Zeile was steht, dann
  If Len(Trim(arrLines(iCnt1))) <> 0 Then
    'Zeile in Spalten trennen
    arrTmp = Split(arrLines(iCnt1), strDelim)
    'Spaltenzahl ermitteln und zuweisen
    lColumn = UBound(arrTmp)
    'temp. A. entsprechend Spalten neu dimensionieren
    ReDim Preserve arrData(lColumn, lRow)
    'Schleife ueber Spalten des temp.A.
    For iCnt2 = LBound(arrTmp) To UBound(arrTmp)
      'Daten in die entsprechende Array-"Zelle" uebernehmen
      arrData(iCnt2, lRow) = arrTmp(iCnt2)
    'Ende Schleife ueber Spalten des temp.A.
    Next
  'Ende wenn in der Zeile was steht, dann
  End If
'Zeilenzaehler hochsetzen
lRow = lRow + 1
'Ende Schleife ueber alle "Zeilen" im Array
Next
'Daten im Blatt ausgeben, ab D1 (iCnt1 + 1, iCnt2 + 4)
Worksheets("TxtToArr").Cells(1, 19).Resize(UBound(arrData, 2) + 1, UBound(arrData, 1) + 1).Value = WorksheetFunction.Transpose(arrData)
End Sub

Bildschirmlupe - Erstellung eigener externer Fenster

Wed, 06 Sep 2023 14:00:11 +0000

Liebe Leserin, lieber Leser,

anliegend stelle ich heute mal mein Projekt "Bildschirmlupe" hier zur Verfügung.
Wer's brauchen kann, kann das gerne nutzen, natürlich wie immer ohne Gewähr.

Sinnvoll wäre die Nutzung als AddIn, bei dem der Startbutton im Ribbon Start zu finden ist.

Das Tool

Die Bildschirmlupe erlaubt das Anzeigen eines Bildschirmausschnittes oder auch eines gerade markierten Objektes in einem externen Fenster.
Der gezeigte Ausschnitt kann in der Lupe per Mausrad vergrößert oder verkleinert dargestellt werden und bleibt auch nach Umschalten z.B. in ein anderes Tabellenblatt, in eine andere Arbeitsmappe und sogar nach Minimierung von Excel an der gewählten Stelle erhalten.

Eine Aktualisierung des Lupeninhalts erfolgt turnusmäßig beim Wechsel der Selektion oder bei Mausklick im Set-Bereich.

Die Lupenfläche ist in sechs Bereiche aufgeteilt.
Je nach dem, in welchem Bereich der User nun klickt, wird folgende Aktion ausgelöst:

Oben links: Neuen Inhalt übernehmen
Oben Mitte: Verschieben der Lupe an eine beliebige neue Stelle bei gedrückter linker Maustaste
Oben rechts: Umschalten zwischen Timer- und Nichttimerbetrieb
Unten links: Verkleinern des Zooms und der Lupengröße
Unten Mitte: Zoom wieder auf 100% setzen
Unten rechts: Vergrößern des Zooms und der Lupengröße

Zur Größenänderung der Lupe zieht man einfach wie gewohnt mit der Maus am Rahmen.

Für eine Übernahme eines Bereichs außerhalb von Excel bzw. an der aktuellen Mausposition kann die Maus ja nicht zum Klicken in der Lupe verwendet werden.
In diesem Fall erfolgt die Übernahme mit der Tastenkombination Strg-Shift. Diese ungewöhnliche Kombination habe ich gewählt, damit andere Programme auf keinen Fall gestört werden.

Zur Beendigung der Lupe drückt man die ESC-Taste oder klickt mit der rechten Maustaste im Lupenbereich.

Die Programmierung

Neben der Nutzung an sich stelle ich diesen Beitrag hier in dieser Rubrik als Workshop ein, weil es ein schönes Beispiel für das Erstellen eines eigenen, externen Fensters ist.
Der Code ist vollständig kommentiert und beschreibt beispielhaft, wie man mit den zwei Haupt-Subs die Fenstererstellung und den Fensterbetrieb realisieren kann.

Hier sieht man, wie man seiner Anwendung eigene Icons und Cursor verpassen kann, sowie Mausaktivitäten und auch Tastaturanschläge abfängt und zur Steuerung nutzen kann.
Zur automatischen, periodischen Übernahme neuer Inhalte in die Lupe ist auch ein Timer integriert. Dieser kann per Mausklick an- oder abgeschaltet werden.

Zusätzlich ist noch Code enthalten, der eine Messagebox je nach Lage der Lupe darüber oder darunter platziert, damit der User nicht immer mit der Maus in die Bildschirmmitte fahren muss.
Natürlich bekommt diese Messagebox auch ein eigenes Icon.
Die Wahl fiel hier auf die API-Messagebox, da sie nur an die Lupe, nicht aber an Excel gebunden sein soll.
Das heißt, dass die Messagebox sichtbar bleibt, auch wenn Excel minimiert oder im Hintergrund ist.

Vielleicht ist es ja für den einen oder anderen ganz interessant, eigene kleine Zusatztools auf dieser Basis zu kreieren.

Zum Schluss noch eine Anmerkung:
Es handelt sich hier nicht um eine unabhängige Windows-Anwendung.
Die Funktionalitäten werden von VBA gehandelt und hierzu läuft abweichend zu anderen Programmen eine entsprechende Do-Schleife.
Dementsprechend hängt alles zeitlich mit Excel und VBA zusammen. Andere Makros können nicht zusätzlich betrieben werden.

Bitte auch beachten, dass das Tool unbedingt vor der Schließung von Excel beendet werden muss.

Lupe.xlsb (Größe: 108,8 KB / Downloads: 4)

Lupe.xlam (Größe: 90,41 KB / Downloads: 4)

So, und nun viel Spaß und Erfolg beim Testen oder Selberbasteln.

Gruß Karl-Heinz

[Excel, Word] Makrorekorder

Fri, 17 May 2019 05:53:40 +0000

Microsoft bietet in seinem Office-Paket den Anwendern unter anderem die Programmiersprache VBA - Visual Basic for Applications. Um den Einstieg in die Programmierung zu erleichtern ist z.B. in Word und Excel ein Makrorekorder integriert.
Auch wenn der Makrorekorder nicht alle möglichen Aktionen aufzeichnet und der aufgezeichnete Code nicht mit einer professionellen Programmierung vergleichbar ist, so kann man ihn doch als Einstieg und zur Vereinfachung einiger Aufgaben nutzen.

Bevor man mit einer Aufzeichnung beginnt, sollte man beachten, dass der Makrorekorder nur die Aktionen aufzeichnet, die man auch ausführt. Wenn z.B. ein Wechsel zwischen Blättern oder Dateien notwendig sein sollte und man tut das bereits vor der Aufzeichnung, fehlt das anschließend bei der Ausführung des Makros. Daher sollte man vor der Aufzeichnung, sofern relevant, möglichst
- Bereiche oder Zellen wählen, die nicht zu Beginn der Aktion oder generell nicht betroffen sind
- ein Blatt / eine Seite wählen, die nicht zu Beginn der Aktion oder generell nicht betroffen ist
- eine Datei wählen, die nicht zu Beginn der Aktion betroffen ist
Dadurch soll erreicht werden, dass im Code einen Wechsel in die entsprechenden Bereiche oder Zellen aufgezeichnet wird. Der Makrorekorder zeichnet Positionen nur auf, wenn man dorthin wechselt. Will man z.B. im Excel immer die Zelle A1 kopieren und befindet sich bei der Aufzeichnung bereits in A1, zeichnet der Code nicht auf, dass es um die Zelle A1 geht. Es wird lediglich das Kopieren der aktuellen Auswahl aufgezeichnet. Hat man beim nächsten Ausführen des aufgezeichneten Makros eine andere Zelle oder einen anderen Bereich gewählt, wird dieser kopiert und nicht A1.

Starten kann man den Makrorekorder z.B. unten Links mit dem Aufzeichnungsbutton.

  Aufzeichnungsbutton.png (Größe: 3,7 KB / Downloads: 111)

Anschließend erscheint ein Dialog, in dem man u.a. den Namen des Makros, eine Tastenkombination, mit der man das Makro starten könnte, und den Speicherort festlegen kann. Anfangs wird das meist die Arbeitsmappe bzw. das Dokument sein. In der persönlichen Arbeitsmappe bzw. der Normal.dotm stehen die Makros dem Anwender in jeder Mappe bzw. jedem Dokument zur Verfügung.

  Dialoge.png (Größe: 6,98 KB / Downloads: 109)
  Dialoge - Spaeicherort.png (Größe: 8,6 KB / Downloads: 97)

Nach Beginn der Aufzeichnung ändert sich der Aufzeichnungsbutton in den Stop-Button. Nach Abschluss aller Aktionen beendet man damit die Aufzeichnung und kann nun testen, ob das Makro seine Aufgabe korrekt erfüllt.

  Aufzeichnungsbutton - Stop.png (Größe: 4,32 KB / Downloads: 96)

Mit einer Tastenkombination geht das sofort, ohne wäre nun die Frage, wie. Man kann z.B. ein Objekt einfügen, z.B. eine Form oder ein Bild, und über das Kontextmenü ein Makro zuweisen. Über diesen Weg kann man auch in den VBA-Editor gelangen, dazu aber in einem anderen Beitrag mehr.

  MakroZuweisen.png (Größe: 64,23 KB / Downloads: 96)
  Dialoge-MakroZuweisen.png (Größe: 5,25 KB / Downloads: 59)

[Excel] Einstieg in das Thema Ribbons Teil 1

Fri, 24 Nov 2017 14:58:31 +0000

Hallo,

ich habe hier eine kurze Einleitung zum Thema Ribbons unter Excel 2016 - derzeit nur zum Download. Im Internet findet man zwar viel zum Thema, aber oft sind die Seiten bei 2007 stehengeblieben. Seitens Microsoft erfolgten jedoch mit steigender Versionsnummer immer wieder Änderungen, sodass hier doch das eine oder andere unter 2016 nicht korrekt funktioniert bzw. meine Beispiele nicht unbedingt in den älteren Versionen.

In diesem ersten Teil geht es darum, was man alles so ohne Programmierung anstellen kann, und das ist gar nicht wenig. Schaut es Euch einfach mal an. In der PowerPoint erfahrt Ihr, wie's geht. Beachtet auch die "Notizen" innerhalb der PowerPoint. Einschalten könnt Ihr die im Ansicht-Ribbon so etwa in der Mitte, Schaltfläche "Notizen".

Die "Example*.xlsx" haben noch die Nummer der PowerPoint-Folie, in der sie behandelt werden.

Für Fragen und Anregungen zum Thema nutzt bitte den Diskussionsbereich zu den Beispielen.

Hier auch noch ein paar Links zum Thema:

René Holtz (mumpel)
http://www.rholtz-office.de/ribbonx/einfuehrung

John Walkenbach
https://powerspreadsheets.com/custom-excel-ribbon/

Ron de Bruin
http://www.rondebruin.nl/win/s2/win001.htm

ein Tool von einem anderer Anbieter
http://www.ribboncreator2016.de/

André Minhorst, ‎Melanie Breden
https://books.google.de/books?id=qdGcfj0tBawC&pg=PA29&lpg=PA29&dq=excel+ribbon+programmierung&source=bl&ots=dgTplYQSfk&sig=-hK_qsNyDnLJmTu4wcU6LLhinWY&hl=de&sa=X&ved=0ahUKEwidj6ryj-bXAhUG7hoKHUhRB4w4ChDoAQhiMAg#v=onepage&q=excel%20ribbon%20programmierung&f=false

  Example-1.xlsm (Größe: 125,27 KB / Downloads: 28)

  Example-2-Folie17.xlsx (Größe: 8,08 KB / Downloads: 14)

  Example-3-Folie18.xlsx (Größe: 8,12 KB / Downloads: 12)

  Example-4-Folie19.xlsx (Größe: 8,73 KB / Downloads: 9)

  Example-5-Folie20.xlsx (Größe: 8,76 KB / Downloads: 10)

  Example-6-Folie21.xlsx (Größe: 8,85 KB / Downloads: 12)

  Ribbon-Aufbau.pptx (Größe: 861,42 KB / Downloads: 40)

[Excel] Umbenennen von Checkboxen

Mon, 29 May 2017 09:34:50 +0000

Zitat:es gibt doch irgendwo in Excel sone Übersicht, wo man sehen kann wie alle Checkboxen heissen und so. Wo finde ich die nochmal? Und wie benenne ich Checkboxen um? Wenn ich einfach oben links die Checkbox umbenenne ändert der das nur manchmal (also bei manchen Kontrollkästchen) und es ändert sich dadruch zwar der angezeigte Name, jedoch nicht der wohl hinterlegte Name. Denn wenn man das Kontrollkästchen dann per Makro anspricht, reagiert es auf seinen alten Namen, aber nicht auf den, der dann oben links durch die Änderung angezeigt wird.

1. Ribbonleiste -> Seitenlayout -> Gruppe: Anordnen -> Aufgabenbereich
Rechts sind alle eingefügten objekte zu sehen.
Dort mit Klick auswählen und Namen ändern

2. Im Namensbereich, da wo sonst die Zelladressen zu sehen sind
vorher die Box mit Rechtsklick auswählen, den Namen im Namensbereich ändern und unbedingt mit ENTER abschließen

3. per VBA:

Code:
Sub kontrolkästchen_umbenennen()
  Dim i As Integer
  With ActiveSheet
      For i = 1 To .CheckBoxes.Count
         .CheckBoxes(i).Name = "CheckBox" & i
      Next
  End With
End Sub

Wenn die Indizes sich in die Quere kommen, kann man die Schleife doppelt laufen lassen, so dass man Namen wählt, die auf keinen Fall vorhanden sind und dann die Benennung mit CheckBox & Index vornimmt.

[Excel] Bereichsnamen - Teil 4b - Dynamische Diagramme

Sat, 06 May 2017 20:26:11 +0000

Beispiel 7
Datenbasis Tabelle (Listobject)

Einen Sonderfall bei der dynamischen Gestaltung von Diagrammen bilden Tabellen. Bezieht sich der Datenbereich eines Diagramms auf den kompletten Bereich der Tabelle, ist keine Definition benannter Bereiche notwendig. Die hier dargestellte Tabelle wurde mit dem entsprechenden Menü erzeugt.

Arbeitsblatt mit dem Namen 'Chart2'
	A	B	C
1	Tage	ich	du
2	heute	1	6
3	morgen	2	5
4	übermorgen	3	4
5	Sonntag	1	1
6	Montag	1	2
7	Dienstag	3	3
8	Mittwoch	4	4

Nochmal als Bild:

DiagrammTabelle.png (Größe: 3,65 KB / Downloads: 25)

Der Datenbereich der Tabelle hat zwar einen Namen, dieser wird bei der Zuordnung der Daten des Diagrammes nicht benötigt und angezeigt.
Zur Erstellung des Diagrammes wird der gesamte Tabellenbereich, hier A1:C8, markiert und anschließend das Diagramm eingefügt. Wo nun genau Excel die Zuordnung zur Tabelle hinterlegt, habe ich noch nicht gesucht. In den Rubriken, wie im Beispiel 6, findet man nur die Zellbezüge.
Im Gegensatz zum Beispiel 6 wird hier das Diagramm ohne benannte Bereiche dynamisch angepasst, sowohl hinsichtlich der Rubriken als auch der Datenreihen.

DiagramNamen2.png (Größe: 9,36 KB / Downloads: 26)

Hinweise für die Verwendung von Namen mit Tabellen
Im Gegensatz zu den bisherigen Formellösungen in Zusammenhang mit der Berechnung der letzten Zeilen und Spalten ist die Definition bei Tabellen sehr einfach.
Allerdings kann man durch die einfache Bezeichnung entsprechend der Spaltenbezeichnungen meist auch auf eine zusätzliche Namensdefinition verzichten. Für die Tabellenbezeichnung sollte man ggf. eine beschreibende Bezeichnung finden.

Hier noch kurz ein paar Formeln mit Zugriff auf die Spalten:

Arbeitsblatt mit dem Namen 'Chart2'
	B
46	kompletter Bereich:
47	=Tabelle1
48	Rubriken:
49	_70_Tab1_RUBRIKEN
50	=Tabelle1[Tage]
51	Ich:
52	_71_Tab1_Ich
53	=Tabelle1[ich]
54	Du:
55	_72_Tab1_Du
56	=Tabelle1[du]

[Excel] Bereichsnamen - Teil 4a - Dynamische Diagramme

Sat, 06 May 2017 20:11:42 +0000

Dynamische Diagramme

Eine einfache dynamische Darstellung der Diagramme hat der eine oder andere vielleicht schon durch Aus- und Einblenden
nicht benötigter Zeilen oder Spalten genutzt.
Im Dialog zu "Daten auswählen" gibt es dazu einen zusätzlichen Dialog für "Ausgeblendete und leere Zellen"
Durch Vorhaltung ausreichend großer Bereiche kann man so auch eine Erweiterung der Darstellung erreichen.
In unserem Workshop zu den benannten Bereichen geht es darum, den Datenbereich ohne Vorhaltung auf die Datenmenge anzupassen.

Beispiel 6
Datenbasis Bereich im Tabellenblatt

In diesem Beispiel geht es lediglich darum, das Diagramm bei Hinzufügen von weiteren Tagen zu erweitern
oder beim Löschen von Tagen einzukürzen.

Arbeitsblatt mit dem Namen 'Chart'
	A	B	C	D	E
1	name	heute	morgen	übermorgen	Sonntag
2	ich	1	2	3	1
3	du	6	5	4	1

Ich habe für diese Aufgabe 3 benannte Bereiche gebildet.
_60_RUBRIKEN
_61_ICH
_62_DU

Arbeitsblatt mit dem Namen 'Chart'
	B	C
9	B1:xx1	=$B$1:INDEX($1:$1;1;VERWEIS(2;1/($1:$1<>"");SPALTE($1:$1)))
10	B2:xx2	=$B$2:INDEX($2:$2;1;VERWEIS(2;1/($2:$2<>"");SPALTE($2:$2)))
11	B3:xx3	=$B$3:INDEX($3:$3;1;VERWEIS(2;1/($3:$3<>"");SPALTE($3:$3)))

Wiederum auf Basis der Funktionen INDEX und VERWEIS wird hier für die Datenreihen und die Rubriken /
Überschriften die jeweils letzte Spalte festgestellt.
Bei Hinzufügen oder Löschen von Daten in den bisher genutzten oder weiteren Spalten erfolgt eine sofortige Umsetzung
im Diagramm.

Ein Hinzufügen von Datenreihen ist hier nicht vorgesehen. Schaut dazu in das folgende Beispiel. Hier aber erst einmal noch das Diagramm:

DiagramNamen1.png (Größe: 4,31 KB / Downloads: 17)

[Excel] Bereichsnamen - Teil 3 - Navigation / Datenabrufe

Sat, 06 May 2017 19:59:50 +0000

Tabellennavigation / Datenabfragen

Ich habe hier eine kleine Mitarbeitertabelle (MAT) erstellt und den Bereich entsprechend benannt.
In den folgenden Beispielen greife ich auf unterschiedliche Art und Weise auf die einzelnen Felder
dieser Tabelle zurück.
An dieser Stelle möchte ich auch gleich darauf hinweisen, dass bei den Mitarbeitern natürlich auch
Doppelungen auftreten können . Das führt zu Problemen bei der korrekten Auswahl.
Für eine eindeutige Auswahl wären weitere Angaben nötig - idealerweise Personalnummern.

Arbeitsblatt mit dem Namen 'Daten'
	A	B	C	D	E
2	Name	Vorname	Geburtstag		MAT
3	Müller	Gerd	02.02.2012
4	Meier	Marion	03.03.2013
5	Schulze	Horst	04.04.2014

Beispiel 4
Gezielte Abfragen
In diesen beiden Abfragen hole ich konkret die Vornamen zu dem in der links benachbarten Zelle eingetragenen
Familiennamen. Ich verwende hier einmal den SVERWEIS und einmal den VERWEIS kombiniert mit INDEX.
=SVERWEIS(Daten!I13;_5_MAT;2;0)
=VERWEIS(2;1/(INDEX(_5_MAT;;1)=A7);INDEX(_5_MAT;;2))
mit den Namen _4_Vorname_S und _4_Vorname_V

Sofern Marion Meier einen der beiden Herren heitratet und beide den gleichen Familiennamen führen,
wird das auch im Ergebnis der Abfragen deutlich - probiert es einfach mal aus.
(Anmerkung: Auch wenn Gerd und Horst so zueinander finden, kann man es sehen

Arbeitsblatt mit dem Namen 'Daten'
	A	B
12	Müller	Gerd
13	Müller	Gerd

Name	Bezug
_4_Vorname_S	=SVERWEIS(Daten!XFD12;_5_MAT;2;0)
_4_Vorname_V	=VERWEIS(2;1/(INDEX(_5_MAT;;1)=Daten!XFD12);INDEX(_5_MAT;;2))

Zelle	Formel
B12	=_4_Vorname_S
B13	=_4_Vorname_V

Beispiel 5
Flexible Abfragen
Um flexibel bestimmte Mitarbeiterdaten abrufen zu können, habe ich mir eine Auswahl der Tabellenspalten
zusammengestellt. Dazu verwende ich die Gültigkeit und beziehe mich auf die erste Zeile der MAT:
=INDEX(_5_MAT;1;)
Ich kann nun entsprechend der Spaltenüberschriften auswählen.
Sofern eine Spalte eingefügt wird, erweitert sich die Auswahl gleich. Auf ein Anfügen einer Spalte würde die
hier gezeigte Lösung nicht reagieren - aber machbar wäre dies auch.

Für die Berechnung der Daten habe ich einen weiteren Namen definiert
=_5_MAT_Auswahl
Auch hier kommt wieder eine Funktion mit VERWEIS und INDEX zum Einsatz.
=VERWEIS(2;1/(INDEX(_5_MAT;;1)=Daten!$A9);INDEX(_5_MAT;;VERGLEICH(Daten!$B9;INDEX(_5_MAT;1;);0)))

Arbeitsblatt mit dem Namen 'Daten'
	A	B	C
24	Müller	Geburtstag	02.02.2012

Name	Bezug
_5_MAT	=Daten!$A$2:$C$5
_5_MAT_Auswahl	=VERWEIS(2;1/(INDEX(_5_MAT;;1)=Daten!$A24);INDEX(_5_MAT;;VERGLEICH(Daten!$B24;INDEX(_5_MAT;1;);0)))

Zelle	Formel
C24	=_5_MAT_Auswahl

Zelle	Gültigkeitstyp	Operator	Wert1	Wert2
B24	Liste		=INDEX(_5_MAT;1;)

Arbeitsblatt mit dem Namen 'Daten'
	B	C	D
36	weitere Formelbeispiele
37
38		letzte	letzte
39		Zeile in	Spalte in
40		Spalte A	Zeile 2
41	bezogen auf	24	5
42	ganzes Blatt	Müller	MAT
43
44		letzte	letzte
45		Zeile von	Spalte von
46		MAT	MAT
47	bezogen auf	5	3
48	ganzes Blatt	Schulze	Geburtstag
49
50		erste	erste
51		Zeile von	Spalte von
52		MAT	MAT
53	bezogen auf	2	1
54	ganzes Blatt
55
56		Anzahl	Anzahl
57		Zeilen in	Spalten in
58		MAT	MAT
59		4	3

Name	Bezug
_5_MAT	=Daten!$A$2:$C$5

Zelle	Formel
C41	=VERWEIS(2;1/(A2:A37<>"");ZEILE(A$2:A$37))
D41	=VERWEIS(2;1/(Daten!2:2<>"");SPALTE(Daten!2:2))
C42	=VERWEIS(2;1/(A2:A37<>"");A$2:A$37)
D42	=VERWEIS(2;1/(Daten!2:2<>"");Daten!2:2)
C47	=VERWEIS(2;1/(INDEX(_5_MAT;;1)<>"");ZEILE(_5_MAT))
D47	=VERWEIS(2;1/(INDEX(_5_MAT;1;)<>"");SPALTE(INDEX(_5_MAT;1;)))
C48	=VERWEIS(2;1/(INDEX(_5_MAT;;1)<>"");INDEX(_5_MAT;;1))
D48	=VERWEIS(2;1/(INDEX(_5_MAT;1;)<>"");INDEX(_5_MAT;1;))
C53	=ZEILE(_5_MAT)
D53	=SPALTE(_5_MAT)
C59	=ZEILEN(_5_MAT)
D59	=SPALTEN(_5_MAT)

[Excel] Bereichsnamen - Teil 2 - Formeln in Namen

Sat, 06 May 2017 19:54:45 +0000

Formeln und Funktionen in Bereichsnamen

In Bereichsnamen können viele Formeln und Funktionen umgesetzt werden.
Dadurch kann man sich eigene Funktionen zusammenstellen und in Zellen nutzen.
Die Formeln in den Zellen kann man so einfacher und übersichtlicher gestalten.
Der Anwender kann bei entsprechender Benennung einfach auf den Zweck der Funktion schließen.
Excel unterstützt immer noch sogenannte Excel4Macro-Funktionen. Viele dieser Funktionen können nur über Bereichsnamen verwendet werden.
Dieses Thema beschreibe ich in einem gesonderten Kapitel.

Beispiel 1
Addition
Die beiden Zellen A1 und A2 sollen addiert werden. Dazu soll eine Formel genutzt werden,
=$A$1+$B$1
Über den Namensmanager wird nun ein neuer Name angelegt,
_1_Rechnen
und mit der Formel versehen.
Die Funktion _1_Rechnen kann nun an beliebiger Stelle platziert werden, überall wird die Summe aus A1 und B1 gebildet.

Der Name könnte natürlich etwas aussagekräftiger sein.
Na ja, die _1_ ist meiner Beispielgliederung geschuldet. Braucht also sonst keiner.
Statt Rechnen wäre z.B. SummeA1B1 ganz gut, oder?

Übrigens, eine Änderung des Namens im Namensmanager führt automatisch zur Änderung der Formeln in den Zellen.

Arbeitsblatt mit dem Namen 'Formeln'
	A	B	C	D	E
12	1	2	3
13	3				3

Name	Bezug
_1_Rechnen	=Formeln!$A$12+Formeln!$B$12

Zelle	Formel
C12	=_1_Rechnen
A13	=_1_Rechnen
E13	=_1_Rechnen

Beispiel 2
Summe der Werte der beiden Zellen aus Spalte A und B in der Formelzeile
Eine absolute Angabe der Zelladressen könnte z.B. Sinn machen, wenn es sich dabei um Zellen zur Eingabe durch den Benutzer handelt.
Für Berechnungen z.B. in Listen sind relative Zellangaben oder eine Kombination aus relativen und absoluten Angaben vorteilhaft.
Bei Fortführung der Listen kann man die Formel ohne Anpassung weiterverwenden.
Ich habe nun diese Formel definiert
=SUMME($A26:$B26)
und unter disem Namen abgelegt
_2_SummeLinks
Die Funktion berechnet nun die Summe der Zahlen aus Spalte A und B der gleichen Zeile und kann in der Zeile in einer beliebigen Spalte ab C stehen..
A und B sind durch das vorangestellte $ absolute angaben, de Zeennummern ohne $ relativ.

Arbeitsblatt mit dem Namen 'Formeln'
	A	B	C	D	E
27	1	3	4	4
28	1	7	8		8

Name	Bezug
_2_SummeLinks	=SUMME(Formeln!$A27:$B27)

Zelle	Formel
C27	=_2_SummeLinks
D27	=_2_SummeLinks
C28	=_2_SummeLinks
E28	=_2_SummeLinks

Summe der Werte aller Zellen links neben der Formelzeile
Hier habe ich eine abgewandelte Form der SummeLinks. In der Formel
=SUMME($A26:B26)
mit dem Namen
_2_SummeVonGanzLinks
ist nur noch die Spalte A absolut. Dadurch wird bei Einsatz der Formel ab Spalte C oder später die Summe aller links daneben befindlichen Zellen berechnet.

Arbeitsblatt mit dem Namen 'Formeln'
	A	B	C	D	E
38	1	7	8	16	32

Name	Bezug
_2_SummeVonGanzLinks	=SUMME(Formeln!$A38:XFD38)

Zelle	Formel
C38	=_2_SummeVonGanzLinks
D38	=_2_SummeVonGanzLinks
E38	=_2_SummeVonGanzLinks

Beispiel 3
Berechnung des Bruttopreises aus dem Nettopreis und der Mehrwertsteuer
Ein kleines praktisches Beispiel ist die Verwendung benannter Bereiche zur Ermittlung des Bruttowertes.
Um mit verschiedenen Mehrwertsteuersätzen ohne Formeländerung arbeiten zu können, habe ich eine Eingabezelle mit MwSt benannt.
Diese Zelle verwende ich dann in der Formel
=A10*(1+MwSt/100)
und speichere sie unter dem Namen
_3_Brutto
Die Formel rechnet nun den Brottowert zu de rlinks daneben befindlichen Zelle.

Arbeitsblatt mit dem Namen 'Formeln'
	A	B	C
46		19
47	120	142,8
48		150	178,5
49	100	119

Name	Bezug
_3_Brutto	=Formeln!XFD46*(1+_3_MwSt/100)

Zelle	Formel
B47	=_3_Brutto
C48	=_3_Brutto
B49	=_3_Brutto