Multiple Groups & Align Under

I have 30+ jpgs in a folder, each jpg is a picture of a person. The file name of the jpg is the name of the person in the picture.

I am trying to create a VBA macro that will import each image, create an artisitc text object below & centered under the picture using the filename as the text. I would like to group each set of imported picture and text. At the end I would have 30+ groups of pictures with the name of the person under the picture.

I have most of it below, but I can't seem to figure out how to group each image & text shape together. In the code below it groups all the images and all the text together.

I am also having trouble aligning the text centered and below the image.

Any help would be greatly appreciated.

Kuty

Sub Macro1()

Dim sr As New ShapeRange


MyPath = "C:\jpg\"

FileName = Dir(MyPath)
Bottom = 0
mLeft = 0
FileNumber = 0
GroupNum = 0

Do While FileName <> "" ' Start the loop.

FileNumber = FileNumber + 2
FileName1 = MyPath & FileName
'Import
ActiveLayer.Import FileName1
ActiveShape.Name = FileName

'Create Name
Bottom = Bottom + 1
mLeft = mLeft + 1
ActiveLayer.CreateArtisticText mLeft, Bottom, FileName, Font:="Arial"
ActiveShape.Name = "Text" & FileName

' Align Name and Shape
ActiveLayer.Shapes(FileName).AlignToShape cdrAlignBottom, ActiveLayer.Shapes("Text" & FileName)

'Group Name and Shape
GroupNum = GroupNum + 1
sr.Add ActiveLayer.Shapes(FileName)
sr.Add ActiveLayer.Shapes("Text" & FileName)
Set GroupNum = sr.Group

FileName = Dir() ' Get next entry.
Loop

So, I managed to get it to work. Here is the final code in case anyone else has this issue.


Sub KutyScript()

Dim sr As New ShapeRange
Dim x As Double, y As Double

MyPath = "C:\jpg\"

FileName = Dir(MyPath)
Bottom = 0
mLeft = 0
FileNumber = 0

Do While FileName <> "" ' Start the loop.

FileNumber = FileNumber + 2
FileName1 = MyPath & FileName
'Import
ActiveLayer.Import FileName1
ActiveShape.Name = FileName

'Create Name
Bottom = Bottom + 1
mLeft = mLeft + 1
ActiveLayer.CreateArtisticText mLeft, Bottom, FileName, Font:="Arial"
ActiveShape.Name = "Text" & FileName

' Align Name and Shape
ActiveDocument.ReferencePoint = cdrBottomMiddle
ActiveLayer.Shapes("Text" & FileName).GetPosition x, y
ActiveLayer.Shapes(FileName).SetPosition x, y + 0.5



'Group Name and Shape
sr.Add ActiveLayer.Shapes(FileName)
sr.Add ActiveLayer.Shapes("Text" & FileName)
sr.Group
sr.Remove 1
sr.Remove 1

FileName = Dir() ' Get next entry.
Loop

End Sub

[Alex]

Kuty,

Good effort there! Nicely done. I have changed some minor details which I noticed. One thing I did was to not naming the objects and then looking them up by name, but instead saving object references into corresponding variables which can be easily recalled at any given moment.

I also changed the code to put the images in a grid on a page, in my example, images are resized to be no larger than 2" x 2" and placed on a page in a grid of 4 x 4 (16 pictures per page). New pages are added as needed.

Here is the modified macro:

Sub KutyScript()
    Const PicWidth As Double = 2
    Const PicHeight As Double = 2
    Const NumPicsX As Long = 4
    Const NumPicsY As Long = 4
    
    Dim sr As New ShapeRange
    Dim sPicture As Shape, sText As Shape
    
    Dim MyPath As String
    Dim FileName As String, FilePath As String
    Dim nX As Long, nY As Long
    Dim x As Double, y As Double
    Dim PicSpaceX As Double, PicSpaceY As Double
        
    MyPath = "C:\jpg\"
    
    FileName = Dir(MyPath & "*.jpg")
    nX = 0
    nY = 0
    
    ' Calculate the spacing between pictures as well as margins
    PicSpaceX = (ActivePage.SizeWidth - PicWidth * NumPicsX) / (NumPicsX + 1)
    PicSpaceY = (ActivePage.SizeHeight - PicHeight * NumPicsY) / (NumPicsY + 1)
    
    Do While FileName <> ""   ' Start the loop.
        FilePath = MyPath & FileName
        
        'Import
        ActiveLayer.Import FilePath
        Set sPicture = ActiveShape
        
        ' Resize and place the picture on the page
        x = (PicWidth + PicSpaceX) * nX + PicSpaceX
        y = (PicHeight + PicSpaceY) * (NumPicsY - nY) - PicHeight
        sPicture.SetBoundingBox x, y, PicWidth, PicHeight, True, cdrCenter

        'Create Name
        Set sText = ActiveLayer.CreateArtisticText(x + PicWidth / 2, y - 0.2, FileName, _
                Font:="Arial", Size:=12, Alignment:=cdrCenterAlignment)

        'Group Name and Shape
        sr.Add sText
        sr.Add sPicture
        sr.Group
        sr.RemoveAll

        FileName = Dir()   ' Get next entry.
        
        nX = nX + 1
        If nX = NumPicsX Then
            nX = 0
            nY = nY + 1
            If nY = NumPicsY And FileName <> "" Then
                nY = 0
                ActiveDocument.AddPages 1
            End If
        End If
    Loop
End Sub