Clever-Excel-Forum - Komplettlösungen

Internationale Feiertage

Sun, 22 Mar 2026 23:05:39 +0000

Hi,

es gibt ja immer wieder mal Vorschläge für Dauer-, Ferien- oder Feiertagskalender. Z. Bsp. den von @PIVPQ oder @Schauan oder vielen anderen. Daher wäre es müßig einen weiteren anzuhängen.
Meist berücksichtigen die jedoch nur die deutschen Feiertage. Die richtig guten sogar sind sogar erweiterbar (neu sind ja der Intern. Frauentag in Berlin und MV oder der Kindertag in Thüringen) und berücksichtigen die Feiertage sogar in Abhängigkeit vom Bundesland.
Aber sobald man über die bundesdeutsche Grenze schaut, wird es schon dünn. Noch dünner, wenn man nach weltweiten Feiertagen sucht.
Bei Github bin ich auf die griechischen Feiertage gestoßen und von da ausgehend auf die internationalen, die ich Euch für die schnelle Recherche in einer PQ Lösung bereitstelle.
Die Datei beinhaltet Makros. Wer keine Makros mag, kann sie deaktivieren, muss dann aber die Auswahl und Aktualisierung der Parameter- und Ergebnistabellen per Hand ausfüllen/anstoßen.
Mit Makro genügt ein Klick in eine beliebige Zelle der Auswahltabelle (linke Seite)

InternationaleFeiertage.xlsm (Größe: 38,27 KB / Downloads: 5)

Date-Picker (Kalendersteuerelement) mit KW

Thu, 14 Aug 2025 07:22:09 +0000

Hallo Miteinander,

den Simple Datepicker hier noch um die Anzeige der Kalenderwoche erweitert.

Stand Alone Simple Datepicker+KW.xlsm (Größe: 128,38 KB / Downloads: 12)

Gruß Uwe

Dynamische Userform - schnelle Auswahlbox

Mon, 04 Aug 2025 12:09:32 +0000

Liebe Leserin, lieber Leser,

für die schnelle Auswahl eines oder mehrerer Elemente aus einem Elementensatz könnte man bequem eine Auswahlbox mit Radio- oder Checkboxen nutzen.

Hierzu gibt es hier im Forum im Bereich "Beispiele und Workshops" ja auch schon Beiträge, z.B. der Umbau einer Inputbox usw.

Wer kein API-Freund ist und lieber bei den Excelmöglichkeiten bleiben möchte, der kann sich ja eine Userform dafür hernehmen.

Heute wollen wir uns für diese Aufgabe eine dynamische Userform bauen, die programmatisch erstellt, angezeigt und nach Benutzung wieder gelöscht wird.

Der nachfolgende Beispielcode erstellt eine Auswahlbox mit folgenden Eigenschaften:

Einfach- oder Mehrfachauswahl mittels Radiobuttons oder Checkboxen
Elementübergabe mittels String, Array, Range oder Objekt
Anzeigeposition zentriert, an vorgegebener Position oder an Mausposition z.B. bei Rechtsklick
Anzeige mit oder ohne Schaltflächen, für eine kleine Box mit schneller Auswahl
und weiteres

Userform_AuswahlBox.png (Größe: 7,28 KB / Downloads: 37)

Zur besseren Demonstration verschiedenster Versionen lade Dir die anliegende Datei herunter....

Dynamische Userform.xlsb (Größe: 41,07 KB / Downloads: 13)

Code:

' #### "Zugriff auf das VBA-Projektobjektmoddel vertrauen" muss im Trustcenter aktiviert sein ####

' Auswahl zwischen mehreren Begriffen auf der Basis einer temporären UserForm
' entweder als Radio-Button (nur ein Eintrag auswählbar) oder als Checkbox (mehrere Einträge auswählbar)

' Beim Aufruf von "GetAuswahl" sind folgende Parameter mitzugeben:
'
' 1:    Ein Array oder ein kommagetrennter String oder ein Excel-Range mit den Begriffen

' alle anderen Parameter sind optional
' 2.    Titeltext (Caption der Userform)
' 3:    MultiSelect:
'       True     Anzeige als Checkbox-Buttons
'       False    Anzeige als Radio-Buttons
' 4:    Prompt:                 Default: "Bitte triff Deine Auswahl!"
'       optional: ein beliebiger Text
' 5, 6: Position
'       einer 0  Anzeige zentriert
'       beide >0 Anzeige der Userform an dieser Position
'       beide -1 Anzeige an der Mausposition

' Rückgabe: Kommagetrennter String, der durch den User durch Split bei Bedarf in ein Aray transferiert werden kann

Option Explicit
Option Compare Text
Option Base 1

' Private Const csPrompt As String = "Bitte triff Deine Auswahl!" ' Wenn leer, dann kein Prompt
Private Const csPrompt As String = ""                           ' Wenn leer, dann kein Prompt, kein Frame
Private Const ccUmrech As Currency = 5.5                        ' Zur Ermittlung der UF-Breite anhand des Textes
Private Const csSep    As String = ","

Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long
Private Type POINTAPI
    x As Long
    y As Long
End Type

Public gvErg() As Variant           ' gvErg(1) ist die Rückgabevariable

Public Function GetAuswahl(ByVal Items As Variant, Optional ByVal Titel As String, _
                           Optional ByVal MultiSel As Boolean, _
                           Optional ByVal MsgTxt As String, _
                           Optional ByVal xPos As Long, Optional ByVal yPos As Long, _
                           Optional NoButtons As Boolean) As Variant

  Dim oUF          As Object
  Dim PT           As POINTAPI
  Dim oFrm         As Object
  Dim bFrame       As Boolean
  Dim sCtrlTyp     As String
  Dim sCode        As String
  Dim sUFName      As String
  Dim iCtrPos      As Long, iAnz  As Long, iNr As Long
  Dim iUFBreite    As Long
  Dim yPosInUF     As Long
  Const ciBtnLinks As Long = 5
  Const ciBtnBreit As Long = 65
  Const ciBtnAbst  As Long = 15

  If IsObject(Items) Then
     iAnz = Items.Count
  ElseIf IsArray(Items) Then
     iAnz = UBound(Items)
  Else
     If Items = vbNullString Then Exit Function
     Items = Split(csSep & Items, csSep)
     iAnz = UBound(Items)
  End If
  ReDim gvErg(iAnz)
  
  bFrame = True                                         ' Mit oder ohne Gruppenrahmen
  yPosInUF = 5

