Get image dimensions

[fishbyname]

I have a piece of code that sets a cells comment to be an image

i can set the width and height of this comment but i am trying to find
a way of setting this dynamically

what i need to do is go to an image and find out its width and height
then i can use these values to set the dimensions of the comment

is there a way to do this?

 

[Guest]

Here is a trick. I ran the code below and added a watch for shp. Then
steped through the code looked inthe watch window to see the properties that
were available. Then I added the code to verify that i could read the
parameters.


Sub getdim()

For Each shp In Sheets("sheet1").Shapes

MyHeight = shp.Height
Mytop = shp.Top
Mywidth = shp.Width

Next shp

End Sub

 

[fishbyname]

that will get the size of the shape but i need the size of the image
in the file to be able to set the dimensions of the shape

here is the code i have at the moment:

Sub pic()

Dim rng As Range
Dim shp As Comment

findlastrow

For i = 12 To first_blank - 1

Set rng = Range("H" & i)

If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If

If rng.Text <> "" Then

Set shp = rng.AddComment("")
shp.Shape.Fill.UserPicture "c:\Screenshots\" &
Range("H" & i).Value & ".gif"

shp.Shape.width = 111
shp.Shape.Height = 92

End If

Next i

End Sub

i want to be change the values of 111 and 92 to the width and height
of the picture it is inserting in the previous line

 

[Peter T]

This adds an image control which has an autosize property. The control could
be on any sheet, shoose to keep/delete or hide it

Function Pic2Image(ws As Worksheet, _
wd As Single, ht As Single, _
sPic As String, _
Optional bVis As Boolean = True, _
Optional bDelete = False) As Boolean
Dim ole As OLEObject
Dim r As Range
On Error Resume Next
Set ole = ws.OLEObjects("myImage1")
On Error GoTo 0
If ole Is Nothing Then
Set ole = ws.OLEObjects.Add("Forms.Image.1")
Set r = Range("A1")
With ole
.Name = "myImage1"
.Left = r.Left
.Top = r.Top
.Visible = bVis
End With
End If

ole.Object.Picture = LoadPicture(sPic)
ole.Object.AutoSize = True
With ole
wd = .Width
ht = .Height
.Visible = bVis
End With

If bDelete Then ole.Delete

End Function

Sub Pic2Comment()
Dim w As Single, h As Single
Dim sPicFile As String
Dim cm As Comment

sPicFile = "C:\myPicture.gif"

Pic2Image ActiveSheet, w, h, sPicFile, True

With Range("D9")
On Error Resume Next
Set cm = .Comment
On Error GoTo 0
' might prefer to delete existing comment

If cm Is Nothing Then
Set cm = .AddComment
End If
End With

cm.Shape.Width = w
cm.Shape.Height = h
cm.Shape.Shadow.Visible = msoFalse
cm.Shape.Fill.UserPicture sPicFile

End Sub

For your needs adapt the range & file name into a loop

Regards,
Peter T

 

[Guest]

Sub pic()

Dim rng As Range
Dim shp As Comment
Dim s as String, h as Long
Dim w as Long

findlastrow
s = "c:\Screenshots\" & Range("H" & i).Value & ".gif"
ReadGif s, h, w
if w = 0 then exit sub
For i = 12 To first_blank - 1

Set rng = Range("H" & i)

If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If

If rng.Text <> "" Then

Set shp = rng.AddComment("")
shp.Shape.Fill.UserPicture s
shp.Shape.width = w
shp.Shape.Height = h

End If

Next i

End Sub



Sub ReadGIF(ByRef pStrPath, lHeight As Long, lWidth As Long)
Dim ff As Long
Dim lStrData As String * 20
If Not UCase(Right(pStrPath, 4)) = ".GIF" Then Exit Sub

ff = FreeFile
Open pStrPath For Input As #1
Input #ff, lStrData
Close #ff
If Len(lStrData) < 10 Then Exit Sub
lWidth = 0: lHeight = 0
If Not Left(lStrData, 3) = "GIF" Then Exit Sub
lWidth = CInt("&h" & _
Right("0" & Hex(Asc(Mid(lStrData, 8, 1))), 2) & _
Right("0" & Hex(Asc(Mid(lStrData, 7, 1))), 2) _
)

lHeight = CInt("&h" & _
Right("0" & Hex(Asc(Mid(lStrData, 10, 1))), 2) & _
Right("0" & Hex(Asc(Mid(lStrData, 9, 1))), 2) _
)
End Sub

 

[fishbyname]

This adds an image control which has an autosize property. The control could
be on any sheet, shoose to keep/delete or hide it

Function Pic2Image(ws As Worksheet, _
wd As Single, ht As Single, _
sPic As String, _
Optional bVis As Boolean = True, _
Optional bDelete = False) As Boolean
Dim ole As OLEObject
Dim r As Range
On Error Resume Next
Set ole = ws.OLEObjects("myImage1")
On Error GoTo 0
If ole Is Nothing Then
Set ole = ws.OLEObjects.Add("Forms.Image.1")
Set r = Range("A1")
With ole
.Name = "myImage1"
.Left = r.Left
.Top = r.Top
.Visible = bVis
End With
End If

ole.Object.Picture = LoadPicture(sPic)
ole.Object.AutoSize = True
With ole
wd = .Width
ht = .Height
.Visible = bVis
End With

If bDelete Then ole.Delete

End Function

Sub Pic2Comment()
Dim w As Single, h As Single
Dim sPicFile As String
Dim cm As Comment

sPicFile = "C:\myPicture.gif"

Pic2Image ActiveSheet, w, h, sPicFile, True

