转自：编程爱好者论坛
作者：一江秋水

Command1：Caption=打开图片
Command2：Caption=数据处理，Enabled=False
Command3：Caption=保存图标，Enabled=False

　　代码如下：

Option Explicit

Dim pDAT() As Byte '源图数据
Dim aDAT() As Byte 'AND位图数据
Dim iDAT() As Byte 'icon文件头和图象信息块数据

Private Sub Command2_Click()
On Error GoTo 100
Dim d As Long, c As Long
Dim aLength As Long 'AND位图长度

aLength = 4 * (pDAT(4) \ 32 + Abs((pDAT(4) Mod 32) > 0)) * pDAT(8) '计算AND位图的长度
ReDim aDAT(aLength - 1) As Byte
ReDim iDAT(21) As Byte

'给 icon文件头和 icon图象信息块的元素赋值
iDAT(2) = 1 '资源类型
iDAT(4) = 1 '图像个数
iDAT(6) = pDAT(4) '图像宽
iDAT(7) = pDAT(8) '图像高
iDAT(8) = 16 * Abs(pDAT(14) = 4)
iDAT(18) = 22 '图象数据块相对于文件头部的偏移量

'更改BMP信息头中的图像高度数据
d = 2 * pDAT(8)
Select Case Len(Hex(d))
Case 1, 2: pDAT(8) = d
Case 3, 4: pDAT(9) = d \ 256: pDAT(8) = d And 255
End Select

'更改BMP信息头中的图象长度数据
c = pDAT(21): d = pDAT(20) + c * 256 + pDAT(22) * 65536 + aLength
Select Case Len(Hex(d))
Case 1, 2: pDAT(20) = d
Case 3, 4: pDAT(21) = d \ 256: pDAT(20) = d And 255
Case 5, 6: c = d And 65535: pDAT(22) = d \ 65536: pDAT(21) = c \ 256: pDAT(20) = c And 255
End Select

'计算icon图像信息块中的图象长度数据
Select Case pDAT(14) 'pDAT(14)＝4为16色，＝8为256色，＝24为真彩
Case 4: d = d + 40 + 64 '64是16色调色板长度，40是BMP信息头的长度
Case 8: d = d + 40 + 1024 '1024是256色调色板长度
Case 24: d = d + 40
End Select
Select Case Len(Hex(d))
Case 1, 2: iDAT(14) = d
Case 3, 4: iDAT(15) = d \ 256: iDAT(14) = d And 255
Case 5, 6: c = d And 65535: iDAT(16) = d \ 65536: iDAT(15) = c \ 256: iDAT(14) = c And 255
End Select

Command3.Enabled = True: Command2.Enabled = False
100
End Sub

Private Sub Command1_Click()
On Error GoTo ReadErr
Dim ImageName As String, fLength As Long, BJ As Boolean
With CommonDialog1
.DialogTitle = "打开"
.Filter = "图片文件(*.bmp,*.jpg,*.gif)|*.bmp;*.jpg;*.gif"
.ShowOpen
If Len(.FileName) < 5 Then Exit Sub
ImageName = .FileName
End With
Picture1.Picture = LoadPicture(ImageName)
Picture2.Width = Picture1.Width: Picture2.Height = Picture1.Height
Picture2.Picture = LoadPicture()
If Right(LCase(ImageName), 3) <> "bmp" Then '如果不是位图，先存为位图，再读取
BJ = True
ImageName = App.Path & "\TempFile.bmp"
SavePicture Picture1.Image, ImageName
End If
fLength = FileLen(ImageName) '获取文件长度
ReDim pDAT(fLength - 15) As Byte
Open ImageName For Binary As #1
Get #1, 15, pDAT
Close
If BJ Then Kill ImageName '删除临时位图文件
If (pDAT(5) + pDAT(6) + pDAT(7) + pDAT(9) + pDAT(10) + pDAT(11) > 0) Then
MsgBox "图片尺寸超出"
Exit Sub
End If
Me.Caption = ImageName
Command2.Enabled = True
Exit Sub
ReadErr:
Close
End Sub

Private Sub Command3_Click()
On Error GoTo WriteErr
Dim IconName As String
With CommonDialog1
.Flags = &H802
.DialogTitle = "保存"
.Filter = "图标文件(*.ico)|*.ico"
.ShowSave
If .FileName = "" Then Exit Sub
IconName = .FileName
End With
Open IconName For Binary As #1
Put #1, , iDAT
Put #1, , pDAT
Put #1, , aDAT
Close
ReDim iDAT(0)
ReDim pDAT(0)
ReDim aDAT(0)
Command3.Enabled = False
Picture2.Picture = LoadPicture(IconName)
Exit Sub
WriteErr:
Close
MsgBox "图标制作失败"
End Sub

[此贴子已经被作者于2007-7-13 16:46:14编辑过]