Clever-Excel-Forum - mit VBA

Userform auf Excelzelle positionieren

Wed, 04 Feb 2026 12:17:27 +0000

Hallo Forum,

wer seine Userform immer genau an die Stelle einer Excelzelle positionieren möchte, der kann dazu folgenden Code verwenden....

Code:

Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) 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 Sub UserForm_Activate()
  Dim oCell As Range
  
  Set oCell = ActiveSheet.Range("B5")
  With ActiveWindow.ActivePane
       SetWindowPos FindWindowA("ThunderDFrame", Me.Caption), 0&, _
                    .PointsToScreenPixelsX(oCell.Left - 5), _
                    .PointsToScreenPixelsY(oCell.Top - 1), _
                    0&, 0&, &H1 ' &H1 = SWP_NOSIZE
  End With
End Sub

_________
viele Grüße
Karl-Heinz

Inputbox als Passwortabfrage

Wed, 10 Dec 2025 09:24:06 +0000

Hallo,

wer eine Passwortabfrage mit geschützten Zeichen mittels einer Excel-Inputbox machen möchte, kann sich des u.a. Codes bedienen.

Es ist eine Minimalversion mit wenig Code, die lediglich die Eigenschaft der Editbox ändert. Das anzuzeigende Ersatzzeichen, z.B. *, kann freigewählt werden.

PS: Die Application.Inputbox funktioniert diesbezüglich nicht. Ich nehme an, dass die Eigenschaft von der Inputbox selbst wieder verstellt wird.

Code:

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 GetActiveWindow Lib "user32" () 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
Dim mhTimer As LongPtr

Public Function GetPassword(Optional sPrompt As String = "Bitte geben Sie das Passwort ein!", _
                            Optional sCaption As String = "Passwortabfrage") As String
  mhTimer = SetTimer(0, 0, 25, AddressOf Password_Callback)
  GetPassword = InputBox(sPrompt, sCaption)
End Function

Private Sub Password_Callback()
  If mhTimer <> 0 Then KillTimer 0, mhTimer: mhTimer = 0  ' Timer löschen
'                       ID der Editbox = 4900, &HCC=EM_SETPASSWORDCHAR
  SendDlgItemMessageA GetActiveWindow(), 4900, &HCC, Asc("*"), 0
End Sub

' ###### Aufruf #####
Sub Test()
  MsgBox GetPassword()
End Sub

_________
viele Grüße
Karl-Heinz

Auswertung Lotto/ Eurojackpot

Thu, 09 Oct 2025 14:20:46 +0000

Hallo,

für alle Lotto- u. Eurojackpotspieler habe ich mal zwei Dateien, mit denen man die Zahlen der Ziehungen ansehen und auswerten kann (für Statistiker)und seine eigenen Tipps auswerten kann. Für Verbesserungsvorschläge bin ich dankbar.

EJ_Abruf_V1.xlsx (Größe: 79,58 KB / Downloads: 11)
Lottoabruf_V1.xlsm (Größe: 491,66 KB / Downloads: 11)

Temporäre tabellierte Abschlussmeldungsbox

Sun, 09 Mar 2025 14:00:06 +0000

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.

Abschlussmeldung.png (Größe: 8,02 KB / Downloads: 64)

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

Datei in mehreren Instanzen suchen

Thu, 20 Feb 2025 13:39:24 +0000

Hallo liebe Leserin, lieber Leser,

manchmal hat man aus irgendwelchen Gründen Dateien geöffnet, die sich in mehreren Excel-Instanzen befinden.
Will man diese schließen oder eine bestimmte Datei via Workbook-Schleife finden, scheitert man oft, da nur in der eigenen Instanz gesucht wird.

Nachfolgende Funktion ermittelt alle vorhandenen Excel-Instanzen, die man nun für seine Zwecke nutzen kann.

Viel Erfolg beim Testen.

Code:

Private Declare PtrSafe Function GetClassNameA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpClassName As String, _
        ByVal nMaxCount As Long) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32" ( _
        ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32" ( _
        ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, _
        ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Sub IIDFromString Lib "ole32.dll" ( _
        ByVal lpsz As String, ByRef lpiid As GUID)
Private Declare PtrSafe Sub AccessibleObjectFromWindow Lib "oleacc.dll" ( _
        ByVal hwnd As LongPtr, ByVal dwId As Long, _
        ByRef riid As GUID, ByRef ppvObject As Any)

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type
Private mtGuid As GUID
Private Const IID_EXCELWINDOW As String = "{00020893-0000-0000-C000-000000000046}"
Private Const OBJID_NATIVEOM  As Long = &HFFFFFFF0
Private moTmpApplications()   As Application
Private miAnz     As Long
Private msAllHWnd As String, msClassname As String * 16

Function GetApplications() As Application()
' Alle Kinder-Fenster über die geladenen Eltern-Fenster ermitteln
  miAnz = 1
  Erase moTmpApplications: msAllHWnd = ","          ' Array zurücksetzen
  
' Konvertiere die IID des Excel-Window-Objektes in die GUID-Struktur
  Call IIDFromString(StrConv(IID_EXCELWINDOW, vbUnicode), mtGuid)

  Call EnumWindows(AddressOf EnumAppsProc, ByVal 0&)
  GetApplications = moTmpApplications               ' Array zurückgeben

End Function

Private Function EnumAppsProc(ByVal hwnd As LongPtr, ByVal lParam As Long) As Long
' Durchlaufe alle Eltern-Fenster
  If Left$(msClassname, GetClassNameA(hwnd, msClassname, 16)) = "XLMAIN" Then
     EnumChildWindows hwnd, AddressOf EnumXlsProc, ByVal 0&
  End If
  EnumAppsProc = 1                                  ' Nächster Aufruf
End Function

Private Function EnumXlsProc(ByVal hwnd As LongPtr, ByVal lParam As Long) As Long
' Durchlaufe alle Kinder-Fenster bis EXCEL7 gefunden
  Dim oWin As Window, hWndApp As LongPtr

  If Left$(msClassname, GetClassNameA(hwnd, msClassname, 16)) = "EXCEL7" Then

' Hole über die Zugriffsnummer das entsprechende Window-Objekt
     Call AccessibleObjectFromWindow(hwnd, OBJID_NATIVEOM, mtGuid, oWin)

' Verweis setzen auf Application-Objekt
     If Not oWin Is Nothing Then
        hWndApp = oWin.Application.hwnd
        If InStr(msAllHWnd, "," & hWndApp & ",") = 0 Then
           ReDim Preserve moTmpApplications(miAnz)
           Set moTmpApplications(miAnz) = oWin.Application
           msAllHWnd = msAllHWnd & hWndApp & ","
           miAnz = miAnz + 1
        End If
     End If
     Exit Function                              ' Fertig mit Job
  End If
  EnumXlsProc = 1                               ' Nächster Aufruf
End Function

