Microsoft Excel

Herbers Excel/VBA-Archiv

Shape Farbwechsel mit jeweiligem Tonwechsel


Betrifft: Shape Farbwechsel mit jeweiligem Tonwechsel von: Dieter(Drummer)
Geschrieben am: 25.07.2018 16:29:29

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)

  

Betrifft: AW: Shape Farbwechsel mit jeweiligem Tonwechsel von: Nepumuk
Geschrieben am: 25.07.2018 16:44:34

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


  

Betrifft: AW: Danke Nepumuk. klappt prima, aber ... von: Dieter(Drummer)
Geschrieben am: 25.07.2018 16:58:20

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)


  

Betrifft: AW: Danke Nepumuk, habs schon ... von: Dieter(Drummer)
Geschrieben am: 25.07.2018 17:12:17

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



  

Betrifft: AW: Danke Nepumuk, habs schon ... von: Nepumuk
Geschrieben am: 25.07.2018 17:20:47

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


  

Betrifft: AW: Danke Nepumuk, einfach perfekte ... von: Dieter(Drummer)
Geschrieben am: 25.07.2018 17:26:13

Hallo Nepumuk,

... Lösung und Code funktioniert nach meinen Wünschen.
Noch einen erfreulichen Tag.

Gruß, Dieter(Drummer)


Beiträge aus dem Excel-Forum zum Thema "Shape Farbwechsel mit jeweiligem Tonwechsel"