editor/bass-sys/win/bass24/vb/WriteWav/frmWriteWave.frm

297 lines
9.6 KiB
Text
Raw Normal View History

2021-01-05 10:17:41 +00:00
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "comdlg32.ocx"
Begin VB.Form frmWriteWave
BorderStyle = 3 'Fixed Dialog
Caption = "BASS WAVE writer example"
ClientHeight = 2295
ClientLeft = 45
ClientTop = 330
ClientWidth = 4470
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 2295
ScaleWidth = 4470
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton btnConvert
Caption = "Convert to ""BASS.WAV"""
Enabled = 0 'False
Height = 495
Left = 120
TabIndex = 3
Top = 1680
Width = 4215
End
Begin VB.CommandButton btnLoadFile
Caption = "Select File to Convert"
Height = 495
Left = 120
TabIndex = 2
Top = 1080
Width = 4215
End
Begin MSComDlg.CommonDialog cmd
Left = 3840
Top = 480
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label lblTime
AutoSize = -1 'True
Caption = "Time:"
Height = 195
Left = 120
TabIndex = 4
Top = 360
Width = 390
End
Begin VB.Label lblStrFile
AutoSize = -1 'True
Caption = "Streaming File:"
Height = 195
Left = 120
TabIndex = 1
Top = 120
Width = 1035
End
Begin VB.Label lblPos
AutoSize = -1 'True
Caption = "Pos:"
Height = 195
Left = 120
TabIndex = 0
Top = 600
Width = 315
End
End
Attribute VB_Name = "frmWriteWave"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'//////////////////////////////////////////////////////////////////////////////////
' frmWriteWave.frm - Copyright (c) 2002-2007 (: JOBnik! :) [Arthur Aminov, ISRAEL]
' [http://www.jobnik.org]
' [ jobnik@jobnik.org ]
'
' BASS WAVE writer example: MOD/MPx/OGG -> "BASS.WAV"
' Originally translated from - writewav.c - Example of Ian Luck
'//////////////////////////////////////////////////////////////////////////////////
Option Explicit
Dim info As BASS_CHANNELINFO
Dim chan As Long, p As Long
Dim pos As Long
Dim buf() As Byte
Private Type WAVEHEADER_RIFF ' == 12 bytes ==
RIFF As Long ' "RIFF" = &H46464952
riffBlockSize As Long ' pos + 44 - 8
riffBlockType As Long ' "WAVE" = &H45564157
End Type
Private Type WAVEHEADER_data ' == 8 bytes ==
dataBlockType As Long ' "data" = &H61746164
dataBlockSize As Long ' pos
End Type
Private Type WAVEFORMAT ' == 24 bytes ==
wfBlockType As Long ' "fmt " = &H20746D66
wfBlockSize As Long
' == block size begins from here = 16 bytes
wFormatTag As Integer
nChannels As Integer
nSamplesPerSec As Long
nAvgBytesPerSec As Long
nBlockAlign As Integer
wBitsPerSample As Integer
End Type
Dim wr As WAVEHEADER_RIFF
Dim wf As WAVEFORMAT
Dim wd As WAVEHEADER_data
' display error message
Sub Error_(ByVal Message As String)
Call MsgBox(Message & vbCrLf & vbCrLf & "Error Code : " & BASS_ErrorGetCode, vbExclamation, "Error")
End Sub
Private Sub Form_Load()
' change and set the current path, to prevent from VB not finding BASS.DLL
ChDrive App.Path
ChDir App.Path
' check the correct BASS was loaded
If (HiWord(BASS_GetVersion) <> BASSVERSION) Then
Call MsgBox("An incorrect version of BASS.DLL was loaded", vbCritical)
End
End If
' not playing anything, so don't need an update thread
Call BASS_SetConfig(BASS_CONFIG_UPDATEPERIOD, 0)
' setup output - "no sound" device, 44100hz, stereo, 16 bits
If (BASS_Init(0, 44100, 0, Me.hWnd, 0) = 0) Then
Call Error_("Can't initialize device")
End
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Local Error Resume Next
BASS_Free
End
End Sub
Private Sub btnLoadFile_Click()
On Local Error Resume Next ' if Cancel pressed...
cmd.CancelError = True
cmd.flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
cmd.DialogTitle = "Select a file to Convert"
cmd.Filter = "Convertable files (*.mo3;*.xm;*.mod;*.s3m;*.it;*.mtm;*.umx;*.mp3;*.mp2;*.mp1;*.ogg)|*.mo3;*.xm;*.mod;*.s3m;*.it;*.mtm;*.umx;*.mp3;*.mp2;*.mp1;*.ogg"
cmd.ShowOpen
' if cancel was pressed, exit the procedure
If Err.Number = 32755 Then Exit Sub
' try streaming the file
chan = BASS_StreamCreateFile(BASSFALSE, StrPtr(cmd.filename), 0, 0, BASS_STREAM_DECODE)
If chan Then
pos = BASS_ChannelGetLength(chan, BASS_POS_BYTE)
lblStrFile.Caption = "Streaming file: " & GetFileName(cmd.filename) & " [" & pos & " bytes]"
End If
' try loading the MOD (with sensitive ramping, and calculate the duration)
If chan = 0 Then
chan = BASS_MusicLoad(BASSFALSE, StrPtr(cmd.filename), 0, 0, BASS_MUSIC_DECODE Or BASS_MUSIC_RAMP Or BASS_MUSIC_PRESCAN, 0)
If chan = 0 Then
' not a MOD either
Call Error_("Can't play the file")
Exit Sub
Else
Dim dummy As Single
p = 0
While (BASS_ChannelGetAttribute(chan, BASS_ATTRIB_MUSIC_VOL_CHAN + p, dummy)) ' count channels
p = p + 1
Wend
lblStrFile.Caption = "MOD music """ & VBStrFromAnsiPtr(BASS_ChannelGetTags(chan, BASS_TAG_MUSIC_NAME)) & _
""" [" & p & " chans, " & BASS_ChannelGetLength(chan, BASS_POS_MUSIC_ORDER) & " orders]"
pos = BASS_ChannelGetLength(chan, BASS_POS_BYTE)
End If
End If
' display the time length
If (pos) Then
p = CLng(BASS_ChannelBytes2Seconds(chan, pos))
lblTime.Caption = "Time: " & CInt(p \ 60) & ":" & Format(CInt(p Mod 60), "00")
Else ' no time length available
lblPos.Caption = ""
End If
lblPos.Caption = "Pos:"
btnConvert.Enabled = True
End Sub
Private Sub btnConvert_Click()
Static convert As Boolean
convert = Not convert
If (convert) Then
btnLoadFile.Enabled = False
btnConvert.Caption = "Stop conversion..."
Call BASS_ChannelGetInfo(chan, info)
' Set WAV Format
wf.wFormatTag = 1
wf.nChannels = info.chans
wf.wBitsPerSample = IIf(info.flags And BASS_SAMPLE_8BITS, 8, 16)
wf.nBlockAlign = wf.nChannels * wf.wBitsPerSample / 8
wf.nSamplesPerSec = info.freq
wf.nAvgBytesPerSec = wf.nSamplesPerSec * wf.nBlockAlign
' Set WAV "fmt " header
wf.wfBlockType = &H20746D66 ' "fmt "
wf.wfBlockSize = 16
' Set WAV "RIFF" header
wr.RIFF = &H46464952 ' "RIFF"
wr.riffBlockSize = 0 ' after conversion
wr.riffBlockType = &H45564157 ' "WAVE"
' set WAV "data" header
wd.dataBlockType = &H61746164 ' "data"
wd.dataBlockSize = 0 ' after conversion
' create a file BASS.WAV
If (FileExists(RPP(App.Path) & "BASS.WAV")) Then _
Call Kill(RPP(App.Path) & "BASS.WAV") ' delete if already created and create a new one
Open RPP(App.Path) & "BASS.WAV" For Binary Lock Read Write As #1
' Write WAV Header to file
Put #1, , wr ' RIFF
Put #1, , wf ' Format
Put #1, , wd ' data
ReDim buf(19999) As Byte
Do While BASS_ChannelIsActive(chan)
If Not convert Then Exit Do
Dim c As Long
c = BASS_ChannelGetData(chan, buf(0), 20000)
' write data to WAV file
Put #1, , buf
pos = BASS_ChannelGetPosition(chan, BASS_POS_BYTE)
lblPos.Caption = "Pos: " & pos
DoEvents ' in case you want to stop/exit...
Loop
End If
convert = False
btnLoadFile.Enabled = True
btnConvert.Caption = "Convert to ""BASS.WAV"""
Call CompleteWAVHeader
' start next conversion from the beginning
pos = 0
Call BASS_ChannelSetPosition(chan, 0, BASS_POS_BYTE)
End Sub
Private Sub CompleteWAVHeader()
' complete WAV header
wr.riffBlockSize = pos + 44 - 8
wd.dataBlockSize = pos
On Local Error Resume Next
Put #1, 5, wr.riffBlockSize
Put #1, 41, wd.dataBlockSize
Close #1
End Sub
'--------------------------
' some useful functions :)
'--------------------------
' check if any file exists
Public Function FileExists(ByVal fp As String) As Boolean
FileExists = (Dir(fp) <> "")
End Function
' RPP = Return Proper Path
Function RPP(ByVal fp As String) As String
RPP = IIf(Mid(fp, Len(fp), 1) <> "\", fp & "\", fp)
End Function
' get file name from file path
Public Function GetFileName(ByVal fp As String) As String
GetFileName = Mid(fp, InStrRev(fp, "\") + 1)
End Function