' ##### Aufrufbeispiele #####
Sub SchließeAlleAnderenInstanzen()
' Sub beendet alle anderen Excel-Instanzen außer der Aktuellen
  Dim oApps() As Application, WkB As Workbook
  Dim i As Long, bIsThis As Boolean
  
  oApps = GetApplications                       ' Hole die Excel-Instanzen

  For i = 1 To UBound(oApps)
      bIsThis = False
      For Each WkB In oApps(i).Workbooks
          bIsThis = WkB Is ThisWorkbook         ' Beinhaltet Instanz diese Datei?
          If bIsThis Then Exit For              ' Wenn ja => raus
      Next WkB
      oApps(i).DisplayAlerts = False
      If bIsThis = False Then
         oApps(i).DisplayAlerts = False
         oApps(i).Quit                          ' Diese Excel-Instanz beenden
      End If
  Next i
End Sub

Sub SucheDateiInAllesInstanzen()
' Sub sucht eine offene Mappe in allen Excel-Instanzen
  Dim oApps() As Application, WkB As Workbook
  Dim i As Long, sMappe As String
  
  sMappe = ThisWorkbook.Name
  oApps = GetApplications                       ' Hole die Excel-Instanzen

  For i = 1 To UBound(oApps)
      For Each WkB In oApps(i).Workbooks
          If WkB.Name Like sMappe Then
             MsgBox "Workbook '" & sMappe & "' gefunden in Instanz " _
                  & i & " von " & UBound(oApps) & " Instanz(en)!", _
                    vbInformation
          End If
      Next WkB
  Next i
End Sub

_________
viele Grüße
Karl-Heinz

Userform - In Listbox mit Mausrad scrollen und weiteres

Thu, 13 Feb 2025 07:45:41 +0000

Liebe Leserin, lieber Leser,
manchmal möchte man in seiner Userform-Listbox gerne mit dem Mausrad bequem scrollen oder vielleicht einen Doppelclick oder Rechtsclick ausführen, um weitere Aktionen zu ermöglichen.

Das ist bei einer Listbox so weit ich weiß nicht vorgesehen.

Das Thema 'Scrollen mit dem Mausrad' wurde hier schon mal behandelt.
https://www.clever-excel-forum.de/Thread...Comboboxen

Damals wurde die Funktionalität über Mousehooking realisiert. Mit der u.a. gezeigten, weniger empfindlichen, Methode benötigt man weniger Code.
Unterschied ist jedoch, dass hier die gewünschte Listbox aktiviert sein muss, während beim Mousehooking das Scrollen bereits beim Überfahren funktioniert.

Hier eine Minimalversion für Listboxscrollen für z.B. zwei Listboxen.
PS: Hat man erst mal Zugang zur Listbox, kann man noch viel mehr machen.....

Code:

' <<<<<<<<< in Modul >>>>>>>>>
Private Declare PtrSafe Function PostMessageA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As Long
Private Declare PtrSafe Function GetFocus 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
#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 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

Dim mlpOldProc As LongPtr

Sub UF_Start(oCtrl As control)
  Dim hWndCtrl As LongPtr
  
  On Error GoTo Fehler
  oCtrl.SetFocus
  hWndCtrl = GetFocus()                     ' Handle holen
  If hWndCtrl <> 0 Then                     ' Listbox hooken
     mlpOldProc = SetWindowLongA(hWndCtrl, GWL_WNDPROC, AddressOf WindowProc)
  End If
Fehler:
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim i As Long
  
  Select Case uMsg
  
  Case &H20A ' WM_MOUSEWHEEL
       If hwnd = GetFocus Then
          If wParam > &HFF0000 Then i = 40 Else i = 38
          PostMessageA hwnd, &H100, i, 0 ' WM_KEYDOWN
          PostMessageA hwnd, &H101, i, 0 ' WM_KEYUP
          Exit Function
       End If
  Case &H203, &H205 ' WM_LBUTTONDBLCLK und WM_RBUTTONUP
       MsgBox IIf(uMsg = &H203, "Doppelclick", "Rechtsclick")
    
  End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, ByVal wParam, ByVal lParam)
End Function


' <<<<<<<<< ins Userformmodul >>>>>>>>>
Private Sub UserForm_Activate()
  Call UF_Start(Me.ListBox1)
  Call UF_Start(Me.ListBox2)
End Sub

_________
viele Grüße
Karl-Heinz

Dateieigenschaften EXIF-Daten ermitteln

Wed, 05 Feb 2025 12:32:35 +0000

Liebe Leserin, lieber Leser,

zum Auslesen diverser Dateieigenschaften von Mediendateien wird oft GetDetailsOf verwendet.

Hier mal eine weitere Möglichkeit, sich diese Daten anzeigen zu lassen.

Die Sub listet alle gefundene Eigenschaften mit Name und Wert auf.
Die Funktion zeigt, wie man ohne Schleife auf eine Einzeleigenschaft, hier Aufnahmedatum, zugreifen kann.

Code:

Function Aufnahmedatum(sDatei As String) As Variant
' Function gibt das Aufnahmedatum eines Fotos zurück
  On Error Resume Next
  With CreateObject("WIA.ImageFile")
     .LoadFile (sDatei)
     If Err.Number <> 0 Then
        Aufnahmedatum = "Die Datei" & vbLf & sDatei & vbLf _
                      & "wurde nicht gefunden!"
     Else
        Aufnahmedatum = "Kein Aufnahmedatum vorhanden!"
        Aufnahmedatum = CDate(Replace(.Properties("ExifDTDigitized").Value, ":", "/", 1, 2))
     End If
  End With
End Function

Sub ErmittleDateieigenschaften(sDatei As String)
' Funktion listet alle EXIF-Dateieigenschaften der Datei auf
  Dim oProp As Object, L As Long
  Const Lz As String = "          "
  
  On Error Resume Next
  With CreateObject("WIA.ImageFile")
     .LoadFile (sDatei)
     If Err.Number <> 0 Then
        MsgBox "Die Datei" & vbLf & sDatei & vbLf & "wurde nicht gefunden!", _
               vbCritical, "EXIF-Daten ermitteln"
        Exit Sub
     End If
     For Each oProp In .Properties
         With oProp
            L = Len(.Name)
            If L > 5 Then
               Debug.Print Left$(.Name & Lz & Lz, 25) & .Value
            End If
         End With
     Next oProp
  End With
End Sub



Sub Test()
  ErmittleDateieigenschaften "D:\Pictures\Fotos\PICT0010.JPG"
  MsgBox Aufnahmedatum("D:\Pictures\Fotos\PICT0010.JPG")
End Sub

_________
viele Grüße
Karl-Heinz

PC - Lautstärke einstellen

Fri, 24 Jan 2025 18:15:30 +0000

Hallo Forum,

manchmal möchte man per VBA die Lautstärke an seinem PC einstellen.

Neben einigen anderen bei mir nicht funktionierenden Methoden bietet sich eine Methode an, bei der eine WM_APPCOMMAND-Message an Windows gesendet wird.
Leider wird hier nur VolumeUp, VolumeDown und VolumeMute angeboten und das auch noch mit zwei Prozent Änderung pro Aufruf anstatt mit einem Prozent.