' Userformbreite ermitteln
  If MultiSel Then
     iUFBreite = (ciBtnLinks + ciBtnBreit) * 2 + ciBtnAbst + 12
  Else
     iUFBreite = ciBtnLinks * 2 + ciBtnBreit + 40
  End If
  If Len(Titel) * ccUmrech * 1.2 > iUFBreite Then iUFBreite = Len(Titel) * ccUmrech * 1.2
  If MsgTxt = "" Then MsgTxt = csPrompt
  If Len(MsgTxt) * ccUmrech > iUFBreite Then iUFBreite = Len(MsgTxt) * ccUmrech
  For iNr = 1 To iAnz
      If Len(Items(iNr)) * ccUmrech > iUFBreite Then iUFBreite = Len(Items(iNr)) * ccUmrech
  Next iNr
  
' Userform erstellen
  If Titel = "" Then Titel = Split(ActiveWorkbook.Name, ".")(0)
  Set oUF = ThisWorkbook.VBProject.VBComponents.Add(3)
  With oUF
     .Properties("Width") = iUFBreite                   ' Breite der Userform setzen
     .Properties("Caption") = Titel
  End With

' Label anlegen
  If MsgTxt <> "" Then
     With oUF.Designer.Controls.Add("Forms.Label.1")
          .Name = "Label1"
          .Caption = MsgTxt
          .Left = ciBtnLinks
          .Top = yPosInUF
          .Width = iUFBreite - 20
          .Height = 10
          .TextAlign = 2 'fmTextAlignCenter
          .Font.Bold = True
          yPosInUF = yPosInUF + .Height + 5
     End With
  Else
     bFrame = False
  End If
  
' Optional einen Frame für die Controls anlegen
  If bFrame = True Then
     Set oFrm = oUF.Designer.Controls.Add("Forms.Frame.1")
     With oFrm
          .Name = "Frame1"
          .Left = ciBtnLinks
          .Top = yPosInUF
          .Width = iUFBreite - 20
     End With
     iCtrPos = 5                                        ' Beginnposition Controls
  Else
     Set oFrm = oUF.Designer                            ' Keinen Frame anlegen
     iCtrPos = yPosInUF                                 ' Beginnposition Controls
  End If
  
' Mehrere gleichartige Controls anlegen
  sCtrlTyp = IIf(MultiSel, "CheckBox", "OptionButton")
  For iNr = 1 To iAnz
      With oFrm.Controls.Add("Forms." & sCtrlTyp & ".1", sCtrlTyp & iNr, True)
           .Name = sCtrlTyp & iNr
           .Caption = Items(iNr)
           .Left = ciBtnLinks
           .Top = iCtrPos
           .Width = iUFBreite - 20
           .Height = 15
           iCtrPos = iCtrPos + .Height + 5
' Code dazu
           sCode = sCode _
                 & "Private Sub " & .Name & "_Click()¶" _
                 & "  ControlClick " & .Name & ", " & iNr & "¶" _
                 & "End Sub¶¶"
      End With
  Next iNr

' Sammel-Sub Code für die Controls schreiben
  sCode = sCode & "Private Sub ControlClick(oCtrl as Object, iNr as Integer)¶"
  If MultiSel Then
     sCode = sCode & "  gvErg(iNr) = IIf(oCtrl.Value = True, oCtrl.Caption, '')¶""
  Else
     sCode = sCode _
           & "  gvErg(1) = oCtrl.Caption¶" _
           & "  Unload Me¶"
  End If
  sCode = sCode & "End Sub¶¶"

  If bFrame Then oFrm.Height = iCtrPos                      ' Framehöhe anpassen an Controlanzahl
  yPosInUF = yPosInUF + (iAnz * 20) + IIf(bFrame, 10, 5)    ' Position für die Buttons festlegen

  If NoButtons = True Then GoTo SetzeCode                   ' Es werden keine Buttons gewünscht, damit UF klein bleibt

' Abbrechen-Button erstellen
  With oUF.Designer.Controls.Add("Forms.CommandButton.1")
       .Name = "Abbrechen"
       .Caption = "Abbrechen"
       .Left = IIf(MultiSel, ciBtnLinks + ciBtnBreit + ciBtnAbst, iUFBreite \ 2 - ciBtnBreit \ 2 - 4)
       .Top = yPosInUF
       .Width = ciBtnBreit
       .Height = 25
       .BackColor = RGB(255, 200, 200)
' Code dazu
       sCode = sCode _
             & "Private Sub " & .Name & "_Click()¶" _
             & "  gvErg(1)=vbNullString¶" _
             & "  Unload Me¶" _
             & "End Sub¶¶"
  End With
  
  If MultiSel Then
   sCode = "Dim bAll as Boolean¶¶" & sCode
' Übernahme-Button erstellen
     With oUF.Designer.Controls.Add("Forms.CommandButton.1")
          .Name = "Uebernehmen"
          .Caption = "Übernehmen"
          .Left = ciBtnLinks
          .Top = yPosInUF
          .Width = ciBtnBreit
          .Height = 25
          .BackColor = RGB(100, 255, 100)
' Code dazu
          sCode = sCode _
                & "Private Sub " & .Name & "_Click()¶" _
                & "  Dim i As Long, Werte As String¶¶" _
                & "  For i = 1 To UBound(gvErg)¶" _
                & "      If gvErg(i) <> vbNullString Then Werte = Werte & gvErg(i) & ','¶" _"
                & "  Next i¶" _
                & "  If Werte = vbNullString Then¶" _
                & "     With Label1¶" _
                & "          .Caption = 'Keine Auswahl getroffen'¶" _"
                & "          .TextAlign = fmTextAlignCenter¶" _
                & "          .BackColor = RGB(255,255,100)¶" _
                & "          .Font.Bold = True¶" _
                & "     End With¶" _
                & "  Else¶" _
                & "     gvErg(1) = Left(Werte, Len(Werte) - 1)¶¶" _
                & "     Unload Me¶" _
                & "  End If¶" _
                & "End Sub¶¶"
     End With

' SetzeAlle-Button erstellen
     With oUF.Designer.Controls.Add("Forms.CommandButton.1")
          .Name = "ButtonAlle"
          .Caption = "Alle auswählen"
          .Left = ciBtnLinks
          .Top = yPosInUF + 35
          .Width = ciBtnBreit
          .Height = 25
          .BackColor = RGB(255, 255, 100)