With Range("D9")
On Error Resume Next
Set cm = .Comment
On Error GoTo 0
' might prefer to delete existing comment

If cm Is Nothing Then
Set cm = .AddComment
End If
End With

cm.Shape.Width = w
cm.Shape.Height = h
cm.Shape.Shadow.Visible = msoFalse
cm.Shape.Fill.UserPicture sPicFile

End Sub

For your needs adapt the range & file name into a loop

Regards,
Peter T

superb, changed the range,.added in a loop and hid the image control
and it works perfectly

cheers, been trying to do this for ages

 

[fishbyname]

Sub pic()

Dim rng As Range
Dim shp As Comment
Dim s as String, h as Long
Dim w as Long

findlastrow
s = "c:\Screenshots\" & Range("H" & i).Value & ".gif"
ReadGif s, h, w
if w = 0 then exit sub
For i = 12 To first_blank - 1

Set rng = Range("H" & i)

If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If

If rng.Text <> "" Then

Set shp = rng.AddComment("")
shp.Shape.Fill.UserPicture s
shp.Shape.width = w
shp.Shape.Height = h

End If

Next i

End Sub

Sub ReadGIF(ByRef pStrPath, lHeight As Long, lWidth As Long)
Dim ff As Long
Dim lStrData As String * 20
If Not UCase(Right(pStrPath, 4)) = ".GIF" Then Exit Sub

ff = FreeFile
Open pStrPath For Input As #1
Input #ff, lStrData
Close #ff
If Len(lStrData) < 10 Then Exit Sub
lWidth = 0: lHeight = 0
If Not Left(lStrData, 3) = "GIF" Then Exit Sub
lWidth = CInt("&h" & _
Right("0" & Hex(Asc(Mid(lStrData, 8, 1))), 2) & _
Right("0" & Hex(Asc(Mid(lStrData, 7, 1))), 2) _
)

lHeight = CInt("&h" & _
Right("0" & Hex(Asc(Mid(lStrData, 10, 1))), 2) & _
Right("0" & Hex(Asc(Mid(lStrData, 9, 1))), 2) _
)
End Sub

thanks for the code, it almost works but for some reason it sets
dimensions to be much bigger than they actually are

eg Width = 176 Height = 44... Width in code = 8224 Height = 8368

do you know what is causing this?

thanks

 

[Peter T]

thanks for the code, it almost works but for some reason it sets
dimensions to be much bigger than they actually are

eg Width = 176 Height = 44... Width in code = 8224 Height = 8368

do you know what is causing this?

thanks

Tom's approach is much cleaner than mine for Gif's. Like you I also get
large even -ve numbers if x/y is under 256 (up to one byte), not sure why.
It should work though size is pixels and would need to be converted to
points. Seems the second byte expected as zero is not.

Another one -

Private Type tGIFInfo
Signature As String * 6
W As Integer
H As Integer
End Type

Function GifSize(sFile As String, wd As Single, ht As Single) As Boolean
Dim FileNum As Integer
Dim tGif As tGIFInfo

FileNum = FreeFile
If UCase(Right$(sFile, 3)) <> "GIF" Then Exit Function
FileNum = FreeFile
On Error GoTo errH

Open sFile For Binary Access Read As FileNum
Get FileNum, , tGif

With tGif
If .Signature = "GIF87a" Or .Signature = "GIF89a" Then
wd = .W
ht = .H
GifSize = True
End If
End With

done:
Close FileNum
Exit Function

errH:
Resume done
End Function

Sub test()
Dim x As Single, y As Single
Dim sPicFile As String
sPicFile = "C:\WINDOWS\Desktop\HexColour\Pictures\Font6.gif" 'Font6.gif
'AdvNamesForm1
b = GifSize(sPicFile, x, y)

If b Then MsgBox x & " x " & y & " pixels" & vbCr & _
x * 0.75 & " x " & y * 0.75 & " points" & vbCr & _
"add extra for border width, eg 1.5"

' points = (pixels x 0.75) for most users but another API to be certain
(large fonts)
' default border size normally 1.5 but should be verified
End Sub

Regards,
Peter T

 

[Tom Ogilvy]

Here is a fix for the Function

Sub ReadGIF(ByRef pStrPath, lHeight As Long, lWidth As Long)
Dim ff As Long, wDbl As Double, hDbl As Double
Dim b() As Byte
If Not UCase(Right(pStrPath, 4)) = ".GIF" Then Exit Sub
ff = FreeFile
ReDim b(1 To 10)
Open pStrPath For Binary As #1
For i = 1 To 10
Get #1, i, b(i)
Next
Close #ff


lWidth = 0: lHeight = 0
wDbl = CDbl(b(8)) * 256#
hDbl = CDbl(b(10)) * 256#
lWidth = wDbl + b(7)
lHeight = hDbl + b(9)

End Sub

this returns the measurements in Pixels.

 

[fishbyname]

Here is a fix for the Function

Sub ReadGIF(ByRef pStrPath, lHeight As Long, lWidth As Long)
Dim ff As Long, wDbl As Double, hDbl As Double
Dim b() As Byte
If Not UCase(Right(pStrPath, 4)) = ".GIF" Then Exit Sub
ff = FreeFile
ReDim b(1 To 10)
Open pStrPath For Binary As #1
For i = 1 To 10
Get #1, i, b(i)
Next
Close #ff

lWidth = 0: lHeight = 0
wDbl = CDbl(b(8)) * 256#
hDbl = CDbl(b(10)) * 256#
lWidth = wDbl + b(7)
lHeight = hDbl + b(9)

End Sub

this returns the measurements in Pixels.

thanks everyone, got this working well now and added in a couple of
little things specific to my spreadsheet

cheers for your help