Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1632to1636
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

Shape Farbwechsel mit jeweiligem Tonwechsel

Shape Farbwechsel mit jeweiligem Tonwechsel
25.07.2018 16:29:29
Dieter(Drummer)
Guten Tag VBA Spezialisten.
vor längerer Zeit hat mir dieses Forum bei einem VBA Code geholfen, wie ein Shape die Farbe (2 versch. Farbem) wechselt, wenn in einer Zelle die vorhanden Zahl angeklickt wurde. Der Farbwechsel erfolgte im Tempo (BPM) der Zahl. Ich habe leider damals nicht vermerkt, wer mir da beim Code geholfen hatte, aber es war hier im Forum.
Der Farbwechel funktioniert bereits perfekt, Dank der Hilfe aus diesem Forum.
Nun meine Bitte, den Code zu anzupassen, dass jeder Farbwechsel mit einem Tonwechsel abläuft. Der Beep fängt mit Ton (888) an und beim Wechsel in die 2. Farbe der Beep (444). Dies solange wie die Farbe wechselt anhand der Zahl aus der Zelle.
Eine Musterdatei mit funtionierendem Farbwechel anbei:
https://www.herber.de/bbs/user/122887.xlsm
Mit der Bitte um Hilfe,
grüßt, Dieter(Drummer)

5
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Shape Farbwechsel mit jeweiligem Tonwechsel
25.07.2018 16:44:34
Nepumuk
Hallo Dieter,
teste mal:
Public Sub Ton()
    With Tabelle1.Shapes(1).Fill.ForeColor
        .RGB = RGB(255, 0, 0)
        DoEvents
        DoEvents
        Call Beep(888) '1. Ton
        .RGB = RGB(0, 255, 0)
        DoEvents
        DoEvents
        Call Beep(444) '2. Ton
    End With
End Sub

Gruß
Nepumuk
Anzeige
AW: Danke Nepumuk. klappt prima, aber ...
25.07.2018 16:58:20
Dieter(Drummer)
Hallo Nepumuk,
... wie und wo muss ich dass jetzt so im Code einbinden, dass die Tonwechsel bei den Farbwechseln mit laufen?
Wäre schön wen die da nochmal helfen kannst, dein Code für sich allein, jetzt im Modul1, funktionert prima.
Gruß, Dieter(Drummer)
AW: Danke Nepumuk, habs schon ...
25.07.2018 17:12:17
Dieter(Drummer)
Hallo Nepumuk,
... raus gefunden. So hab ich es eingebunden (Fett):
Private Declare

Sub Sleep Lib "Kernel32" (ByVal ms As Long)
Dim bolBlink As Boolean

Sub Blinke(tv As Long)
Dim shp As Shape, sl As Long
Set shp = Me.Shapes("Oval 1")
Application.EnableCancelKey = 0
If bolBlink Then
sl = 60000 / tv
With shp.Fill
.Visible = -1
.Solid
.ForeColor.RGB = RGB(255, 0, 0)
End With
Do While bolBlink
With shp.Fill
If .ForeColor.RGB = RGB(255, 0, 0) Then
.ForeColor.RGB = RGB(0, 255, 0)
Else
.ForeColor.RGB = RGB(255, 0, 0)
End If
End With
Sleep sl
DoEvents
Call Ton
Loop
Else
Call Reset
End If
End Sub

Anzeige
AW: Danke Nepumuk, habs schon ...
25.07.2018 17:20:47
Nepumuk
Hallo Dieter,
besser so:
Option Explicit

Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal ms As Long)
Private Declare Sub Beep Lib "kernel32.dll" ( _
    Optional ByVal dwFreq As Long = 440, _
    Optional ByVal dwDuration As Long = 240)

Dim bolBlink As Boolean

Sub Blinke(tv As Long)
    Dim shp As Shape, sl As Long
    Set shp = Me.Shapes("Oval 1")
    Application.EnableCancelKey = 0
    If bolBlink Then
        sl = 60000 / tv
        With shp.Fill
            .Visible = -1
            .Solid
            .ForeColor.RGB = RGB(255, 0, 0)
        End With
        Do While bolBlink
            With shp.Fill
                If .ForeColor.RGB = RGB(255, 0, 0) Then
                    .ForeColor.RGB = RGB(0, 255, 0)
                    DoEvents
                    DoEvents
                    Call Beep(888) '1. Ton
                Else
                    .ForeColor.RGB = RGB(255, 0, 0)
                    DoEvents
                    DoEvents
                    Call Beep(444) '2. Ton
                End If
            End With
            DoEvents
            Call Sleep(sl)
        Loop
    Else
        Call Reset
    End If
End Sub

Private Sub Reset()
    bolBlink = 0
    Me.Shapes("Oval 1").Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim t_v As Long
    Call Reset
    If Target.Column = 2 And Target.Row > 1 Then
        If Target.Count = 1 Then
            If Len(Target.Value) > 0 Then
                If IsNumeric(Target.Value) Then
                    If Target.Value > 40 Then
                        t_v = Target.Value
                        bolBlink = -1
                        Call Blinke(t_v)
                    End If
                End If
            End If
        End If
    End If
End Sub

Gruß
Nepumuk
Anzeige
AW: Danke Nepumuk, einfach perfekte ...
25.07.2018 17:26:13
Dieter(Drummer)
Hallo Nepumuk,
... Lösung und Code funktioniert nach meinen Wünschen.
Noch einen erfreulichen Tag.
Gruß, Dieter(Drummer)

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige