UID 1 精华 积分 76361 威望 点
宅币 个
贡献 次
宅之契约 份
最后登录 1970-1-1
在线时间 小时
原理就是一行一行地扫描位图，每一行作为一个频率的电平图，把像素点的亮度（红绿蓝平均值）作为电平，通过Sin函数制造波形，然后写入WAV文件。
F2W.7z
(154.66 KB, 下载次数: 52)
频谱图转WAV.exe
(36 KB, 下载次数: 6, 售价: 1 个宅币)
频谱图转WAV.7z
(12.03 KB, 下载次数: 1, 售价: 10 个宅币)
VERSION 5.00 Begin VB.Form 主窗口 Caption = "频谱图转WAV" ClientHeight = 8085 ClientLeft = 6435 ClientTop = 3975 ClientWidth = 9585 LinkTopic = "Form1" ScaleHeight = 539 ScaleMode = 3 'Pixel ScaleWidth = 639 StartUpPosition = 3 '窗口缺省 Begin VB.PictureBox picProgress Align = 1 'Align Top Height = 255 Left = 0 ScaleHeight = 13 ScaleMode = 3 'Pixel ScaleWidth = 635 TabIndex = 12 Top = 1455 Visible = 0 'False Width = 9585 Begin VB.CommandButton cmdProgress Enabled = 0 'False Height = 195 Left = 0 Style = 1 'Graphical TabIndex = 13 Top = 0 Width = 90 End End Begin VB.PictureBox picTopPanel Align = 1 'Align Top BorderStyle = 0 'None Height = 1455 Left = 0 ScaleHeight = 1455 ScaleWidth = 9585 TabIndex = 1 Top = 0 Width = 9585 Begin VB.Frame frmAlgorithm Caption = "算法" Height = 1335 Left = 3960 TabIndex = 15 Top = 0 Width = 1335 Begin VB.TextBox txtInterval Height = 270 Left = 120 TabIndex = 19 Text = "100" Top = 960 Width = 855 End Begin VB.OptionButton OpPerFreq Caption = "逐频判断" Height = 180 Left = 120 TabIndex = 17 Top = 480 Width = 1095 End Begin VB.OptionButton OpPerLine Caption = "逐行判断" Height = 180 Left = 120 TabIndex = 16 Top = 240 Value = -1 'True Width = 1095 End Begin VB.Label lbllerpItv AutoSize = -1 'True Caption = "判断间隔：" Height = 180 Left = 120 TabIndex = 18 Top = 720 Width = 900 End End Begin VB.CommandButton cmdStop Caption = "停止" Enabled = 0 'False Height = 375 Left = 3000 TabIndex = 14 Top = 960 Width = 855 End Begin VB.Frame frmAnalyse Caption = "分析" Height = 855 Left = 2160 TabIndex = 9 Top = 0 Width = 1695 Begin VB.OptionButton OpDarkness Caption = "黑度决定电平" Height = 255 Left = 120 TabIndex = 11 Top = 480 Width = 1455 End Begin VB.OptionButton OpBightness Caption = "亮度决定电平" Height = 255 Left = 120 TabIndex = 10 Top = 240 Value = -1 'True Width = 1455 End End Begin VB.CommandButton cmdMakeIt Caption = "合成" Enabled = 0 'False Height = 375 Left = 2160 TabIndex = 8 Top = 960 Width = 855 End Begin VB.TextBox txtMaxFreq Height = 270 Left = 1200 TabIndex = 7 Text = "22050" Top = 840 Width = 855 End Begin VB.TextBox txtMinFreq Height = 270 Left = 1200 TabIndex = 5 Text = "0" Top = 480 Width = 855 End Begin VB.TextBox txtPixelsPerSec Height = 270 Left = 1200 TabIndex = 3 Text = "40" Top = 120 Width = 855 End Begin VB.Label lblMaxFreq AutoSize = -1 'True Caption = "最大频率：" Height = 180 Left = 120 TabIndex = 6 Top = 840 Width = 900 End Begin VB.Label lblMinFreq AutoSize = -1 'True Caption = "最小频率：" Height = 180 Left = 120 TabIndex = 4 Top = 480 Width = 900 End Begin VB.Label lblPixelsPerSec AutoSize = -1 'True Caption = "每秒像素数：" Height = 180 Left = 120 TabIndex = 2 Top = 120 Width = 1080 End End Begin VB.PictureBox picSrc Align = 1 'Align Top BackColor = &H80000005& Height = 5655 Left = 0 OLEDropMode = 1 'Manual ScaleHeight = 373 ScaleMode = 3 'Pixel ScaleWidth = 635 TabIndex = 0 Top = 1710 Width = 9585 End End Attribute VB_Name = "主窗口" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Private Type WAVHeader 'WAV文件头，用来写WAV文件。 dwRIFF As Long dwRIFFVal As Long dwWAVE As Long dwfmt As Long dwfmtSize As Long wPCM As Integer wChannels As Integer dwSampleRate As Long dwByteRate As Long wBytesPerSample As Integer wBits As Integer dwdata As Long dwdataLen As Long End Type Private Type BITMAPINFO 'BMP信息头，给GetDIBits用的 biSize As Long biWidth As Long biHeight As Long biPlanes As Integer biBitCount As Integer biCompression As Long biSizeImage As Long biXPelsPerMeter As Long biYPelsPerMeter As Long biClrUsed As Long biClrImportant As Long End Type Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long Dim PicWidth As Long '图片尺寸 Dim PicHeight As Long Dim ProgWidth As Single '进度条宽度 Dim OutWAV As String '输出WAV文件的文件名 Dim StopProc As Boolean Private Const PI As Double = 3.14159265358979 Private Const SampleRate As Long = 44100 '合成WAV文件 Private Sub cmdMakeIt_Click() On Error GoTo ErrHandler SetAllEnabled False '防止重复操作 picTopPanel.Enabled = True cmdStop.Enabled = True SetProgress 0 picProgress.Visible = True StopProc = False Dim MinFreq As Double, MaxFreq As Double, FreqArea As Double, FreqInterval As Long, PixelsPerSec As Double If (IsNumeric(txtPixelsPerSec.Text) And _ IsNumeric(txtMinFreq.Text) And _ IsNumeric(txtMaxFreq.Text) And _ IsNumeric(txtInterval.Text)) = False Then MsgBox "输入有误" txtPixelsPerSec.Text = "40" '载入默认值然后退出 txtMinFreq.Text = "0" txtMaxFreq.Text = "22050" txtInterval.Text = "50" GoTo ErrHandler End If PixelsPerSec = CDbl(txtPixelsPerSec.Text) '每秒像素数 MinFreq = CDbl(txtMinFreq.Text) '最小频率 MaxFreq = CDbl(txtMaxFreq.Text) '最大频率 FreqInterval = CLng(txtInterval.Text) FreqArea = MaxFreq - MinFreq Dim TotalSamples As Long '样本总数 TotalSamples = CDbl(PicWidth) * SampleRate / PixelsPerSec Dim Pitch As Long '图像每行字节数 Dim Bits() As Byte '一行的图像数据 Pitch = ((PicWidth * 3 - 1) \ 4 + 1) * 4 Dim BI As BITMAPINFO 'BMP信息头 With BI .biSize = 40 .biWidth = PicWidth .biHeight = PicHeight .biPlanes = 1 .biBitCount = 24 '真彩色 .biSizeImage = Pitch * PicHeight End With Dim Values() As Double, MaxValue As Double, Value As Double Dim PValue As Double, NValue As Double '这一行的这个点的像素值，这一行的下个点的像素值 ReDim Values(TotalSamples - 1) '计算出来的波形值 Dim Darkness As Boolean '是否以“是否够黑”来做值大小判断标准 Darkness = OpDarkness.Value Dim X&, XClr&, MaxX& Dim Y&, MaxY&, Progress As Double Dim S&, SB&, SE&, SD&, SI& Dim Freq& If OpPerFreq.Value Then MaxX = PicWidth - 1 MaxY = PicHeight - 1 ReDim Bits(Pitch - 1) For Freq = MinFreq To MaxFreq Step FreqInterval Y = (Freq - MinFreq) * MaxY / FreqArea Progress = CDbl(Y) / MaxY '取得进度 SetProgress CDbl(Freq - MinFreq) / FreqArea GetDIBits picSrc.hDC, picSrc.Picture.Handle, Y + 0, 1, Bits(0), BI, 0 '取得一行位图 XClr = 0 '位图指针 For X = 0 To MaxX - 1 '处理每个像素 PValue = (CDbl(Bits(XClr + 0)) + Bits(XClr + 1) + Bits(XClr + 2)) / 765 '这个点的值 NValue = (CDbl(Bits(XClr + 3)) + Bits(XClr + 4) + Bits(XClr + 5)) / 765 '下个点的值 SB = X * TotalSamples / MaxX '这个点的样本索引（B=Begin） SE = (X + 1) * TotalSamples / MaxX '下个点的样本索引（E=End） SI = 0 '样本插值 SD = SE - SB '像素样本数 For S = SB To SE - 1 Value = PValue + (NValue - PValue) * SI / SD '当前这行“音量” If Darkness Then Value = 1 - Value Values(S) = Values(S) + Sin(PI * 2 * Freq * S / SampleRate) * Value '添加到音轨 If Abs(Values(S)) > MaxValue Then MaxValue = Abs(Values(S)) '取得音轨最大电平 SI = SI + 1 Next XClr = XClr + 3 '到下一个像素 Next DoEvents '反应一下以免假死被杀 If StopProc Then Exit For Next Else MaxX = PicWidth - 1 MaxY = PicHeight - 1 ReDim Bits(Pitch - 1) For Y = 0 To MaxY - 1 '一行一行遍历位图 Progress = CDbl(Y) / MaxY '取得进度 SetProgress Progress Freq = MinFreq + (MaxFreq - MinFreq) * Progress '当前频率 GetDIBits picSrc.hDC, picSrc.Picture.Handle, Y, 1, Bits(0), BI, 0 '取得一行位图 XClr = 0 '位图指针 For X = 0 To MaxX - 1 '处理每个像素 PValue = (CDbl(Bits(XClr + 0)) + Bits(XClr + 1) + Bits(XClr + 2)) / 765 '这个点的值 NValue = (CDbl(Bits(XClr + 3)) + Bits(XClr + 4) + Bits(XClr + 5)) / 765 '下个点的值 SB = X * TotalSamples / MaxX '这个点的样本索引（B=Begin） SE = (X + 1) * TotalSamples / MaxX '下个点的样本索引（E=End） SI = 0 '样本插值 SD = SE - SB '像素样本数 For S = SB To SE - 1 Value = PValue + (NValue - PValue) * SI / SD '当前这行“音量” If Darkness Then Value = 1 - Value Values(S) = Values(S) + Sin(PI * 2 * Freq * S / SampleRate) * Value '添加到音轨 If Abs(Values(S)) > MaxValue Then MaxValue = Abs(Values(S)) '取得音轨最大电平 SI = SI + 1 Next XClr = XClr + 3 '到下一个像素 Next DoEvents '反应一下以免假死被杀 If StopProc Then Exit For Next End If If MaxValue = 0 And StopProc = False Then MsgBox "这张图没有声音。" GoTo ErrHandler End If Dim I&, Values16() As Integer ReDim Values16(UBound(Values)) 'WAV的16位样本 For I = 0 To TotalSamples - 1 '转换为16位整数样本 Values(I) = Values(I) / MaxValue Values16(I) = Values(I) * 32767 Next Dim WAVH As WAVHeader 'WAV文件头 With WAVH .dwRIFF = &H46464952 .dwRIFFVal = 36 + (UBound(Values16) + 1) * 2 .dwWAVE = &H45564157 .dwfmt = &H20746D66 .dwfmtSize = 16 .wPCM = 1 .wChannels = 1 '单声道 .dwSampleRate = SampleRate .dwByteRate = SampleRate * 2 * .wChannels .wBytesPerSample = 2 * .wChannels .wBits = 16 .dwdata = &H61746164 .dwdataLen = 0 + (UBound(Values16) + 1) * 2 End With SetProgress 1 '显示一个完整的进度条，否则进度条缺着一块受不了 DoEvents If Len(Dir$(OutWAV)) Then Kill OutWAV '干掉已有文件 Open OutWAV For Binary As #1 '保存WAV Put #1, , WAVH '写文件头 Put #1, , Values16 '写样本 Close #1 ErrHandler: picProgress.Visible = False '一切结束，隐藏进度条 SetAllEnabled True '恢复所有控件 cmdStop.Enabled = False StopProc = False If Err Then MsgBox Err.Description, vbExclamation, "出错" End Sub Private Sub cmdStop_Click() StopProc = True End Sub Private Sub Form_Resize() On Error Resume Next picSrc.Height = ScaleHeight - picSrc.Top End Sub Private Sub Form_Unload(Cancel As Integer) StopProc = True End Sub '通过拖拽打开图片文件。 Private Sub picSrc_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single) picSrc.Picture = LoadPicture(Data.Files(1)) OutWAV = GetOutWAVName(Data.Files(1)) PicWidth = ScaleX(picSrc.Picture.Width, vbHimetric, vbPixels) PicHeight = ScaleY(picSrc.Picture.Height, vbHimetric, vbPixels) cmdMakeIt.Enabled = True End Sub '取得输出的WAV文件的文件名 Function GetOutWAVName(ByVal StrFile As String) As String Dim RightSlash As Long, RightDot As Long RightSlash = InStrRev(StrFile, "") RightDot = InStrRev(StrFile, ".") If RightSlash > RightDot Then GetOutWAVName = StrFile & ".wav" ElseIf RightDot > RightSlash Then GetOutWAVName = Left$(StrFile, RightDot) & "wav" Else GetOutWAVName = "C:\foo.wav" End If End Function '设置进度条位置，Prog的区间是[0,1] Sub SetProgress(ByVal Prog As Single) cmdProgress.Width = Prog * picProgress.ScaleWidth End Sub '设置所有控件是否灰色 Sub SetAllEnabled(ByVal Val As Boolean) Dim Ctrl As Control For Each Ctrl In Controls Ctrl.Enabled = Val Next End Sub 复制代码
|Archiver|小黑屋|技术宅的结界
( 滇ICP备16008837号 )|网站地图
发表于 2014-7-29 21:34:56
发表于 2014-7-30 11:09:55