Somit ist eigentlich die Übergabe eines festen Lautsprecherlevels nicht möglich.

Ein Trick wäre, immer erst auf Null zu fahren und dann anhand dieses festen Startwerts das Volumen durch Hochfahren festzulegen und sich den neuen Wert zu merken.
Vom neuen gemerkten Startwert können Folgeeinstellungen dann direkt erfolgen.

Der folgende Code ermöglicht die

Festlegung eines Levels durch Übergabe eines geraden positiven Wertes von 0 bis 100

Prozentuale Erhöhung oder Verminderung durch Übergabe eines negativen oder ungeraden Wertes

Stummschaltung bzw. Einschaltung des Tones durch die Übergabe eines Wertes größer 100 bzw. WM_Mute.

Erzwingung des Runterfahrens und dadurch Speicherung eines Startwertes

PS: Durch die Zwei-Prozentveränderung wird der gewünschte Wert manchmal nicht direkt getroffen, aber das sollte ja kein Problem darstellen.

Code:

Public Const WM_Mute    As Long = &H80000
Dim miLastVolume        As Long
        
Private Declare PtrSafe Function SetVolume Lib "user32" Alias "SendMessageA" ( _
        ByVal hwnd As LongPtr, ByVal wMsg As Long, _
        ByVal wParam As LongPtr, lParam As LongPtr) As LongPtr

Private Sub Lautstärke(ByVal iWert As Long, Optional bReset As Boolean)
  Const WM_AppCmd As Long = &H319
  Const WM_Down   As Long = &H90000
  Const WM_Up     As Long = &HA0000
  Dim i As Long
  
  With Application
     If Abs(iWert) > 100 Then
        SetVolume .hwnd, WM_AppCmd, 0, ByVal WM_Mute        ' Mute ein/ausschalten
        Exit Sub
     End If
  
     If iWert < 0 Or (iWert Mod 2) = 1 Then
        iWert = iWert + miLastVolume + IIf(iWert < 0, -1, 1)
     End If
     If iWert <> 0 And iWert = miLastVolume And bReset = False Then Exit Sub

     If miLastVolume = 0 Or bReset Then                     ' Auf Null fahren
        For i = 1 To 50
            SetVolume .hwnd, WM_AppCmd, 0, ByVal WM_Down
        Next i
        miLastVolume = 0                                    ' Runtergefahren
     End If

     For i = 1 To Abs(iWert - miLastVolume) \ 2             ' Jetzt Lautstärke verändern
         SetVolume .hwnd, WM_AppCmd, 0, ByVal IIf(iWert < miLastVolume, WM_Down, WM_Up)
     Next i
     If iWert > 100 Then iWert = 100                        ' Korrigierung
     If iWert < 0 Then iWert = 0                            ' Korrigierung
     miLastVolume = iWert                                   ' Level merken
  End With
End Sub



' ### Tests ###
Sub Test1()
  Lautstärke 6, True ' Lautstärke auf 0, dann auf 6 setzen
End Sub

Sub Test2()
  Lautstärke 60      ' Lautstärke sofort auf 60 setzen
End Sub

Sub Test3()
  Lautstärke 20      ' Lautstärke sofort auf 20 setzen
End Sub

Sub Test4()
  Lautstärke 5       ' Lautstärke um 5 erhöhen
End Sub

Sub Test5()
  Lautstärke -7      ' Lautstärke um 7 erniedrigen
End Sub

Sub Test6()
  Lautstärke WM_Mute ' Lautstärke stummschalten
End Sub

_________
viele Grüße
Karl-Heinz

Dateien auflisten incl. aus Unterordnern

Sun, 29 Dec 2024 17:23:31 +0000

Liebe Leserin, lieber Leser,

eine der häufigsten Fragen in Foren ist u.a. die Frage:
- Wie kann ich alle Dateien anhand einer Suchmaske aus einer Verzeichnisstruktur ermitteln?

Die gute, alte Dir-Funktion aus DOS-Zeiten kann nur aus einem Ordner lesen.
Ansonsten gibt es mehrere Wege, FileScripting oder spezielle DOS-Befehle usw..

Heute wollen wir aber mal eine weniger bekannte API-Funktion dafür nutzen.....

Code:


Option Explicit

Private Declare PtrSafe Function EnumDirTreeW Lib "Dbghelp.dll" ( _
                ByVal hProcess As LongPtr, ByVal RootPath As LongPtr, _
                ByVal InputPathName As LongPtr, ByVal OutputPathBuffer As LongPtr, _
                ByVal cb As LongPtr, ByVal data As LongPtr) As Long
