Re: Picture.Width

Tech-Archive recommends: Speed Up your PC by fixing your registry

I have a picture loaded into an IPictureDisp object. Why does the width come back as 26.5 times the actual width of the
bitmap? I've done a search and turned up very little and the MS help is unhelpful as usual. hmmm time for a rant me
thinks. The help file just states:

Width
OLE_XSIZE_HIMETRIC (long)
R
The width of the picture.

I mean "the width of the picture", well no sh it sherlock great f-ing help that is. It states the return type is
"OLE_XSIZE_HIMETRIC" with no explanation anywhere in the help file as to what that is. You'd think if they did
something radical like multiply an integer value by a seamingly random floating point number to expose us to possible
rounding errors that they would at least friggin explain it!!!!

The reason the picture width is not expressed in pixels, is that pixels are a device dependant scalemode which doesn't
translate well between devices. HiMetric is based on the metric system which can be more easily mapped between devices
(such as display and printer for example.) In addition to this, the IPicture interface can wrap various different
picture types, some of which don't have a dimension in pixels such as metafiles, so a unit of measure valid across all
types was chosen.
To convert from himetric back to pixels, you can use one of three methods:
1) Use the ScaleX/Y() methods of various VB controls such as forms or picture boxes, using vbHimetric as the source and
vbPixels as the destination scalemodes.
2) Grab a copy of the OLEPicture library from my site which exposes HimetricToPixelsX/Y() functions which perform the
calculation without relying on existing VB controls (handy for encapsulation within classes for example.)
3) Interface with the underlying GDI object directly. The code here gets a little more complex:

'***
Private Declare Function GetObject Lib "GDI32.dll" Alias "GetObjectA" ( _
ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function GetBoundsRect Lib "GDI32.dll" (ByVal hDC As Long, _
ByRef lprcBounds As RectAPI, ByVal flags As Long) As Long
Private Declare Function SetBoundsRect Lib "GDI32.dll" (ByVal hDC As Long, _
ByRef lprcBounds As RectAPI, ByVal flags As Long) As Long
Private Declare Function CreateIC Lib "GDI32.dll" Alias "CreateICA" ( _
ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, ByRef lpInitData As Any) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function PlayMetaFile Lib "GDI32.dll" ( _
ByVal hDC As Long, ByVal hMF As Long) As Long
Private Declare Function SetMapMode Lib "GDI32.dll" ( _
ByVal hDC As Long, ByVal nMapMode As Long) As Long
Private Declare Function GetIconInfo Lib "User32.dll" ( _
ByVal hIcon As Long, ByRef pIconInfo As IconInfo) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) As Long
Private Declare Function GetEnhMetaFileHeader Lib "GDI32.dll" ( _
ByVal hEMF As Long, ByVal cbBuffer As Long, ByRef lpEMH As EnhMetaHeader) As Long
Private Declare Function LPtoDP Lib "GDI32.dll" (ByVal hDC As Long, _
ByRef lpPoint As Any, ByVal nCount As Long) As Long

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 Type RectAPI
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type SizeL
cx As Long
cy As Long
End Type

Private Type IconInfo
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type

Private Type EnhMetaHeader
iType As Long
nSize As Long
rclBounds As RectAPI
rclFrame As RectAPI
dSignature As Long
nVersion As Long
nBytes As Long
nRecords As Long
nHandles As Integer
sReserved As Integer
nDescription As Long
offDescription As Long
nPalEntries As Long
szlDevice As SizeL
szlMillimeters As SizeL
End Type

Private Const DCB_RESET As Long = &H1
Private Const DCB_ENABLE As Long = &H4
Private Const MM_TEXT As Long = 1
Private Const MM_HIMETRIC As Long = 3

Private Function GetPictureSize(ByVal inPicture As StdPicture) As SizeL
Dim BMInf As Bitmap
Dim TempIC As Long
Dim BoundsRect As RectAPI
Dim IconInf As IconInfo
Dim EnhHead As EnhMetaHeader

If (Not (inPicture Is Nothing)) Then
Select Case inPicture.Type
Case vbPicTypeBitmap
If (GetObject(inPicture.Handle, Len(BMInf), BMInf)) Then
GetPictureSize.cx = BMInf.bmWidth
GetPictureSize.cy = BMInf.bmHeight
End If
Case vbPicTypeMetafile
TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If (TempIC) Then ' Get bounding rectangle of drawing in pixels
Call SetMapMode(TempIC, MM_TEXT)
Call SetBoundsRect(TempIC, BoundsRect, DCB_ENABLE Or DCB_RESET)
Call PlayMetaFile(TempIC, inPicture.Handle)
Call GetBoundsRect(TempIC, BoundsRect, 0&)
Call DeleteDC(TempIC)

GetPictureSize.cx = BoundsRect.Right - BoundsRect.Left
GetPictureSize.cy = BoundsRect.Bottom - BoundsRect.Top
End If
Case vbPicTypeIcon
If (GetIconInfo(inPicture.Handle, IconInf)) Then
If (GetObject(IconInf.hbmMask, Len(BMInf), BMInf)) Then
GetPictureSize.cx = BMInf.bmWidth

If (IconInf.hbmColor) Then
' Mask contains only mask Bitmap
GetPictureSize.cy = BMInf.bmHeight
Else
' Mask contains both mask and colour Bitmaps
GetPictureSize.cy = BMInf.bmHeight \ 2
End If
End If

If (IconInf.hbmColor) Then Call DeleteObject(IconInf.hbmColor)
If (IconInf.hbmMask) Then Call DeleteObject(IconInf.hbmMask)
End If
Case vbPicTypeEMetafile
If (GetEnhMetaFileHeader(inPicture.Handle, Len(EnhHead), EnhHead)) Then
TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)

If (TempIC) Then
Call SetMapMode(TempIC, MM_HIMETRIC)
Call LPtoDP(TempIC, EnhHead.rclFrame, 2)
Call DeleteDC(TempIC)

With EnhHead.rclFrame
GetPictureSize.cx = .Right - .Left
GetPictureSize.cy = -(.Bottom - .Top)
End With
End If
End If
End Select
End If
End Function
'***

This works ok apart from metafiles, which will return their bounding rectangle (the smallest rectangle that can fit
around the entire drawing) rather than their frame (the size of the 'page' the image was designed on.) The reason for
this is that your standard WMF doesn't actually know this information, which was a huge limitation of the original
format. To rectify this, Aldus (later Adobe) came up with an additional header that could be placed at the start of WMF
files which contained this additional piece of information however the API doesn't support it. As such by the time you
get the hWMF handle, this additional header has long since been lost, so the only way of getting access to it is to
parse the file manually:

'***
Private Type PlaceableMetaHeader
Key As Long
Handle As Integer
Left As Integer
Top As Integer
Right As Integer
Bottom As Integer
Inch As Integer
Reserved As Long
Checksum As Integer
End Type

Private Const MM_LOENGLISH As Long = 4
Private Const APMHeadSig As Long = &H9AC6CDD7

Private Function GetWMFFileSize(ByRef inWMFPath As String, _
Optional ByVal inReturnAsTwips As Boolean = False) As SizeL
Dim FNum As Integer
Dim APMHead As PlaceableMetaHeader
Dim TempIC As Long
Dim MetaSize As SizeL

FNum = FreeFile()
Open inWMFPath For Binary Access Read As #FNum
Get #FNum, , APMHead ' Grab header from file
Close #FNum

If (APMHead.Key = APMHeadSig) Then
With APMHead
If (inReturnAsTwips) Then
GetWMFFileSize.cx = .Right - .Left
GetWMFFileSize.cy = .Bottom - .Top
Else ' Get EMF size in Lo-English (0.01 inches)
MetaSize.cx = (100& * (.Right - .Left)) / .Inch
MetaSize.cy = -(100& * (.Bottom - .Top)) / .Inch

TempIC = CreateIC("DISPLAY", vbNullString, vbNullString, ByVal 0&)
If (TempIC) Then ' Map size to device space
Call SetMapMode(TempIC, MM_LOENGLISH)
Call LPtoDP(TempIC, MetaSize, 1)
Call DeleteObject(TempIC)

GetWMFFileSize = MetaSize
End If
End If
End With
End If
End Function
'***

This method only retrieves the frame size of WMFs with the APM header, for those that don't have the header it simply
returns 0,0 so to make a generic routine you'd need to cope with those too even though they are pretty rare.
Probably far more than you wanted to know about the size of a picture, but just being thorough ;)
Hope this helps,

Mike


- Microsoft Visual Basic MVP -
E-Mail: EDais@xxxxxxxx
WWW: Http://EDais.mvps.org/


.

Relevant Pages