VFP 愛用者社區

[sunghsia]

**************************************************************
* 得知 Wave Output 的音量
* 拷備至: *.prg 或 WaveOutput.prg

* 用vfp寫有結構的值,有時有些累 (vfp的結構值,就像是 VB的 TYPE)
***************************************************************


ouserform=CREATEOBJECT ("userform")
ouserform.SHOW

DEFINE CLASS userform AS form
NAME="Form1"
CAPTION="Form1"
HEIGHT=82
LEFT=46
MAXBUTTON=.F.
SHOWWINDOW=2
TOP=122
VISIBLE=.T.
WIDTH=375


ADD OBJECT Timer1 AS Timer
ADD OBJECT Label1 AS Label WITH CAPTION="outValue",HEIGHT=16,LEFT=26,TOP=26,WIDTH=50
ADD OBJECT ab音量框 AS Label WITH BORDERSTYLE=1,CAPTION="",HEIGHT=30,LEFT=110,TOP=18,WIDTH=210
ADD OBJECT txt音量 AS textbox WITH BORDERSTYLE=0,ENABLED=.F.,DISABLEDBACKCOLOR=1674448,HEIGHT=26,LEFT=112,TOP=20,WIDTH=100
ADD OBJECT Label2 as Label WITH caption=[wav, mp3 , vcd...],left=110,top=50,autosiZe=.T.

PROCEDURE CLICK
= GlobalFree (volHmem)
RELEASE DLL
CLEAR EVENTS

_screen.visible=.T.
_screen.windowstate=2
set talk on
ENDPROC

PROCEDURE ACTIVATE
READ EVENTS
ENDPROC


PROCEDURE INIT
set talk off
_screen.windowstate=1
_screen.visible=.F.

DECLARE INTEGER mixerOpen IN winmm INTEGER @ phmx, INTEGER uMxId, INTEGER dwCallback, INTEGER dwInstance, INTEGER fdwOpen
DECLARE INTEGER mixerGetLineInfo IN winmm INTEGER hmxobj, STRING @ pmxl, INTEGER fdwInfo
DECLARE INTEGER mixerGetLineControls IN winmm INTEGER hmxobj, STRING @ pmxlc, INTEGER fdwControls
DECLARE INTEGER mixerGetControlDetails IN winmm INTEGER hmxobj, STRING @ pmxcd, INTEGER fdwDetails
DECLARE INTEGER GlobalFree IN kernel32 INTEGER hMem
DECLARE INTEGER GlobalLock IN kernel32 INTEGER hMem
DECLARE INTEGER GlobalAlloc IN kernel32 INTEGER wFlags, INTEGER dwBytes
DECLARE RtlMoveMemory IN kernel32 As CopyMemory STRING @ Destination, INTEGER Source, INTEGER nLength


