在网上看了一些有关ADPCM压缩的文章，有VC的代码，也有JAVA的，就是没看见VB的。于是亲自动手用VB编程，成功实现了WAV声音文件从普通的PCM到ADPCM两种格式的互相转换。声音效果与windows自带录音机的转换效果一样，很完美。你要问：不使用windows录音机，非要自己编程干什么呢？这样做的好处有两个，一是可以批量化转换，一键转换一批WAV文件。二是可以实现特殊格式WAV的转换，比如4000bps,2000bps码率的特殊WAV文件。这是其他软件都没有的功能。三是小，从8K采样率转到4K，WAV文件长度缩小一半。再转换成ADPCM格式，WAV文件长度又能缩小一半。相当于原来声音文件大小的25%，而音质几乎没有什么降低。这是不是一件很神奇的事情呢？下面开始看代码。
Dim index_adjust, steptab, stepsizeTable, indexTableDim adb(88, 15) As IntegerPrivate Sub Form_Load()If Dir("e:\yao\4k\*.*") <> "" Then File1.Path = "e:\yao\4k"File1.Pattern = "*.wav;*.1bit"index_adjust = Array(-1, -1, -1, -1, 2, 4, 6, 8, -1, -1, -1, -1, 2, 4, 6, 8)steptab = Array(7, 8, 9, 10, 11, 12, 13, 14, _16, 17, 19, 21, 23, 25, 28, 31, _34, 37, 41, 45, 50, 55, 60, 66, _73, 80, 88, 97, 107, 118, 130, _143, 157, 173, 190, 209, 230, 253, 279, 307, 337, 371, 408, 449, 494, 544, 598, 658, 724, 796, 876, 963, 1060, 1166, 1282, 1411, 1552, 1707, 1878, 2066, 2272, 2499, 2749, 3024, 3327, 3660, 4026, 4428, 4871, 5358, 5894, 6484, 7132, 7845, 8630, 9493, 10442, 11487, 12635, 13899, 15289, 16818, 18500, 20350, 22385, 24623, 27086, 29794, 32767)stepsizeTable = steptab:indexTable = index_adjusta = diffTab '生成adpcm转换要用的ADB数组Text1 = Text1 + vbCrLf + aEnd SubPrivate Function diffTab() As String '差值表b = Array(7, 8, 9, 10, 11, 12, 13, 14, 16, 17, 19, 21, 23, 25, 28, 31, 34, _37, 41, 45, 50, 55, 60, 66, 73, 80, 88, 97, 107, 118, 130, 143, _157, 173, 190, 209, 230, 253, 279, 307, 337, 371, 408, 449, 494, _544, 598, 658, 724, 796, 876, 963, 1060, 1166, 1282, 1411, 1552, _1707, 1878, 2066, 2272, 2499, 2749, 3024, 3327, 3660, 4026, 4428, _4871, 5358, 5894, 6484, 7132, 7845, 8630, 9493, 10442, 11487, 12635, _13899, 15289, 16818, 18500, 20350, 22385, 24623, 27086, 29794, 32767)Dim s As Long, c As Byte, d As LongFor i = 0 To 88For c = 0 To 15s = b(i): d = b(i) \ 8'a = a + h2(i) + h2(c) + "s=" + Str(s) + " d=" + Str(d) + vbCrLfIf (c And 4) Then d = d + s'If c = 15 Then Debug.Print c, s, d'a = a + h2(i) + h2(c) + Str(d) + vbCrLfIf (c And 2) <> 0 Then d = d + (s \ 2)'a = a + h2(i) + h2(c) + Str(d) + vbCrLf'If c = 15 Then Debug.Print c, s, dIf (c And 1) <> 0 Then d = d + (s \ 4)'If c = 15 Then Debug.Print c, s, d'a = a + h2(i) + h2(c) + Str(d) + vbCrLf'If (i = 0) And (c = 15) Then MsgBox d, , Hex(d)'d = Abs(d)If c > 7 Then d = 0 - d 'Else d = Abs(d)'If c = 15 Then Debug.Print c, s, d'If i = 0 And c = 15 Then MsgBox d, , Hex(d)' a = a + h2(i) + h2(c) + Str(d) + vbCrLfIf d > 32767 Then d = 32767 Else If d < -32768 Then d = -32768adb(i, c) = da = a + Str(i) + " code=" + h2(c) + " adb(index,code)=" + Str(d) + vbCrLfNextNextdiffTab = a'去掉上面的注释可以返回差值表，供程序员查看。不返回也可以的。End FunctionPrivate Sub pcmtoadpcm()Dim g() As ByteDim he(7) As ByteDim ad() As Bytef = "E:\YAO\4k\4k琴歌指弹 铁血丹心_高清.wav"f = File1.Path + "\" + File1.FileNameIf Dir(f) = "" Then Text1 = "file is not exist": Exit SubOpen f For Binary As #1ReDim g(LOF(1) - 1)Get #1, 1, gGet #1, &H18 + 1, heReDim ad(LOF(1))Close #1Dim cur_sample, prev_sample, p As Long, index As Byte, code As Byte, aa As Stringx = 0: index = 0For y = &H3C To UBound(g) - 1 Step 505p = cy16(g(y)): P1 = p \ 256: If P1 < 0 Then P1 = P1 + 256ad(x) = 0: x = x + 1ad(x) = CByte(P1): x = x + 1ad(x) = index: x = x + 1ad(x) = 0: x = x + 1prev_sample = cy16(g(y))'8位声音采样字节转16位integer类型For i = 1 To 504 Step 2If y + i + 1 > UBound(g) Then Exit ForIf y + i > UBound(g) Then Exit Forcur_sample = cy16(g(y + i))'第1个字节encode cur_sample, prev_sample, index, s1, aa, g(y + i)cur_sample = cy16(g(y + i + 1))'第2个字节encode cur_sample, prev_sample, index, s2, aa, g(y + i + 1)ad(x) = 16 * s2 + s1: x = x + 1'每两个PCM字节转换成ADPCM的一个字节NextNextReDim Preserve ad(x)Open Left(f, Len(f) - 4) + "toadPCM.wav" For Binary As #1'生成ADPCM文件Put #1, 1, "RIFFLLLLWAVEfmt "Put #1, &H10 + 1, &H14&Put #1, &H14 + 1, &H11: Put #1, &H16 + 1, 1Put #1, &H18 + 1, hePut #1, &H1C + 1, &H7DFPut #1, &H20 + 1, &H40100Put #1, &H24 + 1, &H1F90002Put #1, &H28 + 1, "fact"Put #1, &H2C + 1, &H4Put #1, &H30 + 1, CLng(x \ &H100) * 505Put #1, &H34 + 1, "data"Put #1, &H38 + 1, CLng(k)Put #1, &H4 + 1, CLng(x + &H34)Put #1, &H3C + 1, adClose #1'Me.Caption = "pcmtoadpcm" ' + Hex(ad(1)) + " " + Hex(ad(0)) + " X=" + CStr(x)Text1 = Left(f, Len(f) - 4) + "toadPCM.wav OK!" + vbCrLf + aEnd SubPrivate Function h2(ByVal b As Byte) As StringIf b < 16 Then h2 = "0" + Hex(b) + vbTab Else h2 = Hex(b) + vbTabEnd FunctionPrivate Function cy16(ByVal cy As Byte) As IntegerIf cy >= 128 Then c = cy - 128 Else c = cy + 128'MsgBox h2(cy)d = 256& * c If d > 32767 Then cy16 = d - 65536 Else cy16 = dEnd FunctionPrivate Function h4(x) As StringIf x > 65535 Then h4 = 0: MsgBox "x>FFFF" + Str(x): Exit Functionh4 = Hex(x)If Len(h4) >= 4 Then h4 = Right(h4, 4) + " ": Exit Functionh4 = String(4 - Len(h4), "0") + h4 + " "End FunctionPrivate Sub encode(cur_sample, prev_sample, index, s, a, g)'转码8位pcm声音采样到4位Dim code As Bytewww = 0'这个值改为1,可以返回每一步的运行状态供程序员观察，0=不用观察If www = 1 Then a = a + "cur_sample=" + Str(cur_sample) + " prev_sample=" + Str(prev_sample) + vbTab + h2(g) + vbCrLfdiff = cur_sample - prev_sample'先拿到差值步长1Step = stepsizeTable(index) ';If www = 1 Then a = a + "index=" + Str(index) + " diff=" + Str(diff) + " step=" + Str(Step) + vbCrLf'看看当前输入值, 跟上一个输出值的差值'diff = sample - predsample ';'如果是负的, 就给code 的高4位置1, 表示差值是负数If diff < 0 Then code = 8 ';diff = Abs(diff) ';tmpstep = Step: If www = 1 Then a = a + Str(diff) + "=diff tempstep=" + Str(Step) + vbCrLfdiffq = (Step \ 8)If www = 1 Then a = a + Str(diff) + "=diff tempstep=" + Str(Step) + " code=" + Str(code) + vbCrLf'下面就是按位进行除法, 每一位的结果被依次赋值到code的3,2,1位, 同时presample的值也算出来了If (diff >= tmpstep) Thencode = code Or &H4 diff = diff - tmpstep diffq = diffq + Step End Iftmpstep = tmpstep \ 2: If www = 1 Then a = a + Str(diff) + "=diff tempstep=" + Str(tmpstep) + " diffq=" + Str(diffq) + " code=" + Str(code) + vbCrLfIf (diff >= tmpstep) Thencode = code Or &H2 ';diff = diff - tmpstep ';diffq = diffq + (Step \ 2) ';End Iftmpstep = tmpstep \ 2: If www = 1 Then a = a + Str(diff) + "=diff tempstep=" + Str(tmpstep) + " diffq=" + Str(diffq) + " code=" + Str(code) + vbCrLfIf (diff >= tmpstep) Thencode = code Or &H1 ';diffq = diffq + (Step \ 4) '>> 2) ';End IfIf www = 1 Then a = a + Str(diff) + "=diff tempstep=" + Str(tmpstep) + " diffq=" + Str(diffq) + " code=" + Str(code) + vbCrLf'以下都是避免值越界的一些计算If (code And 8) Thenprev_sample = prev_sample - diffq Elseprev_sample = prev_sample + diffq End IfIf (prev_sample > 32767) Then prev_sample = 32767If (prev_sample < -32768) Then prev_sample = -32768 Reindex index, code ''查表得到下一个数的差值步长下标s = code And 15If www = 1 Then a = a + Str(s) + "=s prev_sample=" + Str(prev_sample) + " index=" + Str(index) + " code=" + Str(code) + vbCrLfEnd SubPrivate Function Reindex(index, code As Byte) As Bytecode = code And &HFj = Array(-1, -1, -1, -1, 2, 4, 6, 8, -1, -1, -1, -1, 2, 4, 6, 8)i = index + j(code)If i >= 0 And i <= 88 Thenindex = iElseIf i < 0 Then index = 0 Else If i > 88 Then index = 88End IfEnd Function
上面是PCM转ADPCM的代码，运行时要在窗体中建立一个名为file1的文件框控件和一个叫Text1的控件，窗体文件名为Form1.如果改了这三个名字，要注意把上面代码中这三个名字也替换成新名字。
我这个代码中，ADPCM的解压缩可以不使用stepsizeTable (=steptab)和
indexTable （=index_adjust）这两个全局数组变量。在转码之前，我先建立了一个adb(88,15)的全局变量数组，把差值与步长的关系固定到这个数组中。可以在转码时节省掉大量的计算过程，速度更快，代码更简单。不需要每一个字节转码都计算一次，只需要从ADPCM差值表中查表根据indext和code两个参数快速检索就可以了。主要过程：从文件框选择一个普通的8位单声道WAV文件，调用pcmtoadpcm过程，自动生成ADPCM格式文件并存盘（新文件名.wav=原文件名+toADPCM.wav,与原文件在同一个目录下）。生成的新文件可以用常用音频播放软件正常播放。
下面是ADPCM到PCM的解压缩代码。
Private Sub unzipADpcm(ByVal f As String)Open f For Binary As #2Dim adpcm() As ByteReDim adpcm(LOF(2) - 1 - &H3C)Get #2, &H3C + 1, adpcmDim wh(&H39) As ByteGet #2, 1, whClose #2au = UBound(adpcm)bk = au \ 256 + 1ss = 505& * bkIf wh(&H14) <> &H11 Then Text1 = "File is not ADPCM WAV!": Exit Sub'检测文件是否=ADPCM格式Dim cz As Long, uf As Byte, u0 As ByteDim n() As Byte'生成8位WAV， 如生成16位要改成 as integer 或直接去掉as byteReDim n(2& * au)For x = 0 To au Step 256If adpcm(x + 3) <> 0 Then MsgBox "adpcm(x)<>0 or adpcm(x+3)<>0 unzip adpcm":exit sub'检测ADPCM格式是否=IMA ADPCM格式u = adpcm(x + 1): u0 = adpcm(x + 4) \ 16: uf = adpcm(x + 4) And &HFindex = adpcm(x + 2): b = b + 1cy = 256& * adpcm(x + 1) + adpcm(x)'16位数If cy > 32767 Then cy = cy - 65536 n(k) = cy8(cy): k = k + 1For i = 4 To 255u = adpcm(x + i): u0 = u \ 16: uf = u And &HFcy = cy + adb(index, uf)y = y + 1: Reindex index, ufn(k) = cy8(cy): k = k + 1cy = cy + adb(index, u0)y = y + 1: Reindex index, u0n(k) = cy8(cy): k = k + 1'16位数转8位数 解压缩的WAV=8位 如果n(k)=cy，将生成16位WAV。NextNextOpen Left(f, Len(f) - 4) + "toPCM.wav" For Binary As #1Put #1, 1, "RIFFLLLLWAVEfmt "Put #1, &H10 + 1, &H10&Put #1, &H14 + 1, 1: Put #1, &H16 + 1, 1Put #1, &H18 + 1, &H1F40Put #1, &H1C + 1, &H1F40Put #1, &H20 + 1, 1Put #1, &H22 + 1, 8Put #1, &H24 + 1, "data"Put #1, &H28 + 1, CLng(k)Put #1, &H4 + 1, CLng(k + &H24)Put #1, &H2C + 1, nClose #1ff = Left(f, Len(f) - 4) + "toPCM.wav"Text1 = ff + vbCrLf + " adpcm to pcm ok"End SubPrivate Function cy8(cy) As ByteIf cy >= 0 Then k = cy \ 256 Else k = (cy + 65536) \ 256 '负数必须先转换为正数才能使用\号If k >= 128 Then cy8 = k - 128 Else cy8 = k + 128End Function
ADPCMtoPCM将生成一个原文件名+topcm.wav的新文件，可以用常用音乐播放器播放。可以解压缩本软件生成的ADPCM文件，也可以解压缩其他软件生成的ima_ADPCM格式。Micsoft ADPCM格式的WAV因为不常用，所以没有写对应代码。ima ADPCM格式最常用，体积小，音质好。
以上ADPCM压缩和解压缩代码中，不象常用音频处理软件那样要求WAV文件采样率必须8Kbps以上。不管是44K还是8K,4K，2K等特殊采样率的WAV文件都一样可以转码。至于怎么制作超低采样率的WAV将另文讲解。