Private Declare PtrSafe Function lstrlenW Lib "kernel32.dll" ( _
                ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function lstrcpyW Lib "kernel32.dll" ( _
                ByVal lpString1 As LongPtr, ByVal lpString2 As LongPtr) As Long
Dim msArrFiles() As String

Private Function DateiListe(ByVal sPfad As String, Optional sDirMaske As String = "*") As Long
' Füllt ein Array mit den Dateipfadnamen
  ReDim Preserve msArrFiles(0)                  ' Dateiarray zurücksetzen
  
  EnumDirTreeW 0, StrPtr(sPfad), StrPtr(sDirMaske), 0, AddressOf CB_EnumDirTree, 0
  DateiListe = UBound(msArrFiles) - 1           ' Anzahl gefundener Dateien zurückgeben

End Function

Private Function CB_EnumDirTree(ByVal lpcwStr As LongPtr, ByVal iNone As Long) As Boolean
  Dim i As Long

  i = UBound(msArrFiles)                        ' Aktuelle Arraygröße ermitteln
  msArrFiles(i) = String(lstrlenW(lpcwStr), 0)  ' Variable mit ausreichend Platz schaffen
  lstrcpyW StrPtr(msArrFiles(i)), lpcwStr       ' String umkopieren
  ReDim Preserve msArrFiles(i + 1)              ' Array neu dimensionieren
End Function


' ##### Aufruftests #####
Private Sub Demo1()
  Dim i As Long
  
  i = DateiListe("C:\Users\voltm\Desktop\MyTools", "*")
  If i < 0 Then
    MsgBox "Habe keine Dateien gefunden!", vbCritical
  Else
    For i = 0 To i
        Debug.Print msArrFiles(i)
    Next i
    MsgBox "Habe " & i & " Dateien gefunden!", vbInformation
  End If
End Sub

Private Sub Demo2()
  Dim i As Long
  
  i = DateiListe("C:\Users\voltm\Desktop\MyTools", "Excel*")
  If i >= 0 Then
    ActiveSheet.Cells(1, 1).Resize(i + 1, 1) = WorksheetFunction.Transpose(msArrFiles)
  End If
End Sub

_________________________
viele Grüße aus Freigericht ?
Karl-Heinz

Info-ToolTip über ausgewählten Zellen anzeigen

Tue, 10 Dec 2024 14:16:46 +0000

Liebe Leserin, lieber Leser,

hat man eine umfangreiche Liste und möchte man beim Lesen gerne Zusatzinformationen haben, die sich aber auf einem anderen Blatt befinden, so könnte man diese in einem kleinen PopUp-Fenster temporär neben dem aktuellen Feld anzeigen lassen.

Es besteht z.B. die Möglichkeit, für jedes relevante Feld (per VBA) einmalig oder ggf. mit gelegentlichen Updates Notizen anzulegen, die dann automatisch beim Überfahren des Feldes angezeigt werden.
Oder man zeigt nach einem Feldwechsel über das Event SelectionChange eine Notiz an oder kreiert eine eigene Textbox. Diese würde nach einem weiteren Feldwechsel wieder verschwinden.

Mit diesem Beitrag möchte ich aber eine weitere Möglichkeit zeigen, die mit einem eher echten Mouseover eine selbst gestaltete Textbox für die Dauer des Mausaufenthalts über dem besagten Feld anzeigt.

Nicht zu verschweigen sei hierbei, dass diese Methode etwas zeitintensiver ist als die anderen beiden Methoden.
Deshalb werden zwei Tickzeiten verwendet.

Eine längere Tickzeit von z.B. 800 mSec, wenn kein ToolTip aktiv ist.
Es dauert dann 800 mSec bis zur Anzeige. Bei schnellen Mausbewegungen werden dann nicht ständig Textboxen aufgemacht.
Und der Rechner ist weniger belastet.

Eine kürzere Tickzeit von z.B. 80 mSec.
Damit verschwindet bei Verlassen des Textfeldes der Tooltip recht zügig.

Über die Events Activate und DeActivate kann die Funktionalität auf beliebige Blätter begrenzt werden.

Code:

Private Sub Worksheet_Activate()
  Call StartPopUp       ' PopUp aktivieren
End Sub

Private Sub Worksheet_Deactivate()
  Call StopPopUp       ' PopUp deaktivieren
End Sub

Außerdem kann zur weiteren Ressourcenschonung ein begrenzter Bereich und/oder ein bestimmtes Suchmuster vorgegeben werden.

Wichtig ist das Abschalten des PopPup beim Schließen der Arbeitsmappe mittels des Events BeforeClose.

Hinweis
Der Code ist etwas umfangreicher, weil auch ein Fensterhandling eingebaut wurde.
Bei Aktivierung einer anderen Anwendung als Excel wird die Funktionalität bis zur Reaktivierung der Mappe abgeschaltet.
Das gilt auch für den VBA-Editor. So kann man auch bequem weiterprogrammieren.

Übrigens, die generierte Textbox kannst Du nach eigenen Vorstellungen anpassen.

Hier auch noch eine Datei zum Ausprobieren....

PopUpUeberZelle.xlsb (Größe: 53,73 KB / Downloads: 10)

Und der Mustercode:

Code:

Option Explicit

' ###    Einstellungen    ###
Private Const mbTooltip     As Boolean = True               ' An- Abschalten der Funktionalität, z.B. für Wartungsarbeiten
Private Const csSuch        As String = "[EI]*"             ' Suchmuster, * = egal
Private Const csActiveRange As String = "*"                 ' Aktiven Bereich vorgeben, * = alles
Private Const csDataRange   As String = "Daten!A:A"         ' Datenblatt und Bereich mit den PopUp-Daten
Private Const ciSpalte      As Integer = 2                  ' Spalte im Datenblatt mit den PopUp-Texten
Private Const ciBMax        As Integer = 0                  ' Feste Kästchenbreite vorgeben 0=auto
Private Const ciFontGross   As Integer = 10                 ' Schriftgröße, 9 ist normal
Private Const ciTickTime    As Long = 800                   ' Verzögerung Box-Anzeige in mSec
' ### Ende Einstellungen ###

Private Declare PtrSafe Function SetTimer Lib "user32.dll" ( _
        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.dll" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SetWinEventHook Lib "user32" ( _
        ByVal eventMin As Long, ByVal eventMax As Long, _
        ByVal hmodWinEventProc As LongPtr, _
        ByVal lpfnWinEventProc As LongPtr, ByVal idProcess As Long, _
        ByVal idThread As Long, ByVal dwflags As Long) As LongPtr
Private Declare PtrSafe Function UnhookWinEvent Lib "user32" ( _
        ByVal hWinEventHook As LongPtr) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Dim mhCurWin    As LongPtr                                  ' Handle de aktiven Fensters
Dim mhEventHook As LongPtr                                  ' Handle des Eventhooking
Dim mhTimer     As LongPtr                                  ' Handle des Hooking
Dim moCurObj    As Range
Dim msLastRange As String                                   ' Letztes PopUp-Feld
Dim mbAktiv     As Boolean

Public Sub StartPopUp()
  If mbTooltip = False Then Exit Sub                        ' Kein PopUp gewünscht =>raus
  Call ToolTip_Delete                                       ' Ggf. altes Tooltip löschen
  mhCurWin = GetActiveWindow                                ' Gerade aktives Fenster
  If mhEventHook = 0 Then
     mhEventHook = SetWinEventHook(3, 3, 0, AddressOf EventProc, 0, 0, 0)
     Call StartTimer                                        ' Mausabfragen starten
  End If
End Sub

Public Sub StopPopUp()                                      ' Beendet den Eventhook und Timer
  If mhEventHook <> 0 Then UnhookWinEvent mhEventHook: mhEventHook = 0
  Call StopTimer                                            ' Timer löschen
  Call ToolTip_Delete                                       ' Ggf. Tooltip löschen
End Sub

Private Sub StartTimer()
  If mhTimer = 0 Then                                       ' Timer starten
     mhTimer = SetTimer(0, 0, IIf(mbAktiv, 80, ciTickTime), AddressOf TimerTick)
  End If
End Sub

Private Sub StopTimer()
  If mhTimer <> 0 Then KillTimer 0&, mhTimer: mhTimer = 0   ' Timer löschen
End Sub

Private Function EventProc(ByVal hWinEventHook As LongPtr, ByVal WinEvent As Long, _
                           ByVal hwnd As LongPtr, ByVal idObject As Long, _
                           ByVal idChild As Long, ByVal dwEventThread As Long, _
                           ByVal dwmsEventTime As Long) As Long
  If hwnd = Application.hwnd Then
     Call StartTimer
  Else
     If mhCurWin = Application.hwnd Then Call StopTimer     ' Mausgesten/Timer stoppen
  End If
  mhCurWin = GetActiveWindow
End Function

Private Sub TimerTick()
' Diese Sub wird periodisch aufgerufen
  Dim Pt As POINTAPI, rngBer As Range
 
  DoEvents
  GetCursorPos Pt                                           ' Mausposition holen
  On Error Resume Next
 
  Set moCurObj = ActiveWindow.RangeFromPoint(Pt.X, Pt.Y)    ' Objekt unter Maus
  If Err <> 0 Then Err.Clear: Exit Sub                      ' Fehler => raus

  If TypeOf moCurObj Is Range Then                          ' Ist es eine Range?
     With moCurObj
         If .MergeArea.Address <> msLastRange Then          ' Maus jetzt auf anderem Range?
            msLastRange = .MergeArea.Address                ' Alte Range-Adresse merken
            If mbAktiv = True Then
               Call StopTimer:   mbAktiv = False
               Call ToolTip_Delete                          ' Tooltip löschen
            End If
            
            If Len(csActiveRange) > 1 Then                  ' Aktiven Bereich setzen
               Set rngBer = Range(csActiveRange)
            Else
               Set rngBer = ActiveSheet.UsedRange
            End If
' PopUp anzeigen
            If Not Intersect(rngBer, moCurObj) Is Nothing And mbAktiv = False _
               And .Value Like csSuch And .Value <> "" Then
               Call StopTimer:   mbAktiv = True
               Call Tooltip_Create(moCurObj)                ' Tooltip erstellen
            End If
            Call StartTimer                                 ' Timer neu starten
         End If
     End With
  End If
End Sub

Sub ToolTip_Delete()
  On Error Resume Next
  ActiveSheet.Shapes.Range("ToolTip").Delete                ' Evtl. vorhandene Textbox löschen
End Sub


Sub Tooltip_Create(oRng As Range)
' Hier das Objekt formatieren oder ggf. etwas anderes programmieren
  Dim WSh As Worksheet
  Dim sText As String, sArr() As String, t As String
  Dim Y As Integer, X As Integer, B As Integer, H As Integer, L As Currency
  Dim i As Integer, j As Integer, iGefunden As Long

  On Error Resume Next
  Set WSh = Sheets(Split(csDataRange, "!")(0))              ' Datenblatt setzen
  If WSh Is Nothing Then Exit Sub                           ' Datenblatt nicht gefunden =>raus

  With oRng
      sText = .MergeArea.Cells(1, 1).Value                  ' Suchtext holen
      If sText = "" Then Exit Sub                           ' Kein Text=>raus
      iGefunden = Application.WorksheetFunction.Match(sText, _
                  WSh.Range(Split(csDataRange, "!")(1)), 0) ' Suchbegriff suchen
      If iGefunden = 0 Then Exit Sub                        ' Suchtext nicht gefunden =>raus
      sText = WSh.Cells(iGefunden, ciSpalte).Value          ' Tooltip-Text holen
      sText = Replace(sText, "¶", vbLf)                     ' Textumbrüche setzen
      sArr = Split(sText, vbLf)                             ' Text in Array
      
      For i = 0 To UBound(sArr)
          If ciBMax = 0 Then
             L = 0
             For j = 1 To Len(sArr(i))                      ' Textbreite je Zeile ermitteln
                 t = Mid$(sArr(i), j, 1)
                 L = L + 2.75
                 If InStr(1, Chr$(34) & " !/()\''|,;.:1ijl", t, vbTextCompare) = 0 Then L = L + 2.5
                 If InStr(1, Chr$(34) & "wm_", t, vbTextCompare) > 0 Then L = L + 0.75
                 If Asc(t) > 64 And Asc(t) < 97 Then L = L + 1.5
              Next j
              If L > B Then B = L                           ' Textboxlänge ermitteln
          End If
          H = H + 12                                        ' Zeilenhöhe
      Next i
      B = B * ciFontGross \ 9
      If ciBMax > 0 Then B = ciBMax                         ' Feste Breitenvorgabe
  
      Call ToolTip_Delete                                   ' Evtl. vorhandenes Tooltip löschen
      Y = .Top + 1: X = .Offset(0, 1).Left + 2              ' Box positionieren

' Tooltip: Anzeigebox erstellen <<< Parameter ggf. hier anpassen >>>
      With .Parent.Shapes.AddTextbox(1, X, Y, B, H)
          .Name = "ToolTip"
          .Visible = msoTrue                                ' ToolTip sichtbar
          With .TextFrame2.TextRange
               .Font.Fill.ForeColor.RGB = RGB(255, 255, 160)
               .Font.Size = ciFontGross
               .Font.Name = "Arial"
               .Text = sText
          End With
          With .Fill
               .ForeColor.RGB = RGB(0, 0, 100)              ' Hintergrundfarbe setzen
               .Solid
          End With
          With .TextFrame2
               .AutoSize = msoAutoSizeShapeToFitText        ' Textboxgröße automatisch
               .MarginLeft = 1.5:   .MarginTop = 1.5        ' Randabstände
               .MarginBottom = 1.5: .MarginRight = 1.5      ' Randabstände
          End With
      End With
  End With
End Sub

_________
viele Grüße
Karl-Heinz

Userform - Titelleiste formatieren

Wed, 09 Oct 2024 14:02:40 +0000

Liebe Leserin, lieber Leser,

das Formatieren der Titelleiste einer Userform ist eigentlich nicht vorgesehen. Möchte man diese formatieren, blenden viele Programmierer die Titelleiste aus und formatieren die Userform an sich entsprechend.
Es entsteht sozusagen eine "Fake"-Titelleiste.

Dass es aber trotzdem geht, die Titelleiste zu formatieren, möchte ich mit nachfolgendem Code einmal aufzeigen.

Der nachfolgende Code bzw. der Code in der Beispieldatei erstellt formatiert die Titelleiste einer Userform.

Hierzu müssen wir uns in die Messageschleife der Userform einhooken und die Message WM_NCPAINT entsprechend bearbeiten, denn das Bemalen der Captionbar ist in Windows standardmäßig nicht vorgesehen.

Zum Malen in der Captionbar wird diese und der Rahmen drum herum erst mal von Windows gelöscht. Leider werden auch der Schatten und das Systemkreuz gelöscht und nicht wieder hergestellt.
Der Aufwand das Systemkreuz und den Schatten wieder herzustellen, ist mir zu groß. Das Systemkreuz wurde daher abgeschaltet und als Schatten eine kleine Sonderlösung eingebaut.

Userform_Titelleiste.png (Größe: 9,11 KB / Downloads: 71)

Wen's also nicht stört, der kann dann gerne so eine formatierte Userform bauen. Restliche Erklärungen wie immer im Code....

Und nun viel Spaß und Erfolg beim Ausprobieren....

Userform_Titelleiste_Formatieren.xlsb (Größe: 46,78 KB / Downloads: 13)

Code:

Private Const iPenB As Long = 2     ' Schattenbreite 1 bis 5

' Window-Funktionen
Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetClientRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long

' Hooking-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
 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 hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
#End If
Private Const GWL_WNDPROC    As Long = -4

' GDI-Funktionen
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
'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
Private Declare PtrSafe Function CreatePen Lib "gdi32" ( _
        ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" ( _
        ByVal crColor As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CreateFontA Lib "gdi32.dll" ( _
        ByVal nHeight As Long, ByVal nWidth As Long, _
        ByVal nEscapement As Long, ByVal nOrientation As Long, _
        ByVal fnWeight As Long, ByVal fdwItalic As Long, _
        ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, _
        ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, _
        ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, _
        ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As LongPtr
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal nBkMode 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 GetStockObject Lib "gdi32" (ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function MoveToEx Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function LineTo Lib "gdi32" (ByVal hDC As LongPtr, _
        ByVal x As Long, ByVal y As Long) As Long

Type POINTAPI
    x As Long
    y As Long
End Type

Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" ( _
        ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
Private Declare PtrSafe Function ColorAdjustLuma Lib "shlwapi.dll" ( _
        ByVal clrRGB As Long, ByVal n As Long, ByVal fScale As Long) As Long
Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, _
        ByVal X1 As Long, ByVal Y1 As Long, _
        ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare PtrSafe Function FrameRect Lib "user32" (ByVal hDC As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long

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

Type Userform_Titlebar_STRUCT
   Caption        As String
   BackFarbe      As Long
   Textfarbe      As Long
   TextPosition   As Long       ' 0=links, 1=Zentriert
   Schriftgroesse As Long
   Schriftart     As String
   Fett           As Boolean
   kursiv         As Boolean
   Rand           As Long       ' 0=keiner, 1=weiß, 5=schwarz usw.
   Rahmenfarbe    As Long
End Type
Global mtUF As Userform_Titlebar_STRUCT

Dim mhDlgProc As LongPtr, mhFont As LongPtr
Dim mhPen(2) As LongPtr, mhBrush(2) As LongPtr
Dim PT As POINTAPI

Sub FormatUserform()
  Dim hWndUF As LongPtr, iFarbe As Long
  Const GWL_STYLE As Long = -16
  
  mhPen(1) = 0: mhPen(2) = 0: mhFont = 0
  With mtUF
     hWndUF = FindWindowA("ThunderDFrame", .Caption)
     
     SetWindowLongA hWndUF, GWL_STYLE, _
     GetWindowLongA(hWndUF, GWL_STYLE) And Not &H80000              ' &H80000 = WS_SYSMENU abschalten

     mhBrush(1) = CreateSolidBrush(.BackFarbe)                      ' Pinsel Caption HG-Farbe erstellen
     iFarbe = IIf(.Rahmenfarbe <> 0, .Rahmenfarbe, .BackFarbe)
     mhBrush(2) = CreateSolidBrush(iFarbe)                          ' Pinsel Rahmen HG-Farbe erstellen
     If .Schriftgroesse > 0 And .Schriftart <> "" Then              ' Neue Schriftart erstellen
        mhFont = CreateFontA(.Schriftgroesse, 0, 0, 0, _
                             IIf(.Fett, 700, 400), IIf(.kursiv, 1, 0), _
                             0, 0, 0, 0, 0, 0, 0, .Schriftart)
     End If
' Pens für die Schattenbildung erstellen
     If .Rand > 0 Then
        mhPen(1) = CreatePen(0, 2, vbWhite)                         ' Weißen Pen erstellen (2 Pixel)
        iFarbe = ColorAdjustLuma(iFarbe, -300, True)                ' Farbe für Schatten abdunkeln
        mhPen(2) = CreatePen(0, iPenB, iFarbe)                      ' Farbigen Pen erstellen (2 Pixel)
     End If
  End With
' Userform hooken, alle Meldungen für die Userform werden umgeleitet
  mhDlgProc = SetWindowLongA(hWndUF, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
                            ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
' CallbackProzedur für Meldungen der Userform
  Dim hDC As LongPtr
  Dim B As Long, H As Long, i As Long
  Dim R As RECT, RC As RECT
  
  Select Case uMsg
  
  Case &H85, &H6  ' WM_NCPAINT, WM_ACTIVATE
' Titelleiste und Rahmen beabeiten
       GetClientRect hwnd, RC                                       ' Userform-Fläche holen
       hDC = GetWindowDC(hwnd)                                      ' Userform-Fläche incl. Caption/Rahmen
       B = RC.Right: H = RC.Bottom + 48
       SetRect R, 0, 0, 9, H:           FillRect hDC, R, mhBrush(2) ' linker Rahmen
       SetRect R, B + 9, 0, B + 18, H:  FillRect hDC, R, mhBrush(2) ' rechter Rahmen
       SetRect R, 0, H - 10, B + 18, H: FillRect hDC, R, mhBrush(2) ' unterer Rahmen
       SetRect R, 9, 0, B + 9, 9:       FillRect hDC, R, mhBrush(2) ' oberer Rahmen
       SetRect R, 9, 9, B + 9, 38:      FillRect hDC, R, mhBrush(1) ' Captionbereich setzen
'      SetRect R, 9, 0, B + 9, 38:      FillRect hDC, R, mhBrush(1) ' Captionbereich setzen
      
       SetBkMode hDC, 1 ' 1 = Transparent                           ' Hintergrundmodus transparent setzen
       If mhFont <> 0 Then SelectObject hDC, mhFont                 ' Font aktivieren
       SetTextColor hDC, mtUF.Textfarbe                             ' Schriftfarbe setzen
       DrawTextA hDC, mtUF.Caption & vbNullChar, (-1), R, _
                      IIf(mtUF.TextPosition > 0, &H25, &H24)        ' Jetzt Text erneut ausgeben

       If mhPen(1) <> 0 And mhPen(2) <> 0 Then                      ' Rand bearbeiten>0
          SelectObject hDC, mhPen(1)                                ' Weißen Pen aktivieren
          MoveToEx hDC, 1, H - 1, PT:  LineTo hDC, 1, 1: LineTo hDC, B + 18, 1
          SelectObject hDC, mhPen(2)                                ' Farbigen Pen aktivieren
          MoveToEx hDC, B + 18 - iPenB, 2, PT: LineTo hDC, B + 18 - iPenB, H - iPenB - 1
                                               LineTo hDC, 2, H - iPenB - 1
       Else
          SetRect R, 1, 1, RC.Right + 18, RC.Bottom + 47            ' Rahmenbereich setzen
          FrameRect hDC, R, GetStockObject(5)                       ' Userform-Umrandung zeichnen
       End If
       
       ReleaseDC hwnd, hDC                                          ' Device Context (DC) auflösen
       Exit Function

  Case &H2   ' WM_DESTROY                                           ' Userform beeenden
' Aufräumen
       For i = 1 To 2
         If mhPen(i) <> 0 Then DeleteObject mhPen(i)                ' Pens wieder löschen
         If mhBrush(i) <> 0 Then DeleteObject mhBrush(i)            ' Pinsel wieder löschen
       Next i
       If mhFont <> 0 Then DeleteObject mhFont                      ' Font wieder löschen
       Call SetWindowLongA(hwnd, GWL_WNDPROC, mhDlgProc)            ' Userform unhooken
       Exit Function
  End Select

' Andere Messages an Urspungsprozedur weiterleiten
  WindowProc = CallWindowProcA(mhDlgProc, hwnd, uMsg, ByVal wParam, ByVal lParam)

End Function

_________
viele Grüße
Karl-Heinz

Msgbox: Schriftfarbe und Hintergrundfarbe ändern

Mon, 26 Aug 2024 22:10:03 +0000

Hallo liebe Leserin, lieber Leser,

immer wieder liest man in den Foren zu Fragen, ob denn die Hintergrundfarbe oder die Textfarbe einer Messagebox nicht geändert werden könne, dass das nicht möglich sei.
Nur einer hat es m.E. bei Mr. Excel mit viel Aufwand geschafft, hier eine entsprechende Lösung zu präsentieren.

Und ja, es ist (natürlich) möglich, die Hintergrundfarbe einer MsgBox oder weiterer Dialogboxen individuell zu verändern.

Eine Möglichkeit wäre, für die gesamte Klasse die Hintergrundfarbe mittels SetClasslong zu setzen. Aber dann hätten ja alle Dialogboxen diesen Hintergrund. Eher nicht so gut.
Das Setzen der Hintergrundfarbe einer Dialogbox oder eines Controls ist mit vertretbarem Aufwand nicht so einfach.

Aber, warum zeichnen wir die Dialogbox oder das Control nicht einfach neu.
Im hier gezeigten Code machen wir genau das. Leider mit ein paar Einschränkungen, aber für den Hausgebrauch könnte es reichen.

Als Font holen wir uns den Originalfont des Static der Messagebox. Natürlich könnte man auch einen eigenen Font kreieren, mit abweichender Schriftart, fett oder unterstrichen usw.
Hierzu findest Du hier eine entsprechende Anregung....
https://www.clever-excel-forum.de/Thread...se-aendern

Eine Möglichkeit, die Button individuell zu beschriften, findest Du hier.
https://www.clever-excel-forum.de/Thread...genem-Icon

Leider sind die Icons, die die Msgbox hier verwendet, keine guten Icons. Die Hintergrundfarbe ist nicht transparent, so dass diese nicht so gut aussehen.
Ggf. kann man bei Bedarf auch eigene Icons verwenden.

PS: Hier wird eine einfache Hintergrundfarbe verwendet. Als Brush könnte man natürlich auch ein Muster hier verwenden....

Msgbox_Backcolor.png (Größe: 4,35 KB / Downloads: 35)

Und nun viel Spaß beim Ausprobieren...

Code:

Option Explicit
' Timerfunktionen
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
' Windowsfunktionen
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
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 = -4
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, _
        lpRect As RECT) As Long
' GDI-Funktionen
Private Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal crColor As Long) As Long
Private Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal nBkMode As Long) As Long
Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hdc As LongPtr, _
        lpRect As RECT, ByVal hBrush As LongPtr) As Long
Private Declare PtrSafe Function BeginPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) As LongPtr
Private Declare PtrSafe Function EndPaint Lib "user32" (ByVal hwnd As LongPtr, _
        lpPaint As PAINTSTRUCT) 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 Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDlgItem Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
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
Private Declare PtrSafe Function TextOutA Lib "gdi32" (ByVal hdc As LongPtr, _
        ByVal x As Long, ByVal y As Long, ByVal lpString As String, _
        ByVal nCount As Long) 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 Type RECT
   Left   As Long
   Top    As Long
   Right  As Long
   Bottom As Long
End Type

Private Type PAINTSTRUCT
   hdc        As LongPtr
   fErase     As Long
   rcPaint    As RECT
   fRestore   As Long
   fIncUpdate As Long
   rgbReserved(0& To 31&) As Byte
End Type

Private Type MSGBOXPARAM
   Textfarbe As Long
   HGFarbe   As Long
End Type
Dim mMP As MSGBOXPARAM

Dim mhTimer As LongPtr, mlpOldProc As LongPtr, msText As String

Private Function MsgboxEx(sText As String, _
         Optional ByVal iDlgStyle As Long, Optional sCaption As String) As Long
  msText = sText
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxHookProc)             ' Timer setzen
  MsgboxEx = MsgBox(sText, iDlgStyle, sCaption)                        ' (Excel)-Msgbox starten
