Есть макрос плавного увеличения-уменьшения фотографий при наведении-отведении курсора мышки. Я добавил к нему макрос плавного увеличения-уменьшения звука проигрывания файла C:\1\1.mp3 Таким образом - при наведении курсора мышки на картинку - не только размер картинки увеличивается-уменьшается, но также увеличивается-уменьшается звук проигрываемого файла.
Но есть изъян. Когда наводится курсор - звук увеличивается несколько раз - пока картинка увеличивается, также и с ее уменьшением.
Как заставить макрос увеличения и уменьшения звука - сработать всего один раз, одновременно с увеличением-уменьшением картинки ?
(для запуска макроса - надо нажать на кнопку "Пуск-Стоп" и навести курсор на любую картинку)
Рабочий код в module1: [vba]
Код
' Изменение масштаба рисунков: предыдущего (уменьшить) и нового (увеличить) Private Sub ScalePic(OldPic As String, Optional NewPic As String) Dim i As Double, j As Double, w As Double, h As Double InZoom = True If Len(OldPic) > 0 Then
UmenshZvuk
' Вернуть масштаб предыдущего рисунка With ActiveSheet.Shapes(OldPic) w = .Width h = .Height j = w / Масштаб While .Width > j Макрос5 Stop1
.ScaleHeight 1 - 2 * Скорость / 100, msoFalse .ScaleWidth 1 - 2 * Скорость / 100, msoFalse DoEvents Wend
.Width = w / Масштаб .Height = h / Масштаб
.ZOrder msoSendToBack
End With If Len(NewPic) = 0 Then Application.StatusBar = "Picture processing" End If
If Len(NewPic) > 0 Then Play
' Установить масштаб текущего рисунка With ActiveSheet.Shapes(NewPic) w = .Width h = .Height j = w * Масштаб .ZOrder msoBringToFront While .Width < j Макрос6 UvelichZvuk
.ScaleHeight 1 + Скорость / 100, msoFalse .ScaleWidth 1 + Скорость / 100, msoFalse DoEvents Wend
.Width = w * Масштаб .Height = h * Масштаб
End With Application.StatusBar = "Picture processing: " & NewPic End If
InZoom = False
End Sub
[/vba]
код макроса UvelichZvuk и UmenshZvuk [vba]
Код
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub UvelichZvuk() Dim i As Integer Sheets("Лист2").Range("F2") = 0 Sheets("Лист2").Range("G2") = 1 For i = Sheets("Лист2").Range("E3") To Sheets("Лист2").Range("G3") Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("F2") + 1 Sleep 20 DoEvents Next i Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("G3") End Sub
Sub UmenshZvuk() Dim i As Integer Sheets("Лист2").Range("F2") = 0 Sheets("Лист2").Range("G2") = 0 For i = Sheets("Лист2").Range("E3") To Sheets("Лист2").Range("G3") Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("F2") + 1 Sleep 20 DoEvents Next i Sheets("Лист2").Range("F2") = Sheets("Лист2").Rang[/offtop]e("G3") End Sub
[/vba]
Здравствуйте форумчане. Помогите решить вопрос.
Есть макрос плавного увеличения-уменьшения фотографий при наведении-отведении курсора мышки. Я добавил к нему макрос плавного увеличения-уменьшения звука проигрывания файла C:\1\1.mp3 Таким образом - при наведении курсора мышки на картинку - не только размер картинки увеличивается-уменьшается, но также увеличивается-уменьшается звук проигрываемого файла.
Но есть изъян. Когда наводится курсор - звук увеличивается несколько раз - пока картинка увеличивается, также и с ее уменьшением.
Как заставить макрос увеличения и уменьшения звука - сработать всего один раз, одновременно с увеличением-уменьшением картинки ?
(для запуска макроса - надо нажать на кнопку "Пуск-Стоп" и навести курсор на любую картинку)
Рабочий код в module1: [vba]
Код
' Изменение масштаба рисунков: предыдущего (уменьшить) и нового (увеличить) Private Sub ScalePic(OldPic As String, Optional NewPic As String) Dim i As Double, j As Double, w As Double, h As Double InZoom = True If Len(OldPic) > 0 Then
UmenshZvuk
' Вернуть масштаб предыдущего рисунка With ActiveSheet.Shapes(OldPic) w = .Width h = .Height j = w / Масштаб While .Width > j Макрос5 Stop1
.ScaleHeight 1 - 2 * Скорость / 100, msoFalse .ScaleWidth 1 - 2 * Скорость / 100, msoFalse DoEvents Wend
.Width = w / Масштаб .Height = h / Масштаб
.ZOrder msoSendToBack
End With If Len(NewPic) = 0 Then Application.StatusBar = "Picture processing" End If
If Len(NewPic) > 0 Then Play
' Установить масштаб текущего рисунка With ActiveSheet.Shapes(NewPic) w = .Width h = .Height j = w * Масштаб .ZOrder msoBringToFront While .Width < j Макрос6 UvelichZvuk
.ScaleHeight 1 + Скорость / 100, msoFalse .ScaleWidth 1 + Скорость / 100, msoFalse DoEvents Wend
.Width = w * Масштаб .Height = h * Масштаб
End With Application.StatusBar = "Picture processing: " & NewPic End If
InZoom = False
End Sub
[/vba]
код макроса UvelichZvuk и UmenshZvuk [vba]
Код
Option Explicit
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub UvelichZvuk() Dim i As Integer Sheets("Лист2").Range("F2") = 0 Sheets("Лист2").Range("G2") = 1 For i = Sheets("Лист2").Range("E3") To Sheets("Лист2").Range("G3") Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("F2") + 1 Sleep 20 DoEvents Next i Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("G3") End Sub
Sub UmenshZvuk() Dim i As Integer Sheets("Лист2").Range("F2") = 0 Sheets("Лист2").Range("G2") = 0 For i = Sheets("Лист2").Range("E3") To Sheets("Лист2").Range("G3") Sheets("Лист2").Range("F2") = Sheets("Лист2").Range("F2") + 1 Sleep 20 DoEvents Next i Sheets("Лист2").Range("F2") = Sheets("Лист2").Rang[/offtop]e("G3") End Sub