Solved: I Word macro, how to sense size in pixels of imported jpg?

[RockMechMark]

I have a macro (thanks to this forum for helping me develop it) whose purpose is to import several jpg contour plots, named in an ASCII file, crop the white space around them and size it to a 6.5-inch width. The macro assumes that the size of each jpg plot is the same, 750 x 564 pixels. The dilemma is that I want to keep the size of the resulting Word file down, but some plots need higher resolution for clarity. Therefore, I may have some plots that are 2, 3, or 4 times those sizes (1500 x 1128, 2250 x 1692, or 3000 x 2256). So if I import various file sizes into the same document, I want to be able to sense the size of each jpg individually, and then branch to the appropriate cropping procedure. I will write these various cropping procedure branches. Is there a way to determine the pixel size from each jpg's properties when it is being handled in this scheme? Please examine the script for reference.Sub ImportPlots()
'
'
' Declarations
Dim wdDoc As Document, StrFile As String, StrPlots As String
Dim i As Long, iShp As InlineShape
'
' Set document margins
ActiveDocument.PageSetup.TopMargin = 54
ActiveDocument.PageSetup.BottomMargin = 54
ActiveDocument.PageSetup.LeftMargin = 72
ActiveDocument.PageSetup.RightMargin = 72
'
StrFile = "C:\Users\" & Environ("UserName") & "\Documents\xxxxxx\yyyyyy\Plots_to_Import.txt"
Set wdDoc = Documents.Open(FileName:=StrFile, ReadOnly:=True, _
ConfirmConversions:=False, AddToRecentFiles:=False, _
Format:=wdOpenFormatAuto, Encoding:=msoEncodingUTF8)
StrPlots = Replace(wdDoc.Range.Text, vbLf, vbCr)
wdDoc.Close
Set wdDoc = Nothing
While InStr(StrPlots, vbCr & vbCr) > 0
StrPlots = Replace(StrPlots, vbCr & vbCr, vbCr) 'Get rid of adjacent carriage return characters with no name between.
Wend
With ActiveDocument
For i = 0 To UBound(Split(StrPlots, vbCr)) - 1
Set iShp = .InlineShapes.AddPicture(FileName:=Split(StrPlots, vbCr)(i), _
LinktoFile:=False, Range:=.Range.Characters.Last)
With iShp
.PictureFormat.CropLeft = 15
.PictureFormat.CropTop = 15
.PictureFormat.CropRight = 28
.PictureFormat.CropBottom = 37
.LockAspectRatio = True
.Width = 468
End With
Next
End With
Exit Sub
End Sub


Thanks in advance.

Mark

[macropod]

It's easy enough to capture the dimensions from the source files.

The following function returns the dimensions & bit depth of a PNG, GIF, BMP or JPEG File as a comma-delimited string, in the format: "Type,Height,Width,Depth".
Function GetImageFileInfo(StrFlNm As String) As String
Dim arrTmp(65535) As Byte, StrType As String, F_Num As Long
Dim lWdth As Long, lHght As Long, lDpth As Long, lngStep As Long
StrType = "UNKNOWN"
On Error GoTo UnKnown
' Open file and get data
F_Num = FreeFile()
Open StrFlNm For Binary As F_Num
Get #F_Num, 1, arrTmp()
Close F_Num
' Check for PNG
If arrTmp(0) = 137 And arrTmp(1) = 80 And arrTmp(2) = 78 Then
StrType = "PNG"
' Check bit Depth
Select Case arrTmp(25)
Case 0: lDpth = arrTmp(24) ' greyscale
Case 2: lDpth = arrTmp(24) * 3 ' RGB encoded
Case 3: lDpth = 8 ' 8 bpp
Case 4: lDpth = arrTmp(24) * 2 ' greyscale with alpha
Case 6: lDpth = arrTmp(24) * 4 ' RGB encoded with alpha
Case Else: StrType = "UNKNOWN"
End Select
If StrType Then
lWdth = arrTmp(19) + arrTmp(18) * 256
lHght = arrTmp(23) + arrTmp(22) * 256
End If
End If
' Check for GIF
If arrTmp(0) = 71 And arrTmp(1) = 73 And arrTmp(2) = 70 Then
StrType = "GIF"
lWdth = arrTmp(6) + arrTmp(7) * 256
lHght = arrTmp(8) + arrTmp(9) * 256
lDpth = (arrTmp(10) And 7) + 1
End If
' Check for BMP
If arrTmp(0) = 66 And arrTmp(1) = 77 Then
StrType = "BMP"
lWdth = arrTmp(18) + arrTmp(19) * 256
lHght = arrTmp(22) + arrTmp(23) * 256
lDpth = arrTmp(28)
End If
' Check for JPEG
If StrType = "UNKNOWN" Then
Do
If (arrTmp(lngStep) = &HFF And arrTmp(lngStep + 1) = &HD8 _
And arrTmp(lngStep + 2) = &HFF) Or ((lngStep + 10) >= 65535) Then Exit Do
lngStep = lngStep + 1
Loop
lngStep = lngStep + 2
If (lngStep + 10) >= 65535 Then Exit Function
Do
Do
If arrTmp(lngStep) = &HFF And arrTmp(lngStep + 1) <> &HFF Then Exit Do
lngStep = lngStep + 1
If (lngStep + 10) >= 65535 Then Exit Function
Loop
lngStep = lngStep + 1
Select Case arrTmp(lngStep)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, &HCD To &HCF
Exit Do
End Select
lngStep = lngStep + (arrTmp(lngStep + 2) + arrTmp(lngStep + 1) * 256)
If (lngStep + 10) >= 65535 Then GoTo UnKnown
Loop
StrType = "JPEG"
lHght = arrTmp(lngStep + 5) + arrTmp(lngStep + 4) * 256
lWdth = arrTmp(lngStep + 7) + arrTmp(lngStep + 6) * 256
lDpth = arrTmp(lngStep + 8) * 8
End If
GetImageFileInfo = StrType & "," & lHght & "," & lWdth & "," & lDpth
Exit Function
UnKnown:
GetImageFileInfo = "UNKNOWN,0,0,0"
End Function
You can call the function with code like:
Sub Test()
Dim StrFlNm As String
StrFlNm = "C:\Users\" & Environ("UserName") & "\Documents\Attachments\Myoic.jpg"
MsgBox GetImageFileInfo(StrFlNm)
End Sub