MIXERLINE_COMPONENTTYPE_DST_FIRST = 0
MIXERLINE_COMPONENTTYPE_SRC_FIRST = 4096
MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
MIXERLINE_COMPONENTTYPE_SRC_LINE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
MIXERLINE_COMPONENTTYPE_DST_WAVEIN = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 7)
MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT = (MIXERLINE_COMPONENTTYPE_SRC_FIRST +

MIXERCONTROL_CT_CLASS_FADER = 1342177280
MIXERCONTROL_CT_UNITS_UNSIGNED = 196608
MIXERCONTROL_CT_UNITS_SIGNED = 131072
MIXERCONTROL_CT_CLASS_METER = 268435456
MIXERCONTROL_CT_SC_METER_POLLED = 0
MIXERCONTROL_CONTROLTYPE_FADER = (MIXERCONTROL_CT_CLASS_FADER + MIXERCONTROL_CT_UNITS_UNSIGNED)
MIXERCONTROL_CONTROLTYPE_VOLUME = (MIXERCONTROL_CONTROLTYPE_FADER + 1)
MIXERCONTROL_CONTROLTYPE_SIGNEDMETER = (MIXERCONTROL_CT_CLASS_METER + MIXERCONTROL_CT_SC_METER_POLLED + MIXERCONTROL_CT_UNITS_SIGNED)
MIXERCONTROL_CONTROLTYPE_PEAKMETER = (MIXERCONTROL_CONTROLTYPE_SIGNEDMETER + 1)

MIXER_GETCONTROLDETAILSF_VALUE = 0
MIXER_GETLINECONTROLSF_ONEBYTYPE = 2
MIXER_GETLINEINFOF_COMPONENTTYPE = 3

MIXER_SHORT_NAME_CHARS = 16
MIXER_LONG_NAME_CHARS = 64
MAXPNAMELEN = 32

GMEM_FIXED = 0
MMSYSERR_NOERROR = 0
DEVICEID = 0


public hmixer, mxc, mxcd, volHmem, 最大音量

hmixer=0
rc = mixerOpen (@hmixer, DEVICEID, 0, 0, 0) &&打開
if MMSYSERR_NOERROR <> rc && 錯誤
messagebox ("Couldn't open the mixer.")
RETURN
endif

mxl = num2dword (168) + repl(chr(0),20) + num2dword(MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT) + repl(chr(0),140)
rc = mixerGetLineInfo (hmixer, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
if MMSYSERR_NOERROR <> rc
messagebox ("~~><~~",16)
RETURN
endif

mxlc= num2dword(24) + substr(mxl, 13, 4) + num2dword(MIXERCONTROL_CONTROLTYPE_PEAKMETER) + num2dword(1)

mxc= num2dword(152) + repl(chr(0),148)
hmem = GlobalAlloc(GMEM_FIXED, len(mxc))

mxlc= mxlc + num2dword (len(mxc))
_add= GlobalLock(hmem)
mxlc= mxlc + num2dword (_add)

ok=0
rc = mixerGetLineControls (hmixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)
If MMSYSERR_NOERROR = rc
_add = buf2dword(substr(mxlc,21,4))
= CopyMemory (@mxc, _add, len (mxc))
ok = 1
endif
= GlobalFree (hmem)

if ok = 1 && ok
v= buf2dword (substr(mxc,105,4))
最大音量 = v
else
messagebox ("Couldn't get waveout meter")
RETURN
endif

volHmem = GlobalAlloc (0, 4)
_add = GlobalLock(volHmem)
mxcd= num2dword(24) + repl(chr(0),4) + num2dword(1) + repl(chr(0),4) + num2dword(4) + num2dword(_add)

DECLARE RtlMoveMemory IN kernel32 As CopyMemory INTEGER @ Destination, INTEGER Source, INTEGER nLength

this.timer1.interval = 130 &&可自行調速
this.timer1.enabled = .T.
ENDPROC


PROCEDURE Timer1.timer
c_id= substr(mxc,5,4)
c_item= substr(mxc,17,4)

mxcd= stuff(mxcd, 5, 4, c_id)
mxcd= stuff(mxcd, 13, 4, c_item)

= mixerGetControlDetails(hmixer, @mxcd, 0)

lrvolume=4
_add = buf2dword(substr(mxcd, 21, 4))
= CopyMemory (@lrvolume, _add, lrvolume)

n1= iif(lrvolume<0 , -lrvolume , lrvolume)
n2= (thisform.ab音量框.width -4) / 最大音量
thisform.txt音量.width = int(n1 * n2)
ENDPROC

ENDDEFINE


FUNCTION num2dword (lnValue) &&接收十進位, 回傳32位元數值資料
#DEFINE m0 256
#DEFINE m1 65536
#DEFINE m2 16777216
LOCAL b0, b1, b2, b3
b3 = Int(lnValue/m2)
b2 = Int((lnValue - b3*m2)/m1)
b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
b0 = Mod(lnValue, m0)
RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)
ENDFUNC


FUNCTION buf2dword (v) &&接收32位元數值資料, 回傳十進位
RETURN asc(substr(v, 1,1)) + asc(substr(v, 2,1)) *256 + asc(substr(v, 3,1)) *65536 + asc(substr(v, 4,1)) *16777216
ENDFUNC

[sunghsia]

要播於音樂,, 才能顯示效果

[garfield]

應該是用這篇去改成VFP語法, 兩相對照,加強改寫功力.

http://www.programfan.net/club/showbbs.asp?id=62245
*********
BEGIN
MultiUse = -1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit '控制系統音量用

Private hmem As Long

Const MMSYSERR_NOERROR = 0
Const MAXPNAMELEN = 32
Const MIXER_LONG_NAME_CHARS = 64
Const MIXER_SHORT_NAME_CHARS = 16
Const MIXER_GETLINEINFOF_COMPONENTTYPE = &H3&
Const MIXER_GETCONTROLDETAILSF_VALUE = &H0&
Const MIXER_SETCONTROLDETAILSF_VALUE = &H0&
Const MIXER_GETLINECONTROLSF_ONEBYTYPE = &H2&
Const MIXERLINE_COMPONENTTYPE_DST_FIRST = &H0&
Const MIXERLINE_COMPONENTTYPE_SRC_FIRST = &H1000&
Const MIXERLINE_COMPONENTTYPE_DST_SPEAKERS = (MIXERLINE_COMPONENTTYPE_DST_FIRST + 4)
Const MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 3)
Const MIXERLINE_COMPONENTTYPE_SRC_LINE = (MIXERLINE_COMPONENTTYPE_SRC_FIRST + 2)
Const MIXERCONTROL_CT_CLASS_FADER = &H50000000
Const MIXERCONTROL_CT_UNITS_UNSIGNED = &H30000
Const MIXERCONTROL_CONTROLTYPE_FADER = _
(MIXERCONTROL_CT_CLASS_FADER Or _
MIXERCONTROL_CT_UNITS_UNSIGNED)
Const MIXERCONTROL_CONTROLTYPE_VOLUME = _
(MIXERCONTROL_CONTROLTYPE_FADER + 1)

