写不出来了。关于PICTUREBOX图像保存为ICO格式解决方案
写不出来了。关于PICTUREBOX图像保存为ICO格式
情况如下
1、图标是用LOADPICTURE方法加载到PICTUREBOX里的
2、求将图像保存为ICO的代码
要求
使用API函数构造一个模块，调用函数为
public function saveicon (filepathname as string ,pic as picturebox) as boolean
第一个参数是保存路径和文件名，第2个参数是已经加载了ICO的PICTUREBOX
返回值为是否成功。
------解决方案--------------------
建议楼主参考ICON文件格式：
http://www.moon-soft.com/program/FORMAT/
其实icon文件小的就766字节，对照资料拿个ultraedit之类的可以分析出它的结构，用VB一个个字节重写都不用API。
------解决方案--------------------
http://www.yesky.com/20021125/1641442.shtml
------解决方案--------------------
将文件中集成的图标资源提取并且保存起来
http://www.applevb.com/sourcecode/icond.zip
使用了saveicon 函数
------解决方案--------------------
'贴一段代码，但似乎没有解决透明的问题。
Option Explicit
Private Declare Function BitBlt Lib "gdi32 " (ByVal hDestDC As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32 " (ByVal hdc As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32 " (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32 " (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32 " (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32 " (ByVal hObject As Long) As Long
Private Declare Function CreateIconIndirect Lib "user32 " (icoinfo As ICONINFO) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll " (lppictDesc As _
pictDesc, riid As Guid, ByVal fown As Long, ipic As IPicture) As Long
Private Declare Function GetIconInfo Lib "user32 " (ByVal hIcon As Long, _
icoinfo As ICONINFO) As Long
Private Declare Function SetBkColor Lib "gdi32 " (ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32 " (ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Const PICTYPE_BITMAP = 1
Const PICTYPE_ICON = 3
Dim iGuid As Guid
Dim hdcMono
Dim bmpMono
Dim bmpMonoTemp
Const stdW = 32
Const stdH = 32
Dim mresult
Private Sub Form_Load()
hdcMono = CreateCompatibleDC(hdc)
bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
With iGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
End Sub
Private Sub command1_Click()
On Error Resume Next
Dim mtransp As Long
情况如下
1、图标是用LOADPICTURE方法加载到PICTUREBOX里的
2、求将图像保存为ICO的代码
要求
使用API函数构造一个模块，调用函数为
public function saveicon (filepathname as string ,pic as picturebox) as boolean
第一个参数是保存路径和文件名，第2个参数是已经加载了ICO的PICTUREBOX
返回值为是否成功。
------解决方案--------------------
建议楼主参考ICON文件格式：
http://www.moon-soft.com/program/FORMAT/
其实icon文件小的就766字节，对照资料拿个ultraedit之类的可以分析出它的结构，用VB一个个字节重写都不用API。
------解决方案--------------------
http://www.yesky.com/20021125/1641442.shtml
------解决方案--------------------
将文件中集成的图标资源提取并且保存起来
http://www.applevb.com/sourcecode/icond.zip
使用了saveicon 函数
------解决方案--------------------
'贴一段代码，但似乎没有解决透明的问题。
Option Explicit
Private Declare Function BitBlt Lib "gdi32 " (ByVal hDestDC As Long, ByVal X As Long, _
ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32 " (ByVal hdc As Long, _
ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32 " (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32 " (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32 " (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32 " (ByVal hObject As Long) As Long
Private Declare Function CreateIconIndirect Lib "user32 " (icoinfo As ICONINFO) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll " (lppictDesc As _
pictDesc, riid As Guid, ByVal fown As Long, ipic As IPicture) As Long
Private Declare Function GetIconInfo Lib "user32 " (ByVal hIcon As Long, _
icoinfo As ICONINFO) As Long
Private Declare Function SetBkColor Lib "gdi32 " (ByVal hdc As Long, _
ByVal crColor As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32 " (ByVal nWidth As Long, ByVal nHeight _
As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBMMask As Long
hBMColor As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type pictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Const PICTYPE_BITMAP = 1
Const PICTYPE_ICON = 3
Dim iGuid As Guid
Dim hdcMono
Dim bmpMono
Dim bmpMonoTemp
Const stdW = 32
Const stdH = 32
Dim mresult
Private Sub Form_Load()
hdcMono = CreateCompatibleDC(hdc)
bmpMono = CreateCompatibleBitmap(hdcMono, stdW, stdH)
bmpMonoTemp = SelectObject(hdcMono, bmpMono)
With iGuid
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
End Sub
Private Sub command1_Click()
On Error Resume Next
Dim mtransp As Long