' Code dazu
          sCode = sCode _
                & "Private Sub " & .Name & "_Click()¶" _
                & "  Dim i As Long, iChk As Long¶¶" _
                & "  bAll = Not bAll¶" _
                & "  iChk = bAll And 1¶" _
                & "  For i = 1 To UBound(gvErg)¶" _
                & "      gvErg(i) = Controls('" & sCtrlTyp & "' & i).Caption¶" _
                & "      Controls('" & sCtrlTyp & "' & i).Value = iChk¶" _
                & "  Next i¶" _
                & "End Sub¶¶"
     End With
     yPosInUF = yPosInUF + 40
  End If
  yPosInUF = yPosInUF + 40
  
SetzeCode:
' Erstellten Code ins Modul einfügen
  oUF.CodeModule.InsertLines 1, Replace(Replace(sCode, "'", Chr(34)), "¶", vbLf)
  oUF.Properties("Height") = yPosInUF + 25
  
' Userform positionieren
  If xPos < 0 And yPos < 0 Then
     GetCursorPos PT                                    ' Mausposition holen
     xPos = PT.x / 1.67: yPos = PT.y / 1.67
  End If
  If xPos > 0 And yPos > 0 Then
     oUF.Properties("Left") = xPos
     oUF.Properties("Top") = yPos
  End If

' Userform anzeigen
  Set oUF = CallByName(UserForms, "Add", VbMethod, oUF.Name)
  sUFName = oUF.Name
  oUF.Show
  
  GetAuswahl = Replace(gvErg(1), ",", csSep)            ' Auswahl zurückgeben
' Exit Function                                         ' Aktivieren, wenn Userform erhalten bleiben soll

' Userform entfernen
  With ActiveWorkbook.VBProject
       For Each oUF In .VBComponents
           If oUF.Type = 3 And oUF.Name Like sUFName Then
              .VBComponents.Remove oUF
           End If
       Next oUF
  End With
End Function

_________
viele Grüße
Karl-Heinz

Link zum Beitrag: Power Queries ferngesteuert aktualisieren

Tue, 01 Jul 2025 09:48:01 +0000

Hier geht es zum entsprechendem Beitrag, der auch Fragen und Antworten zulässt.

https://www.clever-excel-forum.de/Thread...ualisieren

Adresssuche mit Fuzzy-Logik - Entwickelt mit Power Query

Sun, 18 May 2025 13:42:12 +0000

Da hier keine Fragen stellen kann und ich auch keine Updates einstellen kann, habe ich den Beitrag im normalen Excel-Forum eingestellt.

Damit der Beitrag aber schneller gefunden werden kann, hier an dieser Stelle nur ein Link zum Thema.

https://www.clever-excel-forum.de/Thread...ower-Query

API-Viewer - Update -

Mon, 24 Feb 2025 18:28:12 +0000

Wer's brauchen kann...

Hallo Forum,

ich musste meinen API-Viewer aus dem Jahre 2022 mal wieder updaten. Es wurden einige neue Daten hinzugefügt..

Diese Version unterstützt jetzt aber nur noch "neues" Excel mit VBA7 (32/64 Bit).
Mit den alten Excelversionen wird kaum noch jemand unterwegs sein.

  API_Viewer_KHV.png (Größe: 297,05 KB / Downloads: 43)

  API_Viewer_KHV_CEF.xlam (Größe: 317,46 KB / Downloads: 8)
  API_Viewer_KHV_CEF.xlsb (Größe: 351,13 KB / Downloads: 8)

Viel Erfolg damit

Gruß
Karl-Heinz

TreeView - Elemente des VBE auslesen

Tue, 04 Feb 2025 22:04:45 +0000

Liebe Leserin, lieber Leser,

wer's brauchen kann.

Die Elemente eines TreeView lassen sich u.a. mit der Windows-API auslesen.
Das u.a. Beispiel schreibt alle momentan vorhandene Elementtexte des Visual Basic Editors (VBE) in ein Excelblatt.

Erstaunlicherweise werden auch die Elemente eines passwortgeschützten VBA-Projektes hier aufgeführt.

Viel Spaß beim Ausprobieren....

Code:

Option Explicit

Private Declare PtrSafe Function FindWindowA Lib "user32" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function FindWindowExA Lib "user32" ( _
        ByVal hWndParent As LongPtr, ByVal hWndChildAfter As LongPtr, _
        ByVal lpszClass As String, ByVal lpszWindow As String) As LongPtr
Private Declare PtrSafe Function SendMessageA Lib "user32" ( _
        ByVal hWnd As LongPtr, ByVal Msg As Long, _
        ByVal wParam As LongPtr, lParam As Any) As LongPtr
 
' Konstanten für TreeView-Operationen
Private Const TV_FIRST        As Long = &H1100
Private Const TVM_GETCOUNT    As Long = TV_FIRST + 5
Private Const TVM_GETNEXTITEM As Long = TV_FIRST + 10
Private Const TVM_GETITEM     As Long = TV_FIRST + 12
 
Private Type TVITEM
    mask           As Long
    hItem          As LongPtr
    STATE          As Long
    statemask      As Long
    pszText        As String
    cchTextMax     As Long
    iImage         As Long
    iSelectedImage As Long
    cChildren      As Long
    lParam         As LongPtr
End Type
Dim mTVI   As TVITEM
Dim mhTree As LongPtr, miZeile As Long, miAnz As Long
Dim mWSh   As Worksheet
 
Sub ErmittleTreeViewElemente()
  Dim hWnd   As LongPtr, hItem As LongPtr, hItem2 As LongPtr
  Dim iAnz As Long, iAnzMax As Long
  
  Set mWSh = Tabelle1                                       ' <<>>
 
' Handle der App ermitteln
  hWnd = FindWindowA("wndclass_desked_gsk", vbNullString)   ' Handle des VBE-Editor holen
  hWnd = FindWindowExA(hWnd, 0, "PROJECT", vbNullString)    ' Projekt-Handle
  If hWnd = 0 Then
     MsgBox "Die gewünschte App wurde nicht gefunden!", vbCritical, "TreeView"
     Exit Sub
  End If

' TreeView vorhanden?
  mhTree = FindWindowExA(hWnd, 0, "SysTreeView32", vbNullString)
  If mhTree = 0 Then
     MsgBox "Die App enthält kein TreeView-Element!"
     Exit Sub
  End If
  iAnzMax = CLng(SendMessageA(mhTree, TVM_GETCOUNT, 0, ByVal 0&)) ' Anzahl der Elemente
  miZeile = 1
  
