Makro das unter 2007 nicht mehr läuft.Statusbar
chris
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