Private Type MIXERCONTROLDETAILS
cbStruct As Long
dwControlID As Long
cChannels As Long
item As Long
cbDetails As Long
paDetails As Long
End Type

Private Type MIXERCONTROLDETAILS_UNSIGNED
dwValue As Long
End Type

Private Type MIXERCONTROL
cbStruct As Long
dwControlID As Long
dwControlType As Long
fdwControl As Long
cMultipleItems As Long
szShortName As String * MIXER_SHORT_NAME_CHARS
szName As String * MIXER_LONG_NAME_CHARS
lMinimum As Long
lMaximum As Long
reserved(10) As Long
End Type

Private Type MIXERLINECONTROLS
cbStruct As Long
dwLineID As Long
dwControl As Long
cControls As Long
cbmxctrl As Long
pamxctrl As Long
End Type

Private Type MIXERLINE
cbStruct As Long
dwDestination As Long
dwSource As Long
dwLineID As Long
fdwLine As Long
dwUser As Long
dwComponentType As Long
cChannels As Long
cConnections As Long
cControls As Long
szShortName As String * MIXER_SHORT_NAME_CHARS
szName As String * MIXER_LONG_NAME_CHARS
dwType As Long
dwDeviceID As Long
wMid As Integer
wPid As Integer
vDriverVersion As Long
szPname As String * MAXPNAMELEN
End Type
'
'Allocates the specified number of bytes from the heap.
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
'
'Locks a global memory object and returns a pointer to the
' first byte of the object's memory block. The memory block
' associated with a locked object cannot be moved or discarded.
Private Declare Function GlobalLock Lib "kernel32" (ByVal hmem As Long) As Long
'
'Frees the specified global memory object and invalidates its handle.
Private Declare Function GlobalFree Lib "kernel32" (ByVal hmem As Long) As Long
'
Private Declare Sub CopyPtrFromStruct Lib "kernel32" Alias "RtlMoveMemory" _
(ByVal ptr As Long, struct As Any, ByVal cb As Long)

