voicerec.bas

适用于Wince的EVB3.0写的录音实例

Attribute VB_Name = "basVoiceRec"
'******************************************************************************
' Implements Voice Recorder control functions
'******************************************************************************
' FileName:  VoiceRec.bas
' Creator:   Christian Forsberg
' Created:   2001-07-15
'******************************************************************************
' Version   Date   Who Comment
' 00.00.000 010715 CFO Created
'******************************************************************************
Option Explicit

' LocalAlloc style constants
Public Const LMEM_ZEROINIT = &H40

' Voice Recorder style constants
Public Const VRS_NO_OKCANCEL = &H1    ' No OK/CANCLE dispalyed
Public Const VRS_NO_NOTIFY = &H2      ' No parent Notifcation
Public Const VRS_MODAL = &H4          ' Control is Modal
Public Const VRS_NO_OK = &H8          ' No OK displayed
Public Const VRS_NO_RECORD = &H10     ' No REOCRD button displayed
Public Const VRS_PLAY_MODE = &H20     ' Immediatly play supplied file when launched
Public Const VRS_NO_MOVE = &H40       ' Grip is removed and the control cannot be moved

' Voice Recorder messages constants
Public Const VRM_RECORD = &H1900
Public Const VRM_PLAY = &H1901
Public Const VRM_STOP = &H1902
Public Const VRM_CANCEL = &H1903
Public Const VRM_OK = &H1904

' Palysound flag constants
Public Const SND_FILENAME = &H20000
Public Const SND_NODEFAULT = &H2
Public Const SND_SYNC = &H0

' API declarations
Public Declare Function LocalAlloc Lib "Coredll" (ByVal wFlags As Long, ByVal wBytes As Long) As Long
Public Declare Function LocalFree Lib "Coredll" (ByVal hMem As Long) As Long
Public Declare Sub MoveMemory Lib "Coredll" Alias "memmove" (ByVal Destination As Long, ByVal Source As String, ByVal Length As Long)
Public Declare Function VoiceRecorder_Create Lib "VoiceCtl" (ByVal CM_VOICE_RECORDER As String) As Long
Public Declare Function SendMessage Lib "Coredll" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SendMessageString Lib "Coredll" Alias "SendMessageW" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Public Declare Function PlaySound Lib "coredll.DLL" Alias "PlaySoundW" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Public Function ShowVoiceRecorder(ByVal hwnd As Long, ByVal xPos As Long, _
                                  ByVal yPos As Long, ByVal FileName As String, _
                                  ByVal Modal As Boolean, _
                                  ByVal Moveable As Boolean, _
                                  ByVal ShowRecButton As Boolean, _
                                  ByVal PlayNow As Boolean) As Long

' Show Voice Recorder control.
' IN:  hWnd, handle to parent window
'      xPos, x position
'      yPos, y position
'      FileName, filename of file to record to
'      Modal, modal?
'      Moveable, moveable?
'      ShowRecButton, show record button?
'      PlayNow, play file at once?
' OUT: ShowVoiceRecorder, handle to voice recorder control
' Known bugs:
' Version   Date   Who Comment
' 00.00.000 010715 CFO Created
'******************************************************************************


  Dim llpszFileName As Long
  Dim llLength As Long
  Dim llStyle As Long
  Dim udtCM_VOICE_RECORDER As String
  
  ' Reserve 28 bytes for structure
  udtCM_VOICE_RECORDER = Space(14)
    
  ' Allocate memory
  llLength = LenB(FileName) + 1
  llpszFileName = LocalAlloc(LMEM_ZEROINIT, llLength)
    
  ' Copy text from string to allocated memory
  MoveMemory llpszFileName, FileName, llLength
  
  ' Set style from parameters
  llStyle = VRS_NO_NOTIFY
  If Modal Then llStyle = llStyle + VRS_MODAL
  If Not Moveable Then llStyle = llStyle + VRS_NO_MOVE
  If Not ShowRecButton Then llStyle = llStyle + VRS_NO_RECORD
  If PlayNow Then llStyle = llStyle + VRS_PLAY_MODE
  
  ' Fill structure
  udtCM_VOICE_RECORDER = setCM_VOICE_RECORDER(llStyle, xPos, yPos, hwnd, llpszFileName)
  
  ' Create Voice Recorder
  ShowVoiceRecorder = VoiceRecorder_Create(udtCM_VOICE_RECORDER)
  
  ' Release allocated memory
  Call LocalFree(llpszFileName)

End Function
Private Function setCM_VOICE_RECORDER(ByVal dwStyle As Long, ByVal xPos As Long, _
                                      ByVal yPos As Long, hWndParent As Long, _
                                      ByVal lpszRecordFilename As Long) As String
    
' Set CM_VOICE_RECORDER structure (as string).
' IN:  dwStyle, voice recorder style
'      xPos, x position
'      yPos, y position
'      hWndParent, handle to parent window
'      lpszRecordFileName, LPSTR to filename
' OUT: setCM_VOICE_RECORDER, string with structure
' Known bugs:
' Version   Date   Who Comment
' 00.00.000 010715 CFO Created
'******************************************************************************
    
  ' Build CM_VOICE_RECORDER UDT:
  'Type CM_VOICE_RECORDER
  '  cb As Long 'WORD
  '  dwStyle As Long 'DWORD
  '  xPos As Long 'int
  '  yPos As Long 'int
  '  hwndParent As Long 'HWND
  '  id As Long 'int
  '  lpszRecordFileName As Long 'LPSTR
  'End Type
  
  setCM_VOICE_RECORDER = LongToBytes(28) & LongToBytes(dwStyle) & _
                         LongToBytes(xPos) & LongToBytes(yPos) & _
                         LongToBytes(hWndParent) & LongToBytes(0) & _
                         LongToBytes(lpszRecordFilename)

End Function
Public Sub PlaySoundFile(ByVal FileName As String)

' Play a sound (WAV) file.
' IN:  FileName, name of WAV-file
' Known bugs:
' Version   Date   Who Comment
' 00.00.000 010715 CFO Created
'******************************************************************************
  
  Call PlaySound(FileName, 0, SND_FILENAME + SND_SYNC + SND_NODEFAULT)

End Sub
Function LongToBytes(ByVal Value As Long) As String
  
' Convert long value to string of bytes.
' IN:  Value, long value
' OUT: LongToBytes, string with long value converted to bytes
' Known bugs:
' Version   Date   Who Comment
' 00.00.000 010715 CFO Created
'******************************************************************************
  Dim lsHex As String, i As Integer
  
  lsHex = Right("00000000" & Hex(Value), 8)
  For i = 1 To 7 Step 2
    LongToBytes = ChrB(CInt("&H" & Mid(lsHex, i, 2))) & LongToBytes
  Next

End Function