写不出来了。关于PICTUREBOX图像保存为ICO格式

Question

情况如下
1、图标是用LOADPICTURE方法加载到PICTUREBOX里的
2、求将图像保存为ICO的代码
要求
使用API函数构造一个模块，调用函数为
public function saveicon (filepathname as string ,pic as picturebox) as boolean
第一个参数是保存路径和文件名，第2个参数是已经加载了ICO的PICTUREBOX
返回值为是否成功。

Answer 1

建议楼主参考ICON文件格式：
http://www.moon-soft.com/program/FORMAT/
其实icon文件小的就766字节，对照资料拿个ultraedit之类的可以分析出它的结构，用VB一个个字节重写都不用API。

Answer 2

http://www.yesky.com/20021125/1641442.shtml

Answer 3

迷糊。。一个下不下来，一个是 .NET

Answer 4

郁闷ING，有哪位高手在帮忙做啊？我可以提供2个源代码，它们分别通过不同的方式保存了ICON

Answer 5

http://vbaccelerator.com/codelib/gfx/iconread.htm

Answer 6

将文件中集成的图标资源提取并且保存起来
http://www.applevb.com/sourcecode/icond.zip使用了saveicon 函数

Answer 7

'贴一段代码，但似乎没有解决透明的问题。
Option ExplicitPrivate 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 LongPrivate 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 LongPrivate Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPrivate Declare Function CreateIconIndirect Lib "user32" (icoinfo As ICONINFO) As LongPrivate 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 TypePrivate Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End TypePrivate Type pictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End TypeConst 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
    picImage.BackColor = Picture1.BackColor
    mtransp = Picture1.Point(0, 0)
    CreateTransparent Picture1, picImage, mtransp
    CreateMask_viaMemoryDC picImage, picMask
    mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcAnd)
    mresult = BitBlt(Picture2.hdc, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcInvert)
    BuildIcon Picture2
    SavePicture Picture2.Picture, App.Path & "/Frombmp.ico"
End SubPrivate Function CreateMask_viaMemoryDC(Pic1 As PictureBox, Pic2 As PictureBox) As Boolean
     On Error GoTo errHandler
     CreateMask_viaMemoryDC = False
     
     Dim dx As Long, dy As Long
     Dim hdcMono2 As Long, bmpMono2 As Long, bmpMonoTemp2 As Long
     
     dx = Pic1.ScaleWidth
     dy = Pic1.ScaleHeight
     
   hdcMono2 = CreateCompatibleDC(0)
     If hdcMono2 = 0 Then
         GoTo errHandler
     End If
     bmpMono2 = CreateCompatibleBitmap(hdcMono2, dx, dy)
     bmpMonoTemp2 = SelectObject(hdcMono2, bmpMono2)
     mresult = BitBlt(hdcMono2, 0, 0, dx, dy, Pic1.hdc, 0, 0, vbSrcCopy)
     mresult = BitBlt(Pic2.hdc, 0, 0, dx, dy, hdcMono2, 0, 0, vbSrcCopy)
     
     Call SelectObject(hdcMono2, bmpMonoTemp2)
     Call DeleteDC(hdcMono2)
     Call DeleteObject(bmpMono2)
     
     CreateMask_viaMemoryDC = True
     Exit Function
errHandler:
    
End FunctionPrivate Sub BuildIcon(inPic As PictureBox)
    On Error Resume Next
    Dim hOldMonoBM
    Dim hDCWork
    Dim hBMOldWork
    Dim hBMWork
    Dim ipic As IPicture
    Dim pDesc As pictDesc
    Dim icoinfo As ICONINFO    BitBlt hdcMono, 0, 0, stdW, stdH, picMask.hdc, 0, 0, vbSrcCopy
    SelectObject hdcMono, bmpMonoTemp
    hDCWork = CreateCompatibleDC(0)
    
    With inPic
        hBMWork = CreateCompatibleBitmap(inPic.hdc, stdW, stdH)
    End With
    
    hBMOldWork = SelectObject(hDCWork, hBMWork)
    BitBlt hDCWork, 0, 0, stdW, stdH, picImage.hdc, 0, 0, vbSrcCopy
    SelectObject hDCWork, hBMOldWork
    
    With icoinfo
        .fIcon = 1
        .xHotspot = 16
        .yHotspot = 16
        .hBMMask = bmpMono
        .hBMColor = hBMWork
    End With
    
    With pDesc
        .cbSizeofStruct = Len(pDesc)
        .picType = PICTYPE_ICON
        .hImage = CreateIconIndirect(icoinfo)
    End With
    
    OleCreatePictureIndirect pDesc, iGuid, 1, ipic
    
    inPic.Picture = LoadPicture()
    inPic = ipic
    bmpMonoTemp = SelectObject(hdcMono, bmpMono)
    DeleteObject icoinfo.hBMMask
    DeleteDC hDCWork
    Set hBMOldWork = Nothing
End SubSub CreateTransparent(inpicSrc As PictureBox, inpicDest As PictureBox, _
          inTrasparentColor As Long)
    On Error Resume Next
    Dim mMaskDC As Long
    Dim mMaskBmp As Long
    Dim mTempMaskBMP As Long
    Dim mMonoBMP As Long
    Dim mMonoDC As Long
    Dim mTempMonoBMP As Long
    Dim mSrcHDC As Long, mDestHDC As Long
    Dim w As Long, h As Long
    
    w = inpicSrc.ScaleWidth
    h = inpicSrc.ScaleHeight
    
    mSrcHDC = inpicSrc.hdc
    mDestHDC = inpicDest.hdc
    
    mresult = SetBkColor&(mSrcHDC, inTrasparentColor)
    mresult = SetBkColor&(mDestHDC, inTrasparentColor)
    
    mMaskDC = CreateCompatibleDC(mDestHDC)
    mMaskBmp = CreateCompatibleBitmap(mDestHDC, w, h)
    mTempMaskBMP = SelectObject(mMaskDC, mMaskBmp)
    
    mMonoDC = CreateCompatibleDC(mDestHDC)
    mMonoBMP = CreateBitmap(w, h, 1, 1, 0)
    mTempMonoBMP = SelectObject(mMonoDC, mMonoBMP)
    
    mresult = BitBlt(mMonoDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcCopy)
        
    mresult = BitBlt(mMaskDC, 0, 0, w, h, mMonoDC, 0, 0, vbSrcCopy)    mMonoBMP = SelectObject(mMonoDC, mTempMonoBMP)
    mresult = DeleteObject(mMonoBMP)
    mresult = DeleteDC(mMonoDC)
    
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert)
    
    mresult = BitBlt(mDestHDC, 0, 0, w, h, mMaskDC, 0, 0, vbSrcAnd)
    
    BitBlt mDestHDC, 0, 0, w, h, mSrcHDC, 0, 0, vbSrcInvert
    inpicDest.Picture = inpicDest.Image
     
    mMaskBmp = SelectObject(mMaskDC, mTempMaskBMP)
    mresult = DeleteObject(mMaskBmp)
    mresult = DeleteDC(mMaskDC)
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    SelectObject bmpMono, bmpMonoTemp
    DeleteObject bmpMono
    DeleteDC hdcMono
End Sub