[RockMechMark]

Hi Paul,

After some delay because of other things demanding my attention, I am back. Thanks for your very detailed reply.

I have tried to implement your code, but with a modification. I want to be able to extract the width and height, so what if I use those for variables that you return as a string as arguments returned from the function. Here is what I have tried, but there is a syntax error in how I have called the function. So I modified the function heading as
Function GetImageFileInfo(StrType, lWdth, lHght, lDpth)

and the calling subroutine has the line
GetImageFileInfo(StrType, lWdth, lHght, lDpth)

This line is where the syntax error occurs. I want to be able to branch according to the values in lWdth and lHght.

Maybe more context is needed in the calling subroutine. Maybe this will help:
With ActiveDocument
For i = 0 To UBound(Split(StrPlots, vbCr)) - 1
Set iShp = .InlineShapes.AddPicture(FileName:=Split(StrPlots, vbCr)(i), _
LinktoFile:=False, Range:=.Range.Characters.Last)
StrFlNm = Split(StrPlots, vbCr)(i)
GetImageFileInfo(StrType, lWdth, lHght, lDpth)
If lWdth = 750 Then
With iShp
.PictureFormat.CropLeft = 15
.PictureFormat.CropTop = 15
.PictureFormat.CropRight = 28
.PictureFormat.CropBottom = 37
.LockAspectRatio = True
.Width = 468
End With
End If
If lWdth = 1500 Then
With iShp
.PictureFormat.CropLeft = 29
.PictureFormat.CropTop = 29
.PictureFormat.CropRight = 55
.PictureFormat.CropBottom = 75
.LockAspectRatio = True
.Width = 468
End With
End If
If lWdth = 2250 Then
With iShp
.PictureFormat.CropLeft = 44
.PictureFormat.CropTop = 44
.PictureFormat.CropRight = 83
.PictureFormat.CropBottom = 112
.LockAspectRatio = True
.Width = 468
End With
End If
If lWdth = 3000 Then
With iShp
.PictureFormat.CropLeft = 58
.PictureFormat.CropTop = 58
.PictureFormat.CropRight = 110
.PictureFormat.CropBottom = 150
.LockAspectRatio = True
.Width = 468
End With
End If
Next
End With

This is not very general, but with my application, I will only have certain sizes of jpgs.

Thanks in advance.

Mark

[macropod]

Hi Mark,

Simply put, the function doesn't work the way you're tring to use it. As indicated, you pass it a filename and it returns a string containing the data specified. You need to approach it like:
Dim StrData As String, lWdth As Long, lHght As Long
With ActiveDocument
For i = 0 To UBound(Split(StrPlots, vbCr)) - 1
StrFlNm = Split(StrPlots, vbCr)(i)
StrData = GetImageFileInfo(StrFlNm)
lWdth = CLng(Split(StrData, ",")(1))
lHght = CLng(Split(StrData, ",")(2))
Set iShp = .InlineShapes.AddPicture(FileName:=StrFlNm, _
LinktoFile:=False, Range:=.Range.Characters.Last)

[RockMechMark]

Paul,

Thank you so much. It now works. I discovered that lWdth and lHght were the opposite of my intuition. That was easy to correct.

Mark

[macropod]

I discovered that lWdth and lHght were the opposite of my intuition.
That was an error on my part. The code sould have been:
Dim StrData As String, lWdth As Long, lHght As Long
With ActiveDocument
For i = 0 To UBound(Split(StrPlots, vbCr)) - 1
StrFlNm = Split(StrPlots, vbCr)(i)
StrData = GetImageFileInfo(StrFlNm)
lHght = CLng(Split(StrData, ",")(1))
lWdth = CLng(Split(StrData, ",")(2))
Set iShp = .InlineShapes.AddPicture(FileName:=StrFlNm, _
LinktoFile:=False, Range:=.Range.Characters.Last)

[RockMechMark]

Paul,

Yes. I had already made that change.

Thanks again for your kind help. You put in considerable effort. And your effort teaches me several things about using Visual Basic.

Mark