Private Declare Sub CopyStructFromPtr Lib "kernel32" Alias "RtlMoveMemory" _
(struct As Any, ByVal ptr As Long, ByVal cb As Long)
'
'Opens a specified mixer device and ensures that the device
' will not be removed until the application closes the handle.
Private Declare Function mixerOpen Lib "winmm.dll" _
(phmx As Long, ByVal uMxId As Long, ByVal dwCallback As Long, _
ByVal dwInstance As Long, ByVal fdwOpen As Long) As Long
'
'Sets properties of a single control associated with an audio line.
Private Declare Function mixerSetControlDetails Lib "winmm.dll" _
(ByVal hmxobj As Long, pmxcd As MIXERCONTROLDETAILS, _
ByVal fdwDetails As Long) As Long
'
'Retrieves information about a specific line of a mixer device.
Private Declare Function mixerGetLineInfo Lib "winmm.dll" _
Alias "mixerGetLineInfoA" (ByVal hmxobj As Long, _
pmxl As MIXERLINE, ByVal fdwInfo As Long) As Long
'
'Retrieves one or more controls associated with an audio line.
Private Declare Function mixerGetLineControls Lib "winmm.dll" _
Alias "mixerGetLineControlsA" (ByVal hmxobj As Long, _
pmxlc As MIXERLINECONTROLS, ByVal fdwControls As Long) As Long

Private hmixer As Long
Private volCtrl As MIXERCONTROL ' Waveout volume control.
Private micCtrl As MIXERCONTROL ' Microphone volume control.
'
'Local variable to save properties
Private mvarprMicVolume As Long 'Local copy
Private mvarprMicMaxVolume As Long 'Local copy
Private mvarprMicMinVolume As Long 'Local copy

Private mvarprSpeakerVolume As Long 'Local copy
Private mvarprSpeakerMaxVolume As Long 'Local copy
Private mvarprSpeakerMinVolume As Long 'Local copy

Private mvarprMixerErr As Long 'Local copy

Private Function fGetVolumeControl(ByVal hmixer As Long, _
ByVal componentType As Long, ByVal ctrlType As Long, _
ByRef mxc As MIXERCONTROL) As Boolean
'
' This function attempts to obtain a mixer control.
'
Dim mxlc As MIXERLINECONTROLS
Dim mxl As MIXERLINE
Dim hmem As Long
Dim rc As Long

mxl.cbStruct = Len(mxl)
mxl.dwComponentType = componentType
'
' Get a line corresponding to the component type.
'
rc = mixerGetLineInfo(hmixer, mxl, MIXER_GETLINEINFOF_COMPONENTTYPE)
If MMSYSERR_NOERROR = rc Then
With mxlc
.cbStruct = Len(mxlc)
.dwLineID = mxl.dwLineID
.dwControl = ctrlType
.cControls = 1
.cbmxctrl = Len(mxc)
End With
'
' Allocate a buffer for the control.
'
hmem = GlobalAlloc(&H40, Len(mxc))
mxlc.pamxctrl = GlobalLock(hmem)
mxc.cbStruct = Len(mxc)
'
' Get the control.
'
rc = mixerGetLineControls(hmixer, mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE)
If MMSYSERR_NOERROR = rc Then
fGetVolumeControl = True
'
' Copy the control into the destination structure.
'
Call CopyStructFromPtr(mxc, mxlc.pamxctrl, Len(mxc))
Else
fGetVolumeControl = False
End If
Call GlobalFree(hmem)
Exit Function
End If
fGetVolumeControl = False
End Function

Private Function fSetVolumeControl(ByVal hmixer As Long, _
mxc As MIXERCONTROL, ByVal volume As Long) As Boolean
'
' This function sets the value for a volume control.
'
Dim rc As Long
Dim mxcd As MIXERCONTROLDETAILS
Dim vol As MIXERCONTROLDETAILS_UNSIGNED

