【VB】频谱图转WAV
原理就是一行一行地扫描位图，每一行作为一个频率的电平图，把像素点的亮度（红绿蓝平均值）作为电平，通过Sin函数制造波形，然后写入WAV文件。代码很简单。另外我没有写行之间的插值的代码，所以位图的纵向长度直接决定了WAV波形频率线的数量。
用法：把图像文件直接拖进底部白色框。然后点“合成”。合成完了以后，你会在图片文件所在文件夹看到这个WAV文件。
这东西是表达恶意的强力工具之一{:soso_e144:}
经过转换得到的WAV用Gold Wave看到的频谱图是这个样子的：
拿耳机听到的就是一阵怪声，但是它的频谱图却包含了文字信息。这东西可以拿来做加密。就是加密后的数据特别大。。
范例:
BIN:
SRC:
按照惯例给出源码。这个程序只有一个窗体文件。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的区间是
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 这是威逼？ thisAProblem 发表于 2014-7-30 03:09
这是威逼？
没错。 我囧= = 這有趣 vb学习中，非常有收获
页:
[1]