' Root-Knoten abrufen                           &H0 = TVGN_ROOT
  hItem = SendMessageA(mhTree, TVM_GETNEXTITEM, &H0, ByVal 0&)
  If hItem = 0 Then Exit Sub
  
  mWSh.Cells.Clear                                  ' Altdaten löschen
  SchreibeElemente hItem, 1                         ' Daten schreiben
  
  MsgBox (miZeile - 1) & " von" & Str(iAnzMax) & _
         " Elementen wurden eingefügt!", vbInformation, "TreeView"
End Sub

Private Sub SchreibeElemente(ByVal hItem As LongPtr, iSp As Long)
' Schreibt den Elementtext in ein Excelblatt
  Dim hChild As LongPtr
  
  If hItem <> 0 Then
     Do While hItem <> 0
        With mTVI ' &H1 = TVIF_TEXT
            .mask = &H1
            .hItem = hItem
            .pszText = String(256, vbNullChar)      ' Puffer initialisieren
            .cchTextMax = 256
            If SendMessageA(mhTree, TVM_GETITEM, 0, mTVI) <> 0 Then _
               mWSh.Cells(miZeile, iSp).Value = Left(.pszText, InStr(.pszText, vbNullChar) - 1)
        End With
        miZeile = miZeile + 1                        ' &H4 = TVGN_CHILD
        hChild = SendMessageA(mhTree, TVM_GETNEXTITEM, &H4, ByVal hItem)
        If hChild <> 0 Then
           SchreibeElemente hChild, iSp + 1
        End If                                      ' &H1 = TVGN_NEXT
        hItem = SendMessageA(mhTree, TVM_GETNEXTITEM, &H1, ByVal hItem)
     Loop
  End If
End Sub

_________
viele Grüße
Karl-Heinz

Range2HTML - EMail mit HTML-Text und Bildern

Fri, 17 Jan 2025 10:25:08 +0000

Hallo,

heute stelle ich mal mein Range2HTML hier zur weiteren Verwendung bereit.

Das alte im Netz zu findende RangeToHTML ist größer und m.E. ohne Bilderverarbeitung.

Natürlich lassen sich Tabellenbereiche und Bilder auch über .Paste in Mails einfügen, aber das soll in anderen Artikeln behandelt werden.

Code:

Option Explicit

Private Sub Mail_BereichalsBereich_Range2HTML()
' Sendet Mail mit integriertem Bereich mit Signatur
' Bereich wird über Range2HTML bereitgestellt
  Dim WSh1 As Worksheet, WSh2 As Worksheet
  Dim sMailtext As String, sBer As String
  
  sBer = "A1:J20"                                   ' Kopierbereich
  Set WSh1 = ThisWorkbook.Sheets("Tabelle1")        ' Blatt mit Maildaten
  Set WSh2 = ThisWorkbook.Sheets("Tabelle2")        ' Datenblatt
  
  With CreateObject("Outlook.Application").CreateItem(0)
      .BodyFormat = 2                               ' HTML-Format, Angabe optional
      .Subject = WSh1.Range("A2").Value             ' Betreff
      .To = WSh1.Range("A3").Value                  ' Empfänger
      .Cc = WSh1.Range("A4").Value                  ' Kopie an
'     .Bcc = WSh1.Range("A4").Value
      sMailtext = WSh1.Range("A5").Value            ' Mailtext
      .GetInspector                                 ' Signatur
      .HTMLBody = Replace(sMailtext, vbLf, "
") _
      & Range2Html(WSh2.Range(sBer)) & .HTMLBody
      .Display
  End With

End Sub

Private Function Range2Html(oBereich As Range) As String
' Gibt den angegebenen Bereich als HTML zurück, incl.Bilder
  Dim sTmpDatei As String, sTmp As String, sTmpVz As String
  Dim iff As Integer, P As Long

' Bereich in Datei exportieren
  With oBereich
      sTmpVz = Environ$("temp") & "\"
      sTmpDatei = sTmpVz & Format(Now, "ddmmyy" & Int(Timer) * 10) & ".htm"
      .Parent.Parent.PublishObjects.Add( _
              SourceType:=xlSourceRange, _
              Filename:=sTmpDatei, Sheet:=.Parent.Name, _
              Source:=.Address, _
              HtmlType:=xlHtmlStatic).Publish Create:=True
      iff = FreeFile
      Open sTmpDatei For Input As iff
      Range2Html = Replace(Input(LOF(iff), iff), "align=center x:publishsource=", _
                   "align=left x:publishsource=")
      Close iff

' Feststellen, ob auch Bilder im Bereich sind
      P = InStr(1, Range2Html, "") + 26
      If P > 26 Then
         sTmp = Mid$(Range2Html, P, InStr(P, Range2Html, "/filelist.xml") - P)
         Range2Html = Replace(Range2Html, sTmp, sTmpVz & sTmp)
      End If
      
  End With
  
  On Error Resume Next
  Kill sTmpDatei
  Kill sTmpVz & sTmp

End Function

_________
viele Grüße
Karl-Heinz

Anzeigebox mit bis zu 10 Schaltflächen

Wed, 04 Dec 2024 21:51:21 +0000

Hallo liebe Leserin, lieber Leser,

wer's brauchen kann.....

Standardmäßig kann man in seiner Msgbox maximal drei Schaltflächen + 1 Hilfebutton anzeigen lassen.
Wer mehr möchte, musste bisher andere Wege gehen, z.B. eines der vielen Beispiele hier im Forum nutzen.

Aber Windows stellt auch eine MsgBox-Version zur Verfügung, die optional bis zu elf Buttons anzeigen kann.
Zwei davon sind abweichend und einer schwer zu handeln. Deshalb kann man mit dem hier gezeigten Code nur maximal 10 Buttons anzeigen lassen.

Evtl. Anwendungsmöglichkeit: Auswahl aus einer Vielzahl von Optionen.....

Diese Minimalversion kann 9 Buttons mit individuellem Buttontext anzeigen lassen und bietet auch eine TimeOut-Möglichkeit.

Code:

Option Explicit

Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) As Long

Private Type MSGBOXPARAMS
  cbSize             As Long
  hWndOwner          As LongPtr
  hInstance          As LongPtr
  lpszText           As LongPtr
  lpszCaption        As LongPtr
  dwStyle            As Long
  hIcon              As LongPtr
  dwContextHelpId    As Long
  lpfnMsgBoxCallback As LongPtr
  dwLanguageId       As Long
End Type
 