With mxcd
.item = 0
.dwControlID = mxc.dwControlID
.cbStruct = Len(mxcd)
.cbDetails = Len(vol)
End With
'
' Allocate a buffer for the control value buffer.
'
hmem = GlobalAlloc(&H40, Len(vol))
mxcd.paDetails = GlobalLock(hmem)
mxcd.cChannels = 1
vol.dwValue = volume
'
' Copy the data into the control value buffer.
'
Call CopyPtrFromStruct(mxcd.paDetails, vol, Len(vol))
'
' Set the control value.
'
rc = mixerSetControlDetails(hmixer, mxcd, MIXER_SETCONTROLDETAILSF_VALUE)
Call GlobalFree(hmem)

If MMSYSERR_NOERROR = rc Then
fSetVolumeControl = True
Else
fSetVolumeControl = False
End If
End Function

Public Function meOpenMixer() As Long
Dim rc As Long
Dim bOK As Boolean
'
' Open the mixer with deviceID 0.
'
rc = mixerOpen(hmixer, 0, 0, 0, 0)
mvarprMixerErr = rc
If MMSYSERR_NOERROR <> rc Then
MsgBox "Could not open the mixer.", vbCritical, "Volume Control"
Exit Function
End If
*******
'
'*********************************************************
'
' Get the main volume control.
'
bOK = fGetVolumeControl(hmixer, _
MIXERLINE_COMPONENTTYPE_DST_SPEAKERS, _
MIXERCONTROL_CONTROLTYPE_VOLUME, volCtrl)
'
' If the function successfully gets the volume control,
' the maximum and minimum values are specified by
' lMaximum and lMinimum.
'
If bOK Then
mvarprSpeakerMaxVolume = volCtrl.lMaximum
mvarprSpeakerMinVolume = volCtrl.lMinimum
End If
'
'*********************************************************
'
' Get the microphone volume control.
'
bOK = fGetVolumeControl(hmixer, _
MIXERLINE_COMPONENTTYPE_SRC_MICROPHONE, _
MIXERCONTROL_CONTROLTYPE_VOLUME, micCtrl)

If bOK Then
mvarprMicMaxVolume = micCtrl.lMaximum
mvarprMicMinVolume = micCtrl.lMinimum
End If
'
'*******************************************************
'
Public Property Get prSpeakerMinVolume() As Long
prSpeakerMinVolume = mvarprSpeakerMinVolume
End Property

Public Property Get prSpeakerMaxVolume() As Long
prSpeakerMaxVolume = mvarprSpeakerMaxVolume
End Property

Public Property Let prSpeakerVolume(ByVal vData As Long)
mvarprSpeakerVolume = vData
Call fSetVolumeControl(hmixer, volCtrl, vData)
End Property

Public Property Get prSpeakerVolume() As Long
prSpeakerVolume = mvarprSpeakerVolume
End Property
'
'*********************************************************
'
Public Property Get prMicMinVolume() As Long
prMicMinVolume = mvarprMicMinVolume
End Property

Public Property Get prMicMaxVolume() As Long
prMicMaxVolume = mvarprMicMaxVolume
End Property

Public Property Let prMicVolume(ByVal vData As Long)
mvarprMicVolume = vData
Call fSetVolumeControl(hmixer, micCtrl, vData)
End Property

Public Property Get prMicVolume() As Long
prMicVolume = mvarprMicVolume
End Property
*******

以下代碼寫在程序開頭的全局部分

Const MMSYSERR_NOERROR = 0
Dim MyVolume As Class1
Dim MaxVol, MinVol As Double

以下代碼為類模塊的引出端函數

'**************************************************
' 在啟動時獲取與音量相關的信息並初始化音量值
'**************************************************
Set MyVolume = New Class1
MyVolume.meOpenMixer

MyVolume.prSpeakerVolume = CLng(50000) '音量設定部分，最大值65535

If MyVolume.prMixerErr = MMSYSERR_NOERROR Then
MinVol = MyVolume.prSpeakerMinVolume
MaxVol = MyVolume.prSpeakerMaxVolume
End If

[sunghsia]

不錯的建議