End Function

Sub MsgBoxHookProc()
' Setzt die Hooking-Prozedur für die MsgBox
  Dim hwnd As LongPtr
  
  KillTimer 0&, mhTimer: mhTimer = 0                                   ' Timer löschen
  hwnd = GetActiveWindow()                                             ' (Excel)-Msgbox suchen
  If hwnd <> 0 Then _
  mlpOldProc = SetWindowLongA(hwnd, GWL_WNDPROC, AddressOf WindowProc) ' (Excel)-Msgbox hooken
End Sub

Private Function WindowProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
         ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
  Dim tPS As PAINTSTRUCT
  Dim tR  As RECT
  Dim hdc As LongPtr, hBrush As LongPtr, hStatic As LongPtr, hFont As LongPtr
  Dim i As Integer, z As Integer, sArr() As String
     
  Select Case uMsg
  Case &HF  ' &HF = WM_PAINT
     hBrush = CreateSolidBrush(mMP.HGFarbe)             ' Einen neuen Brush erstellen
     hStatic = GetDlgItem(hwnd, 65535)                  ' Handle des Textfeldes
     hFont = SendMessageA(hStatic, &H31, 0, 0)          ' Schriftart des Textfeldes
     For i = 1 To 2
         BeginPaint IIf(i = 1, hwnd, hStatic), tPS
         If i = 1 Then
            FillRect tPS.hdc, tPS.rcPaint, hBrush       ' Dlgbox mit Farbe füllen
         Else
            SetBkMode tPS.hdc, 1 ' 1 = Transparent      ' Hintergrundmodus setzen
            SelectObject tPS.hdc, hFont                 ' Font aktivieren
            SetTextColor tPS.hdc, mMP.Textfarbe         ' Schriftfarbe setzen
            sArr = Split(msText, vbLf)
            For z = 0 To UBound(sArr)
                TextOutA tPS.hdc, 1, z * 18 + 1, sArr(z), Len(sArr(z)) ' Text ausgeben
            Next z
         End If
         EndPaint hwnd, tPS
      Next i
      DeleteObject hBrush                               ' Brush löschen
   End Select
  WindowProc = CallWindowProcA(mlpOldProc, hwnd, uMsg, wParam, lParam)
