VB编程的高手们,跪求了

来自:    更新日期:早些时候
请问VB编程高手们:~

呵呵!楼上的蹭分啊!
为了声音再加个控件不是很值哈!

下面的程序不是我写的!但是很不错!一个vb类,提供了很全的vb操作方法!使用简单

先新建个类clsVolume,把下面文件复制进去
=======================================开始
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 waveout 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
End Function

Public Property Get prMixerErr() As Long
prMixerErr = mvarprMixerErr
End Property

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

=============================================结束

用的时候只要
Set MyVolume = New clsVolume
MyVolume.prMicVolume = lVol就可以了

Private Sub Form_Click()
Dim R As Double, V As Double, S As Double
Const pi = 3.1415926 '把这里的Consi改成Const
R = Val(InputBox("请输入球的半径(mm):"))
Print
Print "球的半径R="; R; "mm"
Print
V = 4 / 3 * pi * R ^ 3
S = 4 * pi * R ^ 2
Print "球的体积为"; V; "mm^3"
Print
Print "球的面积为"; S; "mm^2"
End Sub

w = InputBox("请输入需要转换的温度:"&vbcrlf&_
"例如:"&vbcrlf&"101F中的F表示华氏温度"&vbcrlf&_
"30C中的C表示摄氏温度",,"115F")
wz = Left(w,Len(w)-1)
If IsNumeric(wz) Then
wz = CSng(wz)
If Right(w,1) = "F" Then
wz = (wz-50)*5/9+10
MsgBox w&" → "&Round(wz, 2)&"C",,"华氏温度转摄氏温度"
ElseIf Right(w,1) = "C" Then
wz = (wz-10)*9/5+50
MsgBox w&" → "&Round(wz, 2)&"F",,"摄氏温度转华氏温度"
Else
MsgBox "请输入正确的温度数值!"
End If
Else
MsgBox "请输入正确的温度数值!"
End If

——————————————
这是用vbs做的,保存问*.vbs文件,运行即可


VB编程的高手们,跪求了视频

相关评论:
  • 15691592975高手们帮我看看C++程序啊,跪求啊!!!
    傅耐侦把一段字符串s中指定的小写字母t,替换成大写字母,关键是在*s = t - 'a' + 'A';这句:小写字母的ASCII码值比大写字母的ASCII码值大32,也就是'a' - 'A'所以小写字母t,减去'a' - 'A',就是t - ( 'a' - 'A'),也就是 t - 'a' + 'A',就成了大写字母了 ...

  • 15691592975会编写autorun.inf的高手来呀
    傅耐侦autorun.INF里头的:[AUTORUN]shellexecute=1.bat 1.BAT里头的:start 江湖怨.rm 你的江湖怨.rm也要放U盘里 这些都是我自己打的,虽然我以前也是在网上看的。具体操作:新建两个文本文档(扩展名txt的那个),分别改名为autorun.INF和1.BAT,分别右键了点编辑,把上面说的复制进去,保存后全部扔进你...

  • 15691592975Run-time error’-2147024770 (8007007e)什么来的、跪求啊
    傅耐侦你在代码中所有用到的 .dll .ocx 都必需在客户机注册,打包不是万能的,还有你打包的过程可能出了错, VB卸载也不能解决问题,如果你用精简版的VB,那你头就更大了.The specified module could not be found.这句话应该是要先看看你在VB窗体能不能运行?编译成exe后能不能运行?你有可能在代码中打...

  • 15691592975跪求优化大师7.74.7.702版本的注册码,请高手们给个注册码了,谢谢
    傅耐侦是41D2AE1B-B97E989C-D32F55F3-CEFB2785

  • 15691592975本人感觉学习C很重要,但我根本入不了门跪求高手们教教我
    傅耐侦先告诉你C语言也是一门语言,只不过它用来和计算机交流。培养兴趣是必要的 你怎么告诉它你要做什么,怎么去获得它帮你解决问题的结果。由于你的计算机朋友办事效率高,而且吃苦耐劳,不过它自己不会拐弯抹角,需要你告诉它,哪儿向左哪向右,它也不会自己走回头路,也需要你限制它,办完一件事后,再...

  • 15691592975跪求高手们,计算机高手熟悉电脑周边设备的大哥,大神们,我连接个wifi无...
    傅耐侦你按路由器后面的那个小按钮, 按着不放,知道几个灯一起亮了, 你再重新设置。

  • 15691592975跪求盗贼嫁祸指向宏,各位做宏高手们,本人泪求啊
    傅耐侦showtooltip 嫁祸诀窍\/cast [target=mouseover, exists] 嫁祸诀窍\/cast [modifier:alt, target=focus] 嫁祸诀窍 此宏作用。有鼠标指向给鼠标指向(非当前目标)施放嫁祸诀窍,没有鼠标指向给当前目标使用。按ALT+施放给焦点目标施放嫁祸诀窍。 希望对你有帮助。

  • 15691592975本人感觉学习C很重要,但我根本入不了门跪求高手们教教我
    傅耐侦去找一本c语言入门的书,不如说现在的大学教材《c语言程序设计》谭浩强版,上面知识非常系统,缺点就是不够生动,如果你不在乎那么几十块钱的话也可以区买《c语言参悟之旅》这本左飞出的书要生动易懂一点!当然最好下载一下c语言方面的视频教程,到电驴里面去搜非常多的,对了,下载资料电驴是个不...

  • 15691592975JSP中点击新闻标题显示显示新闻内容要怎么?急~~跪求..开发高手们
    傅耐侦你的新闻标题和内容应该在数据库中,你应该写一个类,里面有根据新闻ID或者新闻标题获取这条新闻的方法,取出来,放到request中,然后再shownews.jsp文件中拿出新闻的标题和内容.

  • 15691592975如何用asp做排列组合
    傅耐侦一定要用ASP写吗,其实可以把数字传到SQLServer中,让每个字符作为一行,利用迪卡尔运算(cross),就可以自动生成从小到大的顺序排列了。

  • 相关主题精彩

    版权声明:本网站为非赢利性站点,内容来自于网络投稿和网络,若有相关事宜,请联系管理员

    Copyright © 喜物网