24
Октябрь
2009
Преобразование .bmp в .ico
Преобразование .bmp в .ico
Option Explicit
Private Declare Function CreateIconIndirect Lib "user32.dll" (piconinfo As ICONINFO) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32.dll" (ByRef lpPictDesc As PictDesc, riid As Guid, ByVal fOwn As Long, lplpvObj As Any)
Private Declare Function DestroyIcon Lib "user32.dll" (ByVal hIcon As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32.dll" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function SetBkColor Lib "gdi32.dll" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetBkColor Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (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 RasterOpConstants) As Long
Private Declare Function GetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function SetPixel Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Type ICONINFO
fIcon As Long
xHotspot As Long
yHotspot As Long
hBmMask As Long
hBmColor As Long
End Type
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Private Type Guid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Dim hIcon As Long
Private Sub Command1_Click()
'Загрузка BMP
With Me.CommonDialog1
.Filter = "Точечный рисунок (*.bmp)|*.bmp"
.ShowOpen
If .FileName = "" Then Exit Sub
Set Me.Picture1.Picture = LoadPicture(.FileName)
End With
End Sub
Private Sub Command2_Click()
'Преобразование BMP в ICO
Dim a
hIcon = PicToIco(Me.Picture1.hdc, 32, 32)
Set Me.Image1.Picture = Nothing
Set Me.Image1.Picture = IconToPicture(hIcon)
End Sub
Private Sub Command3_Click()
'Сохранение ICO
With Me.CommonDialog1
.Filter = "ICO (*.ico)|*.ico"
.ShowSave
If .FileName = "" Then Exit Sub
SavePicture IconToPicture(hIcon), .FileName
End With
End Sub
Private Sub Form_Load()
With Me
.Command1.Caption = "Открыть *.bmp"
.Command2.Caption = "Преобразовать"
.Command3.Caption = "Сохранить *.ico"
End With
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Call DestroyIcon(hIcon)
End Sub
Public Function PicToIco(ByVal hSrcDC As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
Optional ByVal lMaskColor As Long = &HFFFF) As Long
Dim hDCMask As Long, hDCColor As Long, hScrDC As Long, hDstDC As Long
Dim hBmMask As Long, hBmColor As Long
Dim hBmColorOld As Long, hBmMaskOld As Long
Dim Ico As ICONINFO
hScrDC = GetDC(0&)
hDstDC = CreateCompatibleDC(hSrcDC)
' Создаем цветную картинку
hBmColor = CreateCompatibleBitmap(hSrcDC, nWidth, nHeight)
' Создаем черно-белую картинку
hBmMask = CreateBitmap(nWidth, nHeight, 1&, 1&, ByVal 0&)
' Создаем DC
hDCColor = CreateCompatibleDC(hSrcDC)
' Объединяем...
hBmColorOld = SelectObject(hDCColor, hBmColor)
' Ставим нашему DC цвета исходного
Call SetBkColor(hDCColor, GetBkColor(hSrcDC))
Call SetTextColor(hDCColor, GetTextColor(hSrcDC))
' Копируем исходную картинку
Call BitBlt(hDCColor, 0&, 0&, nWidth, nHeight, hSrcDC, 0&, 0&, vbSrcCopy)
' Создаем маску и
hDCMask = CreateCompatibleDC(hSrcDC)
' Крепим ее к DC
hBmMaskOld = SelectObject(hDCMask, hBmMask)
' Цвет маски ...
If lMaskColor = &HFFFF Then lMaskColor = GetPixel(hSrcDC, 0&, 0&)
' Ставим прозрачный цвет основным
Call SetBkColor(hDCColor, lMaskColor)
Call SetTextColor(hDCColor, vbWhite)
' Создаем маску
Call BitBlt(hDCMask, 0, 0, nWidth, nHeight, hDCColor, 0, 0, vbSrcCopy)
' Ставим цвет и создаем белую маску (XOR)
Call SetTextColor(hDCColor, vbBlack)
Call SetBkColor(hDCColor, vbWhite)
' Ставим бел. маску на ненужные места
Call BitBlt(hDCColor, 0, 0, nWidth, nHeight, hDCMask, 0, 0, &H220326)
' Накладываем маску
Call BitBlt(hDstDC, 0, 0, nWidth, nHeight, hDCMask, 0, 0, vbSrcAnd)
' Объединяем содержимое картинки и hdcColor
Call BitBlt(hDstDC, 0, 0, nWidth, nHeight, hDCColor, 0, 0, vbSrcPaint)
Ico.fIcon = True
Ico.hBmColor = SelectObject(hDCColor, hBmColorOld)
Ico.hBmMask = SelectObject(hDCMask, hBmMaskOld)
PicToIco = CreateIconIndirect(Ico)
'Очистка
Call DeleteObject(Ico.hBmColor)
Call DeleteDC(hDCColor)
Call DeleteObject(Ico.hBmMask)
Call DeleteDC(hDCMask)
Call DeleteDC(hDstDC)
Call ReleaseDC(0&, hScrDC)
End Function
Private Function IconToPicture(ByVal hIcon As Long) As IPicture
Dim iPic As IPicture, picDes As PictDesc, iidIPicture As Guid
With picDes
.cbSizeofStruct = Len(picDes)
.picType = &H3
.hImage = hIcon
End With
With iidIPicture
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
Call OleCreatePictureIndirect(picDes, iidIPicture, True, IconToPicture)
End Function