End Function

Private Sub Aufruftest()
  Dim sText As String
  sText = "Dieses hier ist ein Beispieltext," & vbLf & "der auch umgebrochen ist" _
        & vbLf & "und zwar mehrfach!" & vbLf & "Findest Du das gut?"
  With mMP
    .Textfarbe = RGB(0, 0, 60)
    .HGFarbe = RGB(255, 210, 255)
  End With
  MsgBox (MsgboxEx(sText, vbYesNo, "Mein Hintergundtest"))
End Sub

_________
viele Grüße
Karl-Heinz

Excel schließen nach Timeout mit Countdown

Thu, 22 Aug 2024 15:00:04 +0000

Liebe Leserin, liebe Leser,

manchmal möchte man Excel nach einer bestimmten Zeit automatisch schließen. Hierbei wäre es schön, wenn der User auch darüber informiert würde und ggf. auch noch die Möglichkeit hätte, den Schließenprozess abzuwenden.

Hier mal eine Idee zur Aufgabenstellung...

Es wird nach Ablauf einer bestimmten Zeit eine Msgbox angezeigt, in der ein Countdown abläuft. Während des Countdowns hat der User Zeit, die Msgbox zu schließen und Excel weiter aktiv zu lassen.
Ansonsten wird Excel bzw. die aktuelle Mappe automatisch beendet.

