📄 main.frm
字号:
End
End
Begin VB.PictureBox PIC2
AutoRedraw = -1 'True
BackColor = &H00000000&
Height = 2385
Left = 8190
ScaleHeight = 155
ScaleMode = 3 'Pixel
ScaleWidth = 136
TabIndex = 3
Top = 510
Width = 2100
Begin VB.Image Image1
Height = 600
Left = 135
Picture = "Main.frx":04EA
Top = 30
Width = 1920
End
End
Begin VB.CommandButton cmdSave
Caption = "保存声音文件(16位单声道)"
Height = 300
Left = 150
TabIndex = 2
Top = 90
Width = 2490
End
Begin VB.PictureBox PIC
AutoRedraw = -1 'True
BackColor = &H00000000&
ForeColor = &H0000FF00&
Height = 2385
Left = 360
ScaleHeight = 155
ScaleMode = 3 'Pixel
ScaleWidth = 508
TabIndex = 0
Top = 510
Width = 7680
End
Begin Project1.Container fraParams
Height = 3315
Left = 360
TabIndex = 31
Top = 2985
Width = 2370
_ExtentX = 4180
_ExtentY = 5847
BackColor = -2147483633
BorderColorDark = 4210752
Caption = "参数 "
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = 16711680
Picture = "Main.frx":11F4
Begin VB.CommandButton cmdMaxAmp
Caption = "最大"
Height = 255
Left = 1710
TabIndex = 36
Top = 330
Width = 495
End
Begin VB.HScrollBar HS
Height = 210
Index = 0
LargeChange = 1000
Left = 120
Min = 1
SmallChange = 100
TabIndex = 35
TabStop = 0 'False
Top = 690
Value = 1
Width = 2085
End
Begin VB.HScrollBar HS
Height = 210
Index = 1
LargeChange = 100
Left = 120
Max = 8000
Min = 5
TabIndex = 34
TabStop = 0 'False
Top = 1410
Value = 10
Width = 2085
End
Begin VB.HScrollBar HS
Height = 210
Index = 2
Left = 135
Max = 100
Min = 1
TabIndex = 33
TabStop = 0 'False
Top = 2100
Value = 10
Width = 2085
End
Begin VB.HScrollBar HS
Height = 210
Index = 3
Left = 135
Max = 4
Min = 1
TabIndex = 32
TabStop = 0 'False
Top = 2790
Value = 4
Width = 2085
End
Begin VB.Label LabTest
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "LabTest"
ForeColor = &H00000000&
Height = 270
Left = 570
TabIndex = 41
Top = 2985
Width = 1170
End
Begin VB.Label Lab
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "振幅"
Height = 255
Index = 0
Left = 165
TabIndex = 40
Top = 330
Width = 1500
End
Begin VB.Label Lab
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "频率"
Height = 255
Index = 1
Left = 165
TabIndex = 39
Top = 1050
Width = 1950
End
Begin VB.Label Lab
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "持续"
Height = 255
Index = 2
Left = 165
TabIndex = 38
Top = 1755
Width = 1950
End
Begin VB.Label Lab
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "采样"
Height = 255
Index = 3
Left = 195
TabIndex = 37
Top = 2430
Width = 1950
End
End
Begin VB.Label LabF
Alignment = 2 'Center
Appearance = 0 'Flat
BorderStyle = 1 'Fixed Single
Caption = "LabF"
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 270
Left = 4935
TabIndex = 1
Top = 105
Width = 3285
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' ~Wavettes~ by Robert Rayment May 2006
' Some code adapted from Ulli's prog at PSC CodeId=64845
' Container UC by Eric Madison, PSC CodeId=40130
' Formulae:_
' Strings at Sub SetFunctions
' Evaluate at Function EvalFunc (Module1.bas)
' If a formula is added or deleted then
' both these routines have to be modified.
' See notes in Pretext.txt for rules on
' editting by hand.
Option Explicit
' For XP manifest
Private Declare Sub InitCommonControls Lib "comctl32" ()
'------- Highlighting
Private Declare Function GetCursorPos Lib "user32.dll" (ByRef _
lpPoint As POINTAPI) As Long
Private Declare Function WindowFromPoint Lib "user32.dll" ( _
ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Pnt As POINTAPI
'--------
'------- Shape Controls
Private Declare Function CreateRoundRectRgn Lib "gdi32.dll" _
(ByVal x1 As Long, ByVal y1 As Long, _
ByVal x2 As Long, ByVal y2 As Long, _
ByVal X3 As Long, ByVal Y3 As Long) As Long
' X1,Y1 X2,Y2 Top left & Bottom right coords of rectangle.
' For whole control X1 & Y1 = 0
' X2 & Y2 = Controls width & height
' X3,Y3 width & height of ellipse used to create corners
Private Declare Function SetWindowRgn Lib "user32.dll" _
(ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'-------
Private uAmp As Single, uFrq As Single, uDur As Single
Private aBlock As Boolean
Private aPlay As Boolean
Private aPlayOnce As Boolean
Private aRepeatPlay As Boolean
Private CDL As OSDialog
Private Sub SetFunctions()
'Public Func$()
'Public FuncIndex As Long
Dim k As Long
' Could be in an external file
ReDim Func$(20)
Func$(1) = "1. Sin(x)"
Func$(2) = "2. Sin(x) + Sin(x * pi#/3)"
Func$(3) = "3. (x * pi#) * Sin(x)"
Func$(4) = "4. (Rnd - Rnd)"
Func$(5) = "5. Sin(x) + Sin(x)^2 + Sin(x)^3"
Func$(6) = "6. Sin(Int(x \ pi) * pi# + pi# / 2"
Func$(7) = "7. Sin(x)^3"
Func$(8) = "8. Sin(x^2)^3"
Func$(9) = "9. Sawtooth 1"
Func$(10) = "10. Squarewave"
Func$(11) = "11. Sin(3 * x) / Tan(x)"
Func$(12) = "12. Sin(3 * x) / Tan(x) * sin(x / 2)"
Func$(13) = "13. Exp^(Sin(x + pi / 2)) * Sin(x)"
Func$(14) = "14. Exp^(Sin(x^2 + pi / 2)) * Sin(x)"
Func$(15) = "15. Atn(Cos(x^3) + Sin(x^2))"
Func$(16) = "16. x^Sin(x)"
'Func$(17) = "17. -4(Cos(x)+Cos(3*x)/9+Cos(5*x)/25)/pi"
Func$(17) = "17. Sawtooth 2"
'Func$(18) = "18. 1/pi#+Sin(x)/2-(Cos(2*x)/1*3 + Cos(4*x)/3*5 + cos(6*x)/5*7 + +)/pi"
Func$(18) = "18. Bumps"
Func$(19) = "19. Cosec(x)"
For k = 1 To 19 ' 20
List1.AddItem Func$(k)
Next k
End Sub
Private Sub Form_Initialize()
InitCommonControls
SamplesPerSecond = 44100
Bitnum = 0 ' 8 bit start
InitHeader
LoadWav
End Sub
Private Sub Form_Load()
Dim X As Single
PathSpec$ = App.Path
If Right$(PathSpec$, 1) <> "\" Then PathSpec$ = PathSpec$ & "\"
CurrPath$ = PathSpec$
ReDim RampFrac(0 To 2)
X = picRamp(0).ScaleWidth / 2
picRamp(1).Line (0, 0)-(X, picRamp(1).ScaleHeight)
picRamp(1).Line (X, picRamp(1).ScaleHeight)-(picRamp(1).ScaleWidth, 0)
RampFrac(1) = 0.5
LabFrac(1) = RampFrac(1)
SetFunctions
aPlay = False
aPlayOnce = False
aBlock = True
AmpMult = 1
aRepeat = False
RepeatMul = 2
LabRepeat = "2"
aShape = False
aABS = False
aReverse = False
' Default to 8 bit
Bitnum = 0
optBit(Bitnum).Value = True
optBit_Click 0
LabTest.Visible = False
Show
' Starter
picRamp_MouseDown 0, 1, 0, 10, 0
chkEcho.Value = Checked
HSEcho.Value = 7
HS(0).Value = 23000 ' Amplitude 100*23000/32767 = 70%
HS(1).Value = 300
HS(2).Value = 20
HS(3).Value = 4
List1.ListIndex = 1
ShapeCtrl PIC, 20, 0
ShapeCtrl PIC2, 20, 0
ShapeCtrl chkPlay, 10, 1
aBlock = False
End Sub
Private Sub ShapeCtrl(p As Control, Rad As Long, SM As Long)
Dim Reg As Long
' Rad, in this case circular corner radius
' SM 0 for Pixels, 1 for Twips
If SM = 0 Then
Reg = CreateRoundRectRgn(0, 0, p.Width, p.Height, Rad, Rad)
Else
Reg = CreateRoundRectRgn(1, 1, p.Width \ Screen.TwipsPerPixelX, p.Height \ Screen.TwipsPerPixelY, Rad, Rad)
End If
SetWindowRgn p.hWnd, Reg, True
DeleteObject Reg
End Sub
Private Sub chkReverse_Click()
aReverse = -chkReverse.Value
If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
aPlayOnce = False
End Sub
Private Sub chkABS_Click()
aABS = -chkABS.Value
If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
aPlayOnce = False
End Sub
Private Sub cmdMaxAmp_Click()
HS(0).Value = 32767
aPlayOnce = False
End Sub
Private Sub chkShape_Click()
' With Dummy freq
aShape = -chkShape.Value
If Not aBlock Then EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
End Sub
' Play ----------------------------------------------------
Private Sub chkPlay_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
chkPlay.Value = Unchecked
chkPlay.Enabled = False
aPlay = True
aPlayOnce = True
EvalPlot PIC, PIC2, uAmp * AmpMult, uFrq, uDur, aPlay
DoEvents
If Not aRepeatPlay Then
PlayWAV SoundFile(1), 0, SND_MEMORY Or SND_ASYNC
Else
PlayWAV SoundFile(1), 0, SND_MEMORY Or SND_ASYNC Or SND_LOOP
End If
chkPlay.Enabled = True
aPlay = False
PIC.SetFocus
End Sub
Private Sub chkPlay_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
HiLiter chkPlay, ShapeChkPlay
End Sub
Private Sub HiLiter(C As Control, S As Shape)
S.FillColor = vbCyan
Do
If GetCursorPos(Pnt) <> 0 Then
If WindowFromPoint(Pnt.X, Pnt.Y) = C.hWnd Then
DoEvents
Else
Exit Do
End If
End If
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -