Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1188to1192
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro das unter 2007 nicht mehr läuft.Statusbar

Makro das unter 2007 nicht mehr läuft.Statusbar
chris
Hallo VBA Experten,ich habe eine frage.Hier ist ein Code der bei mir unter 2003 läuft.Leider aber nicht unter 2007 kann mir jemand helfen ?
Der code hat mir einen Counter in der Statusleiste angezeigt.
Der Aufruf war in einer Schleife drinnen und der counter hat einfach nur hochgezählt.
Das Makro besteht nuc aus 2 teilen den Aufruf hier:
LEDShow "Update " & Update & " from " & e & " - carried over data from " & Quelle.Name, "Process line " & zeile & " from " & Quelle.Cells(Rows.Count, Spalte_Nummer).End(xlUp).Row, (100 / Quelle.Cells(Rows.Count, Spalte_Nummer).End(xlUp).Row * zeile)
Und hier das ist alles in einem Modul:

  • Option Explicit
    Option Private Module
    Global preMessageG As String
    Global postMessageG As String
    Global thePctComplete As Long
    Dim m_hDeviceContext As Long
    Dim m_UserStatusBar As Boolean
    Dim m_numberOfLEDs As Long
    Dim m_preMessage As String
    Dim m_postMessage As String
    Dim m_percentComplete As Long
    Dim m_hWndXLStatus As Long
    Dim m_hDCXLStatus As Long
    Dim m_LEDBarShowing As Boolean
    Dim m_LEDsAlight As Long
    Dim XLBar As RECT32
    Dim XLBarSize As SIZE32
    Dim StatusFont As LOGFONT32
    Dim ACTIVECAPTION As Long
    Dim BTNTEXT As Long
    Dim BTNHIGHLIGHT As Long
    Dim BTNSHADOW As Long
    Dim BTNFACE As Long
    Dim RGB_LEDBarBG As Long
    Dim RGB_LEDBarFG As Long
    Dim RGB_StatusBG As Long
    Dim RGB_preMessageBG As Long
    Dim RGB_preMessageFG As Long
    Dim RGB_postMessageBG As Long
    Dim RGB_postMessageFG As Long
    Dim RGB_highlightTop As Long
    Dim RGB_highlightLeft As Long
    Dim RGB_highlightBottom As Long
    Dim RGB_highlightRight As Long
    Dim LEDBlock As RECT32
    Dim LEDBlockSize As SIZE32
    Dim LEDSpace As Long
    Dim LEDSpaceBefore As Long
    Dim LEDSpaceAfter As Long
    Dim LEDSpaceTop As Long
    Dim LEDSpaceBottom As Long
    Dim LEDTextSpacer As Long
    Dim LEDBar As RECT32
    Dim LEDBarSize As SIZE32
    Dim preMessageBox As RECT32
    Dim postMessageBox As RECT32
    Type RECT16
    Left As Integer
    Top As Integer
    Right As Integer
    Bottom As Integer
    End Type
    Type RECT32
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type
    Type SIZE16
    cx As Integer
    cy As Integer
    End Type
    Type SIZE32
    cx As Long
    cy As Long
    End Type
    Type LOGFONT16
    lfHeight As Integer
    lfWidth As Integer
    lfEscapement As Integer
    lfOrientation As Integer
    lfWeight As Integer
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
    End Type
    Type LOGFONT32
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
    End Type
    Declare
    
    Function GetActiveWindow16 Lib "USER" Alias "GetActiveWindow" () As Integer
    Declare 
    
    
    Function GetActiveWindow32 Lib "user32" Alias "GetActiveWindow" () As Long
    Declare 
    
    
    Function SystemParametersInfo16 Lib "USER" Alias "SystemParametersInfo" (ByVal uAction As  _
    Integer, ByVal uParam As Integer, lpvParam As Any, ByVal fuWinIni As Integer) As Integer
    Declare 
    
    
    Function SystemParametersInfo32 Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As  _
    Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long
    Declare 
    
    
    Function GetSysColor16 Lib "USER" Alias "GetSysColor" (ByVal nIndex As Integer) As Long
    Declare 
    
    
    Function GetSysColor32 Lib "user32" Alias "GetSysColor" (ByVal nIndex As Long) As Long
    Declare 
    
    
    Sub GetClientRect16 Lib "USER" Alias "GetClientRect" (ByVal hwnd As Integer, lpRect As RECT16)
    Declare 
    
    
    Function GetClientRect32 Lib "user32" Alias "GetClientRect" (ByVal hwnd As Long, lpRect As  _
    RECT32) As Long
    Declare 
    
    
    Function GetDC16 Lib "USER" Alias "GetDC" (ByVal hwnd As Integer) As Integer
    Declare 
    
    
    Function GetDC32 Lib "user32" Alias "GetDC" (ByVal hwnd As Long) As Long
    Declare 
    
    
    Function SaveDC16 Lib "GDI" Alias "SaveDC" (ByVal hdc As Integer) As Integer
    Declare 
    
    
    Function SaveDC32 Lib "GDI32" Alias "SaveDC" (ByVal hdc As Long) As Long
    Declare 
    
    
    Function RestoreDC16 Lib "GDI" Alias "RestoreDC" (ByVal hdc As Integer, ByVal nSavedDC As  _
    Integer) As Integer
    Declare 
    
    
    Function RestoreDC32 Lib "GDI32" Alias "RestoreDC" (ByVal hdc As Long, ByVal nSavedDC As Long)  _
    As Long
    Declare 
    
    
    Function ReleaseDC16 Lib "USER" Alias "ReleaseDC" (ByVal hwnd As Integer, ByVal hdc As Integer)  _
    As Integer
    Declare 
    
    
    Function ReleaseDC32 Lib "user32" Alias "ReleaseDC" (ByVal hwnd As Long, ByVal hdc As Long) As  _
    Long
    Declare 
    
    
    Sub InvalidateRect16 Lib "USER" Alias "InvalidateRect" (ByVal hwnd As Integer, lpRect As RECT16, _
    ByVal bErase As Integer)
    Declare 
    
    
    Function InvalidateRect32 Lib "user32" Alias "InvalidateRect" (ByVal hwnd As Long, lpRect As  _
    RECT32, ByVal bErase As Long) As Long
    Declare 
    
    
    Function GetWindow16 Lib "USER" Alias "GetWindow" (ByVal hwnd As Integer, ByVal wCmd As Integer) _
    As Integer
    Declare 
    
    
    Function GetWindow32 Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As  _
    Long
    Declare 
    
    
    Function GetClassName16 Lib "USER" Alias "GetClassName" (ByVal hwnd As Integer, ByVal className  _
    As String, ByVal maxCount As Integer) As Integer
    Declare 
    
    
    Function GetClassName32 Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal  _
    lpClassName As String, ByVal nmaxCount As Long) As Long
    Declare 
    
    
    Function CreateFontIndirect16 Lib "GDI" Alias "CreateFontIndirect" (lpLogFont As LOGFONT16) As  _
    Integer
    Declare 
    
    
    Function CreateFontIndirect32 Lib "GDI32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT32)  _
    As Long
    Declare 
    
    
    Function SelectObject16 Lib "GDI" Alias "SelectObject" (ByVal hdc As Integer, ByVal hObject As  _
    Integer) As Integer
    Declare 
    
    
    Function SelectObject32 Lib "GDI32" Alias "SelectObject" (ByVal hdc As Long, ByVal hObject As  _
    Long) As Long
    Declare 
    
    
    Function DeleteObject16 Lib "GDI" Alias "DeleteObject" (ByVal hObject As Integer) As Integer
    Declare 
    
    
    Function DeleteObject32 Lib "GDI32" Alias "DeleteObject" (ByVal hObject As Long) As Long
    Declare 
    
    
    Function SetBkColor16 Lib "GDI" Alias "SetBkColor" (ByVal hdc As Integer, ByVal RGB As Long) As  _
    Long
    Declare 
    
    
    Function SetBkColor32 Lib "GDI32" Alias "SetBkColor" (ByVal hdc As Long, ByVal crColor As Long)  _
    As Long
    Declare 
    
    
    Function SetTextColor16 Lib "GDI" Alias "SetTextColor" (ByVal hdc As Integer, ByVal RGB As Long) _
    As Long
    Declare 
    
    
    Function SetTextColor32 Lib "GDI32" Alias "SetTextColor" (ByVal hdc As Long, ByVal crColor As  _
    Long) As Long
    Declare 
    
    
    Function GetTextExtentPoint16 Lib "GDI" Alias "GetTextExtentPoint" (ByVal hdc As Integer, ByVal  _
    text As String, ByVal lenText As Integer, lpSize As SIZE16) As Integer
    Declare 
    
    
    Function GetTextExtentPoint32 Lib "GDI32" Alias "GetTextExtentPointA" (ByVal hdc As Long, ByVal  _
    lpszString As String, ByVal cbString As Long, lpSize As SIZE32) As Long
    Declare 
    
    
    Function CreateSolidBrush16 Lib "GDI" Alias "CreateSolidBrush" (ByVal RGB As Long) As Integer
    Declare 
    
    
    Function CreateSolidBrush32 Lib "GDI32" Alias "CreateSolidBrush" (ByVal crColor As Long) As  _
    Long
    Declare 
    
    
    Function PatBlt16 Lib "GDI" Alias "PatBlt" (ByVal hdc As Integer, ByVal x As Integer, ByVal y  _
    As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal deROP As Long) As Integer
    Declare 
    
    
    Function PatBlt32 Lib "GDI32" Alias "PatBlt" (ByVal hdc As Long, ByVal x As Long, ByVal y As  _
    Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
    Declare 
    
    
    Function FrameRect16 Lib "USER" Alias "FrameRect" (ByVal hdc As Integer, lpRect As RECT16,  _
    ByVal hBrush As Integer) As Integer
    Declare 
    
    
    Function FrameRect32 Lib "user32" Alias "FrameRect" (ByVal hdc As Long, lpRect As RECT32, ByVal  _
    hBrush As Long) As Long
    Declare 
    
    
    Function DrawText16 Lib "USER" Alias "DrawText" (ByVal hdc As Integer, ByVal text As String,  _
    ByVal nCount As Integer, lpRect As RECT16, ByVal wFormat As Integer) As Integer
    Declare 
    
    
    Function DrawText32 Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String,  _
    ByVal nCount As Long, lpRect As RECT32, ByVal wFormat As Long) As Long
    Global Const GW_CHILD As Integer = 5
    Global Const GW_HWNDFIRST As Integer = 0
    Global Const GW_HWNDNEXT As Integer = 2
    Global Const DT_SINGLELINE As Integer = &H20
    Global Const DT_CENTER As Integer = &H1
    Global Const DT_VCENTER As Integer = &H4
    Global Const DT_NOPREFIX As Integer = &H800
    Global Const DT_NOCLIP As Integer = &H100
    Global Const SPI_GETICONTITLELOGFONT As Integer = 31
    Global Const PATCOPY As Long = &HF00021
    Global Const COLOR_ACTIVECAPTION As Integer = 2
    Global Const COLOR_BTNTEXT As Integer = 18
    Global Const COLOR_BTNHIGHLIGHT As Integer = 20
    Global Const COLOR_BTNSHADOW As Integer = 16
    Global Const COLOR_BTNFACE As Integer = 15
    
    
    Function GetActiveWindow() As Long
    If Engine32() Then
    GetActiveWindow = GetActiveWindow32()
    Else
    GetActiveWindow = GetActiveWindow16()
    End If
    End Function
    
    Function IconTitleFont() As LOGFONT32
    Dim fontInfo32 As LOGFONT32
    Dim fontInfo16 As LOGFONT16
    If Engine32() Then
    Call SystemParametersInfo32(SPI_GETICONTITLELOGFONT, Len(fontInfo32), fontInfo32, 0)
    Else
    Call SystemParametersInfo16(SPI_GETICONTITLELOGFONT, Len(fontInfo16), fontInfo16, 0)
    fontInfo32 = ConvertToFontInfo32(fontInfo16)
    End If
    IconTitleFont = fontInfo32
    End Function
    
    Function GetSysColor(nIndex As Long) As Long
    If Engine32() Then
    GetSysColor = GetSysColor32(nIndex)
    Else
    GetSysColor = GetSysColor16(nIndex)
    End If
    End Function
    
    Function ClientRectangle(hwnd As Long) As RECT32
    Dim aRect32 As RECT32
    If Engine32() Then
    Dim stat32 As Long
    stat32 = GetClientRect32(hwnd, aRect32)
    Else
    Dim aRect16 As RECT16
    Call GetClientRect16(hwnd, aRect16)
    aRect32 = ConvertToRect32(aRect16)
    End If
    ClientRectangle = aRect32
    End Function
    
    Function GetDC(hwnd As Long) As Long
    If Engine32() Then
    GetDC = GetDC32(hwnd)
    Else
    GetDC = GetDC16(hwnd)
    End If
    End Function
    
    Function SaveDC(hdc As Long) As Long
    If Engine32() Then
    SaveDC = SaveDC32(hdc)
    Else
    SaveDC = SaveDC16(hdc)
    End If
    End Function
    
    Function RestoreDC(hdc As Long, nSavedDC As Long) As Long
    If Engine32() Then
    RestoreDC = RestoreDC32(hdc, nSavedDC)
    Else
    RestoreDC = RestoreDC16(hdc, nSavedDC)
    End If
    End Function
    
    Function ReleaseDC(hwnd As Long, hdc As Long) As Long
    If Engine32() Then
    ReleaseDC = ReleaseDC32(hwnd, hdc)
    Else
    ReleaseDC = ReleaseDC16(hwnd, hdc)
    End If
    End Function
    
    Sub InvalidateRect(hwnd As Long, aRect32 As RECT32, bErase As Long)
    If Engine32() Then
    Dim stat32 As Long
    stat32 = InvalidateRect32(hwnd, aRect32, bErase)
    Else
    Dim aRect16 As RECT16
    aRect16 = ConvertToRect16(aRect32)
    Call InvalidateRect16(hwnd, aRect16, bErase)
    End If
    End Sub
    
    Function GetWindow(hwnd As Long, wCmd As Long) As Long
    If Engine32() Then
    GetWindow = GetWindow32(hwnd, wCmd)
    Else
    GetWindow = GetWindow16(hwnd, wCmd)
    End If
    End Function
    
    Function GetClassName(hwnd As Long, lpClassName As String, nmaxCount As Long) As Long
    If Engine32() Then
    GetClassName = GetClassName32(hwnd, lpClassName, nmaxCount)
    Else
    GetClassName = GetClassName16(hwnd, lpClassName, nmaxCount)
    End If
    End Function
    
    Function CreateFontIndirect(fontInfo32 As LOGFONT32) As Long
    If Engine32() Then
    CreateFontIndirect = CreateFontIndirect32(fontInfo32)
    Else
    Dim fontInfo16 As LOGFONT16
    fontInfo16 = ConvertToFontInfo16(fontInfo32)
    CreateFontIndirect = CreateFontIndirect16(fontInfo16)
    End If
    End Function
    
    Function SelectObject(hdc As Long, hObject As Long) As Long
    If Engine32() Then
    SelectObject = SelectObject32(hdc, hObject)
    Else
    SelectObject = SelectObject16(hdc, hObject)
    End If
    End Function
    
    Function DeleteObject(hObject As Long) As Long
    If Engine32() Then
    DeleteObject = DeleteObject32(hObject)
    Else
    DeleteObject = DeleteObject16(hObject)
    End If
    End Function
    
    Function SetBkColor(hdc As Long, RGB As Long) As Long
    If Engine32() Then
    SetBkColor = SetBkColor32(hdc, RGB)
    Else
    SetBkColor = SetBkColor16(hdc, RGB)
    End If
    End Function
    
    Function SetTextColor(hdc As Long, RGB As Long) As Long
    If Engine32() Then
    SetTextColor = SetTextColor32(hdc, RGB)
    Else
    SetTextColor = SetTextColor16(hdc, RGB)
    End If
    End Function
    
    Function GetTextExtentPoint(hdc As Long, text As String, lenText As Long, aSize32 As SIZE32) As  _
    Long
    If Engine32() Then
    GetTextExtentPoint = GetTextExtentPoint32(hdc, text, lenText, aSize32)
    Else
    Dim aSize16 As SIZE16
    GetTextExtentPoint = GetTextExtentPoint16(hdc, text, lenText, aSize16)
    aSize32 = ConvertToSize32(aSize16)
    End If
    End Function
    
    Function CreateSolidBrush(RGB As Long) As Long
    If Engine32() Then
    CreateSolidBrush = CreateSolidBrush32(RGB)
    Else
    CreateSolidBrush = CreateSolidBrush16(RGB)
    End If
    End Function
    
    Function PatBlt(hdc As Long, x As Long, y As Long, nWidth As Long, nHeight As Long, deROP As  _
    Long) As Long
    If Engine32() Then
    PatBlt = PatBlt32(hdc, x, y, nWidth, nHeight, deROP)
    Else
    PatBlt = PatBlt16(hdc, x, y, nWidth, nHeight, deROP)
    End If
    End Function
    
    Function FrameRect(hdc As Long, aRect32 As RECT32, hBrush As Long) As Long
    If Engine32() Then
    FrameRect = FrameRect32(hdc, aRect32, hBrush)
    Else
    Dim aRect16 As RECT16
    aRect16 = ConvertToRect16(aRect32)
    FrameRect = FrameRect16(hdc, aRect16, hBrush)
    End If
    End Function
    
    Function DrawText(hdc As Long, text As String, nCount As Long, aRect32 As RECT32, wFormat As  _
    Long) As Long
    If Engine32() Then
    DrawText = DrawText32(hdc, text, nCount, aRect32, wFormat)
    Else
    Dim aRect16 As RECT16
    aRect16 = ConvertToRect16(aRect32)
    DrawText = DrawText16(hdc, text, nCount, aRect16, wFormat)
    End If
    End Function
    
    Function ConvertToRect16(aRect32 As RECT32) As RECT16
    ConvertToRect16.Top = aRect32.Top
    ConvertToRect16.Left = aRect32.Left
    ConvertToRect16.Bottom = aRect32.Bottom
    ConvertToRect16.Right = aRect32.Right
    End Function
    
    Function ConvertToRect32(aRect16 As RECT16) As RECT32
    ConvertToRect32.Top = aRect16.Top
    ConvertToRect32.Left = aRect16.Left
    ConvertToRect32.Bottom = aRect16.Bottom
    ConvertToRect32.Right = aRect16.Right
    End Function
    
    Function ConvertToSize16(aSize32 As SIZE32) As SIZE16
    ConvertToSize16.cx = aSize32.cx
    ConvertToSize16.cy = aSize32.cy
    End Function
    
    Function ConvertToSize32(aSize16 As SIZE16) As SIZE32
    ConvertToSize32.cx = aSize16.cx
    ConvertToSize32.cy = aSize16.cy
    End Function
    
    Function ConvertToFontInfo16(fontInfo32 As LOGFONT32) As LOGFONT16
    ConvertToFontInfo16.lfHeight = fontInfo32.lfHeight
    ConvertToFontInfo16.lfWidth = fontInfo32.lfWidth
    ConvertToFontInfo16.lfEscapement = fontInfo32.lfEscapement
    ConvertToFontInfo16.lfOrientation = fontInfo32.lfOrientation
    ConvertToFontInfo16.lfWeight = fontInfo32.lfWeight
    ConvertToFontInfo16.lfItalic = fontInfo32.lfItalic
    ConvertToFontInfo16.lfUnderline = fontInfo32.lfUnderline
    ConvertToFontInfo16.lfStrikeOut = fontInfo32.lfStrikeOut
    ConvertToFontInfo16.lfCharSet = fontInfo32.lfCharSet
    ConvertToFontInfo16.lfOutPrecision = fontInfo32.lfOutPrecision
    ConvertToFontInfo16.lfClipPrecision = fontInfo32.lfClipPrecision
    ConvertToFontInfo16.lfQuality = fontInfo32.lfQuality
    ConvertToFontInfo16.lfPitchAndFamily = fontInfo32.lfPitchAndFamily
    ConvertToFontInfo16.lfFaceName = fontInfo32.lfFaceName
    End Function
    
    Function ConvertToFontInfo32(fontInfo16 As LOGFONT16) As LOGFONT32
    ConvertToFontInfo32.lfHeight = fontInfo16.lfHeight
    ConvertToFontInfo32.lfWidth = fontInfo16.lfWidth
    ConvertToFontInfo32.lfEscapement = fontInfo16.lfEscapement
    ConvertToFontInfo32.lfOrientation = fontInfo16.lfOrientation
    ConvertToFontInfo32.lfWeight = fontInfo16.lfWeight
    ConvertToFontInfo32.lfItalic = fontInfo16.lfItalic
    ConvertToFontInfo32.lfUnderline = fontInfo16.lfUnderline
    ConvertToFontInfo32.lfStrikeOut = fontInfo16.lfStrikeOut
    ConvertToFontInfo32.lfCharSet = fontInfo16.lfCharSet
    ConvertToFontInfo32.lfOutPrecision = fontInfo16.lfOutPrecision
    ConvertToFontInfo32.lfClipPrecision = fontInfo16.lfClipPrecision
    ConvertToFontInfo32.lfQuality = fontInfo16.lfQuality
    ConvertToFontInfo32.lfPitchAndFamily = fontInfo16.lfPitchAndFamily
    ConvertToFontInfo32.lfFaceName = fontInfo16.lfFaceName
    End Function
    
    Function GetSize(rC As RECT32) As SIZE32
    GetSize.cx = rC.Right - rC.Left
    GetSize.cy = rC.Bottom - rC.Top
    End Function
    
    Function hWndOfChildFromClass(hWndTop As Long, requiredClassName As String) As Long
    Dim lenClassNameBuffer As Long
    Dim lenClassName As Long
    Dim aClassName As String * 7
    Dim hWndNext As Long
    lenClassNameBuffer = 7
    hWndNext = GetWindow(hWndTop, GW_CHILD)
    hWndNext = GetWindow(hWndNext, GW_HWNDFIRST)
    lenClassName = GetClassName(hWndNext, aClassName, lenClassNameBuffer)
    If (Left$(aClassName, 6) = Left$(requiredClassName, 6)) Then
    hWndOfChildFromClass = hWndNext
    Exit Function
    End If
    While hWndNext  0
    hWndNext = GetWindow(hWndNext, GW_HWNDNEXT)
    lenClassName = GetClassName(hWndNext, aClassName, lenClassNameBuffer)
    If (Left$(aClassName, 6) = Left$(requiredClassName, 6)) Then
    hWndOfChildFromClass = hWndNext
    Exit Function
    End If
    Wend
    hWndOfChildFromClass = hWndNext
    End Function
    
    Function Engine32() As Boolean
    Static engineIs32 As Boolean
    Static haveTested As Boolean
    If haveTested Then
    Engine32 = engineIs32
    Exit Function
    ElseIf InStr(Application.OperatingSystem, "32") Then
    engineIs32 = True
    End If
    haveTested = True
    Engine32 = engineIs32
    End Function
    

    Property Let OpenDC(hwnd As Long)
    m_hDeviceContext = GetDC(hwnd)
    Call SaveDC(m_hDeviceContext)
    End Property
    Property Let CloseDC(hwnd As Long)
    Call RestoreDC(m_hDeviceContext, -1)
    Call ReleaseDC(hwnd, m_hDeviceContext)
    End Property
    Sub DrawWindowText(cFG As Long, cBG As Long, Font As LOGFONT32, text As String, rC As RECT32)
    Dim hFont As Long
    Dim textSize As SIZE32
    Dim textDrawFlags As Long
    hFont = CreateFontIndirect(Font)
    hFont = SelectObject(m_hDeviceContext, hFont)
    Call SetBkColor(m_hDeviceContext, cBG)
    Call SetTextColor(m_hDeviceContext, cFG)
    Call GetTextExtentPoint(m_hDeviceContext, text, Len(text), textSize)
    rC.Right = rC.Left + textSize.cx
    textDrawFlags = DT_SINGLELINE Or DT_CENTER Or DT_VCENTER Or DT_NOPREFIX Or DT_NOCLIP
    Call DrawText(m_hDeviceContext, text, -1, rC, textDrawFlags)
    hFont = SelectObject(m_hDeviceContext, hFont)
    Call DeleteObject(hFont)
    End Sub
    
    Sub RectangleClear(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    Dim rS As SIZE32
    rS = GetSize(rC)
    hBrush = CreateSolidBrush(RGB)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, rS.cx, rS.cy, PATCOPY)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call DeleteObject(hBrush)
    End Sub
    
    Sub RectangleFrame(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    hBrush = CreateSolidBrush(RGB)
    Call FrameRect(m_hDeviceContext, rC, hBrush)
    End Sub
    
    Sub RectangleHighlight(rC As RECT32, TopRGB As Long, LeftRGB As Long, BottomRGB As Long,  _
    RightRGB As Long)
    Call RectanglePaintTop(rC, TopRGB)
    Call RectanglePaintLeft(rC, LeftRGB)
    Call RectanglePaintBottom(rC, BottomRGB)
    Call RectanglePaintRight(rC, RightRGB)
    End Sub
    
    Sub RectanglePaintTop(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    Dim rS As SIZE32
    rS = GetSize(rC)
    hBrush = CreateSolidBrush(RGB)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, rS.cx, 1, PATCOPY)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call DeleteObject(hBrush)
    End Sub
    
    Sub RectanglePaintLeft(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    Dim rS As SIZE32
    rS = GetSize(rC)
    hBrush = CreateSolidBrush(RGB)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Top, 1, rS.cy, PATCOPY)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call DeleteObject(hBrush)
    End Sub
    
    Sub RectanglePaintBottom(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    Dim rS As SIZE32
    rS = GetSize(rC)
    hBrush = CreateSolidBrush(RGB)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call PatBlt(m_hDeviceContext, rC.Left, rC.Bottom, rS.cx + 1, 1, PATCOPY)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call DeleteObject(hBrush)
    End Sub
    
    Sub RectanglePaintRight(rC As RECT32, RGB As Long)
    Dim hBrush As Long
    Dim rS As SIZE32
    rS = GetSize(rC)
    hBrush = CreateSolidBrush(RGB)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call PatBlt(m_hDeviceContext, rC.Right, rC.Top, 1, rS.cy + 1, PATCOPY)
    hBrush = SelectObject(m_hDeviceContext, hBrush)
    Call DeleteObject(hBrush)
    End Sub
    
    Sub LEDInitialise(numberOfLEDs As Long)
    Dim hWndParent As Long
    Dim XLBarCentre As Long
    m_numberOfLEDs = numberOfLEDs
    hWndParent = GetActiveWindow()
    If Val(Application.Version)  0) Then
    XLBar = ClientRectangle(m_hWndXLStatus)
    XLBarSize.cx = XLBar.Right - XLBar.Left
    XLBarSize.cy = XLBar.Bottom - XLBar.Top
    ACTIVECAPTION = GetSysColor(COLOR_ACTIVECAPTION)
    BTNTEXT = GetSysColor(COLOR_BTNTEXT)
    BTNHIGHLIGHT = GetSysColor(COLOR_BTNHIGHLIGHT)
    BTNSHADOW = GetSysColor(COLOR_BTNSHADOW)
    BTNFACE = GetSysColor(COLOR_BTNFACE)
    StatusFont = IconTitleFont
    LEDBar.Top = 4
    LEDBlockSize.cx = 6
    LEDBlockSize.cy = 6
    LEDBlock.Top = 6
    LEDBlock.Bottom = 12
    LEDSpace = 2
    LEDSpaceBefore = 1
    LEDSpaceAfter = 2
    LEDSpaceTop = 1
    LEDSpaceBottom = 2
    LEDTextSpacer = 7
    LEDBar.Bottom = LEDBar.Top + LEDSpaceTop + LEDBlockSize.cy + LEDSpaceBottom + 1
    StatusFont.lfFaceName = "Tahoma" & String(26, Right(StatusFont.lfFaceName, 1))
    StatusFont.lfHeight = -11
    RGB_LEDBarBG = BTNFACE
    RGB_LEDBarFG = ACTIVECAPTION
    RGB_StatusBG = BTNFACE
    RGB_preMessageBG = BTNFACE
    RGB_preMessageFG = BTNTEXT
    RGB_postMessageBG = BTNFACE
    RGB_postMessageFG = BTNTEXT
    RGB_highlightTop = BTNHIGHLIGHT
    RGB_highlightLeft = BTNHIGHLIGHT
    RGB_highlightRight = BTNHIGHLIGHT
    RGB_highlightBottom = BTNHIGHLIGHT
    XLBar.Top = -1
    LEDSpace = 2
    LEDBlock.Top = LEDBar.Top + 1 + LEDSpaceTop
    LEDBlock.Bottom = LEDBlock.Top + LEDBlockSize.cy
    LEDBarSize.cx = LEDSpaceBefore + numberOfLEDs * (LEDSpace + LEDBlockSize.cx) + LEDSpaceAfter -  _
    1
    LEDBarSize.cy = LEDSpaceTop + LEDBlockSize.cy + LEDSpaceBottom + 1
    preMessageBox = XLBar
    postMessageBox = XLBar
    preMessageBox.Left = 6
    preMessageBox.Top = 2
    postMessageBox.Top = 2
    End If
    End Sub
    
    Sub LEDShow(Optional preMessageA As String, Optional postMessageA As String, Optional  _
    thePctCompleteA As Variant)
    If preMessageA  "" Then preMessageG = preMessageA
    If postMessageA  "" Then postMessageG = postMessageA
    If Not IsError(thePctCompleteA) Then thePctComplete = thePctCompleteA
    m_preMessage = preMessageG
    m_postMessage = postMessageG
    If (m_hWndXLStatus  0) Then
    m_UserStatusBar = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
    Application.StatusBar = " "
    OpenDC = m_hWndXLStatus
    Call RectangleClear(XLBar, RGB_StatusBG)
    Call DrawWindowText(RGB_preMessageFG, RGB_preMessageBG, StatusFont, m_preMessage, preMessageBox) _
    LEDBar.Left = preMessageBox.Right + LEDTextSpacer
    LEDBar.Right = LEDBar.Left + LEDBarSize.cx
    postMessageBox.Left = LEDBar.Right + LEDTextSpacer + 3
    Call DrawWindowText(RGB_postMessageFG, RGB_postMessageBG, StatusFont, m_postMessage,  _
    postMessageBox)
    Call RectangleClear(LEDBar, RGB_LEDBarBG)
    Call RectanglePaintTop(XLBar, RGB_highlightTop)
    Call RectanglePaintLeft(XLBar, RGB_highlightLeft)
    Call RectangleHighlight(LEDBar, RGB_highlightTop, RGB_highlightLeft, RGB_highlightBottom,  _
    RGB_highlightRight)
    CloseDC = m_hWndXLStatus
    m_LEDsAlight = 0
    m_LEDBarShowing = True
    percentComplete = thePctComplete
    End If
    End Sub
    
    Sub LEDHide()
    If (m_hWndXLStatus  0) Then
    Application.DisplayStatusBar = m_UserStatusBar
    Application.StatusBar = False
    Call InvalidateRect(m_hWndXLStatus, XLBar, True)
    m_LEDBarShowing = False
    End If
    End Sub
    

    Property Let preMessage(theMessage As String)
    m_preMessage = theMessage
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let postMessage(theMessage As String)
    m_postMessage = theMessage
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let percentComplete(thePercent As Long)
    Dim newBlocksDone As Long
    m_percentComplete = thePercent
    If (m_hWndXLStatus 0) And m_LEDBarShowing Then
    If ((m_percentComplete > 0) And (m_percentComplete newBlocksDone = (m_numberOfLEDs * m_percentComplete) / 100
    If (m_LEDsAlight newBlocksDone) Then
    OpenDC = m_hWndXLStatus
    While (m_LEDsAlight LEDBlock.Left = LEDBar.Left + (LEDBlockSize.cx / 2) + m_LEDsAlight * (LEDBlockSize.cx + LEDSpace) - LEDSpace + LEDSpaceBefore
    LEDBlock.Right = LEDBlock.Left + LEDBlockSize.cx
    Call RectangleClear(LEDBlock, RGB_LEDBarFG)
    m_LEDsAlight = m_LEDsAlight + 1
    Wend
    While (m_LEDsAlight > newBlocksDone)
    LEDBlock.Left = LEDBar.Left + (LEDBlockSize.cx / 2) + m_LEDsAlight * (LEDBlockSize.cx + LEDSpace) - 1
    LEDBlock.Right = LEDBlock.Left + LEDBlockSize.cx
    Call RectangleClear(LEDBlock, RGB_LEDBarBG)
    m_LEDsAlight = m_LEDsAlight - 1
    Wend
    CloseDC = m_hWndXLStatus
    End If
    End If
    End If
    End Property
    Property Let LEDBarFG_RGB(RGBColour As Long)
    RGB_LEDBarFG = RGBColour
    m_LEDsAlight = 0
    percentComplete = m_percentComplete
    End Property
    Property Let LEDBarBG_RGB(RGBColour As Long)
    RGB_LEDBarBG = RGBColour
    m_LEDsAlight = 0
    percentComplete = m_percentComplete
    End Property
    Property Let statusAreaBG_RGB(RGBColour As Long)
    RGB_StatusBG = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let preMessageFG_RGB(RGBColour As Long)
    RGB_preMessageFG = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let preMessageBG_RGB(RGBColour As Long)
    RGB_preMessageBG = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let postMessageFG_RGB(RGBColour As Long)
    RGB_postMessageFG = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let postMessageBG_RGB(RGBColour As Long)
    RGB_postMessageBG = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let highlightTop_RGB(RGBColour As Long)
    RGB_highlightTop = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let highlightLeft_RGB(RGBColour As Long)
    RGB_highlightLeft = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let highlightBottom_RGB(RGBColour As Long)
    RGB_highlightBottom = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property
    Property Let highlightRight_RGB(RGBColour As Long)
    RGB_highlightRight = RGBColour
    Call LEDShow(m_preMessage, m_postMessage, m_percentComplete)
    End Property

  • Vielmals Danke ich voraus !
    gruß Chris

    10
    Beiträge zum Forumthread
    Beiträge zu diesem Forumthread

    Betreff
    Benutzer
    Anzeige
    Wer soll das denn alles lesen,...
    30.11.2010 14:25:42
    Luc:-?
    …Chris,
    und auch noch sauschlecht formatiert!
    Tipp: Könnte an den vielen DLL-Einbindungen liegen. Existieren ggf unter XL12 nicht mehr. Falls außerdem noch irgendwas mit XL-Objekten wie CommandBars gemacht wdn sollte → kannste alles vergessen…
    Sollte sich ja mittlerweile rumgesprochen haben, dass XL ab Vs12 ganz anders gestrickt ist!
    Gruß Luc :-?
    AW: Ich :-)
    30.11.2010 15:27:08
    Nepumuk
    Hallo,
    das ist nicht mehr so einfach. Früher musstest du nur nach "EXCEL4" in "XLMAIN" suchen. Jetzt musst du:
    in "XLMAIN" nach "EXCEL2" darin nach "MsoCommandBar" darin nach "MsoWorkPane" darin nach "NUIPane" und darin nach "NetUIHWND" suchen.
    Hier Excel 2003:
    Userbild
    Hier Excel 2007:
    Userbild
    Die Texte in Anführungszeichen hinter dem Klassennamen kannst du ingnorieren.
    Und schmeiß den ganze 16Bit - Müll raus. Niemand außer einem Museum hat noch so einen alten Rechner.
    Gruß
    Nepumuk
    Anzeige
    AW: Ich :-)
    01.12.2010 07:03:16
    chris
    Ohh herrje,
    Nepumuk,
    kannst Du mir dabei helfen den Code umzustellen ?
    Ich habe in fertig irgendwo gefunden und blicke selbst da nicht durch :(
    Wenn es nicht zu viel Arbeit macht wäre super ?!
    Vielen Dank im voraus.
    Weil was Du da oben schreibst verstehe ich als Leihe leider nicht so ganz.
    ...Mit Lai-Wissen... :-> ohne Worte!
    01.12.2010 11:52:18
    Luc:-?
    :-?
    leihen oder mieten ?...
    01.12.2010 12:00:44
    Renee
    hier
    GreetZ Renée
    AW: Ich :-)
    01.12.2010 12:34:25
    chris
    Nepumuk,
    kannst Du helfen ?
    Rennee Luc Danke auch... Hilft nur nicht
    AW: Ich :-)
    01.12.2010 18:45:02
    Nepumuk
    Hallo chris,
    seit Anfang 2002, das sind jetzt immerhin schon fast 8 Jahre stellst du nun Fragen hier im Forum. Schätzt aber dein Wissen über VBA auf kärglich ein.
    Wie kann das sein?
    In dieser Zeit habe ich nicht nur mein Wissen über VBA enorm erweitert, sondern zusätzlich noch VB.net, C++ und C# gelernt.
    Ich kenne viele Hobby-Programmierer die in nicht einmal der Hälfte der Zeit zu fleißigen Antwortern in Foren wurden weil sie ein weit größeres Wissen bezüglich VBA aufweisen als du.
    Vielleicht sollte man dir einfach nicht mehr helfen, damit du dich entlich aufrappelst und durch Eigeninitiative dein Wissen erweiterst anstatt dich nur auf das Forum zu verlassen.
    Dein Motto "Warum soll ich mich anstrengen, die anderen machen das schon für mich" geht mir auf alle Fälle langsam auf den Keks.
    Ich habe dir in meiner Antwort das Ziel gezeigt und welche Schritte dahin notwendig sind. Den ersten hast du schon in dem Programm. Die nächsten 4 kannst du aus diesem ganz einfach ableiten. Ja richtig, du benötigst genau 4 Zeilen Code zusätzlich. Also schalte endlich dein eigenes Gehirn ein und nach 5 Minuten (länger kann es keinesfalls dauern) hast du die Lösung.
    Gruß
    Nepumuk
    Anzeige
    AW: Ich :-)
    02.12.2010 09:08:00
    chris
    Nepumuk,
    Danke für deine Aussage.ich hoffe Du weißt jetzt mittlerweilen warum das alles....
    Es liegt daran das ich so viel frage weil ich z.b Das was da jetzt steht:
    Ich habe dir in meiner Antwort das Ziel gezeigt und welche Schritte dahin notwendig sind. Den ersten hast du schon in dem Programm. Die nächsten 4 kannst du aus diesem ganz einfach ableiten. Ja richtig, du benötigst genau 4 Zeilen Code zusätzlich. Also schalte endlich dein eigenes Gehirn ein und nach 5 Minuten (länger kann es keinesfalls dauern) hast du die Lösung.
    Komplett gar nicht verstehe :(
    Es tut mir leid aber ich kann nichts dafür das mir das nicht viel sagt.
    Ich braue eben genauere beschreibungen weil ich das so leider alleine nicht fertig bekomme.
    Danke trotzdem
    Anzeige
    AW: Ich :-)
    02.12.2010 09:10:53
    chris
    Ach ja und noch was... ich weiß zum beispiel gar nicht das Du damit meinst :(
    "Schmeis den ganzen 16 Bit Müll raus.
    Wo oder was ist im Code 16Bit Müll ?
    Und weil Du schreibst das ich einen teil schon im Code habe und nur noch die anderen in "" suchen muss.
    Aber wie oder wo habe ich das bis jetzt ?
    Kannst Du grob erklären warum der code nicht mehr tut ?
    Ich lasse jetzt mal zu weil muss ja nicht jeder mitbekommen.
    Dein Schreibstil ist recht verworren und...
    02.12.2010 15:48:23
    Luc:-?
    …die Aussage dadurch ziemlich unverständlich, Chris…
    Da macht schon das Lesen keinen Spaß! Frage mich wie man sich so jahrelang in Lohn und Brot halten kann bei den vielen oft qualifizierteren Arbeitslosen…?
    Mit 16Bit-Müll sind natürl Einbindungen von Pgmm aus der 16Bit-PC-Ära von vor mehr als 10 Jahren gemeint. Inzwischen haben wir schon lange 32Bit und sind im Übergang zu 64 (Vista, Windows7 u.a.). Aber, wem sagen wir das… Viell solltest du doch mal ab und zu in 'n PC-Magazin schauen statt nur in die Bunte oder den Kicker… ;->
    Im Grunde genommen interessiert dich das alles doch gar nicht wirklich…! Oder…? ;-)
    Gruß Luc :-?
    Anzeige

    Links zu Excel-Dialogen

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige