|
Рисунок для набора вкладок
#34976772
Ссылка:
Ссылка на сообщение:
Ссылка с названием темы:
Ссылка на профиль пользователя:
|
|
|
|
Олег Мамченко,
лень, как известно, двигатель прогресса. Поэтому, чтобы не переделывать модуль с LoadPictureDataFromIPictureDIB(), сделал ещё один: 1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
96.
97.
98.
99.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
Option Explicit
Private Type BITMAP '24 bytes
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Private Declare Function CreateIC Lib "gdi32" Alias "CreateICA" ( _
ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
ByVal hDC As Long) As Long
Private Declare Function GetObjectA Lib "gdi32" ( _
ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" ( _
ByVal hObject As Long) As Long
Private Declare Function GetObjectType Lib "gdi32" ( _
ByVal hgdiobj As Long) As Long
Private Const OBJ_BITMAP = 7
Private Declare Function CreateCompatibleBitmap Lib "gdi32" ( _
ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function GetSysColor Lib "user32" ( _
ByVal nIndex As Long) As Long
Private Const SYSCOLORMASK As Long = &H80000000
Private Declare Function CreateSolidBrush Lib "gdi32" ( _
ByVal crColor As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Const ROP3_DSna = &H220326
Private Const ROP3_DPSao = &HEA02E9
Private Declare Function BitBlt Lib "gdi32" ( _
ByVal hdcDst As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hdcSrc As Long, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Function CombinePicMask( _
ByVal pdPic As IPictureDisp, ByVal pdMsk As IPictureDisp, _
Optional ByVal BackColor As Long = 12632256 ) As IPictureDisp
Dim hicRef As Long
Dim hdcSrc As Long
Dim hdcMsk As Long
Dim hdcDst As Long
Dim hbmSrc As Long
Dim hbmMsk As Long
Dim hbmDst As Long
Dim hbmSrcOld As Long
Dim hbmMskOld As Long
Dim hbmDstOld As Long
Dim cbSize As Long
Dim cbCopied As Long
Dim bmSrc As BITMAP
Dim bmMsk As BITMAP
Dim hbrDst As Long
Dim hbrDstOld As Long
'Проверка входных параметров
If (pdPic Is Nothing) Or (pdMsk Is Nothing) Then Exit Function
hbmSrc = pdPic.Handle
If GetObjectType(hbmSrc) <> OBJ_BITMAP Then Exit Function
hbmMsk = pdMsk.Handle
If GetObjectType(hbmMsk) <> OBJ_BITMAP Then Exit Function
cbSize = LenB(bmSrc)
cbCopied = GetObjectA(hbmSrc, cbSize, bmSrc)
If cbSize <> cbCopied Then Exit Function
cbCopied = GetObjectA(hbmMsk, cbSize, bmMsk)
If cbSize <> cbCopied Then Exit Function
If (bmSrc.bmWidth <> bmMsk.bmWidth) Or _
(bmSrc.bmHeight <> bmMsk.bmHeight) Then Exit Function
'Создание контекстов устройств для манипуляций с растровыми изображениями
hicRef = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0 &)
hdcSrc = CreateCompatibleDC(hicRef)
hdcMsk = CreateCompatibleDC(hicRef)
hdcDst = CreateCompatibleDC(hicRef)
'Выбор и создание растровых изображений
hbmSrcOld = SelectObject(hdcSrc, hbmSrc)
hbmMskOld = SelectObject(hdcMsk, hbmMsk)
hbmDst = CreateCompatibleBitmap(hicRef, bmSrc.bmWidth, bmSrc.bmHeight)
hbmDstOld = SelectObject(hdcDst, hbmDst)
'Создание и выбор фоновой кисти
If BackColor And SYSCOLORMASK Then _
BackColor = GetSysColor(BackColor Xor SYSCOLORMASK)
hbrDst = CreateSolidBrush(BackColor)
hbrDstOld = SelectObject(hdcDst, hbrDst)
'Наложение изображений, подмена фона.
'Незначительно отличается от классического ((D xor S) and M) xor S.
'Не стал возиться с MaskBlt().
BitBlt hdcDst, 0 , 0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcSrc, 0 , 0 , SRCCOPY
BitBlt hdcDst, 0 , 0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcMsk, 0 , 0 , ROP3_DSna
BitBlt hdcDst, 0 , 0 , bmSrc.bmWidth, bmSrc.bmHeight, hdcMsk, 0 , 0 , ROP3_DPSao
'Выбор старых объектов и уничтожение созданных
SelectObject hdcDst, hbrDstOld
DeleteObject hbrDst
SelectObject hdcDst, hbmDstOld
SelectObject hdcMsk, hbmMskOld
SelectObject hdcSrc, hbmSrcOld
DeleteDC hdcDst
DeleteDC hdcMsk
DeleteDC hdcSrc
DeleteDC hicRef
'Возврат результата в объектном виде
Set CombinePicMask = CreateIPictureDispFromHBITMAP(hbmDst)
End Function
, и добавил другой, старый: 1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
Option Explicit
Private Enum PICTYPE
PICTYPE_UNINITIALIZED = - 1
PICTYPE_NONE = 0
PICTYPE_BITMAP = 1
PICTYPE_METAFILE = 2
PICTYPE_ICON = 3
PICTYPE_ENHMETAFILE = 4
End Enum
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4( 0 To 7 ) As Byte
End Type
Private Type PicBmp
Size As Long
Type As PICTYPE
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32" ( _
PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As IPictureDisp) As Long
Public Function CreateIPictureDispFromHBITMAP( _
ByVal hBitmap As Long, _
Optional ByVal hPal As Long = 0 , _
Optional ByVal fPictureOwnsHandle As Boolean = True) As IPictureDisp
Dim IID_IDispatch As GUID
Dim Pic As PicBmp
With Pic
.Size = Len(Pic)
.Type = PICTYPE_BITMAP
.hBmp = hBitmap
.hPal = hPal
End With
With IID_IDispatch
.Data1 = &H20400
.Data4( 0 ) = &HC0
.Data4( 7 ) = &H46
End With
OleCreatePictureIndirect Pic, IID_IDispatch, -fPictureOwnsHandle, _
CreateIPictureDispFromHBITMAP
End Function
Использование: 1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
Private Sub Кнопка0_Click()
Dim cbr As Office.CommandBar
Dim cbn As Office.CommandBarButton
Set cbr = CommandBars.Add("Custom2", msoBarTop, , True)
Set cbn = cbr.Controls.Add(msoControlButton, , , , True)
cbn.FaceId = 358
LoadPictureDataFromIPictureDIB CombinePicMask(cbn.Picture, cbn.Mask), _
НаборВкладок1.Pages("Вкладка2")
cbn.Delete
Set cbn = Nothing
cbr.Delete
Set cbr = Nothing
End Sub
Пробуйте. |
|
|
