AW: Farbe eines Objektes an Zellenfarbe anpassen
20.03.2007 11:39:11
Dan
Hi, ok, hier ein Beispiel. Du brauchst dazu eine Mappe, wo auf einem bestimmten Sheet drei 'Shapes' vorhanden sind. Die Namen der Shapes muessen so lauten : "green_light", "yellow_light", "red_light". In der Sub Main findest Du den Anfang des Codes. Wichtig ist, das die bestimmte Color-lieferende-Zelle muss nur mit einer dieser Farben gefaerbt werden : vbRed, vbYellow, vbGreen. Auf andere Farben reagiert der Code nicht. Hilft es :-)? Gruss Dan, cz.
Option Explicit
Private Const GREEN_LIGHT As String = "green_light"
Private Const YELLOW_LIGHT As String = "yellow_light"
Private Const RED_LIGHT As String = "red_light"
Private m_greenLightShape As Shape
Private m_yellowLightShape As Shape
Private m_redLightShape As Shape
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub SwitchStoplight(ByRef io_stoplightSwitcher As Range)
On Error GoTo Err_SwitchStoplight
If (ResetStoplight(io_stoplightSwitcher) = True) Then
Select Case io_stoplightSwitcher.Interior.Color
Case vbRed
m_redLightShape.OLEFormat.Object.Interior.Color = vbRed
Case vbYellow
m_yellowLightShape.OLEFormat.Object.Interior.Color = vbYellow
Case vbGreen
m_greenLightShape.OLEFormat.Object.Interior.Color = vbGreen
Case Else
MsgBox "Unknown stoplight color : " & io_stoplightSwitcher.Interior.Color, vbExclamation, "Switching stoplight failed"
End Select
Else
End If
Exit Sub
Err_SwitchStoplight:
MsgBox Err.Description, vbCritical, "Error in function SwitchStoplight"
End Sub
Private Function ResetStoplight(ByRef io_stoplightSwitcher As Range) As Boolean
ResetStoplight = False
' nur shapes auf dem selben sheet, wo auch der stoplight-switcher liegt
With io_stoplightSwitcher.Worksheet
On Error Resume Next
Set m_greenLightShape = .Shapes(GREEN_LIGHT)
Set m_yellowLightShape = .Shapes(YELLOW_LIGHT)
Set m_redLightShape = .Shapes(RED_LIGHT)
On Error GoTo Err_ResetStoplight
' alle lights-shapes muessen vorhanden sein
If (m_greenLightShape Is Nothing Or m_yellowLightShape Is Nothing Or m_redLightShape Is Nothing) Then
MsgBox "Stoplight reset function failed. Some stoplight-shape was not found in the collection.", vbCritical, "Stoplight reset failed"
Exit Function
End If
m_greenLightShape.OLEFormat.Object.Interior.Color = vbWhite
m_yellowLightShape.OLEFormat.Object.Interior.Color = vbWhite
m_redLightShape.OLEFormat.Object.Interior.Color = vbWhite
ResetStoplight = True
End With
Exit Function
Err_ResetStoplight:
MsgBox Err.Description, vbCritical, "Error in function ResetStoplight"
End Function
Public Sub Main()
' -- test stoplight switching:
Dim stoplightSwitcher As Range
On Error GoTo Err_Main
Set stoplightSwitcher = ActiveSheet.Range("a1")
stoplightSwitcher.Interior.Color = vbRed
Call SwitchStoplight(stoplightSwitcher)
Call Sleep(3000)
stoplightSwitcher.Interior.Color = vbYellow
Call SwitchStoplight(stoplightSwitcher)
Call Sleep(3000)
stoplightSwitcher.Interior.Color = vbGreen
Call SwitchStoplight(stoplightSwitcher)
Call Sleep(3000)
stoplightSwitcher.Interior.Color = VBA.RGB(158, 168, 137)
Call SwitchStoplight(stoplightSwitcher)
Exit Sub
Err_Main:
MsgBox Err.Description, vbCritical, "Error in function Main"
End Sub