Option Explicit
Dim fso As New FileSystemObject, ts As TextStream
Dim myFiles As Object, i&, f As Object
Dim Rc As Integer 'number of folders in directory
Dim fldr As Scripting.Folder, myFolders As Scripting.Folders
Dim iCount As Integer
Private Sub Command1_Click()
'select directory, write names of folders into txt file, write names of files from folders into txt files, add to folder image_txt_files
'added code
MsgBox ImageSize("c:\test.jpg")
'*************'
Screen.MousePointer = vbHourglass
DoEvents
'create directory if it does not already exist
If Dir(App.Path & "\" & "image_txt_files", vbDirectory) = "" Then
'MsgBox "Directory doesn't exist"
MkDir (App.Path & "\" & "image_txt_files") ' make new directory
Else
'MsgBox "Directory Exist"
End If
'get folder count from Directory write folders.txt
For i = 0 To Dir1.ListCount - 1
Rc = Dir1.ListCount
Next i
Set myFolders = fso.GetFolder(Dir1.Path).SubFolders
Set ts = fso.OpenTextFile(App.Path & "\image_txt_files\folders.txt", ForWriting, True, TristateFalse)
ts.Write ("&Rc=" & myFolders.Count)
i = 0
For Each fldr In myFolders
ts.Write ("&Folder" & i & "=" & fldr.Name)
i = i + 1 'increment the counter
Next
ts.Close
'write seperate folderName.txts for each folder
Set myFolders = fso.GetFolder(Dir1.Path).SubFolders
i = 0
For Each fldr In myFolders
Set ts = fso.OpenTextFile(App.Path & "\image_txt_files\" & fldr.Name & ".txt", ForWriting, True, TristateFalse)
i = i + 1 'increment the counter
Next
ts.Close
Dim nReplace As String
Dim folderContent As String
For Each fldr In myFolders
Set myFiles = fldr.Files
folderContent = vbNullString
i = 0
For Each f In myFiles
If VBA.Right$(f.Name, 4) = ".jpg" Or VBA.Right$(f.Name, 4) = ".JPG" Then
'append file names
folderContent = (folderContent & "&pic" & i & "=" & f.Name & "&imgsize" & i & "=" & ImageSize) '// something here //'
i = i + 1
End If
Next f
'prepend file count
nReplace = "&Rc=" & i & folderContent
Set ts = fso.OpenTextFile(App.Path & "\image_txt_files\" & fldr.Name & ".txt", ForWriting, True, TristateFalse)
ts.Write (nReplace)
ts.Close 'close each file, not just the last one
Next fldr
Screen.MousePointer = vbNormal
End Sub
'added code
'*************'
Private Function GetJPGSize( _
nW As Long, nH As Long, sFileName As String) As Boolean
Dim sHeader As String
Dim hFile As Integer
Dim nPos As Long
Dim n As Long
Dim c(3) As Long
Dim nMin As Long
Dim sChar As String
Const MARKER As String = "JFIF" & vbNullChar
Const ID As String = "ÿØ"
hFile = FreeFile
On Error Resume Next
Open sFileName For Binary Access Read As #hFile
If Err.Number Then
Exit Function
End If
If LOF(hFile) < 300 Then
Close #hFile
Exit Function
End If
'read the first 300 bytes
sHeader = Input(300, hFile)
Close #hFile
If Left$(sHeader, 2) <> ID Then
Exit Function
End If
nPos = InStr(sHeader, MARKER)
If nPos = 0 Or nPos + 7 > 291 Then
Exit Function
End If
c(0) = InStr(nPos + 5, sHeader, Chr(255) & Chr$(192))
If c(0) = 0 Then c(0) = 301
c(1) = InStr(nPos + 5, sHeader, Chr(255) & Chr$(193))
If c(1) = 0 Then c(1) = 301
c(2) = InStr(nPos + 5, sHeader, Chr(255) & Chr$(194))
If c(2) = 0 Then c(2) = 301
c(3) = InStr(nPos + 5, sHeader, Chr(255) & Chr$(195))
If c(3) = 0 Then c(3) = 301
nMin = 301
For n = 0 To 3
If c(n) < nMin Then
nMin = c(n)
End If
Next
If nMin > 291 Then
Exit Function
End If
sChar = Mid$(sHeader, nMin + 5, 2)
nH = Asc(Left$(sChar, 1)) * 256 + Asc(Right$(sChar, 1))
sChar = Mid$(sHeader, nMin + 7, 2)
nW = Asc(Left$(sChar, 1)) * 256 + Asc(Right$(sChar, 1))
GetJPGSize = True
End Function
'added code
'*************'
Public Function ImageSize(ByVal sFileName As String) As String
Dim nW As Long, nH As Long
Dim pic As StdPicture
If GetJPGSize(nW, nH, sFileName) Then
ImageSize = nW & "x" & nH
Else
On Error Resume Next
Set pic = LoadPicture(sFileName)
If Err.Number = 0 Then
nW = ScaleX(pic.Width, vbHimetric, vbPixels)
nH = ScaleY(pic.Height, vbHimetric, vbPixels)
ImageSize = nW & "x" & nH
End If
End If
End Function
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Reply With Quote