Private Type MSGBOXDATA
  PARAMS         As MSGBOXPARAMS
  pwndOwner      As LongPtr     ' Nur intern
  dwPadding      As Long
  wLanguageId    As Long
  pidButton      As LongPtr     ' Array (Button-IDs)
  ppszButtonText As LongPtr     ' Array (Buttontext)
  cButtons       As Long        ' Anzahl der Buttons
  defButton      As Long        ' Button-ID Default
  cancelId       As Long        ' Button-ID Abbruch
  Timeout        As Long        ' Timeout
  phwndList      As LongPtr     ' Nur intern
  dwReserved(19) As Long        ' Reserviert
End Type

Dim mhTimer As LongPtr, msArrTxt() As String

Function MsgboxEx(ByVal sText As String, _
                  Optional ByVal iStyle As Long = 0, _
                  Optional ByVal sCaption As String = "Microsoft Excel", _
                  Optional ByVal sButtontexte As String = "OK", _
                  Optional ByVal iTimeOut As Long, _
                  Optional ByVal iDefBtn As Long, _
                  Optional ByVal bSysKreuz As Boolean) As String
  Dim md As MSGBOXDATA
  Dim lArrBtn() As Long, i As Long
  Const ID_CANCEL  As Long = 2
  Const ID_TIMEOUT As Long = 32000
  
  msArrTxt = Split(sButtontexte, ",")                       ' Buttontexte in Array
  If UBound(msArrTxt) > 8 Then Exit Function                ' Zu viele Buttontexte
  ReDim lArrBtn(UBound(msArrTxt))                           ' ID-Array dimensionieren
  For i = 1 To UBound(lArrBtn) + 1
      lArrBtn(i - 1) = IIf(i < 8, i, i + 2)                 ' IDs in Array setzen
  Next i
  
  With md
      With .PARAMS
          .cbSize = LenB(md.PARAMS)
          .hWndOwner = Application.hwnd                     ' Excel-Handle
          .hInstance = Application.HinstancePtr             ' Excel-Instance
          sText = Replace(sText, "¶", vbLf)                 ' Zeilenumbrüche einsetzen
          .lpszText = StrPtr(sText)                         ' Messagetext (Prompt)
          .lpszCaption = StrPtr(sCaption)                   ' Titel
          .dwStyle = iStyle Or 1                            ' Ggf. internes Icon setzen
          .lpfnMsgBoxCallback = 0
      End With
      .cancelId = IIf(bSysKreuz, ID_CANCEL, 0)              ' Systemkreuz aktivieren
      .cButtons = UBound(lArrBtn) + 1                       ' Anzahl der Buttons übergeben
      If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
      .defButton = (iDefBtn - 1)                            ' DefaultButton-ID
      .pidButton = VarPtr(lArrBtn(0))                       ' IDs übergeben
      .ppszButtonText = VarPtr(msArrTxt(0))                 ' Buttontexte übergeben
      .Timeout = (iTimeOut - 1)                             ' Timeout setzen, -1 = abgeschaltet
  End With
  
  i = SoftModalMessageBox(md)                               ' Jetzt MsgBox anzeigen
 
  If i = ID_TIMEOUT Then MsgboxEx = "Timeout": Exit Function
  If i > 8 Then i = i - 2                                   ' Ggf. Korrigierung Button-Nr
  MsgboxEx = Replace(msArrTxt(i - 1), "&", "")              ' Ergebnistext zurückgeben
End Function

' Diese Subs sind zum Testen
' Es können 1 bis 10 Buttons angezeigt werden => kommagetrennt angeben
' & vor einem Buchstaben stellt die Shortcut-Taste dar z.B. Alt-S usw.
' ¶ stellt einen Zeilenumbruch dar (vbLf)
' Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
Sub Test11()
  MsgBox MsgboxEx("Minimum")
End Sub

Sub Test12()
  MsgBox MsgboxEx("Dies ist eine Information!¶¶Und noch 'ne Zeile", vbExclamation, "Mein Test", "Verstanden")"
End Sub

Sub Test13()
  Call MsgboxEx("Dies ist eine Information für kurze Zeit!", vbInformation, "Mein Timeout", "Schließen", 2000)
End Sub

Sub Test14()
    MsgBox MsgboxEx("Bitte wähle eine¶Option aus!", , "Meine Auswahl", _
                    "Option 1,Option 2,Option 3", 0, 2, True)
End Sub

Sub Test15()
    MsgBox MsgboxEx("Bitte wähle eine Option aus oder klicke das Systemkreuz für einen Abbruch an", vbExclamation, "Meine Auswahl", _
                     "O1,O2,O3,O4,O5,O6,O7,O8,O9,O10", 0, 0, True)
End Sub

Als zweites zeige ich eine noch umfangreichere Version, die bis zu 10 Buttons, Timeout, eigenes Icon, MsgBox-Positionierung, Individuelle Schriftart und mehr bietet.

Msgbox5Button.png (Größe: 8,17 KB / Downloads: 40)

Code:

Option Explicit

Private Declare PtrSafe Function SoftModalMessageBox Lib "user32" (pMsgBoxParams As MSGBOXDATA) 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 Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" ( _
        ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32" () 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 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 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 GetSystemMetrics Lib "user32" ( _
        ByVal nIndex As Long) As Long
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 Type POINTAPI
   x As Long
   y As Long
End Type
Dim mPtKreuz As POINTAPI
Dim mPT      As POINTAPI

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

Private Type MSGBOXPARAMS
  cbSize             As Long
  hWndOwner          As LongPtr
  hInstance          As LongPtr
  lpszText           As LongPtr
  lpszCaption        As LongPtr
  dwStyle            As Long
  hIcon              As LongPtr ' lpszIcon
  dwContextHelpId    As Long
  lpfnMsgBoxCallback As LongPtr
  dwLanguageId       As Long
End Type
 
Private Type MSGBOXDATA
  PARAMS         As MSGBOXPARAMS
  pwndOwner      As LongPtr     ' Nur intern
  dwPadding      As Long
  wLanguageId    As Long
  pidButton      As LongPtr     ' Array (Button-IDs)
  ppszButtonText As LongPtr     ' Array (Buttontext)
  cButtons       As Long        ' Anzahl der Buttons
  defButton      As Long        ' Button-ID Default
  cancelId       As Long        ' Button-ID Abbruch
  Timeout        As Long        ' Timeout
  phwndList      As LongPtr     ' Nur intern
  dwReserved(19) As Long        ' Reserviert
End Type

Private Type SCHRIFTART_STRUCT
  Groesse    As Long
  Fett       As Boolean
  Kursiv     As Boolean
  Schriftart As String
End Type
Dim mtSCHRIFT As SCHRIFTART_STRUCT

Dim mhDlg As LongPtr, mhTimer As LongPtr, mhIcon As LongPtr, mhFont As LongPtr
Dim msArrTxt() As String

