gincemathew
02-13-2013, 02:19 AM
I am using a macro to insert picture from subfolders to worksheet.Picture name is in the order 0,10,30,60,90,120,150,180,210,240,270,300,330 etc....
Now its inserting picture in the order
0 10
120 150
180 210
240 270
300 30
330 60
90
But The output i required is
0 10
30 60
90 120
150 180
210 240
270 300
330
Pls help..
Code i am using is....
Option Explicit
Private fso As Object
Private fsoRoot As Object
Private fsoFolder As Object
Private fsoFile As Object
Const strRootFolder As String = "C:\Pictures"
'########################################################################## ############################################# #####
'########################################################################## ############################################# #####
Public Sub MainLine()
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoRoot = fso.GetFolder(strRootFolder)
Application.ScreenUpdating = False
Call libProcessFolder(fsoRoot)
Application.ScreenUpdating = False
End Sub
'########################################################################## ############################################# #####
'########################################################################## ############################################# #####
Private Sub libProcessFolder(ByRef prmFolder As Object)
On Error Resume Next
Dim wbkPictures As Excel.Workbook
Dim xlsPictures As Excel.Worksheet
Dim lngRowNumber As Long
Dim strColumnName As String
lngRowNumber = -8
strColumnName = "A"
'#
'# first process all objects with the folder received and when valid jpg files are found, create a new
'# workbook instance and start inserting pictures on the first worksheet
'#
For Each fsoFile In prmFolder.Files
If fsoFile.Name Like "*.jpg" Then
'# create a workbook object if not yet opened
If lngRowNumber < 0 Then
Set wbkPictures = Application.Workbooks.Add
Set xlsPictures = wbkPictures.Worksheets(1)
lngRowNumber = lngRowNumber + 10
End If
'# insert the picture
With xlsPictures.Pictures.Insert(fsoFile.Path)
.Left = xlsPictures.Cells(lngRowNumber, strColumnName).Left
.Top = xlsPictures.Cells(lngRowNumber, strColumnName).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 125#
.ShapeRange.Width = 150#
.ShapeRange.Rotation = 0#
End With
'# insert the picture name one row above the picture
xlsPictures.Cells(lngRowNumber - 1, strColumnName).Value = Split(fsoFile.Name, ".")(0)
'# set the location for the next picture
If strColumnName = "A" Then
strColumnName = "F"
Else
strColumnName = "A"
lngRowNumber = lngRowNumber + 10
End If
End If
Next fsoFile
'#
'# if pictures were found, the workbook created is to be saved using the name of the folder
'#
If lngRowNumber > 0 Then
wbkPictures.SaveAs strRootFolder & "\" & prmFolder.Name & ".xls"
wbkPictures.Close
End If
'#
'# repeat the process for any subfolders found
'#
For Each fsoFolder In prmFolder.SubFolders
Call libProcessFolder(fsoFolder)
Next fsoFolder
End Sub
Now its inserting picture in the order
0 10
120 150
180 210
240 270
300 30
330 60
90
But The output i required is
0 10
30 60
90 120
150 180
210 240
270 300
330
Pls help..
Code i am using is....
Option Explicit
Private fso As Object
Private fsoRoot As Object
Private fsoFolder As Object
Private fsoFile As Object
Const strRootFolder As String = "C:\Pictures"
'########################################################################## ############################################# #####
'########################################################################## ############################################# #####
Public Sub MainLine()
Set fso = CreateObject("Scripting.FileSystemObject")
Set fsoRoot = fso.GetFolder(strRootFolder)
Application.ScreenUpdating = False
Call libProcessFolder(fsoRoot)
Application.ScreenUpdating = False
End Sub
'########################################################################## ############################################# #####
'########################################################################## ############################################# #####
Private Sub libProcessFolder(ByRef prmFolder As Object)
On Error Resume Next
Dim wbkPictures As Excel.Workbook
Dim xlsPictures As Excel.Worksheet
Dim lngRowNumber As Long
Dim strColumnName As String
lngRowNumber = -8
strColumnName = "A"
'#
'# first process all objects with the folder received and when valid jpg files are found, create a new
'# workbook instance and start inserting pictures on the first worksheet
'#
For Each fsoFile In prmFolder.Files
If fsoFile.Name Like "*.jpg" Then
'# create a workbook object if not yet opened
If lngRowNumber < 0 Then
Set wbkPictures = Application.Workbooks.Add
Set xlsPictures = wbkPictures.Worksheets(1)
lngRowNumber = lngRowNumber + 10
End If
'# insert the picture
With xlsPictures.Pictures.Insert(fsoFile.Path)
.Left = xlsPictures.Cells(lngRowNumber, strColumnName).Left
.Top = xlsPictures.Cells(lngRowNumber, strColumnName).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 125#
.ShapeRange.Width = 150#
.ShapeRange.Rotation = 0#
End With
'# insert the picture name one row above the picture
xlsPictures.Cells(lngRowNumber - 1, strColumnName).Value = Split(fsoFile.Name, ".")(0)
'# set the location for the next picture
If strColumnName = "A" Then
strColumnName = "F"
Else
strColumnName = "A"
lngRowNumber = lngRowNumber + 10
End If
End If
Next fsoFile
'#
'# if pictures were found, the workbook created is to be saved using the name of the folder
'#
If lngRowNumber > 0 Then
wbkPictures.SaveAs strRootFolder & "\" & prmFolder.Name & ".xls"
wbkPictures.Close
End If
'#
'# repeat the process for any subfolders found
'#
For Each fsoFolder In prmFolder.SubFolders
Call libProcessFolder(fsoFolder)
Next fsoFolder
End Sub