这个是转载
Function ImageSize(fileName As String) As Variant
' Given a source file name (path to the GIF or JPG on disk), return an array containing
' the width (1st element) and height (2nd element).
Dim retVal As Variant
Dim header As String
Dim f As Integer
Dim wHi As Variant
Dim wLo As Variant
Dim hHi As Variant
Dim hLo As Variant
Dim w As Integer ' width of image
Dim h As Integer ' height of image
Dim foundMarker As Integer
Redim retVal(2) As Integer
Redim retVal(Lbound(retVal)+1) ' Size it so there's 2 entries
retVal(Lbound(retVal)) = 0
retVal(Ubound(retVal)) = 0
f = Freefile()
On Error Resume Next
Open fileName For Input As #f
On Error Goto 0
If Err <> 0 Then
ImageSize = retVal ' File name incorrect - return zero for both the height and width
Exit Function
End If
If Lcase(Right(fileName, 3)) = "gif" Then
' GIF's height and width stored in a fixed location
header = Input(10, f)
wHi = Mid(header, 8, 1)
wLo = Mid(header, 7, 1)
hHi = Mid(header, 10, 1)
hLo = Mid(header, 9, 1)
w = Asc(wHi) * 256 + Asc(wLo)
h = Asc(hHi) * 256 + Asc(hLo)
Elseif Lcase(Right(fileName, 3)) = "jpg" Then
' JPG's stored in a variable location. The code has been verified with JFIF
' file format (the most common format)
On Error Goto EndOfFile ' In case we run over the file for some reason
header = Input(2, f)
If header = Chr$(255) & Chr$(216) Then ' Must start with hex FF D8
foundMarker = False ' Look for the marker that will contain the height and width
While Not foundMarker
header = Input(2, f) ' Grab the next marker
' Look for the marker (in hex) FF C0, FF C1, FF C2, or FF C3
If header = Chr$(255) & Chr$(192) Or header = Chr$(255) & Chr$(193) _
Or header = Chr$(255) & Chr$(194) Or header = Chr$(255) & Chr$(195) Then
' Next two bytes are the length, then a single byte that can be ignored.
header = Input(3, f)
' Next two bytes are the height of the image
header = Input(2, f)
hHi = Asc(Midbp(header, 1, 1))
hLo = Asc(Midbp(header, 2, 1))
h = hHi * 256 + hLo
' Next two bytes are the width of the image
header = Input(2, f)
wHi = Asc(Midbp(header, 1, 1))
wLo = Asc(Midbp(header, 2, 1))
w = wHi * 256 + wLo
foundMarker = True ' Exit the while loop
Else ' It's not one of the special markers - skip over it
header = Input(2, f) ' Next two bytes are the marker length
wHi = Asc(Midbp(header, 1, 1))
wLo = Asc(Midbp(header, 2, 1))
w = wHi * 256 + wLo
header = Input(w-2, f) ' Skip over that many bytes (minus the 2 byte length already read)
w = 0 ' Clear the variable
End If
Wend ' Continue until the marker is found
End If ' Ends the check to see if the file starts with FF D8
EndOfFile:
If Err <> 0 Then
Err = 0
Resume AfterError
End If
End If ' Ends the check to see if the format is GIF or JPG
AfterError:
retVal(Lbound(retVal)) = w
retVal(Ubound(retVal)) = h
Close #f
ImageSize = retVal
End Function
Here's a sample GIFFile class cloning ImageSize() routine original logic:
Private Const GIF_HEADER_LENGTH = 10
Private Const GIF_MARKER = "GIF"
Private Const GIF_ID1 = "87a"
Private Const GIF_ID2= "89a"
Private Class GIFFile
Private m_w As Integer
Private m_h As Integer
Public Property Set fileName As String
Dim h ' GIF file Header: "GIF87a" or GIF89a" followed by logical width & height
h = Me.Header ' Let's check GIF format presence..
If ( Left$( h, 3 ) <> GIF_MARKER ) Then Error 1000, _
|Not a GIF file: Graphical Interchange File "GIF" marker not found|
If ( Mid$( h, 4, 3 ) <> GIF_ID1 And Mid$( h, 4, 3 ) <> GIF_ID2 ) Then Error 1002, _
|Not a GIF file: Graphical Interchange File "87a/89a" identifier not found|
m_w = Asc( Mid( h, 8, 1 ) ) * 256 + Asc( Mid( h, 7, 1 ) ) ' Little-endian Screen Width
m_h = Asc( Mid( h, 10, 1 ) ) * 256 + Asc( Mid( h, 9, 1 ) ) ' Little-endian Screen Height
End Property
Private Property Get Header As Variant
Dim h As Integer
h% = Freefile()
Open Me.Name For Input Shared As #h
Header = Input( GIF_HEADER_LENGTH, #h )
Close #h
End Property
Public Property Get Heigth As Integer
Heigth = m_h
End Property
Public Property Get Width As Integer
Me.Width = m_w
End Property
Public Sub new( fileName As String )
Me.FileName = fileName
End Sub
End Class
I have added GIF format additional checks intended to detect files holding inaccurate extension/type
本文地址：http://com.8s8s.com/it/it26672.htm