Function MsgboxEx(ByVal sText As String, _
                  Optional ByVal iStyle As Long = 0, _
                  Optional ByVal sCaption As String = "Microsoft Excel", _
                  Optional ByVal sButtontexte As String = "OK", _
                  Optional ByVal sIconname As String, _
                  Optional ByVal iTimeOut As Long, _
                  Optional ByVal iDefBtn As Long, _
                  Optional ByVal bSysKreuz As Boolean, _
                  Optional x As Long = 0, Optional y As Long = 0) As String
  Dim md As MSGBOXDATA, PT As POINTAPI
  Dim lArrBtn() As Long, i As Long
  Const ID_CANCEL  As Long = 2
  Const ID_TIMEOUT As Long = 32000
  
  mPT.x = x: mPT.y = y                                      ' MsgBox Positionen übernehmen
  msArrTxt = Split(sButtontexte, ",")                       ' Buttontexte in Array
  If UBound(msArrTxt) > 9 Then Exit Function                ' Zu viele Buttontexte
  ReDim lArrBtn(UBound(msArrTxt))                           ' ID-Array dimensionieren
  For i = 1 To UBound(lArrBtn) + 1
      lArrBtn(i - 1) = IIf(i < 8, i, i + 2)                 ' IDs in Array setzen
      If i = 10 Then lArrBtn(i - 1) = 9                     ' ID_HELP BtnNr korrigieren
  Next i
    
  mhIcon = 0: mhDlg = 0: mhFont = 0: mhTimer = 0
  If sIconname <> "" Then                                   ' Handle des gefundenen Icons
     On Error Resume Next
' <<<< Hier den Tabellennamen für die Icons anpassen! >>>>
     mhIcon = Tabelle1.OLEObjects(sIconname).Object.Picture.handle
     If mhIcon <> 0 Then iStyle = iStyle Or &H40            ' MB_ICONINFORMATION = &H40
  End If
  
  With md
      With .PARAMS
          .cbSize = LenB(md.PARAMS)
          .hWndOwner = Application.hwnd                     ' Excel-Handle
          .hInstance = Application.HinstancePtr             ' Excel-Instance
          sText = Replace(sText, "¶", vbLf)                 ' Zeilenumbrüche einsetzen
          .lpszText = StrPtr(sText)                         ' Messagetext (Prompt)
          .lpszCaption = StrPtr(sCaption)                   ' Titel
          .dwStyle = iStyle Or 1                            ' Ggf. internes Icon setzen
          .lpfnMsgBoxCallback = GetAddressOf(AddressOf MsgBoxCallbackProc)
      End With
      .cancelId = IIf(bSysKreuz, ID_CANCEL, 0)              ' Systemkreuz aktivieren
      .cButtons = UBound(lArrBtn) + 1                       ' Anzahl der Buttons übergeben
      If iDefBtn = 0 Or iDefBtn > .cButtons Then iDefBtn = 1
      .defButton = (iDefBtn - 1)                            ' DefaultButton-ID
      .pidButton = VarPtr(lArrBtn(0))                       ' IDs übergeben
      .ppszButtonText = VarPtr(msArrTxt(0))                 ' Buttontexte übergeben
      .Timeout = (iTimeOut - 1)                             ' Timeout setzen, -1 = abgeschaltet
  End With
  
  mhTimer = SetTimer(0&, 0&, 25, AddressOf MsgBoxCallbackProc)
  
  i = SoftModalMessageBox(md)                               ' Jetzt MsgBox anzeigen
 
  If mhFont <> 0 Then DeleteObject mhFont                   ' Font-Objekt löschen
  mtSCHRIFT.Groesse = 0
  
  If i = ID_TIMEOUT Then MsgboxEx = "Timeout": Exit Function
  If i > 8 Then i = i - 2                                   ' Ggf. Korrigierung Button-Nr
  MsgboxEx = Replace(msArrTxt(i - 1), "&", "")              ' Ergebnistext zurückgeben

' Systemkreuz angeklickt?
  GetCursorPos PT                                           ' Mausposition holen
  If PT.y < mPtKreuz.y Then MsgboxEx = "SystemAbbruch"      ' Systemkreuz angeklickt?
  
End Function

Private Function GetAddressOf(ByVal lpProcAddress As LongPtr) As LongPtr
  GetAddressOf = lpProcAddress
End Function

Private Sub MsgBoxCallbackProc()
' TYPE HELP_INFO abgeschaltet, wird nicht benötigt
  Dim R As RECT, lPos As Long, hFont As LongPtr

  
  If mhTimer <> 0 Then
     KillTimer 0&, mhTimer: mhTimer = 0                         ' Timer löschen
     mhDlg = GetActiveWindow                                    ' MsgBox-Handle ermitteln
' Icon setzen                                           &H170=STM_SETICON
     If mhIcon <> 0 Then SendDlgItemMessageA mhDlg, 20, &H170, mhIcon, 0

' MsgBox positionieren
     If mPT.x < 0 Or mPT.y < 0 Then GetCursorPos mPT            ' Mausposition holen
     If mPT.x > 0 And mPT.y > 0 Then                            ' MsgBox-Position setzen
         GetWindowRect mhDlg, R                                 ' Koordinaten der MsgBox holen
         lPos = GetSystemMetrics(0) - (R.Right - R.Left)        ' 0=SM_CXSCREEN
         If mPT.x > lPos Then mPT.x = lPos
         lPos = GetSystemMetrics(1) - (R.Bottom - R.Top) - 50   ' 1=SM_CYSCREEN
         If mPT.y > lPos Then mPT.y = lPos        ' &H1=SWP_NOSIZE
         SetWindowPos mhDlg, 0, mPT.x, mPT.y, 0, 0, &H1         ' MsgBox positionieren
     End If
     
     GetWindowRect mhDlg, R                                     ' Koordinaten der MsgBox holen
     mPtKreuz.y = R.Top + 40:   mPtKreuz.x = R.Right - 40       ' Position des roten Systemkreuzes
  
     With mtSCHRIFT
        If .Groesse > 1 Then
           mhFont = CreateFontA(.Groesse, 0, 0, 0, _
                                IIf(.Fett, 700, 400), IIf(.Kursiv, 1, 0), _
                                0, 0, 0, 0, 0, 0, 0, .Schriftart)
' Schriftart setzen       Textfeld-ID=65535  &H30 = WM_SETFONT
           SendDlgItemMessageA mhDlg, 65535, &H30, mhFont, True ' Font dem Textfeld zuweisen
       End If
     End With
  
  Else
