K
keepitcool
I've been figuring an easy way to deal with overlays and masking
from VBA without resorting to API's etc.
I'm interested in tips re the following AND I've got a TIP for you.
QUESTION:
One Problem remains...
Excel CAN do a simple .CopyPicture to place either a MetaFile or a
Bitmap on the Clipboard.
Excel CANT change an existing Excel.Picture object from the clipboard.
Within Excel pasting it other than into a NEW picture not possible
(like you could set an Forms.Image.1 Picture property by passing it a
handle to the IPictDisp.
I found NO WAY to modify an Excel Picture other then via the harddisk..
Worksheet.Shapes.AddPicture
Worksheet.Pictures.Insert
Worksheet.Shapes.FillFormat.UserPicture
Why VBA doest support VB's Clipboard Class is quite beyond me
TIP:
While investigating Office2003 icons.. I found that the ONLY easily
accessible control that supports overlays/masking is:
the IMAGELIST (Microsoft Common Controls 6.0
with it I can easily modify the Icon's MonoChrome Mask to the
transparency color I want for saved Bitmaps.
Following codes shows how...
BTW:
On my site I have 5 HiRes PNG's of all Office 2003 Toolbar Icons
(which you can use as an Image List for your Icon editor)
keepITcool
< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >
Sub IconBitMaps()
'From Microsoft Office 11.0 Object Library
Dim oBAR As Office.CommandBar
Dim oBTN As Office.CommandBarButton
'From Microsoft Windows Common Controls 6.0
Dim oIL(0 To 1) As MSComctlLib.ImageList
'From OLE Automation
Dim oIPD As stdole.IPictureDisp
'Misc
Dim sFldr As String
Dim sSubF As String
Dim i As Integer
Const lRGB As Long = &H9900FF 'RGB(255, 0, 153)
sFldr = CurDir
On Error Resume Next
CommandBars("tmpFACEPUMP").Delete
On Error GoTo 0
Set oBAR = CommandBars.Add("tmpFACEPUMP", , , True)
Set oBTN = oBAR.Controls.Add(msoControlButton, , , , True)
For i = 0 To 1
Set oIL(i) = New ImageList
With oIL(i)
.ImageHeight = 16
.ImageWidth = 16
.UseMaskColor = True
.MaskColor = IIf(i = 0, vbWhite, vbBlack)
.BackColor = IIf(i = 0, lRGB, vbBlack)
End With
Next
On Error Resume Next
For i = 0 To 4399
If i Mod 100 = 0 Then
sSubF = Format(i \ 100, "00")
Application.StatusBar = "Pumping " & i & "of 4400"
MkDir sFldr & "\" & sSubF
ChDir sSubF
End If
oBTN.FaceId = i
With oIL(0).ListImages
.Clear
.Add 1, "M", oBTN.Mask
End With
With oIL(1).ListImages
.Clear
.Add 1, "MM", oIL(0).Overlay("M", "M")
.Add 2, "P", oBTN.Picture
End With
Set oIPD = Nothing
Set oIPD = oIL(1).Overlay("P", "MM")
SavePicture oIPD, "Face" & Format(i, "0000") & ".bmp"
Next
ChDir sFldr
CommandBars("tmpFacePUMP").Delete
Application.StatusBar = "Files pumped to " & sFldr
End Sub
from VBA without resorting to API's etc.
I'm interested in tips re the following AND I've got a TIP for you.
QUESTION:
One Problem remains...
Excel CAN do a simple .CopyPicture to place either a MetaFile or a
Bitmap on the Clipboard.
Excel CANT change an existing Excel.Picture object from the clipboard.
Within Excel pasting it other than into a NEW picture not possible
(like you could set an Forms.Image.1 Picture property by passing it a
handle to the IPictDisp.
I found NO WAY to modify an Excel Picture other then via the harddisk..
Worksheet.Shapes.AddPicture
Worksheet.Pictures.Insert
Worksheet.Shapes.FillFormat.UserPicture
Why VBA doest support VB's Clipboard Class is quite beyond me
TIP:
While investigating Office2003 icons.. I found that the ONLY easily
accessible control that supports overlays/masking is:
the IMAGELIST (Microsoft Common Controls 6.0
with it I can easily modify the Icon's MonoChrome Mask to the
transparency color I want for saved Bitmaps.
Following codes shows how...
BTW:
On my site I have 5 HiRes PNG's of all Office 2003 Toolbar Icons
(which you can use as an Image List for your Icon editor)
keepITcool
< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >
Sub IconBitMaps()
'From Microsoft Office 11.0 Object Library
Dim oBAR As Office.CommandBar
Dim oBTN As Office.CommandBarButton
'From Microsoft Windows Common Controls 6.0
Dim oIL(0 To 1) As MSComctlLib.ImageList
'From OLE Automation
Dim oIPD As stdole.IPictureDisp
'Misc
Dim sFldr As String
Dim sSubF As String
Dim i As Integer
Const lRGB As Long = &H9900FF 'RGB(255, 0, 153)
sFldr = CurDir
On Error Resume Next
CommandBars("tmpFACEPUMP").Delete
On Error GoTo 0
Set oBAR = CommandBars.Add("tmpFACEPUMP", , , True)
Set oBTN = oBAR.Controls.Add(msoControlButton, , , , True)
For i = 0 To 1
Set oIL(i) = New ImageList
With oIL(i)
.ImageHeight = 16
.ImageWidth = 16
.UseMaskColor = True
.MaskColor = IIf(i = 0, vbWhite, vbBlack)
.BackColor = IIf(i = 0, lRGB, vbBlack)
End With
Next
On Error Resume Next
For i = 0 To 4399
If i Mod 100 = 0 Then
sSubF = Format(i \ 100, "00")
Application.StatusBar = "Pumping " & i & "of 4400"
MkDir sFldr & "\" & sSubF
ChDir sSubF
End If
oBTN.FaceId = i
With oIL(0).ListImages
.Clear
.Add 1, "M", oBTN.Mask
End With
With oIL(1).ListImages
.Clear
.Add 1, "MM", oIL(0).Overlay("M", "M")
.Add 2, "P", oBTN.Picture
End With
Set oIPD = Nothing
Set oIPD = oIL(1).Overlay("P", "MM")
SavePicture oIPD, "Face" & Format(i, "0000") & ".bmp"
Next
ChDir sFldr
CommandBars("tmpFacePUMP").Delete
Application.StatusBar = "Files pumped to " & sFldr
End Sub