Is this macro scenario possible using VBA?

[Kelly]

Hi there,

I'm new to VBA. I'd like to be able to have a column of cells in excel
that houses a directory path in each cell (for instance, A1 =
c:\folders\folder1, A2 = c:\folders\folder2, ... and so on). Each
destination directory contains a certain number of JPEG files. I need
to create a macro that looks in each folder and then spits out the names
of JPEGs in each folder.

For instance, if there are two JPEGs in c:\folders\folder1 (photo1.jpeg
and photo2.jpeg), could you write a macro for the following to occur:

A1 = c:\folders\folder1
B1 = photo1.jpeg
C1 = photo2.jpeg

For c:\folders\folder2, there are 4 photos (apple.jpeg, orange.jpeg,
banana.jpeg and grape.jpeg).

A2 = c:\folders\folder2
B2 = apple.jpeg
C2 = orange.jpeg
D2 = banana.jpeg
E2 = grape.jpeg

Also, given that the column of data I may be using for the directory
paths is not "A," I'd like to make it user defined so that I can use
"QQ" or "Z" or whatever I need to.

Many thanks for any energy devoted to my question.

Kelly

 

[Mark Ivey]

See if this one will work...


Sub GetJPEGS()
Dim lRow As Long
Dim sPath As String
Dim sFname As String
Dim LastRow As Long
Dim i As Long
Dim j As Long

If Cells(1, 1).Value = "" Then
Exit Sub
End If

LastRow = Cells(Rows.Count, "A").End(xlUp).Row

For j = 1 To LastRow

sPath = Cells(j, 1).Value

sPath = sPath & "\"

sFname = Dir(sPath & "*.jpg", vbNormal) ' change ext as needed

i = 1

Do Until sFname = vbNullString
Cells(j, "a").Offset(0, i).Value = sFname
sFname = Dir
i = i + 1
Loop

Next j

End Sub



Mark Ivey

 

[Kelly]

Wow, Mark. It works like a charm. Thank you so much - I'm incredibly
appreciative. Lots of good karma coming your way!

Kelly

 

[Mark Ivey]

Glad I could help out..

Mark Ivey

 

[Kelly]

Aloha again Mark,

I'm having trouble changing the desired column I'd like to apply this
macro to. From what I can tell, I'm supposed to edit

LastRow = Cells(Rows.Count, "A")

So, the "A", correct? Or am I totally off? When I change it to "B" or
"AA", it doesn't seem to pick up on the values in this column. I know
I'm probably doing something incorrectly. Any advice would be greatly
appreciated.

Mahalo,

Kelly

 

[Gord Dibben]

LastRow = Cells(Rows.Count, "A") won't get you anything but row 66536 if you
change to this...............

LastRow = Cells(Rows.Count, "A").Row
MsgBox "last row is" & LastRow

You must make a few more changes...........

Dim LastRow As Long
LastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
MsgBox "last row number is" & LastRow

Change the "A" to "B" or "AA" should work OK

Or perhaps more better is this which uses the ActiveCell.Column instaed of a
hard-coded column?

Dim LastRow As Long
LastRow = ActiveSheet.Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
MsgBox "last row number is" & LastRow


Gord Dibben MS Excel MVP

 

[Kelly]

Thanks for your input, Gord.

I attempted to add the activecell column piece of code, but this does
not then generate the names of the files inside of my directories. It
generates the row number which is last in the column of data.

I need to be able to specify which column my directory paths are located
in and then have the macro spit out the names of the files inside the
folder and move on to the next folder and do the same. The macro Mark
contributed looks at data in only column A. I need to be able to apply
his macro to any column of data I choose.

Any additional advice would be much appreciated. Many thanks again for
your assistance.

Kelly

 

[Gord Dibben]

In one of your earlier posts you told Mark it worked like a charm but needed
only to be able to change the "A" to another column.

Make sure to also change the "a" in this line if you change the "A" to "B" or
"AA"

Cells(j, "a").Offset(0, i).Value = sFname


Gord

 

[Kelly]

My apologies, Gord. I think my question was confusing.

So the macro does work like a charm, but only for data in Column A. I
had not tested to see if this macro worked on other columns of data
until today. I need to know exactly what areas of the code to edit so
that I can get the macro to run in column B or AB, etc.

Taking a look at the whole macro, my initial guess was that I needed to
edit the areas marked by asterisks if I wanted to apply this macro to
column B, for instance:

Sub GetJPEGS()
Dim lRow As Long
Dim sPath As String
Dim sFname As String
Dim LastRow As Long
Dim i As Long
Dim j As Long

If Cells(1, 1).Value = "" Then
Exit Sub
End If

**** LastRow = Cells(Rows.Count, "B").End(xlUp).Row

For j = 1 To LastRow

