Можно ли задействовать динамик компьютера из VB?

[gsv]

Требуется "оживить" программу на VB звуковым фоном, что-то вроде рокота программно изменяемой частоты. Со звуковой картой все получилось, а вот со Speaker'ом нет. Может кто подскажет?

[sanches]

см. http://bbs.vbstreets.ru/viewtopic.php?t ... light=beep

ps а вообще, на будущие - ПОИСК по форуму

[serix]

Public Declare Function Beep Lib "kernel32" Alias "Beep" (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Тут тебе и длина и частота, пользуйся...

[KolAR]

Код: Выделить всё

' File - spkr_lib.bas

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const SPEAKER_IO_42 = 0
Const SPEAKER_IO_43 = 1
Const SPEAKER_IO_61 = 2
Const SPEAKER_ITEMS = 3
Const SPEAKER_IO_ADDR42 = &H42
Const SPEAKER_IO_ADDR43 = &H43
Const SPEAKER_IO_ADDR61 = &H61

Const bit0 As Long = &H1
Const bit1 As Long = &H2

Type SPEAKER_HANDLE
   hWD As Long
   cardReg As WD_CARD_REGISTER
End Type

'this string is set to an error message, if one occurs
Public SPEAKER_ErrorString   As String

Sub SPEAKER_SetCardElements(hSPEAKER As SPEAKER_HANDLE)
' internal function used by SPEAKER_Open()
    hSPEAKER.cardReg.Card.dwItems = SPEAKER_ITEMS
          ' SPEAKER IO range
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_42).Item = ITEM_IO
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_42).fNotSharable = False
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_42).dw1 = SPEAKER_IO_ADDR42
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_42).dw2 = 1
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_43).Item = ITEM_IO
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_43).fNotSharable = False
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_43).dw1 = SPEAKER_IO_ADDR43
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_43).dw2 = 1
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_61).Item = ITEM_IO
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_61).fNotSharable = False
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_61).dw1 = SPEAKER_IO_ADDR61
    hSPEAKER.cardReg.Card.Item(SPEAKER_IO_61).dw2 = 1
End Sub

Function SPEAKER_Open(hSPEAKER As SPEAKER_HANDLE) As Boolean
Dim ver As WD_Version
   hSPEAKER.cardReg.hCard = 0
   hSPEAKER.hWD = WD_Open()
      If hSPEAKER.hWD = INVALID_HANDLE_VALUE Then
         SPEAKER_ErrorString = "ERROR - Cannot open WinDriver device"
         GoTo Error
      End If
      ' check if handle valid & version OK
   WD_Version hSPEAKER.hWD, ver
   If ver.dwVer < WD_VER Then
      SPEAKER_ErrorString = "ERROR - incorrect WinDriver version"
      GoTo Error
   End If
   SPEAKER_SetCardElements hSPEAKER
   hSPEAKER.cardReg.fCheckLockOnly = False
   WD_CardRegister hSPEAKER.hWD, hSPEAKER.cardReg
   If (hSPEAKER.cardReg.hCard = 0) Then
      SPEAKER_ErrorString = "ERROR - could not lock device, already in use"
      GoTo Error
   End If
          'open finished OK
   SPEAKER_Open = True
   GoTo finish
Error:
          'error during open
   If (hSPEAKER.cardReg.hCard <> 0) Then
      WD_CardUnregister hSPEAKER.hWD, hSPEAKER.cardReg
   End If
   If (hSPEAKER.hWD <> INVALID_HANDLE_VALUE) Then
      WD_Close hSPEAKER.hWD
   End If
   SPEAKER_Open = False
finish:
End Function

Sub SPEAKER_Close(hSPEAKER As SPEAKER_HANDLE)
   ' unregister card
   If (hSPEAKER.cardReg.hCard <> 0) Then
      WD_CardUnregister hSPEAKER.hWD, hSPEAKER.cardReg
   End If
   ' close WinDriver
   WD_Close (hSPEAKER.hWD)
End Sub

Sub SPEAKER_WriteCtrl(hSPEAKER As SPEAKER_HANDLE, data As Byte)
Dim trans As WD_Transfer
   trans.cmdTrans = WP_BYTE
   trans.dwPort = SPEAKER_IO_ADDR61
   trans.dwDataTransfer = data
   WD_Transfer hSPEAKER.hWD, trans
End Sub

Function SPEAKER_ReadCtrl(hSPEAKER As SPEAKER_HANDLE) As Byte
Dim trans As WD_Transfer
    trans.cmdTrans = RP_BYTE
    trans.dwPort = SPEAKER_IO_ADDR61
    WD_Transfer hSPEAKER.hWD, trans
    SPEAKER_ReadCtrl = trans.dwDataTransfer
End Function

Sub SPEAKER_WriteTimerData(hSPEAKER As SPEAKER_HANDLE, data As Byte)
Dim trans As WD_Transfer
   trans.cmdTrans = WP_BYTE
   trans.dwPort = SPEAKER_IO_ADDR42
   trans.dwDataTransfer = data
   WD_Transfer hSPEAKER.hWD, trans
End Sub

Sub SPEAKER_WriteTimerCtrl(hSPEAKER As SPEAKER_HANDLE, data As Byte)
Dim trans As WD_Transfer
   trans.cmdTrans = WP_BYTE
   trans.dwPort = SPEAKER_IO_ADDR43
   trans.dwDataTransfer = data
   WD_Transfer hSPEAKER.hWD, trans
End Sub

Sub SPEAKER_Tone(hSPEAKER As SPEAKER_HANDLE, dwHz As Long, dwMilli As Long)
Dim dwDevisor As Long
Dim bCtrl As Byte
   dwDevisor = 1190000 \ dwHz
   SPEAKER_WriteTimerCtrl hSPEAKER, &HB6
   SPEAKER_WriteTimerData hSPEAKER, dwDevisor And &HFF
   SPEAKER_WriteTimerData hSPEAKER, ((dwDevisor \ 2 ^ 8) And &HFF)
   bCtrl = SPEAKER_ReadCtrl(hSPEAKER)
   SPEAKER_WriteCtrl hSPEAKER, bCtrl Or (bit0 Or bit1)
   Sleep (dwMilli)
   SPEAKER_WriteCtrl hSPEAKER, bCtrl And Not (bit0 Or bit1)
End Sub



Юзай...

[sanches]

пстой, я чет не понял, а где WD_CARD_REGISTER

[goro]

Требуется "оживить" программу на VB звуковым фоном, что-то вроде рокота программно изменяемой частоты. Со звуковой картой все получилось, а вот со Speaker'ом нет. Может кто подскажет?

А как ты программно сгенерировал звук на зауковую карту

[gsv]

Самым варварским способом, подсаживая процессор
Private Sub Timer3_Timer() 'Переменный интервал !!!
' Звук мотора. Привязка к расположению файла !!!!
If Rpm > 1 And Mk > 0 Then RetVal = PlaySound ("C:\Program Files\Trans\Sound\RpmMk.wav", 0&, &H1)
If Rpm > 1 And Mk <= 0 Then RetVal = PlaySound("C:\Program Files\Trans\Sound\RpmMc.wav", 0&, &H1)
End Sub
Рублю wav по таймеру...
' Выбор периода выдачи звука вращения ДВС(x2)
If Rpm > 0 Then Timer3.Interval = 2000 / (Rpm / 60)
Rpm это частота вращения ДВС
Смотри lab-master.narod.ru там в презентации есть звук, правда фиксированной частоты, но хороший
Всех благ, спасибо за участие, Gsv