' Help-Button wurde geklickt
     msArrTxt(1) = msArrTxt(9)            ' &H10=WM_CLOSE       ' Hilfe-Buttontext für Rückgabe übernehmen
     If mhDlg <> 0 Then PostMessageA mhDlg, &H10, 0&, 0&        ' MsgBox schließen
  End If
End Sub


' Diese Subs sind zum Testen
' Es können 1 bis 10 Buttons angezeigt werden => kommagetrennt angeben
' & vor einem Buchstaben stellt die Shortcut-Taste dar z.B. Alt-S usw.
' ¶ stellt einen Zeilenumbruch dar (vbLf)
' Über x und y kann die Position der MsgBox festgelegt oder an der Mausposition gestartet werden
' Zurückgegeben wird keine Nummer, sondern der Buttontext des geklickten Buttons
Sub Test1()
  MsgBox MsgboxEx("Minimum")
End Sub

Sub Test2()
  MsgBox MsgboxEx("Dies ist eine Information!¶¶Und noch 'ne Zeile", vbExclamation, "Mein Test", "Verstanden")"
End Sub

Sub Test3()
  Call MsgboxEx("Dies ist eine Information für kurze Zeit!", vbInformation, "Mein Timeout", "Schließen", , 2000)
End Sub

Sub Test4()
    MsgBox MsgboxEx("Bitte wähle eine¶Option aus!", , "Meine Auswahl", _
                    "Option 1,Option 2,Option 3", "Image1", 0, 2, True)
End Sub

Sub Test5()
    MsgBox MsgboxEx("Bitte wähle eine Option aus oder klicke das Systemkreuz für einen Abbruch an", , "Meine Auswahl", _
                    "O1,O2,O3,O4,O5,O6,O7,O8,O9,O10", "Image2", 0, 0, True)
End Sub

Sub Test6()
    MsgBox MsgboxEx("Ich bin jetzt ganz wo anders zu finden", , "Meine Auswahl", _
                    "&Ja,&Nein,&Vielleicht", "Image3", 0, 0, True, 10, 10)
End Sub

Sub Test7()
    With mtSCHRIFT
       .Schriftart = "Lucida Handwriting"
       .Groesse = 22
       .Fett = True
       .Kursiv = False
    End With
    
    MsgBox MsgboxEx("Mich kann man besser lesen als den Standard!", vbModal, "Große Schrift", _
                    "Schlumpf &ein,Schlumpf &aus,Schlumpf &um,Ab&schlumpfen,Abbrechen", _
                     "Image1")
End Sub

_________
viele Grüße
Karl-Heinz

Verwendete Funktionen aus Power Queries auslesen

Fri, 29 Nov 2024 10:00:50 +0000

Da ich keine Berechtigung habe, den vorherigen Beitrag zu ergänzen, muss ich für die Fortführung einen neuen Beitrag erstellen.

Die Aussage: "Meine ursprüngliche Idee war, auf diesem Wege Abfragen finden zu können, die eine gesuchte M-Funktion enthalten.", ist natürlich Quatsch, da ich in der Liste ja suchen und filtern kann.

Aber da ich auch einen Überblick haben wollte, welche der verfügbaren Funktionen schon im Fundus meiner Mappen enthalten sind, habe ich mich nun doch noch etwas mit dem Thema beschäftigt und eine für mich halbwegs befriedigende Lösung entwickeln können. Die Einschränkung "befriedigende" deshalb, weil es entweder recht schwierig ist, M-Code mit Power Query zu parsen, oder ich nicht den richtigen Ansatz gefunden habe.

Auf jeden Fall ist es so, dass innerhalb einer ausgelesenen Abfrage, die bei mir alle mit
"section Section1;" beginnen und einem ";" am am Ende nach "let" enden, die Gesamte Abfrage keine Zeilenumbrüche enthalten muss und somit als Fließtext vorliegen kann, auch wenn im Standard bei der Erstellung neuer Schritte automatisch Zeilenumbrüche eingefügt werden. Werden diese aber nachträglich entfernt, so werden diese aber immer noch im PQ-Editor korrekt angezeigt. Auch die Verwendung von Funktionsnamen als Schrittbezeichnungen, ist teilweise möglich, führt aber auch zum Teil zu Fehlermeldungen in nachfolgenden Schritten.

Der Code eines Schritts beginnt somit nach dem Ersten "=" nach "let" und endet mit einem ",", nachdem es zu allen öffnenden Klammern, die schließenden vorliegen. In generiertem M-Code liegen Funktionen zwischen einem Leerzeichen und einer sich öffnenden Klammer "(", und können so eigentlich recht leicht extrahiert werden. Durch manuelle Nachbearbeitung des M-Codes können aber vor der öffnenden Klammer mehrere Leerzeichen und Zeilenumbrüche enthalten sein. Dies erschwert dann das Finden von verwendeten Funktionen.
Insgesamt waren somit einige Hand- und Kopfstände erforderlich, um aus Abfragen die benutzten Funktionen und möglichst auch die Schrittnamen zu extrahieren. Dabei werden auch die Funktionen extrahiert, die sich in den meist unsinnigen aus einem Schritt bestehenden Ab fragen befinden. Abhängig davon, ob und wie der M-Code manuell nachbearbeitet wurde, können die Schrittnamen nicht in allen Fällen zuverlässig ermittelt werden.

In einer weiteren Abfrage wird summarisch ermittelt, welche Funktionen in den ausgelesenen Mappen verwendet werden. Diese Auswertung kann bspw. dazu benutzt werden, um gezielt im Internet nach Beispielen zu Funktionen zu suchen, die bisher noch nicht verwendet werden. Dazu gibt es auch eine summarische PivotTable.

Schön wäre es, wenn der eine oder andere PQ-interessierte bessere Möglichkeiten findet, die Codes zu parsen.

cef - Power Queries aus Mappen auslesen (PQ) - v2.xlsx (Größe: 600,78 KB / Downloads: 4)

Power Queries aus Mappen auslesen

Thu, 24 Oct 2024 07:37:23 +0000

Da im Excel-Forum die Frage hochkam, wie die Quellen aller Power Queries ausgelesen werden können, habe ich mich daran erinnert, dass ich vor länger Zeit eine Lösung gefunden hatte, mit der die Oueries einer Mappe bzw. eines Verzeichnisses ausgelesen werden können.

In der Mappe, die ich hochlade, ist auch eine Abfrage enthalten, die alle PQ-Funktionen auflistet.