sPath = Cells(j, 1).Value

sPath = sPath & "\"

sFname = Dir(sPath & "*.jpg", vbNormal) ' change ext as needed

i = 1

Do Until sFname = vbNullString
***** Cells(j, "b").Offset(0, i).Value = sFname
sFname = Dir
i = i + 1
Loop

Next j

End Sub


This does not work though. Nothing happens when you run the macro.

Any advice?

 

[Mark Ivey]

Kelly,

Not totally sure how many files you may have or your expected format, but
here are two possible solutions. One is as you requested (from the current
column). But I thought I would add in another possible solution if you were
interested (from current column to a new worksheet). See what you think...


Mark


Sub GetJPEGS_At_Current_Column_To_The_Same_Sheet()
Dim lRow As Long
Dim sPath As String
Dim sFname As String
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim myColumn As Long

myColumn = ActiveCell.Column

If Cells(1, myColumn).Value = "" Then
Exit Sub
End If

LastRow = Cells(Rows.Count, myColumn).End(xlUp).Row

For j = 1 To LastRow

sPath = Cells(j, myColumn).Value

sPath = sPath & "\"

sFname = Dir(sPath & "*.jpg", vbNormal) ' change ext as needed

i = 1

Do Until sFname = vbNullString
Cells(j, myColumn).Offset(0, i).Value = sFname
sFname = Dir
i = i + 1
Loop

Next j

End Sub





Sub GetJPEGS_At_Current_Column_To_A_New_Sheet()
Dim lRow As Long
Dim sPath As String
Dim sFname As String
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim mainSheet As String
Dim targetSheet As String
Dim myColumn As Long

mainSheet = ActiveSheet.Name

myColumn = ActiveCell.Column

Sheets.Add
ActiveSheet.Name = "JPEG Listing"
targetSheet = ActiveSheet.Name

Sheets(mainSheet).Select

If Cells(1, myColumn).Value = "" Then
Exit Sub
End If

LastRow = Cells(Rows.Count, myColumn).End(xlUp).Row

For j = 1 To LastRow
sPath = Cells(j, myColumn).Value
sPath = sPath & "\"
sFname = Dir(sPath & "*.jpg", vbNormal) ' change ext as needed

i = 1

Do Until sFname = vbNullString
Sheets(targetSheet).Cells(j, "a").Value = Left(sPath,
Len(sPath) - 1)
Sheets(targetSheet).Cells(j, "a").Offset(0, i).Value = sFname
sFname = Dir
i = i + 1
Loop
Next j
End Sub

 

[Kelly]

Many, many thanks Mark. I can see a use for both of these macros in my
current project. My sincere gratitude for your assistance once again.

Best wishes,

Kelly

 

[Mark Ivey]

Glad to help out...

Mark

 

[Kelly]

Aloha again,

I have an add-on question regarding this macro. Is it possible to also
ascertain the dimensions of the JPEGS? In an ideal world, it would
process like this:


A1 = C:\pathtofolder\foldername
A2 = photoname1.jpg
A3 = width dimension
A4 = height dimension
A5 = photoname2.jpg
A6 = width dimension
A7 = height dimension
etc...

I imagine that the dimension information can be extracted from the file
properties, no? If not, is there some other way of ascertaining the
dimensions?

I really appreciate any energy devoted to my inquiry.

Mahalo,

Kelly

 

[Mark Ivey]

With some help from David Crowell @
http://www.freevbcode.com/ShowCode.Asp?ID=112

Here is what you requested...

'************************* Code starts here *************************
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
' (e-mail address removed)
' 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


Sub GetJPEGS_Height_Width()
Dim sPath As String
Dim sFname As String
Dim i As Long

If Cells(1, 1).Value = "" Then
Exit Sub
End If

sPath = Cells(1, 1).Value

sPath = sPath & "\"

sFname = Dir(sPath & "*.jpg", vbNormal)

i = 2

Do Until sFname = vbNullString

ReadImageInfo (sPath & sFname)

Cells(i, 1).Value = sFname
i = i + 1
Cells(i, 1).Value = "Width: " & m_Width
i = i + 1
Cells(i, 1).Value = "Height: " & m_Height
i = i + 1
sFname = Dir

Loop

End Sub

 

[Kelly]

Mark,

Your contributions have helped me tremendously. Would you send me your
email address so that I can send you a small token of appreciation?
Please send it to thewordfortheuniverse at gmail dot com.

This macro does exactly what I need, though I accidentally wrote
A1
A2
A3
... etc (column)

but meant to write
A1
B1
C1
... etc (row)

Could you let me know what piece of code I need to edit so that it spits
out the data across the row?

Please do send me your email address. I'd really like to thank you for
your immense help.

All the best,

Kelly