|
Source Code:
Form1:
Form1 Screenshot
Option Explicit
Dim ImageList() As String
Dim ctr As Integer
Dim ctr2 As Integer
Dim ImageName As String
Dim DirectoryName As String
Dim NumberImages As Integer
Dim ImageWidth As Integer
Dim ImageHeight As Integer
Dim WidthString As String
Dim HeightString As String
Dim IndentString As String
Dim OutputString As String
Private Sub CommandStart_Click()
'Implements Class1
IndentString = ""
For ctr = 1 To Val(TextIndentValue.Text)
IndentString = IndentString + " "
Next ctr
ctr = 1
DirectoryName = TextGraphicsSourceDir.Text
ImageName = Dir(DirectoryName + TextFileType.Text)
ReDim Preserve ImageList(ctr)
ImageList(ctr) = ImageName
Do Until ImageName = ""
ctr = ctr + 1
ImageName = Dir
ReDim Preserve ImageList(ctr)
ImageList(ctr) = ImageName
Loop
NumberImages = ctr - 1
For ctr = 1 To NumberImages
'TextDebug.Text = TextDebug.Text + vbCrLf + ImageList(ctr)
ImageName = DirectoryName + ImageList(ctr)
Module1.ReadImageInfo (ImageName)
ImageWidth = Module1.Width
ImageHeight = Module1.Height
'Remove leading space from width & height
WidthString = Str(ImageWidth)
WidthString = Right(WidthString, Len(WidthString) - 1)
HeightString = Str(ImageHeight)
HeightString = Right(HeightString, Len(HeightString) - 1)
'Specify output
OutputString = IndentString + "<div class=""float"">"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = IndentString + " <a href=""" + TextGraphicsPath.Text + ImageList(ctr) + """>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = IndentString + " <img src=""" + TextThumbnailPath.Text + ImageList(ctr) + """ height=" + HeightString + " width=" + WidthString + " border=0 alt=""""></a><br>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
For ctr2 = 1 To Val(TextCaptionLines.Text)
OutputString = IndentString + " <br>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
Next ctr2
OutputString = IndentString + "</div>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = ""
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
'TextDebug.Text = TextDebug.Text + vbCrLf + ImageName + vbCrLf + " height= " + Str(ImageHeight) + " width= " + Str(ImageWidth)
Next ctr
TextDebug.Text = TextDebug.Text + vbCrLf + "End"
'ReadImageInfo (sFileName)
End Sub
Private Sub CommandStartSlideshow_Click()
'Implements Class1
IndentString = ""
For ctr = 1 To Val(TextIndentValue.Text)
IndentString = IndentString + " "
Next ctr
ctr = 1
DirectoryName = TextGraphicsSourceDir.Text
ImageName = Dir(DirectoryName + TextFileType.Text)
ReDim Preserve ImageList(ctr)
ImageList(ctr) = ImageName
Do Until ImageName = ""
ctr = ctr + 1
ImageName = Dir
ReDim Preserve ImageList(ctr)
ImageList(ctr) = ImageName
Loop
NumberImages = ctr - 1
For ctr = 1 To NumberImages
'TextDebug.Text = TextDebug.Text + vbCrLf + ImageList(ctr)
ImageName = TextGraphicsPath.Text + ImageList(ctr)
'Specify output
OutputString = IndentString + "<option value=""" + ImageName + """>" + ImageList(ctr) + "</option>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
'TextDebug.Text = TextDebug.Text + vbCrLf + ImageName + vbCrLf + " height= " + Str(ImageHeight) + " width= " + Str(ImageWidth)
Next ctr
TextDebug.Text = TextDebug.Text + vbCrLf + "End"
TextDebug.Text = TextDebug.Text + vbCrLf + " Number Images = " + Str(NumberImages)
'ReadImageInfo (sFileName)
End Sub
Module1:
Option Explicit
' Only the first X bytes of the file are read into a byte array.
' BUFFERSIZE is X. A larger number will use more memory and
' be slower. A smaller number may not be able to decode all
' JPEG files. Feel free to play with this number.
Private Const BUFFERSIZE As Long = 65535
' image type enum
Public Enum eImageType
itUNKNOWN = 0
itGIF = 1
itJPEG = 2
itPNG = 3
itBMP = 4
End Enum
' private member variables
Private m_Width As Long
Private m_Height As Long
Private m_Depth As Byte
Private m_ImageType As eImageType
'
' CImageInfo
'
' Author: David Crowell
' davidc@qtm.net
' http://www.qtm.net/~davidc
'
' Released to the public domain
' use however you wish
'
' CImageInfo will get the image type ,dimensions, and
' color depth from JPG, PNG, BMP, and GIF files.
'
' version date: June 16, 1999
'
' http://www.wotsit.org is a good source of
' file format information. This code would not have been
' possible without the files I found there.
'
' read-only properties
Public Property Get Width() As Long
Width = m_Width
End Property
Public Property Get Height() As Long
Height = m_Height
End Property
Public Property Get Depth() As Byte
Depth = m_Depth
End Property
Public Property Get ImageType() As eImageType
ImageType = m_ImageType
End Property
Public Sub ReadImageInfo(sFileName As String)
' This is the sub to call to retrieve information on a file.
' Byte array buffer to store part of the file
Dim bBuf(BUFFERSIZE) As Byte
' Open file number
Dim iFN As Integer
' Set all properties to default values
m_Width = 0
m_Height = 0
m_Depth = 0
m_ImageType = itUNKNOWN
' here we will load the first part of a file into a byte
'array the amount of the file stored here depends on
'the BUFFERSIZE constant
iFN = FreeFile
Open sFileName For Binary As iFN
Get #iFN, 1, bBuf()
Close iFN
If bBuf(0) = 137 And bBuf(1) = 80 And bBuf(2) = 78 Then
' this is a PNG file
m_ImageType = itPNG
' get bit depth
Select Case bBuf(25)
Case 0
' greyscale
m_Depth = bBuf(24)
Case 2
' RGB encoded
m_Depth = bBuf(24) * 3
Case 3
' Palette based, 8 bpp
m_Depth = 8
Case 4
' greyscale with alpha
m_Depth = bBuf(24) * 2
Case 6
' RGB encoded with alpha
m_Depth = bBuf(24) * 4
Case Else
' This value is outside of it's normal range, so
'we'll assume
' that this is not a valid file
m_ImageType = itUNKNOWN
End Select
If m_ImageType Then
' if the image is valid then
' get the width
m_Width = Mult(bBuf(19), bBuf(18))
' get the height
m_Height = Mult(bBuf(23), bBuf(22))
End If
End If
If bBuf(0) = 71 And bBuf(1) = 73 And bBuf(2) = 70 Then
' this is a GIF file
m_ImageType = itGIF
' get the width
m_Width = Mult(bBuf(6), bBuf(7))
' get the height
m_Height = Mult(bBuf(8), bBuf(9))
' get bit depth
m_Depth = (bBuf(10) And 7) + 1
End If
If bBuf(0) = 66 And bBuf(1) = 77 Then
' this is a BMP file
m_ImageType = itBMP
' get the width
m_Width = Mult(bBuf(18), bBuf(19))
' get the height
m_Height = Mult(bBuf(22), bBuf(23))
' get bit depth
m_Depth = bBuf(28)
End If
If m_ImageType = itUNKNOWN Then
' if the file is not one of the above type then
' check to see if it is a JPEG file
Dim lPos As Long
Do
' loop through looking for the byte sequence FF,D8,FF
' which marks the begining of a JPEG file
' lPos will be left at the postion of the start
If (bBuf(lPos) = &HFF And bBuf(lPos + 1) = &HD8 _
And bBuf(lPos + 2) = &HFF) _
Or (lPos >= BUFFERSIZE - 10) Then Exit Do
' move our pointer up
lPos = lPos + 1
' and continue
Loop
lPos = lPos + 2
If lPos >= BUFFERSIZE - 10 Then Exit Sub
Do
' loop through the markers until we find the one
'starting with FF,C0 which is the block containing the
'image information
Do
' loop until we find the beginning of the next marker
If bBuf(lPos) = &HFF And bBuf(lPos + 1) _
<> &HFF Then Exit Do
lPos = lPos + 1
If lPos >= BUFFERSIZE - 10 Then Exit Sub
Loop
' move pointer up
lPos = lPos + 1
Select Case bBuf(lPos)
Case &HC0 To &HC3, &HC5 To &HC7, &HC9 To &HCB, _
&HCD To &HCF
' we found the right block
Exit Do
End Select
' otherwise keep looking
lPos = lPos + Mult(bBuf(lPos + 2), bBuf(lPos + 1))
' check for end of buffer
If lPos >= BUFFERSIZE - 10 Then Exit Sub
Loop
' If we've gotten this far it is a JPEG and we are ready
' to grab the information.
m_ImageType = itJPEG
' get the height
m_Height = Mult(bBuf(lPos + 5), bBuf(lPos + 4))
' get the width
m_Width = Mult(bBuf(lPos + 7), bBuf(lPos + 6))
' get the color depth
m_Depth = bBuf(lPos + 8) * 8
End If
End Sub
Private Function Mult(lsb As Byte, msb As Byte) As Long
Mult = lsb + (msb * CLng(256))
End Function
|