Code:

Option Explicit
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) 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 MessageBoxA Lib "user32" ( _
        ByVal hwnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, _
        ByVal wType As Long) As Long
Private Declare PtrSafe Function SetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
Private Declare PtrSafe Function GetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, _
        ByVal lpString As String, ByVal nMaxCount As Long) 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
        
Private mhTimer As LongPtr, miRestzeit As Long
Private Const miTimeOut As Long = 10     ' in Sekunden

Private Sub CloseExcelNow()
' Anzeigen einer MsgBox mit CountDown
  
  mhTimer = SetTimer(0&, 0&, 1000, AddressOf SetMsgText)    ' Timer setzen
  MessageBoxA Application.hwnd, _
              "Das Programm schließt automatisch in " & miTimeOut & " Sekunden!", _
              "Schließen: " & ThisWorkbook.Name, vbExclamation Or vbModeless
  KillTimer 0&, mhTimer                                     ' Timer löschen

  If miRestzeit > 1 Then Exit Sub                           ' User hat Button geklickt
' Jetzt Excel bzw. Mappe schließen
  If Workbooks.Count = 1 Then
     If ThisWorkbook.Saved = False Then ThisWorkbook.Save   ' Mappe ggf. speichern
     Application.Quit                                       ' Excel beenden
  Else
     ThisWorkbook.Close True                                ' Nur Mappe schließen
  End If