Meine ursprüngliche Idee war, auf diesem Wege Abfragen finden zu können, die eine gesuchte M-Funktion enthalten. Wegen einer Reihe offenen Fragen, habe ich diese Idee dann aber verworfen.

Aber alleine schon die Möglichkeit zu haben, Abfragen aus Mappen auszulesen, kann nützlich sein. Deswegen stelle ich die Mappe nun hier ein.

cef - Power Queries aus Mappen auslesen (PQ).xlsx (Größe: 281,54 KB / Downloads: 19)

Dateieigenschaften Zeiten ändern

Fri, 23 Aug 2024 20:56:07 +0000

wer's brauchen kann....

Liebe Leserin, lieber Leser,

manchmal möchte man, dass die im Explorer angezeigte Bearbeitungszeit einer Datei individuell verändert werden kann.

Nachfolgend findest Du ein einfaches Tool, mit dem Du für einzelne Dateien oder auch für alle Dateien in einem ausgewählten Ordner die Attribute Erstellungszeit, Bearbeitungszeit und letzter Zugriff bequem ändern kannst.
Das Tool ist natürlich ohne Gewähr, aber hoffentlich etwas hilfreich.

DateiDatumÄndern.xlsb (Größe: 62,25 KB / Downloads: 4)

Und nun viel Erfolg und Spaß damit....

Gruß aus Hessen
Karl-Heinz

Date Picker AddIn und Stand Alone

Thu, 09 May 2024 08:43:07 +0000

Hallo,

anbei der Simple Date Picker sowohl als AddIn als zum Einbinden in ein Projekt (als Stand Alone benannt).

DatePicker AddIn und Stand Alone.zip (Größe: 183,92 KB / Downloads: 38)

Gruß Uwe

Inputbox - mit zwei Textboxen (z.B. Login)

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

Hallo liebe Leserin, lieber Leser,

manchmal benötigt man eine Inputbox, in der in zwei oder mehr Editboxen unterschiedlicher Text eingegeben werden kann. Die normale Inputbox bietet aber nur eine Eingabe an.

Wenn mehrere Editboxen gewünscht werden, werden diese meistens in eine Userform eingebettet.

Dass es aber auch anders geht, möchte ich mit diesem kleinen Beispiel mal aufzeigen.

Als Beispiel erstellen wir uns eine Login-Dialogbox, in der sowohl der Username wie auch das Passwort eingegeben werden kann.
Hierzu bauen wir die Standard-Inputbox einfach passend um.

Zunächst 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 zwei Überschriften (Static) und zwei neue Editboxen hinzu und legen sie über die vorher ausgeblendete Editbox.
Als Schriftart übernehmen wir den Font aus der Ursprungseditbox.
Nach dem Hinzufügen der gewünschten Elemente ist unsere Login-Dialogbox auch schon fertig.

Nach einer Eingabe in eines der Editboxen werden beide Inhalte in der Originaleditbox zusammen geführt. Damit überlassen wir der Inputbox das Managen der Rückgabe und haben keine Arbeit damit.

Im zweiten Beispiel (in anlegender Datei) fügen wir noch ein ansprechendes Icon hinzu. Da die Editboxen hier untereinander liegen, wird noch die Funktion zur Fenstergrößenanpassung benötigt.

Inputbox_Login.png (Größe: 19,05 KB / Downloads: 71)

Inputbox_Userpasswort.xlsb (Größe: 52,06 KB / Downloads: 16)

Und nun viel Spaß beim Ausprobieren...

Gruß
Karl-Heinz

MsgBox - Buttonbeschriftung, Icon ändern

Tue, 26 Mar 2024 13:20:26 +0000

Hallo liebe Leserin, lieber Leser,

manchmal möchte man die Schaltflächen in seiner Msgbox individuell beschriften und vielleicht sogar das Icon ändern können.

Hierfür gibt es jede Menge Möglichkeiten. Zum Beispiel kann man die Messagebox-Funktion aus der Windows-API verwenden und hier die Buttons ändern.
Neben der Beschriftung können natürlich auch die Positionen und Größen der Buttons oder auch der Text und das Icon nachträglich (mehrfach) geändert werden, z.B. für einen Countdown usw..
Ein weites Feld.

Heute möchte ich hier aber nur eine Minmalversion unter Benutzung der Excel-MsgBox aufzeigen, die für eine einfache Buttonbeschriftung reicht....

Eine Möglichkeit, eine MsgBox mit vier Buttons zu erstellen wurde bereits hier aufgezeigt.
https://www.clever-excel-forum.de/Thread...genem-Icon

MsgBoxExMin.xlsb (Größe: 40,77 KB / Downloads: 13)

Und nun viel Spaß beim Ausprobieren...

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 SetDlgItemTextA Lib "user32" ( _
        ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long, ByVal lpString As String) As Long
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, mhIcon  As LongPtr, msBtns() As String

Function MsgboxEx(sText As String, _
         Optional ByVal iDlgStyle As Long, _
         Optional sCaption As String, _
         Optional sBtnText As String = "OK", _
         Optional sIcon As String) As String
  mhIcon = 0
  If sIcon <> "" Then
     mhIcon = Tabelle2.OLEObjects(sIcon).Object.Picture.Handle  ' <<>>
  End If
  
  msBtns = Split(",,," & sBtnText & ",,", ",")
  msBtns(1) = msBtns(3): msBtns(2) = IIf(UBound(msBtns) = 5, msBtns(1), msBtns(4))
  iDlgStyle = (iDlgStyle And &HFFFF8) Or (UBound(msBtns) - 5)

  mhTimer = SetTimer(0&, 0&, 10, AddressOf SetIconButtontext)
  MsgboxEx = Replace(msBtns(MsgBox(sText, iDlgStyle, sCaption)), "&", "")
End Function

Private Sub SetIconButtontext()
' Setzt die Button-Texte und das Icon individuell
  Dim iBtn As Integer

  KillTimer 0&, mhTimer       ' Timer löschen,   Static-ID=20  &H170=STM_SETICON
  If mhIcon <> 0 Then SendDlgItemMessageA GetActiveWindow, 20, &H170, mhIcon, 0
  For iBtn = 1 To 5:  SetDlgItemTextA GetActiveWindow, iBtn, msBtns(iBtn): Next iBtn
End Sub

' ###############################
Private Sub CommandButton3_Click()
  MsgBox (MsgboxEx("Ein Test", vbInformation, "Meine Msgbox", "&Nehmen,&Ablehnen", "Freigericht"))
End Sub

_________
viele Grüße
Karl-Heinz