Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Макрос увеличения звука с изменением размеров картинки - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос увеличения звука с изменением размеров картинки (Макросы/Sub)
Макрос увеличения звука с изменением размеров картинки
rotten41 Дата: Четверг, 10.08.2017, 14:03 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 163
Репутация: 0 ±
Замечаний: 0% ±

Excel 2013
Здравствуйте форумчане. Помогите решить вопрос.

Есть макрос плавного увеличения-уменьшения фотографий при наведении-отведении курсора мышки.
Я добавил к нему макрос плавного увеличения-уменьшения звука проигрывания файла 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]
К сообщению приложен файл: 87686.xlsb (74.2 Kb)
 
Ответить
СообщениеЗдравствуйте форумчане. Помогите решить вопрос.

Есть макрос плавного увеличения-уменьшения фотографий при наведении-отведении курсора мышки.
Я добавил к нему макрос плавного увеличения-уменьшения звука проигрывания файла 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]

Автор - rotten41
Дата добавления - 10.08.2017 в 14:03
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Макрос увеличения звука с изменением размеров картинки (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2024 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!