|
Source Code:
Form1:
Form1 Screenshot
'Instructions:
'1. Make sure all input boxes are set up properly. It's usually easiest to do that from
'the VB editor, and save it, so that in case there are any bugs, you don't have to
'input them all over again.
'
'2. Hit the Read Graphics Directory button. This will output text into the "File List"
'box of the form needed for the program.
'
'3. Optional - copy and paste that text into a separate text file for archiving. You can
'rearrange the order of pictures here, add the captions for the index page, or modify the
'captions for the photo pages.
'
'4. Optional - Copy and paste the list from the separate text file into the "File List" box
'
'5. Hit the "Create Page for Each Photo..." box. This will create the individual html
'photo pages. It will also output the necessary html code for the index page into the
'"HTML Output to Copy and Paste" box. Copy and paste that code into the index page.
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 Command1_Click()
TextFileList.Text = ""
End Sub
Private Sub CommandClearTextDebug_Click()
TextDebug.Text = ""
End Sub
Private Sub CommandReadGraphicsDirectory_Click()
Dim a As Single
Dim ImageName As String
Dim ThumbName As String
Dim ThumbSuf As String
Dim AltText As String
Dim TestChar As String
Dim PrefixLength As Integer
ctr = 0
DirectoryName = TextGraphicsPathInput.Text
TextFileList.Text = ""
PrefixLength = Val(TextPrefixLength.Text)
ThumbSuf = TextThumbnailSuffix.Text
ImageName = "START"
ctr = ctr + 1
ImageName = Dir(DirectoryName + TextFileType.Text)
TextCurrentPhoto.Text = ImageName
ThumbName = Left(ImageName, (Len(ImageName) - 4)) + ThumbSuf + Right(ImageName, 4)
AltText = Mid(ImageName, 1, (Len(ImageName) - 4))
AltText = Right(AltText, (Len(AltText) - PrefixLength))
For ctr2 = 1 To Len(AltText)
TestChar = Mid(AltText, ctr2, 1)
If TestChar = "_" Then
Mid(AltText, ctr2, 1) = " "
End If
Next ctr2
TextFileList.Text = TextFileList.Text + "image=""" + ImageName + """" + vbCrLf
TextFileList.Text = TextFileList.Text + "thumb=""" + ThumbName + """" + vbCrLf
TextFileList.Text = TextFileList.Text + "alt=""" + AltText + """" + vbCrLf
For ctr2 = 1 To Val(TextCaptionLines.Text)
TextFileList.Text = TextFileList.Text + "<br>" + vbCrLf
Next ctr2
Do Until ImageName = ""
DoEvents
ctr = ctr + 1
ImageName = Dir
TextCurrentPhoto.Text = ImageName
If ImageName <> "" Then
ThumbName = Left(ImageName, (Len(ImageName) - 4)) + ThumbSuf + Right(ImageName, 4)
AltText = Mid(ImageName, 1, (Len(ImageName) - 4))
AltText = Right(AltText, (Len(AltText) - PrefixLength))
For ctr2 = 1 To Len(AltText)
TestChar = Mid(AltText, ctr2, 1)
If TestChar = "_" Then
Mid(AltText, ctr2, 1) = " "
End If
Next ctr2
TextFileList.Text = TextFileList.Text + vbCrLf
TextFileList.Text = TextFileList.Text + "image=""" + ImageName + """" + vbCrLf
TextFileList.Text = TextFileList.Text + "thumb=""" + ThumbName + """" + vbCrLf
TextFileList.Text = TextFileList.Text + "alt=""" + AltText + """" + vbCrLf
For ctr2 = 1 To Val(TextCaptionLines.Text)
TextFileList.Text = TextFileList.Text + "<br>" + vbCrLf
Next ctr2
End If
Loop
TextFileList.Text = TextFileList.Text + "END"
'NumberImages = ctr - 1
End Sub
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 CommandStartIndividualPages_Click()
Dim HTMLFileName As String
Dim PreviousHTMLFileName As String
Dim NextHTMLFileName As String
Dim Extension As String
Dim DirectoryGraphics As String
Dim DirectoryThumbnails As String
Dim TestChar As String
Dim IndexLink As String
Dim ctr3 As Integer
Dim FileList As String
Dim ContinueProc As Boolean
Dim NewEntry As Boolean
Dim ImageName() As String
Dim ThumbName() As String
Dim AltText() As String
Dim CaptionText() As String
Dim FullImageName As String
Dim OutputTextFile As String
Dim PageTitle As String
DirectoryGraphics = TextGraphicsPathInput.Text
DirectoryThumbnails = TextThumbnailsPathInput.Text
IndexLink = TextIndexLink.Text
PageTitle = TextPhotoPageTitle.Text
IndentString = ""
For ctr = 1 To Val(TextIndentValue.Text)
IndentString = IndentString + " "
Next ctr
ContinueProc = True
NewEntry = False
FileList = TextFileList.Text
ctr3 = 0
Do Until ContinueProc = False
ctr3 = ctr3 + 1
If Left(FileList, 3) = "END" Then
ContinueProc = False
Else
'Look for next entry
Do Until NewEntry = True
If Left(FileList, 5) = "image" Then
NewEntry = True
Else
'Remove Current Line
ctr = 1
Do Until TestChar = Chr$(13)
TestChar = Mid(FileList, ctr, 1)
ctr = ctr + 1
Loop
FileList = Right(FileList, Len(FileList) - ctr)
End If
Loop
NewEntry = False
'Get Image Name, Remove Leading Directory, then trim FileList
ReDim Preserve ImageName(ctr3)
ctr = 1
TestChar = ""
Do Until TestChar = Chr$(13)
TestChar = Mid(FileList, ctr, 1)
ctr = ctr + 1
Loop
ImageName(ctr3) = Mid(FileList, 8, ctr - 10)
FileList = Right(FileList, Len(FileList) - ctr)
ReDim Preserve ThumbName(ctr3)
'Get Thumb Name, then trim FileList
ctr = 1
TestChar = ""
Do Until TestChar = Chr$(13)
TestChar = Mid(FileList, ctr, 1)
ctr = ctr + 1
Loop
ThumbName(ctr3) = Mid(FileList, 8, ctr - 10)
FileList = Right(FileList, Len(FileList) - ctr)
ReDim Preserve AltText(ctr3)
'Get Alt Text, then trim FileList
ctr = 1
TestChar = ""
Do Until TestChar = Chr$(13)
TestChar = Mid(FileList, ctr, 1)
ctr = ctr + 1
Loop
AltText(ctr3) = Mid(FileList, 6, ctr - 8)
FileList = Right(FileList, Len(FileList) - ctr)
'Get Caption Text
ReDim Preserve CaptionText(Val(TextCaptionLines.Text), ctr3)
For ctr2 = 1 To Val(TextCaptionLines.Text)
'Get Alt Text, then trim FileList
ctr = 1
TestChar = ""
Do Until TestChar = Chr$(13)
TestChar = Mid(FileList, ctr, 1)
ctr = ctr + 1
Loop
CaptionText(ctr2, ctr3) = Left(FileList, ctr - 2)
FileList = Right(FileList, Len(FileList) - ctr)
Next ctr2
'End of Current Revision
End If
Loop
NumberImages = ctr3 - 1
For ctr = 1 To NumberImages
DoEvents
'Get Image Info
FullImageName = DirectoryGraphics + ImageName(ctr)
TextCurrentPhoto.Text = ImageName(ctr)
Module1.ReadImageInfo (FullImageName)
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)
'Open file for writing
HTMLFileName = FullImageName
HTMLFileName = Left(HTMLFileName, Len(HTMLFileName) - 3) & "html" 'remove .jpg or appropriate extension & add .html
Open HTMLFileName For Output As #1
'Write HTML to file
Print #1, "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"">"
Print #1, "<html>"
Print #1, ""
Print #1, "<head>"
Print #1, "<meta http-equiv=""Content-Language"" content=""en-us"">"
Print #1, "<meta http-equiv=""Content-Type"" content=""text/html; charset=windows-1252"">"
Print #1, "<title>" + PageTitle + "</title>"
Print #1, ""
Print #1, "<style TYPE=""text/css""><!--"
Print #1, " @import ""jrl.photos.css"";"
Print #1, "--></style>"
Print #1, ""
Print #1, "<script language=""JavaScript"">"
Print #1, "<!-- hide"
Print #1, ""
Print #1, "trueHeight = " & HeightString & ";"
Print #1, "trueWidth = " & WidthString & ";"
Print #1, ""
Print #1, "trueAR = trueWidth / trueHeight;"
Print #1, "toggleState = 0;"
Print #1, "resizeTF = 1;"
Print #1, ""
Print #1, "window.onresize = ResizeImage;"
Print #1, ""
Print #1, "function ResizeImage() {"
Print #1, ""
Print #1, " if (resizeTF == 1) {"
Print #1, " winWidth=document.all?document.body.clientWidth:window.innerWidth;"
Print #1, " winHeight=document.all?document.body.clientHeight:window.innerHeight;"
Print #1, ""
Print #1, " heightAvail = winHeight - 85;"
Print #1, " widthAvail = winWidth - 25;"
Print #1, ""
Print #1, " aspectRatio = widthAvail / heightAvail;"
Print #1, ""
Print #1, " if (aspectRatio > trueAR) {"
Print #1, " newPicHeight = heightAvail;"
Print #1, " newPicWidth = heightAvail * trueAR;"
Print #1, " } else {"
Print #1, " newPicWidth = widthAvail;"
Print #1, " newPicHeight = widthAvail / trueAR;"
Print #1, " }"
Print #1, ""
Print #1, " if (newPicHeight < trueHeight) {"
Print #1, " document.images[""PhotoImage""].height = newPicHeight;"
Print #1, " document.images[""PhotoImage""].width = newPicWidth;"
Print #1, " } else {"
Print #1, " document.images[""PhotoImage""].height = trueHeight;"
Print #1, " document.images[""PhotoImage""].width = trueWidth;"
Print #1, " }"
Print #1, " }"
Print #1, "}"
Print #1, ""
Print #1, ""
Print #1, "function Toggle() {"
Print #1, " if (toggleState == 0) {"
Print #1, " resizeTF = 0;"
Print #1, " toggleState = 1;"
Print #1, " document.images[""PhotoImage""].height = trueHeight;"
Print #1, " document.images[""PhotoImage""].width = trueWidth;"
Print #1, " window.document.formMain.buttonToggle.value = 'Scale to Window';"
Print #1, " } else {"
Print #1, " resizeTF = 1;"
Print #1, " toggleState = 0;"
Print #1, " window.document.formMain.buttonToggle.value = 'Full Size';"
Print #1, " ResizeImage();"
Print #1, ""
Print #1, " var watermarkID = DOMGetElement('watermark');"
Print #1, " PositionWatermark(watermarkID, 0, 0);"
Print #1, " }"
Print #1, "}"
Print #1, ""
Print #1, ""
Print #1, "function CalculateWatermarkPos() {"
Print #1, " xOffset = 140;"
Print #1, " yOffset = 45;"
Print #1, ""
Print #1, " var watermarkID = DOMGetElement('watermark');"
Print #1, ""
Print #1, " winWidth=document.all?document.body.clientWidth:window.innerWidth;"
Print #1, " winHeight=document.all?document.body.clientHeight:window.innerHeight;"
Print #1, ""
Print #1, " if (document.all) xScrollOffset = document.body.scrollLeft;"
Print #1, " else if (document.getElementById) xScrollOffset = window.pageXOffset;"
Print #1, " else if (document.layers) xScrollOffset = window.pageXOffset;"
Print #1, ""
Print #1, " if (document.all) yScrollOffset = document.body.scrollTop;"
Print #1, " else if (document.getElementById) yScrollOffset = window.pageYOffset;"
Print #1, " else if (document.layers) yScrollOffset = window.pageYOffset;"
Print #1, ""
Print #1, " yPos = winHeight + yScrollOffset - yOffset;"
Print #1, " xPos = winWidth +xScrollOffset - xOffset;"
Print #1, ""
Print #1, " if (yPos > trueHeight + 15) yPos = trueHeight + 15;"
Print #1, " if (xPos > trueWidth - xOffset) xPos = trueWidth - xOffset;"
Print #1, ""
Print #1, " PositionWatermark(watermarkID, xPos, yPos);"
Print #1, ""
Print #1, " if ((yScrollOffset == 0) && (xScrollOffset == 0) && (yPos == trueHeight + 15) && (xPos == trueWidth - xOffset) && (document.images[""PhotoImage""].width == trueWidth) && (document.images[""PhotoImage""].height == trueHeight)) {"
Print #1, " if (document.getElementById) watermarkID.style.visibility = ""hidden"";"
Print #1, " else if (document.all) watermarkID.style.visibility = ""hidden"";"
Print #1, " else if (document.layers) watermarkID.visibility = ""hidden"";"
Print #1, " } else {"
Print #1, " if (document.getElementById) watermarkID.style.visibility = ""visible"";"
Print #1, " else if (document.all) watermarkID.style.visibility = ""visible"";"
Print #1, " else if (document.layers) watermarkID.visibility = ""visible"";"
Print #1, " }"
Print #1, ""
Print #1, " setTimeout('CalculateWatermarkPos()',10);"
Print #1, "}"
Print #1, ""
Print #1, "function DOMGetElement(o) {"
Print #1, " if (document.getElementById) return document.getElementById(o);"
Print #1, " else if (document.all) return document.all[o];"
Print #1, " else if (document.layers) return document.layers[o];"
Print #1, " return null;"
Print #1, "}"
Print #1, ""
Print #1, "function PositionWatermark(watermarkID, xPos, yPos) {"
Print #1, " if (document.getElementById) watermarkID.style.top = yPos;"
Print #1, " else if (document.all) watermarkID.style.top = yPos;"
Print #1, " else if (document.layers) watermarkID.pageY = yPos;"
Print #1, ""
Print #1, " if (document.getElementById) watermarkID.style.left = xPos;"
Print #1, " else if (document.all) watermarkID.style.left = xPos;"
Print #1, " else if (document.layers) watermarkID.pageX = xPos;"
Print #1, "}"
Print #1, ""
Print #1, "// -->"
Print #1, "</script>"
Print #1, ""
Print #1, "</head>"
Print #1, ""
Print #1, "<body bgcolor=""FFFFFF"" style=""font-family: Arial"" onLoad=""CalculateWatermarkPos()"">"
Print #1, ""
Print #1, "<p>"
Print #1, " <img src=""" & ImageName(ctr) & """ width=" & WidthString & " height=" & HeightString & " alt=""" + AltText(ctr) + """ name=""PhotoImage"" onLoad=""ResizeImage()""><br>"
Print #1, AltText(ctr) + " <br>"
Print #1, " <br>"
Print #1, " <a href=""" + IndexLink + """>Back To Index</a><br>"
If ctr = 1 Then
NextHTMLFileName = ImageName(ctr + 1)
NextHTMLFileName = Left(NextHTMLFileName, Len(NextHTMLFileName) - 3) & "html"
Print #1, " <Prev <a href=""" & NextHTMLFileName & """>Next></a><br>"
ElseIf ctr = NumberImages Then
PreviousHTMLFileName = ImageName(ctr - 1)
PreviousHTMLFileName = Left(PreviousHTMLFileName, Len(PreviousHTMLFileName) - 3) & "html"
Print #1, " <a href=""" & PreviousHTMLFileName & """><Prev</a> Next><br>"
Else
PreviousHTMLFileName = ImageName(ctr - 1)
PreviousHTMLFileName = Left(PreviousHTMLFileName, Len(PreviousHTMLFileName) - 3) & "html"
NextHTMLFileName = ImageName(ctr + 1)
NextHTMLFileName = Left(NextHTMLFileName, Len(NextHTMLFileName) - 3) & "html"
Print #1, " <a href=""" & PreviousHTMLFileName & """><Prev</a> <a href=""" & NextHTMLFileName & """>Next></a><br>"
End If
Print #1, "</p>"
Print #1, ""
Print #1, "<div id=""watermark"" style=""position:absolute;"">"
Print #1, " <form name=""formMain"">"
Print #1, " <input TYPE=""button"" NAME=""buttonToggle"" Value=""Full Size"" onClick=""Toggle()"" style=""width:120px;"">"
Print #1, " </form>"
Print #1, "</div>"
Print #1, ""
Print #1, "</body>"
Print #1, "</html>"
'Close HTML file
Close #1
'Get Thumbnail Information
'AltText = AltText(ctr)
FullImageName = DirectoryThumbnails + ThumbName(ctr)
Extension = Right(FullImageName, 4)
FullImageName = Left(FullImageName, Len(FullImageName) - 4) & TextThumbnailSuffix.Text & Extension
Module1.ReadImageInfo (FullImageName)
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)
' ImageName = ImageList(ctr)
' Extension = Right(ImageName, 4)
' ImageName = Left(ImageName, Len(ImageName) - 4) & TextThumbnailSuffix.Text & Extension
HTMLFileName = ImageName(ctr)
HTMLFileName = Left(HTMLFileName, Len(HTMLFileName) - 3) & "html" 'remove .jpg or appropriate extension
'OutputTextFile = TextOutputTextName.Text
'Specify output
OutputString = IndentString + "<div class=""float"">"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = IndentString + " <a href=""" + TextGraphicsPath.Text + HTMLFileName + """>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = IndentString + " <img src=""" + TextThumbnailPath.Text + ThumbName(ctr) + """ height=" + HeightString + " width=" + WidthString + " border=0 alt=""" + AltText(ctr) + """></a><br>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
For ctr2 = 1 To Val(TextCaptionLines.Text)
OutputString = IndentString + " " + CaptionText(ctr2, ctr)
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
Next ctr2
OutputString = IndentString + "</div>"
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
OutputString = ""
TextDebug.Text = TextDebug.Text + vbCrLf + OutputString
Next ctr
TextDebug.Text = TextDebug.Text + vbCrLf + "End"
TextDebug.Text = TextDebug.Text + vbCrLf + " Number Images = " + Str(NumberImages)
'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:
Attribute VB_Name = "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
|
