Here is the first change - some sound waves are counted as Sine. The principle remained the same. Control is now fully mouse-based. Wave rendering is now for each freqency range. The appearance and principle of creating some waves have changed since the last version. I definitely have a lot more modifications planned.
This version uses direntry.h, so you don't need to write the name of the audio file anymore, the program will play all the audio files in the current folder (QB64PE compatible) one by one. The bass frequency is very deep, it's more like a subwoofer band. Of course, an adjustment is needed. It is necessary to use resonance. Next time.
Enjoy it.
Program need direntry.h library.
direntry.h (Size: 1.15 KB / Downloads: 25)
This version uses direntry.h, so you don't need to write the name of the audio file anymore, the program will play all the audio files in the current folder (QB64PE compatible) one by one. The bass frequency is very deep, it's more like a subwoofer band. Of course, an adjustment is needed. It is necessary to use resonance. Next time.
Enjoy it.
Code: (Select All)
$NoPrefix
Declare CustomType Library ".\direntry"
Function load_dir& (s As String)
Function has_next_entry& ()
Sub close_dir ()
Sub get_next_entry (s As String, flags As Long, file_size As Long)
End Declare
ReDim Dire(0) As String
ReDim File(0) As String
ReDim Music(0) As String
GetFileList _CWD$, Dire(), File()
FilterMusicFiles File(), Music()
Type Tahlo
typ As _Byte
Xpos As Integer
Ypos As Integer
MinVal As _Float
MaxVAL As _Float
Lenght As Integer
CurrVal As _Float
DVal As Integer
End Type
ReDim Shared Pull(0) As Tahlo
Type RG
position As Integer
SO As Long
Recs As Long
End Type
ReDim Shared RG(0) As RG
ReDim Shared RG_Helper(0) As Single
_Title "preEQ-Alpha test"
SOR1 = _SndOpenRaw 'original audio stream
SOR2 = _SndOpenRaw 'triangle (bass) stream (recomended 160 Hz)
SOR3 = _SndOpenRaw 'high stream (11 KHz)
SOR4 = _SndOpenRaw 'middle stream
SOR5 = _SndOpenRaw 'Bass middle 800 Hz
mix = .25 'Original signal MIX level to output signal (is not volume level)
Volume = .3 'Created Signal (Created Signal) volume level
Vol1K = .3
Bmix = .6 '100 percent volume for original stream
mix = .2 '30 percrent volume for triangle (bass) audio stream
HighVol = .2 'percent for 22 KHz stream
MidVol800 = .2
Screen NewImage(1200, 768, 256) 'graphis screen for visualising output signal
_ScreenHide
F1 = NewPull(30, 213, 0, 5, 1, 120, 0)
F2 = NewPull(300, 213, 0, 5, .2, 120, 0)
F3 = NewPull(550, 213, 0, 5, .3, 120, 0)
F4 = NewPull(800, 213, 0, 5, .3, 120, 0)
F5 = NewPull(1050, 213, 0, 5, .5, 120, 0)
F6 = NewPull(240, 583, -1, 1, 0, 720, 2)
InitPull F1
InitPull F2
InitPull F3
InitPull F4
InitPull F5
InitPull F6
Do Until SoundIndex = UBound(Music) + 1
n2:
s$ = Music(SoundIndex) 'this version plays all files in folder automaticaly - use direntry.h for it
s = SndOpen(s$)
ReDim As MEM LS, RS, LS800, RS800, L, R, O, f1KL, f1KR ' arrays with default original MP3 values
ReDim As Integer L1, R1, L2, R2, L3, R3, L4, R4, NL, NR, Mid800L, Mid800R, Mid800Lb, Mid800Rb 'L1, R1 - integers contains original signal values from MEMSOUND arrays, L2, R2 - the same as L1 and R1 but shifted right by KROK value, so if is created 100 Hz signal,
' so L2 and R2 are shifted by 441 records in MEMSOUND array to right, NL, NR - for mixing both - new and original signal to new signal
'LS = MemSound(s, 1)
'RS = MemSound(s, 2)
O = _MemSound(s, 0)
If O.SIZE = 0 Then SoundIndex = SoundIndex + 1: GoTo n2
BackCompatible O, L, R
_MemFree O
OriginalStream = NewRG(0, 100)
SinusBass = NewRG(0, 100)
HighStream = NewRG(0, 100)
MiddleStream = NewRG(0, 100)
MiddleBass = NewRG(0, 100)
LSPK = NewRG(0, 700)
RSPK = NewRG(0, 700)
Proposal = 0
'-------------------- downsampling block begin -----------------------
Proposal = 44100 ' my proposal for minimal soundrate - but this is not dividible by my SndRate 192 Khz
Do Until _SndRate Mod Proposal = 0 And Proposal > 0
Proposal = Proposal + 2 ' why + 2: sound output is WAV 16 bit, 16 bit = 2 bytes, INTEGER has lenght 2 bytes and INTEGER is used in WAV data block for saving sound information (just in 16 bit WAV)
Loop
Ratio = _SndRate \ Proposal ' downsampling to 48000 Hz, my sndrate 192000 is dividible by 48000, not by 44100 (SaveSound16S is also upgraded, but it is still for saving without _SndNew)
LS = _MemNew(L.SIZE \ Ratio)
RS = _MemNew(R.SIZE \ Ratio)
LS800 = _MemNew(L.SIZE \ Ratio)
RS800 = _MemNew(R.SIZE \ Ratio)
f1KL = _MemNew(L.SIZE \ Ratio)
f1KR = _MemNew(L.SIZE \ Ratio)
i& = 0
Done& = 0
Do Until Done& >= L.SIZE - Ratio * 4
L1 = _MemGet(L, L.OFFSET + Done&, Integer)
_MemPut LS, LS.OFFSET + i&, L1
R1 = _MemGet(R, R.OFFSET + Done&, Integer)
_MemPut RS, RS.OFFSET + i&, R1
i& = i& + 2
Done& = Done& + Ratio * 2
Loop
'-------------------- downsampling block end -----------------------
_MemFree L
_MemFree R
L1 = 0: R1 = 0
Make800 LS, RS, LS800, RS800, 8
' ensure that the LS and RS fields are dividible by the KROK value
Dim As Offset MaxKrok, stp, krok, oldkrok ' varibles for reading MEMSOUND array
Dim As _Float PropocetL, PropocetR ' variables for calculating TRIANGLE signal
krok = 400 ' Default is program set to creating 110 Hz (Bass) signal (44100 / 400)
MaxKrok = LS.SIZE ' maximal steps value for MEM functions
Do Until MaxKrok Mod krok * 2 = 0 ' this loop ensures that when reading the field MEMSOUND to create a new signal, the field will not overflow and Memory out of range not occur.
MaxKrok = MaxKrok - 1
Loop
ScreenShow
stp = 0
Do Until stp >= MaxKrok - krok * 4 ' read MEMSOUND array in full range
MemGet LS, LS.OFFSET + stp, L1 ' read left original signal
MemGet RS, RS.OFFSET + stp, R1 ' read right original signal
MemGet LS, LS.OFFSET + stp + krok * 2, L2 'read left original signal shifted to right by krok's value
MemGet RS, RS.OFFSET + stp + krok * 2, R2 'read right original signal shifted to right by krok's value
stp = stp + krok * 2 ' * 2 - values in MEMSOUND array are INTEGERS, 2 Bytes long
If L1 > L2 Then NL = L1 Else NL = L2 ' bass signal L default value
If R2 > R2 Then NR = R1 Else NR = R2 ' bass signal R default value
es = 0
If _SndRate < 48000 Then snr = 44100 Else snr = 48000
Locked = 0
StartL = L1 / 32768 * _Pi(.5)
EndL = L2 / 32768 * _Pi(.5)
StartR = R1 / 32768 * _Pi(.5)
EndR = R2 / 32768 * _Pi(.5)
If EndL < StartL Then ssgn = -1 Else ssgn = 1
If EndR < StartR Then rsgn = -1 Else rsgn = 1
Okrok = ConvertOffset(krok)
ReDim As _Float NarustL, NarustR
'pro vypocet uhlu sinusovky calculate sinus angle step
NarustL = Abs(StartL - EndL) * ssgn / Okrok
NarustR = Abs(StartR - EndR) * rsgn / Okrok
SinL = StartL 'prvni hodnoty uhlu sinusovky
SinR = StartR
' -------------------
If stpUPDT Mod 5 = 0 Then
UpdateRG OriginalStream, SL
UpdateRG SinusBass, sl2
UpdateRG HighStream, hl
UpdateRG MiddleStream, midl
UpdateRG MiddleBass, NL800
End If
stpUPDT = stpUPDT + 1
Do Until es = krok 'it only reads the slice of the memsound field in which the new signal is formed
'keyborad program setup
k$ = InKey$
Select Case k$
Case "N", "n": GoTo nextsong
End Select
mix = MINMAX(mix, 0, 4)
Bmix = MINMAX(Bmix, 0, 4)
MidVol = MINMAX(MidVol, 0, 4)
Volume = MINMAX(Volume, 0, 5)
MidVol800 = MINMAX(MidVol800, 0, 5)
Vol1K = MINMAX(Vol1K, 0, 3)
MemGet f1KL, f1KL.OFFSET + stp + es * 2, f1kLs
MemGet f1KR, f1KR.OFFSET + stp + es * 2, f1kRs
MemGet LS800, LS800.OFFSET + stp + 2 + es * 2, Mid800L
MemGet RS800, RS800.OFFSET + stp + 2 + es * 2, Mid800R
MemGet LS, LS.OFFSET + (stp - krok * 2) + es * 2, L1
MemGet RS, RS.OFFSET + (stp - krok * 2) + es * 2, R1
'get 22 Khz frequency in this 4 rows (for sample rate 44100!, this samples are all downsampled to 44100!)
MemGet LS, LS.OFFSET + (stp + es * 2), L3
MemGet RS, RS.OFFSET + (stp + es * 2), R3
MemGet LS, LS.OFFSET + (stp + es * 2) - 2, L4
MemGet RS, RS.OFFSET + (stp + es * 2) - 2, R4
'--------------------------------------------
'get middle frequency 800 Hz
NL800 = Mid800L / 32768 * MidVol800
NR800 = Mid800R / 32768 * MidVol800
'Other middle
midl = (L3 / 32768 - (hl - midl800)) * MidVol
midR = (R3 / 32768 - (hr - MidR800)) * MidVol
s1KL = f1kLs / 32768 * Vol1K
s1KR = f1kRs / 32768 * Vol1K
midl = MINMAX(midl, -1, 1)
midR = MINMAX(midR, -1, 1)
s1KL = MINMAX(s1KL, -1, 1)
s1KR = MINMAX(s1KR, -1, 1)
'22KHz
hl = (L3 / -32768 + L4 / 32768) * HighVol
hr = (R3 / -32768 + R4 / 32768) * HighVol
'Original stream
SL = L3 * mix / 32768 * Bmix
sR = R3 * mix / 32768 * Bmix
'bass
sl2 = (Sin(SinL)) * Volume
sr2 = (Sin(SinR)) * Volume
hl = MINMAX(hl, -1, 1)
hr = MINMAX(hr, -1, 1)
SL = MINMAX(SL, -1, 1)
sR = MINMAX(sR, -1, 1)
sl2 = MINMAX(sl2, -1, 1)
sr2 = MINMAX(sr2, -1, 1)
NL800 = MINMAX(NL800, -1, 1)
NR800 = MINMAX(NR800, -1, 1)
For UpSampling = 1 To Ratio
SndRaw SL * LeftBalance, sR * RightBalance, SOR1 ' original audio stream
SndRaw sl2 * LeftBalance, sr2 * RightBalance, SOR2 ' triangle created stream
SndRaw hl * LeftBalance, hr * RightBalance, SOR3 ' high signal 22KHz
SndRaw midl * LeftBalance, midR * RightBalance, SOR4 'middle
SndRaw NL800 * LeftBalance, NR800 * RightBalance, SOR5 'MiddleBass800
Next
es = es + 1
'my loop counter
'bass sinus get up or down
SinL = SinL + NarustL
SinR = SinR + NarustR
'MiddleBass800Hz
SinL800 = SinL800 + NarustL800
SinR800 = SinR800 + NarustR800
Do Until SndRawLen(SOR1) < 0.1 'wait until all music samples are playing
_Limit 300
Loop
Loop
SinL = 0
SinR = 0
If stp Mod 1200 = 0 Then
UpdateRG OriginalStream, SL
UpdateRG SinusBass, sl2
UpdateRG HighStream, hl
UpdateRG MiddleStream, midl
UpdateRG MiddleBass, NL800
LSOut = SL + sl2 + hl + midl + NL800
RSOut = sR + sr2 + hr + midR + NR800
LSOut = MINMAX(LSOut, -1, 1)
RSOut = MINMAX(RSOut, -1, 1)
UpdateRG LSPK, LSOut
UpdateRG RSPK, RSOut
ShowRG 40, 150, OriginalStream, "Original"
ShowRG 310, 150, SinusBass, "Bass signal"
ShowRG 560, 150, HighStream, "High - 22 KHz"
ShowRG 810, 150, MiddleStream, "Middle signal"
ShowRG 1060, 150, MiddleBass, "Middle bass"
ShowRG 250, 350, LSPK, "Left Speaker Out"
ShowRG 250, 520, RSPK, "Right Speaker Out"
'Vol1K je ponekud plonkovy
Bmix = GetPull(F1)
Volume = GetPull(F2)
HighVol = GetPull(F3)
MidVol = GetPull(F4)
MidVol800 = GetPull(F5)
Balance = GetPull(F6)
LeftBalance = 1
RightBalance = 1
If Balance > 0 Then LeftBalance = -1 * Balance + LeftBalance
If Balance < 0 Then RightBalance = RightBalance + Balance
If SoundIndex < UBound(Music) - 1 Then _PrintString (50, 5), "Press N for next audio track: " + Music(SoundIndex + 1)
_PrintString (50, 25), "Now playing: " + Music(SoundIndex)
_PrintString (50, 45), "This track lenght:" + Str$(Int(LS.SIZE / 2 / Proposal)) + " [sec], track time:" + Str$(stp \ Proposal \ 2) + " [sec] "
_Display
End If
Loop
nextsong:
es = 0
MemFree LS
_MemFree RS
_MemFree LS800
_MemFree RS800
_MemFree f1KL
_MemFree f1KR
SndClose s
SoundIndex = SoundIndex + 1
Loop
_SndClose s
_MemFree LS
_MemFree RS
End
Function MINMAX (Value, MinVal, MaxVal)
MINMAX = Value
If Value > MaxVal Then MINMAX = MaxVal
If Value < MinVal Then MINMAX = MinVal
End Function
Function ConvertOffset&& (value As _Offset)
$Checking:Off
Dim m As _MEM 'Define a memblock
m = _Mem(value) 'Point it to use value
$If 64BIT Then
'On 64 bit OSes, an OFFSET is 8 bytes in size. We can put it directly into an Integer64
_MemGet m, m.OFFSET, temp&&
ConvertOffset&& = temp&& 'Get the contents of the memblock and put the values there directly into ConvertOffset&&
$Else
'However, on 32 bit OSes, an OFFSET is only 4 bytes. We need to put it into a LONG variable first
_MemGet m, m.OFFSET, temp& 'Like this
ConvertOffset&& = temp& 'And then assign that long value to ConvertOffset&&
$End If
_MemFree m 'Free the memblock
$Checking:On
End Function
Sub BackCompatible (Snd As _MEM, Left As _MEM, Right As _MEM)
If Snd.SIZE = 0 Then
Print "Original sample data array is empty."
Exit Sub
End If
Dim SndChannels As Long, ChannelLenght As _Offset
Select Case Snd.TYPE
Case 260 ' 32-bit floating point
ChannelLenght = Snd.SIZE \ 4 'return size in INTEGERS
If Snd.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 132 ' 32-bit integer
ChannelLenght = Snd.SIZE \ 4 'return size in INTEGERS
If Snd.ELEMENTSIZE = 4 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 8 Then
SndChannels = 2
End If
Case 130: ' 16-bit integer
ChannelLenght = Snd.SIZE \ 2 'return size in INTEGERS
If Snd.ELEMENTSIZE = 2 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 4 Then
SndChannels = 2
End If
Case 1153: ' 8-bit unsigned integer
ChannelLenght = Snd.SIZE 'return size in INTEGERS
If Snd.ELEMENTSIZE = 1 Then
SndChannels = 1
ElseIf Snd.ELEMENTSIZE = 2 Then
SndChannels = 2
End If
End Select
Left = _MemNew(ChannelLenght)
Right = _MemNew(ChannelLenght)
Dim As Integer LI, RI
Dim As Long Oi
Dim i As _Offset
Do Until i = Snd.SIZE - Snd.ELEMENTSIZE * 2 'Read Phoenix MEMSOUND and convert it as back-compatible as QB64 2.02 MEMSOUND's output.
Select Case SndChannels
Case 1
Select Case Snd.TYPE
Case 260: sampL = _MemGet(Snd, Snd.OFFSET + i, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(Snd, Snd.OFFSET + i, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(Snd, Snd.OFFSET + i, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(Snd, Snd.OFFSET + i, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
Case 2
Select Case Snd.TYPE
Case 260: sampL = _MemGet(Snd, Snd.OFFSET + i, Single): sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Single) ' 32-bit floating point
Case 132: sampL = _MemGet(Snd, Snd.OFFSET + i, Long) / 2147483648: sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Long) / 2147483648 ' 32-bit integer
Case 130: sampL = _MemGet(Snd, Snd.OFFSET + i, Integer) / 32768: sampR = _MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, Integer) / 32768 ' 16-bit integer
Case 1153: sampL = (_MemGet(Snd, Snd.OFFSET + i, _Unsigned _Byte) - 128) / 128: sampR = (_MemGet(Snd, Snd.OFFSET + i + Snd.ELEMENTSIZE \ 2, _Unsigned _Byte) - 128) / 128 ' 8-bit unsigned integer
End Select
End Select
If SndChannels Mod 2 = 0 Then
LI = sampL * 32767
RI = sampR * 32767
_MemPut Left, Left.OFFSET + Oi, LI
_MemPut Right, Right.OFFSET + Oi, RI
Else
LI = sampL * 32767
_MemPut Left, Left.OFFSET + Oi, LI
_MemPut Right, Right.OFFSET + Oi, LI
End If
i = i + Snd.ELEMENTSIZE
Oi = Oi + 2
Loop
End Sub
Sub Make800 (LS As _MEM, RS As _MEM, LS800 As _MEM, RS800 As _MEM, StepMem)
Dim As Integer Mid800L, MID800R, MID800Lb, MID800Rb
Dim Stp As Long
Do Until Stp >= LS.SIZE - StepMem * 4
MemGet LS, LS.OFFSET + Stp, MID800Lb
MemGet RS, RS.OFFSET + Stp, MID800Rb
StL = MID800Lb / 32768 * _Pi(.5)
StR = MID800Rb / 32768 * _Pi(.5)
MemGet LS, LS.OFFSET + Stp + StepMem, Mid800L
MemGet RS, RS.OFFSET + Stp + StepMem, MID800R 'stredobasova frekvence SIN
If MID800Lb > Mid800L Then NL800 = MID800Lb Else NL800 = Mid800L 'middle bass signal default value Left channel
If MID800Rb > MID800R Then NR800 = MID800Rb Else NR800 = MID800R
EndL800 = Mid800L / 32768 * _Pi(.5)
EndR800 = MID800R / 32768 * _Pi(.5)
If EndL800 < StL Then ssgn800 = -1 Else ssgn800 = 1
If EndR800 < StR Then rsgn800 = -1 Else rsgn800 = 1
NarustL800 = Abs(StL - EndL800) * ssgn800 / (StepMem / 2) 'sinus 800 Hz step LEFT channel
NarustR800 = Abs(StR - EndR800) * rsgn800 / (StepMem / 2) ' RIGHT
sl = MID800Lb / 32768
sr = MID800Rb / 32768
For WriteAll = Stp To Stp + StepMem Step 2
NL800 = Sin(sl) * 32768
NR800 = Sin(sr) * 32768
_MemPut LS800, LS800.OFFSET + WriteAll, NL800 As INTEGER
_MemPut RS800, RS800.OFFSET + WriteAll, NR800 As INTEGER
sl = sl + NarustL800
sr = sr + NarustR800
Next
Stp = Stp + StepMem
Loop
End Sub
Function NewRG (value, records) 'create new graph handle, reserve place in RG_Helper, write to RG_Helper array first value and this value position in RG_Helper array
u = records
u2 = UBound(RG_Helper)
u3 = UBound(RG)
RG(u3).SO = u2
RG(u3).Recs = u
RG(u3).position = 1
NewRG = u3
RG_Helper(u2) = value
ReDim _Preserve RG_Helper(u2 + u + 1) As Single
ReDim _Preserve RG(u3 + 1) As RG
End Function
Sub UpdateRG (identity, value) ' update and shift values in RG_Helper array using RG array (identity is RG array index)
Id = identity
V = value
If RG(Id).position < RG(Id).Recs Then
RG(Id).position = RG(Id).position + 1
i2 = RG(Id).position
u = RG(Id).SO
RG_Helper(u + i2) = value
Exit Sub
Else
shift = RG(Id).SO
Do Until shift = RG(Id).SO + RG(Id).Recs
RG_Helper(shift) = RG_Helper(shift + 1)
shift = shift + 1
Loop
RG_Helper(RG(Id).SO + RG(Id).Recs) = value
End If
End Sub
Sub ShowRG (x, y, id, index$) ' Draw graph to screen
xx = x
s2 = RG(id).Recs
s = RG(id).SO
_PrintMode _KeepBackground
p = xx - 10 + s2 / 2 - _PrintWidth(index$) / 2 'printstring X
Line (xx - 20, y - 70)-(xx + 20 + s2, y + 50), 30, BF
Line (xx - 17, y - 67)-(xx + 17 + s2, y + 47), , B
C = _DefaultColor
Color 0
_PrintString (p, y - 64), index$
Color C
_PrintMode _FillBackground
Line (xx - 20, y - 70)-(xx + 20 + s2, y + 50), , B
Line (xx - 17, y - 47)-(xx + 17 + s2, y + 47), , B
ss = s
Do Until ss = s2 + s - 1
v = RG_Helper(ss)
v2 = RG_Helper(ss + 1)
GoTo notthis
If Abs(v) > 1 Then
Do Until Abs(v) <= 1
v = v / 2
Loop
End If
notthis:
xx = xx + 1
Line (xx, y + v * 15)-(xx + 1, y + v2 * 15), 0
ss = ss + 1
Loop
xx = 0
End Sub
Function NewPull (x, y, ValAtMin, ValAtMax, DefaultValue, PullLen, KindOfPull)
u = UBound(Pull)
Pull(u).Xpos = x
Pull(u).Ypos = y
Pull(u).MinVal = ValAtMin
Pull(u).MaxVAL = ValAtMax
Pull(u).Lenght = PullLen
Pull(u).typ = KindOfPull
Pull(u).CurrVal = DefaultValue 'designed for range 0 to 1 - value at start
NewPull = u
ReDim _Preserve Pull(u + 1) As Tahlo
End Function
Sub GetMouse (Mx, My, Lb, Rb, Mw)
While _MouseInput
Mw = Mw + _MouseWheel
Wend
Mx = _MouseX
My = _MouseY
Lb = _MouseButton(1)
Rb = _MouseButton(2)
End Sub
Function QDetect (x1, y1, x2, y2, Xd, Yd)
If x1 > x2 Then Swap x2, x1
If y1 > y2 Then Swap y2, y1
QDetect = 0
If Xd > x1 And Xd < x2 Then
If Yd > y1 And Yd < y2 Then
QDetect = -1
End If
End If
End Function
Function CircleDetect (X&, Y&, CX&, CY&, R&)
xy& = ((X& - CX&) ^ 2) + ((Y& - CY&) ^ 2) 'Pythagorean theorem
If R& ^ 2 >= xy& Then CircleDetect = -1 Else CircleDetect = 0
End Function
Sub InitPull (P)
GetMouse mx, my, lb, rb, mw
Static GrX, GrY
X = Pull(P).Xpos
Y = Pull(P).Ypos
XX = X + Pull(P).Lenght
YY = Y + Pull(P).Lenght
If lb = -1 Then
stat = QDetect(X, Y, XX, YY, mx, my)
End If
stat = 0
Dim As Integer GrX, GrY
Select Case Pull(P).typ
Case 0
Line (X - 10, Y - 10)-(XX + 10, Y + 10), 30, BF
Line (X - 7, Y - 7)-(XX + 7, Y + 7), , B
Line (X, Y)-(XX, Y), 31
Xp = X + Pull(P).Lenght * (Pull(P).CurrVal / Pull(P).MaxVAL)
If stat Then GrX = mx Else GrX = Int(Xp)
Line (X, Y)-(GrX, Y), 22
CircleFill GrX, Y, 6, 16
CircleFill GrX, Y, 5, 28
Pull(P).DVal = Xp
Case 1
Line (X - 10, Y - 10)-(X + 10, YY + 10), 30, BF
Line (X - 7, Y - 7)-(X + 7, YY + 7), , B
Line (X, Y)-(X, YY), 31
Yp = YY - Pull(P).Lenght * (Pull(P).CurrVal / Pull(P).MaxVAL)
If stat Then GrY = my Else GrY = Int(Yp)
Line (X, YY)-(X, GrY), 22
CircleFill X, GrY, 6, 16
CircleFill X, GrY, 5, 28
Pull(P).DVal = Yp
Case 2
Line (X - 10, Y - 10)-(XX + 10, Y + 10), 30, BF
Line (X - 7, Y - 7)-(XX + 7, Y + 7), , B
Line (X, Y)-(XX, Y), 31
Xp = X + Pull(P).Lenght / 2 + (Pull(P).Lenght / 2 * (Pull(P).CurrVal / Pull(P).MaxVAL))
If stat Then GrX = mx Else GrX = Int(Xp)
Line (X + Pull(P).Lenght / 2, Y)-(GrX, Y), 22
CircleFill GrX, Y, 6, 16
CircleFill GrX, Y, 5, 28
Pull(P).DVal = Xp
Case 3
Line (X - 10, Y - 10)-(X + 10, YY + 10), 30, BF
Line (X - 7, Y - 7)-(X + 7, YY + 7), , B
Line (X, Y)-(X, YY), 31
Yp = YY - Pull(P).Lenght / 2 - (Pull(P).Lenght / 2 * (Pull(P).CurrVal / Pull(P).MaxVAL))
If stat Then GrY = my Else GrY = Int(Yp)
Line (X, YY - Pull(P).Lenght / 2)-(X, GrY), 22
CircleFill X, GrY, 6, 16
CircleFill X, GrY, 5, 28
Pull(P).DVal = Yp
End Select
End Sub
Function GetPull (p)
GetMouse mx, my, lb, rb, mw
Select Case Pull(p).typ
Case 0
If QDetect(Pull(p).Xpos - 20, Pull(p).Ypos - 20, Pull(p).Xpos + 20 + Pull(p).Lenght, Pull(p).Ypos + 20, mx, my) Then
status = CircleDetect(mx, my, Pull(p).DVal, Pull(p).Ypos, 40)
If lb = -1 Then
If status Then
GetMouse mx, my, lb, rb, mw
Pull(p).CurrVal = (mx - Pull(p).Xpos) / Pull(p).Lenght * Pull(p).MaxVAL
If Pull(p).CurrVal > Pull(p).MaxVAL Then Pull(p).CurrVal = Pull(p).MaxVAL
If Pull(p).CurrVal < Pull(p).MinVal Then Pull(p).CurrVal = Pull(p).MinVal
InitPull p
End If
End If
End If
Case 2
'asi ok
If QDetect(Pull(p).Xpos - 20, Pull(p).Ypos - 20, Pull(p).Xpos + 20 + Pull(p).Lenght, Pull(p).Ypos + 20, mx, my) Then
status = CircleDetect(mx, my, Pull(p).DVal, Pull(p).Ypos, 40)
If lb = -1 Then
If status Then
GetMouse mx, my, lb, rb, mw
If mx > Pull(p).Xpos And mx < Pull(p).Xpos + Pull(p).Lenght / 2 Then
Pull(p).CurrVal = ((mx - Pull(p).Lenght / 2) - Pull(p).Xpos) / (Pull(p).Lenght / 2) * Pull(p).MinVal * -1
If Pull(p).CurrVal < Pull(p).MinVal Then Pull(p).CurrVal = Pull(p).MinVal
End If
If mx > Pull(p).Xpos + Pull(p).Lenght / 2 And mx < Pull(p).Lenght + Pull(p).Xpos Then
Pull(p).CurrVal = (mx - Pull(p).Xpos - (Pull(p).Lenght / 2)) / (Pull(p).Lenght / 2) * Pull(p).MaxVAL
If Pull(p).CurrVal > Pull(p).MaxVAL Then Pull(p).CurrVal = Pull(p).MaxVAL
End If
InitPull p
End If
End If
End If
Case 1
x = Pull(p).Xpos
Y = Pull(p).Ypos
XX = x + Pull(p).Lenght
YY = Y + Pull(p).Lenght
If QDetect(x - 20, Y - 20, x + 20, YY, mx, my) Then
status = CircleDetect(mx, my, Pull(p).Xpos, Pull(p).DVal, 40)
If lb = -1 Then
If status Then
GetMouse mx, my, lb, rb, mw
Pull(p).CurrVal = (YY - my) / Pull(p).Lenght * Pull(p).MaxVAL
If Pull(p).CurrVal > Pull(p).MaxVAL Then Pull(p).CurrVal = Pull(p).MaxVAL
If Pull(p).CurrVal < Pull(p).MinVal Then Pull(p).CurrVal = Pull(p).MinVal
InitPull p
End If
End If
End If
Case 3
If QDetect(Pull(p).Xpos - 20, Pull(p).Ypos - 20, Pull(p).Xpos + 20, Pull(p).Ypos + 20 + Pull(p).Lenght, mx, my) Then
status = CircleDetect(mx, my, Pull(p).Xpos, Pull(p).DVal, 40)
If lb = -1 Then
If status Then
GetMouse mx, my, lb, rb, mw
If my > Pull(p).Ypos + Pull(p).Lenght / 2 Then
Pull(p).CurrVal = ((my - Pull(p).Lenght / 2) - Pull(p).Ypos) / (Pull(p).Lenght / 2) * Pull(p).MinVal
If Pull(p).CurrVal < Pull(p).MinVal Then Pull(p).CurrVal = Pull(p).MinVal
End If
If my < Pull(p).Ypos + Pull(p).Lenght / 2 Then
Pull(p).CurrVal = ((Pull(p).Lenght / 2) - (my - Pull(p).Ypos)) / (Pull(p).Lenght / 2) * Pull(p).MaxVAL
If Pull(p).CurrVal > Pull(p).MaxVAL Then Pull(p).CurrVal = Pull(p).MinVal
End If
InitPull p
End If
End If
End If
End Select
GetPull = Pull(p).CurrVal
End Function
Sub ResetMouse
While _MouseInput
Wend
Do Until _MouseButton(1) = 0
While _MouseInput
Wend
Loop
End Sub
Sub CircleFill (CX As Long, CY As Long, R As Long, C As Long)
Dim Radius As Long, RadiusError As Long
Dim X As Long, Y As Long
Radius = Abs(R)
RadiusError = -Radius
X = Radius
Y = 0
If Radius = 0 Then PSet (CX, CY), C: Exit Sub
Line (CX - X, CY)-(CX + X, CY), C, BF
While X > Y
RadiusError = RadiusError + Y * 2 + 1
If RadiusError >= 0 Then
If X <> Y + 1 Then
Line (CX - Y, CY - X)-(CX + Y, CY - X), C, BF
Line (CX - Y, CY + X)-(CX + Y, CY + X), C, BF
End If
X = X - 1
RadiusError = RadiusError - X * 2
End If
Y = Y + 1
Line (CX - X, CY - Y)-(CX + X, CY - Y), C, BF
Line (CX - X, CY + Y)-(CX + X, CY + Y), C, BF
Wend
End Sub
Sub GetFileList (SearchDirectory As String, DirList() As String, FileList() As String)
Const IS_DIR = 1
Const IS_FILE = 2
Dim flags As Long, file_size As Long
ReDim _Preserve DirList(100), FileList(100)
DirCount = 0: FileCount = 0
If load_dir(SearchDirectory) Then
Do
length = has_next_entry
If length > -1 Then
nam$ = Space$(length)
get_next_entry nam$, flags, file_size
If flags And IS_DIR Then
DirCount = DirCount + 1
If DirCount > UBound(DirList) Then ReDim _Preserve DirList(UBound(DirList) + 100)
DirList(DirCount) = nam$
ElseIf flags And IS_FILE Then
FileCount = FileCount + 1
If FileCount > UBound(FileList) Then ReDim _Preserve FileList(UBound(FileList) + 100)
FileList(FileCount) = nam$
End If
End If
Loop Until length = -1
close_dir
Else
End If
ReDim _Preserve DirList(DirCount)
ReDim _Preserve FileList(FileCount)
End Sub
Sub FilterMusicFiles (AllFiles() As String, Music() As String)
For f = LBound(AllFiles) To UBound(AllFiles)
coma = InStrRev(AllFiles(f), ".") + 1
ext$ = Mid$(AllFiles(f), coma, 4)
If Len(ext$) < 4 Then ext$ = ext$ + Space$(4 - Len(ext$))
Select Case LCase$(ext$)
Case "mp3 ", "wav ", "flac", "s3m ", "xm ", "mod ", "it ", "ogg ", "rad ", "mid "
Music(i) = AllFiles(f)
i = i + 1
ReDim _Preserve Music(i) As String
End Select
Next f
End SubProgram need direntry.h library.
direntry.h (Size: 1.15 KB / Downloads: 25)