OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 16-08-2004, 15:58
kuty
Guest
 
Posts: n/a
Default 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
Reply With Quote
  #2  
Old 17-08-2004, 09:51
kuty
Guest
 
Posts: n/a
Default Got it to Work

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
Reply With Quote
  #3  
Old 17-08-2004, 14:21
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,941
Blog Entries: 4
Default Re: Got it to Work

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:

Code:
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
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
Multiple CDs installed on 1 PC geHucKa CorelDRAW/Corel DESIGNER VBA 1 08-04-2005 11:25
How? scanning multiple images Jerry Corel Photo-Paint VBA 1 04-10-2004 00:57
multiple addins (coreldraw 10) kelley CorelDRAW/Corel DESIGNER VBA 1 10-08-2004 17:56
CorelDraw 12's Align Mark CorelDRAW/Corel DESIGNER VBA 8 16-07-2004 18:24
Printing multiple copies sfldan CorelDRAW CS 0 21-08-2003 15:37


All times are GMT -5. The time now is 16:02.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2023, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com