End Sub

Private Sub SetMsgText()
  Dim i As Integer, sArr() As String, hDlg As LongPtr
  Dim sText As String * 255

  hDlg = GetActiveWindow                                    ' Handle der Dialogbox
  SetDlgItemTextA hDlg, 2, "Stopp Prozess"                  ' Buttontext setzen
  GetDlgItemTextA hDlg, 65535, sText, 255                   ' Messagetext holen
  sArr = Split(Left$(sText, InStr(sText, vbNullChar) - 1))  ' Messagetext splitten
  For i = 0 To UBound(sArr)
     If Val(sArr(i)) > 0 Then
        sArr(i) = sArr(i) - 1: miRestzeit = Val(sArr(i))    ' Restzeit anpassen
        DoEvents
        If sArr(i) < 1 Then PostMessageA hDlg, &H10, 0&, 0& ' &H10 = WM_CLOSE
        SetDlgItemTextA hDlg, 65535, ByVal Join$(sArr)      ' Messagetext neu setzen
     End If
   Next i

End Sub


Public Sub CloseExcel()
' Starte den Schließenprozess, Wartezeit 5 Minuten
  Application.OnTime Now + TimeSerial(0, 5, 0), "CloseExcelNow"
End Sub

_________
viele Grüße
Karl-Heinz

Datei in den Papierkorb verschieben

Tue, 20 Aug 2024 17:44:39 +0000

Hallo,

der VBA-Befehl Kill löscht ja eine Datei unwiderruflich.

Wer Dateien lediglich in den Papierkorb schicken möchte, um sie später vielleicht doch wieder dort raus zu kramen, kann folgenden Code dafür nutzen.

Code:

Private Declare PtrSafe Function SHFileOperationA Lib "Shell32.dll" ( _
        lpFileOp As SHFILEOPSTRUCT) As Long

Private Type SHFILEOPSTRUCT
   hwnd                  As LongPtr
   wFunc                 As Long
   pFrom                 As String
   pTo                   As String
   fFlags                As Integer
   fAnyOperationsAborted As Long
   hNameMappings         As LongPtr
   lpszProgressTitle     As String
End Type

Private Sub VerschiebeDateiIndenPapierkorb(sDateiname As String)
  Dim tStruct As SHFILEOPSTRUCT
  
  Const FOF_ALLOWUNDO       As Long = &H40  ' Datei wird in den Papierkorb verschoben
  Const FOF_FILESONLY       As Long = &H80  ' Löscht nur Dateien, keine Verzeichnisse
  Const FOF_NOCONFIRMATION  As Long = &H10  ' Löscht ohne Rückfrage
  Const FOF_SILENT          As Long = &H4   ' Zeigt keinen Fortschrittsbalken an.
  
  tStruct.wFunc = &H3           ' &H3& = FO_DELETE
  tStruct.pFrom = sDateiname
  tStruct.fFlags = FOF_ALLOWUNDO Or FOF_SILENT Or FOF_NOCONFIRMATION
  SHFileOperationA tStruct      ' Jetzt löschen
End Sub

' ##### Test ####
Sub Test()
  VerschiebeDateiIndenPapierkorb "D:\Freigericht.png"
End Sub

_________
viele Grüße
Karl-Heinz

Scrollen mit dem Mausrad und Mittelbuttonklick abschalten

Sun, 18 Aug 2024 08:21:33 +0000

Hallo,

in bestimmten Fällen möchte man das Mousewheeling, also das Scrollen mit der Maus unterbinden oder das Klicken mit dem Mittelbutton abschalten.

Anliegend mal ein Beispiel, wie das erreicht werden kann.

PS: Das gilt bei Bedarf natürlich auch analog für die übrigen Mausfunktionen.

Code:

Private Declare PtrSafe Function SetWindowsHookExA Lib "user32" ( _
        ByVal idHook As Long, ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, ByVal dwThreadId As Long) As LongPtr
Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, ByVal nCode As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As LongPtr) As Long
Dim hHook As LongPtr

Sub MausRadAn()
  UnhookWindowsHookEx hHook: hHook = 0
End Sub

Sub MausRadAus()
' Baut den Mousehook auf                      14 = WH_MOUSE_LL
  If hHook = 0 Then hHook = SetWindowsHookExA(14, _
                    AddressOf MouseProc, Application.HinstancePtr, 0)
End Sub

Private Function MouseProc(ByVal nCode As Long, ByVal wParam As LongPtr, _
                           lParam As LongPtr) As LongPtr
' Fängt Mausrad und MittelButton ab
  Const WM_MOUSEWHEEL  As Long = &H20A
  Const WM_MBUTTONDOWN As Long = &H207
  Const WM_MBUTTONUP   As Long = &H208
  
  If nCode = 0 Then ' 0 = HC_ACTION
     Select Case wParam
     Case WM_MOUSEWHEEL, WM_MBUTTONDOWN, WM_MBUTTONUP
          MouseProc = 1: Exit Function
     End Select
  End If
  MouseProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End Function


'########### In das gewünschte Tabellenmodul #############
Private Sub Worksheet_Activate()
  Call MausRadAus
End Sub

Private Sub Worksheet_Deactivate()
  Call MausRadAn
End Sub

_________
viele Grüße
Karl-Heinz