home *** CD-ROM | disk | FTP | other *** search
/ Chip 2005 November / CDVD1105.ISO / Software / Freeware / programare / bass / vb / CustLoop / modCustLoop.bas < prev    next >
Encoding:
BASIC Source File  |  2005-09-22  |  7.7 KB  |  196 lines
  1. Attribute VB_Name = "modCustLoop"
  2. '/////////////////////////////////////////////////////////////////////////////////
  3. ' modCustLoop.bas - Copyright (c) 2004-2005 (: JOBnik! :) [Arthur Aminov, ISRAEL]
  4. '                                                         [http://www.jobnik.org]
  5. '                                                         [  jobnik@jobnik.org  ]
  6. ' Other source: frmCustLoop.frm
  7. '
  8. ' BASS custom looping example
  9. ' Originally translated from - custloop.c - Example of Ian Luck
  10. '/////////////////////////////////////////////////////////////////////////////////
  11.  
  12. Option Explicit
  13.  
  14. Public Const BI_RGB = 0&
  15. Public Const DIB_RGB_COLORS = 0&    'color table in RGBs
  16.  
  17. Public Type BITMAPINFOHEADER    '40 bytes
  18.         biSize As Long
  19.         biWidth As Long
  20.         biHeight As Long
  21.         biPlanes As Integer
  22.         biBitCount As Integer
  23.         biCompression As Long
  24.         biSizeImage As Long
  25.         biXPelsPerMeter As Long
  26.         biYPelsPerMeter As Long
  27.         biClrUsed As Long
  28.         biClrImportant As Long
  29. End Type
  30.  
  31. Public Type RGBQUAD
  32.         rgbBlue As Byte
  33.         rgbGreen As Byte
  34.         rgbRed As Byte
  35.         rgbReserved As Byte
  36. End Type
  37.  
  38. Public Type BITMAPINFO
  39.         bmiHeader As BITMAPINFOHEADER
  40.         bmiColors(255) As RGBQUAD
  41. End Type
  42.  
  43. Public Declare Function SetDIBitsToDevice Lib "gdi32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long
  44.  
  45. Public Const TRANSPARENT = 1
  46. Public Const TA_LEFT = 0
  47. Public Const TA_RIGHT = 2
  48.  
  49. Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
  50. Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
  51. Public Declare Function SetTextAlign Lib "gdi32" (ByVal hdc As Long, ByVal wFlags As Long) As Long
  52. Public Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
  53.  
  54. Public Const WIDTH_ = 600   'display width
  55. Public Const HEIGHT_ = 201  'height (odd number for centre line)
  56. Public bpp As Long          'stream bytes per pixel
  57. Public loop_(2) As Long     'loop start & end
  58. Public lsync As Long        'looping sync
  59. Public killscan As Boolean
  60.  
  61. Public wavebuf() As Byte    'wave buffer
  62. Public chan As Long         'stream/music handle
  63.  
  64. Public bh As BITMAPINFO     'bitmap header
  65.  
  66. 'display error messages
  67. Public Sub Error_(ByVal es As String)
  68.     Call MsgBox(es & vbCrLf & vbCrLf & "error code: " & BASS_ErrorGetCode, vbExclamation, "Error")
  69. End Sub
  70.  
  71. Sub LoopSyncProc(ByVal handle As Long, ByVal channel As Long, ByVal data As Long, ByVal user As Long)
  72.     If (BASS_ChannelSetPosition(channel, loop_(0)) = 0) Then 'try seeking to loop start
  73.         Call BASS_ChannelSetPosition(channel, 0) 'failed, go to start of file instead
  74.     End If
  75. End Sub
  76.  
  77. Sub SetLoopStart(ByVal pos As Long)
  78.     loop_(0) = pos
  79. End Sub
  80.  
  81. Sub SetLoopEnd(ByVal pos As Long)
  82.     loop_(1) = pos
  83.     Call BASS_ChannelRemoveSync(chan, lsync) 'remove old sync
  84.     lsync = BASS_ChannelSetSync(chan, BASS_SYNC_POS Or BASS_SYNC_MIXTIME, loop_(1), AddressOf LoopSyncProc, 0) 'set new sync
  85. End Sub
  86.  
  87. 'scan the peaks
  88. Sub ScanPeaks(ByVal decoder As Long)
  89.     ReDim wavebuf(-120600 To 120600) As Byte    'set 'n clear the buffer (600 x 201 = 120600)
  90.     Dim cpos As Long, peak(2) As Long
  91.  
  92.     Do While (Not killscan)
  93.         Dim Level As Long, pos As Long
  94.         Level = BASS_ChannelGetLevel(decoder)  'scan peaks
  95.         pos = BASS_ChannelGetPosition(decoder) / bpp
  96.         If (peak(0) < LoWord(Level)) Then peak(0) = LoWord(Level) 'set left peak
  97.         If (peak(1) < HiWord(Level)) Then peak(1) = HiWord(Level) 'set right peak
  98.         If (BASS_ChannelIsActive(decoder) = 0) Then
  99.             pos = -1 'reached the end
  100.         Else
  101.             pos = BASS_ChannelGetPosition(decoder) / bpp
  102.         End If
  103.         If (pos > cpos) Then
  104.             Dim a As Long
  105.             For a = 0 To (peak(0) * (HEIGHT_ / 2) / 32768) - 1
  106.                 'draw left peak
  107.                 wavebuf(IIf((HEIGHT_ / 2 - 1 - a) * WIDTH_ + cpos > 120600, 120600, (HEIGHT_ / 2 - 1 - a) * WIDTH_ + cpos)) = 1 + a
  108.             Next a
  109.             For a = 0 To (peak(1) * (HEIGHT_ / 2) / 32768) - 1
  110.                 'draw right peak
  111.                 wavebuf(IIf((HEIGHT_ / 2 + 1 + a) * WIDTH_ + cpos > 120600, 120600, (HEIGHT_ / 2 + 1 + a) * WIDTH_ + cpos)) = 1 + a
  112.             Next a
  113.             If (pos >= WIDTH_) Then Exit Do 'gone off end of display
  114.             cpos = pos
  115.             peak(0) = 0
  116.             peak(1) = 0
  117.         End If
  118.         DoEvents
  119.     Loop
  120.     Call BASS_StreamFree(decoder) 'free the decoder
  121. End Sub
  122.  
  123. 'select a file to play, and start scanning it
  124. Function PlayFile() As Boolean
  125.     On Local Error Resume Next    'if Cancel pressed...
  126.  
  127.     With frmCustLoop.cmdCustLoop
  128.         .CancelError = True
  129.         .flags = cdlOFNExplorer Or cdlOFNFileMustExist Or cdlOFNHideReadOnly
  130.         .DialogTitle = "Select a file to play"
  131.         .Filter = "Playable files|*.mp3;*.mp2;*.mp1;*.ogg;*.wav;*.aif;*.mo3;*.it;*.xm;*.s3m;*.mtm;*.mod;*.umx|All files|*.*"
  132.         .ShowOpen
  133.  
  134.         'if cancel was pressed, exit the procedure
  135.         If Err.Number = 32755 Then Exit Function
  136.  
  137.         chan = BASS_StreamCreateFile(BASSFALSE, .FileName, 0, 0, 0)
  138.         If (chan = 0) Then chan = BASS_MusicLoad(BASSFALSE, .FileName, 0, 0, BASS_MUSIC_RAMPS Or BASS_MUSIC_POSRESET Or BASS_MUSIC_PRESCAN, 0)
  139.  
  140.         If (chan = 0) Then
  141.             Call Error_("Can't play file")
  142.             PlayFile = False 'Can't load the file
  143.             Exit Function
  144.         End If
  145.         
  146.         frmCustLoop.Show   'show form
  147.  
  148.         With bh.bmiHeader
  149.             .biSize = Len(bh.bmiHeader)
  150.             .biWidth = WIDTH_
  151.             .biHeight = -HEIGHT_
  152.             .biPlanes = 1
  153.             .biBitCount = 8
  154.             .biClrUsed = HEIGHT_ / 2 + 1
  155.             .biClrImportant = HEIGHT_ / 2 + 1
  156.         End With
  157.  
  158.         'setup palette
  159.         Dim a As Byte
  160.  
  161.         For a = 1 To HEIGHT_ / 2
  162.             bh.bmiColors(a).rgbRed = (255 * a) / (HEIGHT_ / 2)
  163.             bh.bmiColors(a).rgbGreen = 255 - bh.bmiColors(a).rgbRed
  164.         Next a
  165.  
  166.         bpp = BASS_ChannelGetLength(chan) / WIDTH_ 'bytes per pixel
  167.         If (bpp < BASS_ChannelSeconds2Bytes(chan, 0.02)) Then 'minimum 20ms per pixel (BASS_ChannelGetLevel scans 20ms)
  168.             bpp = BASS_ChannelSeconds2Bytes(chan, 0.02)
  169.         End If
  170.         lsync = BASS_ChannelSetSync(chan, BASS_SYNC_END Or BASS_SYNC_MIXTIME, 0, AddressOf LoopSyncProc, 0) 'set sync to loop at end
  171.         Call BASS_ChannelPlay(chan, BASSFALSE) 'start playing
  172.         frmCustLoop.tmrCustLoop.Enabled = True 'timer's interval is 100ms (10Hz)
  173.  
  174.         Dim chan2 As Long
  175.         chan2 = BASS_StreamCreateFile(BASSFALSE, .FileName, 0, 0, BASS_STREAM_DECODE)
  176.         If (chan2 = 0) Then chan2 = BASS_MusicLoad(BASSFALSE, .FileName, 0, 0, BASS_MUSIC_DECODE, 0)
  177.         Call ScanPeaks(chan2)    'start scanning peaks
  178.     End With
  179.     PlayFile = True
  180. End Function
  181.  
  182. Sub DrawTimeLine(ByVal dc As Long, ByVal pos As Long, ByVal col As Long, ByVal Y As Long)
  183.     Dim wpos As Long
  184.     wpos = pos / bpp
  185.     Dim time As Long
  186.     time = BASS_ChannelBytes2Seconds(chan, pos)
  187.     Dim text As String
  188.     text = time \ 60 & ":" & Format(time Mod 60, "00")
  189.     frmCustLoop.CurrentX = wpos
  190.     frmCustLoop.Line (wpos, 0)-(wpos, HEIGHT_ - 1), col
  191.     Call SetTextColor(dc, col)
  192.     Call SetBkMode(dc, TRANSPARENT)
  193.     Call SetTextAlign(dc, IIf(wpos >= WIDTH_ / 2, TA_RIGHT, TA_LEFT))
  194.     Call TextOut(dc, wpos, Y, text, Len(text))
  195. End Sub
  196.