OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 03-02-2006, 07:59
akayani
Guest
 
Posts: n/a
Default Objects in Document

Code:
Dim s As Shape
For Each s In ActivePage.Shapes
s.Type = cdrBitmapShape Then
This works for a page

Code:
Dim ss As Shape
For Each ss In ActiveDocument.Shapes
If ss.Type = cdrBitmapShape Then
This is incorrect... Is there a similar method for processing items in a whole document.

Thanks...
Yani
Reply With Quote
  #2  
Old 03-02-2006, 08:05
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

You need to go through pages yourself:

Code:
Sub ProcessBitmaps()
     Dim p As Page
     Dim s As Shape
     For Each p In ActiveDocument.Pages
          For Each s In p.Shapes.FindShapes(Type:=cdrBitmapShape)
               ' ... do something to the bitmaps found on the page
          Next s
     Next p
End Sub
You might also want to process the shapes on masterlayers. In this case you might loop through pages by index and start with index 0 which indicates the master page:

Code:
Sub ProcessBitmaps2()
     Dim n As Integer
     Dim p As Page
     Dim s As Shape
     For n = 0 To ActiveDocument.Pages.Count
          Set p = ActiveDocument.Pages(n)
          For Each s In p.Shapes.FindShapes(Type:=cdrBitmapShape)
               ' ... do something to the bitmaps found on the page
          Next s
     Next n
End Sub
That's it.
Reply With Quote
  #3  
Old 03-02-2006, 08:25
akayani
Guest
 
Posts: n/a
Default

Alex thanks for that...

Code:
    Case 2 'This Document
        MsgBox "Warning all greyscale bitmaps in the Whole Document will be converted as per your settings!"
        
    Dim p As Page
    Dim s As Shape
    
        For Each p In ActiveDocument.Pages
             For Each s In p.Shapes.FindShapes(Type:=cdrBitmapShape)
                  If s.Type = cdrBitmapShape Then
                    
                        If s.Bitmap.Mode = cdrGrayscaleImage Then
                        s.CreateSelection
                        ProcessBitmap 'Calls the bitmap processing
                        End If
                    
                    End If
             Next s
        Next p
    Exit Sub

End Select
I can see this at work but when I review the document it has deleted all the objects except those on the last page processed. Got any clues?

Yani
Reply With Quote
  #4  
Old 03-02-2006, 08:54
ddonnahoe's Avatar
ddonnahoe ddonnahoe is offline
Senior Member
 
Join Date: Jan 2004
Location: Louisville, KY
Posts: 552
Send a message via ICQ to ddonnahoe Send a message via AIM to ddonnahoe Send a message via MSN to ddonnahoe Send a message via Yahoo to ddonnahoe
Default

What does the ProcessBitmap code look like?
__________________
Sean
Waiting for a ride in the T.A.R.D.I.S.
Reply With Quote
  #5  
Old 03-02-2006, 09:05
akayani
Guest
 
Posts: n/a
Default

Code:
Option Explicit
Public DPI As Long, ApplyICC As Boolean, Antialiasing As cdrAntiAliasingType, TransparentBG As Boolean, SelectImage As String, CMYKProfileUsed As String


Sub UserForm_Initialize()

    'Add list entries to combo box. The value of each
    'entry matches the corresponding ListIndex value
    'in the combo box.
    
    ComboBoxDPI.AddItem "360 DPI"     'ListIndex = 0
    ComboBoxDPI.AddItem "300 DPI"     'ListIndex = 1
    ComboBoxDPI.AddItem "200 DPI"     'ListIndex = 2
    ComboBoxDPI.AddItem "150 DPI"     'ListIndex = 3
    ComboBoxDPI.AddItem "100 DPI"     'ListIndex = 4
    ComboBoxDPI.AddItem "96 DPI"      'ListIndex = 5
    ComboBoxDPI.AddItem "72 DPI"      'ListIndex = 6
   
    ComboBoxSI.AddItem "Selected"            'ListIndex = 0
    ComboBoxSI.AddItem "All on Page"         'ListIndex = 1
    ComboBoxSI.AddItem "All in Document"     'ListIndex = 2
   
    'Use drop-down list
    ComboBoxDPI.Style = fmStyleDropDownList
    'Combo box values are ListIndex values
    ComboBoxDPI.BoundColumn = 0
    'Set combo box to first entry
    ComboBoxDPI.ListIndex = 0
    
    'Use drop-down list
    ComboBoxSI.Style = fmStyleDropDownList
    'Combo box values are ListIndex values
    ComboBoxSI.BoundColumn = 0
    'Set combo box to first entry
    ComboBoxSI.ListIndex = 0
    
'Set default values for checkboxes
ApplyICCCB.Value = True
AntialiasingCB.Value = False
TransparentBGCB.Value = True


End Sub

Private Sub ComboBoxDPI_Click()

    Select Case ComboBoxDPI.Value
    Case 0  '360DPI
        DPI = 360

    Case 1  '300DPI
        DPI = 300

    Case 2  '200DPI
        DPI = 200

    Case 3  '150DPI
        DPI = 150

    Case 4  '100DPI
        DPI = 100

    Case 5  '96DPI
        DPI = 96

    Case 6  '72DPI
        DPI = 72

    End Select

End Sub

Private Sub ComboBoxSI_Click()

    Select Case ComboBoxSI.Value
    Case 0  'Selection
        SelectImage = 0
        
    Case 1  'This page
        SelectImage = 1

    Case 2  'Whole Document
        SelectImage = 2

    End Select

End Sub

Private Sub QTOK_Click()

''Setup for checkbox ICC
'If ApplyICCCB.Value = True Then
'        ApplyICC = True
'    Else
'        ApplyICC = False
'End If

'Setup for checkbox Anti-aliasing
If AntialiasingCB.Value = True Then
        Antialiasing = 1 'cdrNormalAntiAliasing
    Else
        Antialiasing = 0 'cdrNoAntiAliasingType
End If

'Setup for checkbox Transparency
If TransparentBGCB.Value = True Then
        TransparentBG = True
    Else
        TransparentBG = False
End If

'Check the current profile in use
CMYKProfileUsed = ColorManager.CurrentProfile(clrSeparationPrinter).Name

Dim s As Shape 'Used for page and document loops


'Work out if anything is selected and what happens with page and document selections
'All cases should check the bitmap is grayscale first... needs code
Select Case SelectImage
    Case 0 'Single object selected
        If ActiveSelectionRange.Count = 0 Then
        MsgBox "There is no object selected."
        Exit Sub
        Else
        ProcessBitmap 'Calls the bitmap processing
        End If
    Case 1 'This Page
        MsgBox "Warning all greyscale bitmaps on the current page will be converted as per your settings!"
        'The following example converts all bitmaps on the active page to the RGB color mode.
        
            
            For Each s In ActivePage.Shapes
            
              If s.Type = cdrBitmapShape Then
            
                If s.Bitmap.Mode = cdrGrayscaleImage Then
                s.CreateSelection
                
                ProcessBitmap 'Calls the bitmap processing
                End If
            
            End If
        Next s

    Exit Sub
    
    Case 2 'This Document
        MsgBox "Warning all greyscale bitmaps in the Whole Document will be converted as per your settings!"
        'The following example converts all bitmaps on the active page to the RGB color mode.
        
    Dim p As Page
    
        For Each p In ActiveDocument.Pages
             For Each s In p.Shapes.FindShapes(Type:=cdrBitmapShape)
                  If s.Type = cdrBitmapShape Then
                    
                        If s.Bitmap.Mode = cdrGrayscaleImage Then
                        s.CreateSelection
                        ProcessBitmap 'Calls the bitmap processing
                        End If
                    
                    End If
             Next s
        Next p
    Exit Sub

End Select

End Sub

Private Sub ProcessBitmap()
'Get for color profile
'Dim CMYKProfileUsed As String ' Made a public var
'CMYKProfileUsed = ColorManager.CurrentProfile(clrSeparationPrinter).Name

'This needs a clean up Shape is one object Shape Range is many only one shape will be selected at a time

'Setup for checkbox ICC - This code moved to accomodate multi image and need to reset the var
If ApplyICCCB.Value = True Then
        ApplyICC = True
    Else
        ApplyICC = False
End If

'This bit is about Case 1 selected bitmap
Dim OrigSelection As ShapeRange
Set OrigSelection = ActiveSelectionRange
Dim MyBitmap As Shape

Dim AlreadyAppliedICC As String
Dim MyBitmapData As String

'Get a profile that is listed in the profile field
MyBitmapData = ActiveShape.ObjectData("Profile").Value


'Has a profile been applied and what to write in the profile field
If ApplyICC = True Then
        If MyBitmapData = "" Then
        ApplyICC = True
        Else
        AlreadyAppliedICC = "+ " + MyBitmapData
        ApplyICC = False
        End If
Else
        If ApplyICC = False Then
        AlreadyAppliedICC = MyBitmapData
        Else
        End If
End If

'Manulipulate the bitmap
Set MyBitmap = OrigSelection.ConvertToBitmapEx(cdrGrayscaleImage, False, TransparentBG, DPI, Antialiasing, ApplyICC, False, 95)

'The value for Profile Data noting if a profile was previously applied
Dim ProfileVal As String
If ApplyICC = True Then
        ProfileVal = CMYKProfileUsed
    Else
        ApplyICC = False
        ProfileVal = AlreadyAppliedICC
End If

'Insert Object Data Profile
CheckDataItem ("Profile")
MyBitmap.ObjectData("Profile").Value = ProfileVal

'Convert variable to a string for object field
Dim TransparentVal As String
If TransparentBG = True Then
        TransparentVal = "Transparent"
    Else
        TransparentBG = False
        TransparentVal = "Opaque"
End If

'Insert Object Data for Transparent
CheckDataItem ("Transparent")
MyBitmap.ObjectData("Transparent").Value = TransparentVal

'Convert variable to a string for object field
Dim AntialiasingVal As String
If Antialiasing = 0 Then
        AntialiasingVal = "None"
    Else
        Antialiasing = 1
        AntialiasingVal = "Standard"
End If

'Insert Object Data Anti-Aliasing
CheckDataItem ("Anti-Aliasing")
MyBitmap.ObjectData("Anti-Aliasing").Value = AntialiasingVal

'Convertion is not required for DPI
'Insert Object Data DPI
CheckDataItem ("DPI")
MyBitmap.ObjectData("DPI").Value = DPI

'So that when a bitmap is selected the sub finishes with a selected object & refreshed Object Data dialogue
MyBitmap.Selected = True
Application.Refresh
Refresh

End Sub

'Check for the existance of object field
Private Sub CheckDataItem(diName As String)

Dim bFound As Boolean
Dim df As DataField

bFound = False

For Each df In ActiveDocument.DataFields
    If df.Name = diName Then
        bFound = True
        Exit For
    End If
Next df

If bFound = False Then ActiveDocument.DataFields.Add diName, , True, True

End Sub

'The cancel button
Private Sub QTCancel_Click()
    End
End Sub
That's the whole lot...

Needs a bit of a clean up but it basically works bar the objects being deleted when Case 2 whole document is processed. It's run from a form.

Yani
Reply With Quote
  #6  
Old 03-02-2006, 10:31
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default

I will look at your code a bit more later but there are a few things that I would like to note now:

1. Once you do Shapes.FindShapes(Type:=cdrBitmapShape) you don't have to check the type of the object returned. It will be a bitmap guaraneed, so you can remove that check from the loop. You can also add the same FindShape trick in your loop for the shapes in the page

2. Try to avoid creating a selection inside the macro and then use the currently selected object for later processing. This is very inefficient. Rather just pass the shape on to your ProcessBitmap function and work with that shape directly. Something like this...

Instead of:

Code:
Sub DoTheLoop()
...
s.CreateSelection
ProcessBitmap
...
End Sub

Sub ProcessBitmap()
...
Set MyNewBitmap = ActiveShape.CreateBitmapEx(...)
...
End Sub
Consider rewriting it like this:

Code:
Sub DoTheLoop()
...
ProcessBitmap s
...
End Sub

Sub ProcessBitmap(ByVal sBitmap As Shape)
...
Set MyNewBitmap = sBitmap.CreateBitmapEx(...)
...
End Sub
This will be much faster and more reliable.
Reply With Quote
  #7  
Old 03-02-2006, 17:05
akayani
Guest
 
Posts: n/a
Default

Cool Alex...

Wait till I have a bit more of a play before looking at this again.

Because I used the Macro Recorder at the start to get a handle on Object Names... well I'm sure you can see that it's working against me now as I build up the code.

Yani
Reply With Quote
  #8  
Old 03-02-2006, 18:56
akayani
Guest
 
Posts: n/a
Default

This is pretty much OK I've cleaned out stuff etc...

Code:
Option Explicit
Public DPI As Long, ApplyICC As Boolean, Antialiasing As cdrAntiAliasingType, TransparentBG As Boolean, SelectImage As String, CMYKProfileUsed As String, SelectedBitmap As Shape, ConvertedBitmap As Shape

Sub UserForm_Initialize()

    'Add list entries to combo box. The value of each
    'entry matches the corresponding ListIndex value
    'in the combo box.
    
    ComboBoxDPI.AddItem "360 DPI"     'ListIndex = 0
    ComboBoxDPI.AddItem "300 DPI"     'ListIndex = 1
    ComboBoxDPI.AddItem "200 DPI"     'ListIndex = 2
    ComboBoxDPI.AddItem "150 DPI"     'ListIndex = 3
    ComboBoxDPI.AddItem "100 DPI"     'ListIndex = 4
    ComboBoxDPI.AddItem "96 DPI"      'ListIndex = 5
    ComboBoxDPI.AddItem "72 DPI"      'ListIndex = 6
   
    ComboBoxSI.AddItem "Selected"            'ListIndex = 0
    ComboBoxSI.AddItem "All on Page"         'ListIndex = 1
    ComboBoxSI.AddItem "All in Document"     'ListIndex = 2
   
   
    'Combo box values are ListIndex values
    ComboBoxDPI.BoundColumn = 0
    'Set combo box to first entry
    ComboBoxDPI.ListIndex = 0
    
    'Combo box values are ListIndex values
    ComboBoxSI.BoundColumn = 0
    'Set combo box to first entry
    ComboBoxSI.ListIndex = 0
    
'Set default values for checkboxes
ApplyICCCB.Value = True
AntialiasingCB.Value = False
TransparentBGCB.Value = True


End Sub

Private Sub ComboBoxDPI_Click()

'Set the Var DPI using the ComboBoxDPI

    Select Case ComboBoxDPI.Value
    Case 0
        DPI = 360

    Case 1
        DPI = 300

    Case 2
        DPI = 200

    Case 3
        DPI = 150

    Case 4
        DPI = 100

    Case 5
        DPI = 96

    Case 6
        DPI = 72

    End Select

End Sub

Private Sub ComboBoxSI_Click()

'Set the Var SelectImage using the ComboBoxSI
    
    Select Case ComboBoxSI.Value
    Case 0  'Selection
        SelectImage = 0
        
    Case 1  'This page
        SelectImage = 1

    Case 2  'Whole Document
        SelectImage = 2

    End Select

End Sub

Private Sub QTOK_Click()

Dim Response

'Setup for checkbox ICC //Moved to allow correct recall after second bitmap selection

'Setup for checkbox Anti-aliasing
If AntialiasingCB.Value = True Then
        Antialiasing = 1 'cdrNormalAntiAliasing
    Else
        Antialiasing = 0 'cdrNoAntiAliasingType
End If

'Setup for checkbox Transparency
If TransparentBGCB.Value = True Then
        TransparentBG = True
    Else
        TransparentBG = False
End If

'Get the current profile in use
CMYKProfileUsed = ColorManager.CurrentProfile(clrSeparationPrinter).Name


'Work out if anything is selected and what happens with page and document selections
'Cases 1 & 2 check the bitmap is grayscale first...
Select Case SelectImage
    
Case 0 'Single object selected
    If ActiveSelectionRange.Count = 0 Then
        MsgBox "There is no object selected."
        Exit Sub
            Else
            Set SelectedBitmap = ActiveShape
            ProcessBitmap SelectedBitmap 'Calls the bitmap processing
            
            'So that when a bitmap is selected the sub finishes with a selected object & refreshed Object Data dialogue
            ConvertedBitmap.Selected = True
            Application.Refresh
            Refresh
    End If
    
Case 1 'This Page
   Response = MsgBox("Warning all greyscale bitmaps on the current page will be converted as per your settings!", 1)
       If Response = 1 Then
            For Each SelectedBitmap In ActivePage.Shapes
                
                If SelectedBitmap.Type = cdrBitmapShape Then
                
                    If SelectedBitmap.Bitmap.Mode = cdrGrayscaleImage Then
                    'SelectedBitmap.CreateSelection
                    ProcessBitmap SelectedBitmap 'Calls the bitmap processing
                    End If
                    
                End If
      
            Next SelectedBitmap
        Else
        End If
Exit Sub

Case 2 'This Document
    Response = MsgBox("Warning all greyscale bitmaps in the current DOCUMENT will be converted as per your settings!", 1)
    If Response = 1 Then
        Dim p As Page
       
        For Each p In ActiveDocument.Pages
            
             For Each SelectedBitmap In p.Shapes.FindShapes(Type:=cdrBitmapShape)
                    If SelectedBitmap.Type = cdrBitmapShape Then
    
                        If SelectedBitmap.Bitmap.Mode = cdrGrayscaleImage Then
                        ProcessBitmap SelectedBitmap 'Calls the bitmap processing
                        End If
    
                    End If
             Next SelectedBitmap

        Next p
        
    Else
    End If
Exit Sub

End Select

End Sub

Private Sub ProcessBitmap(ByVal SelectedBitmap As Shape)

'Setup for checkbox ICC
If ApplyICCCB.Value = True Then
        ApplyICC = True
    Else
        ApplyICC = False
End If


Dim AlreadyAppliedICC As String
Dim ConvertedBitmapData As String

'Get a profile that is listed in the profile field
ConvertedBitmapData = SelectedBitmap.ObjectData("Profile").Value

'Has a profile been applied and what to write in the profile field
If ApplyICC = True Then
        If ConvertedBitmapData = "" Then
        ApplyICC = True
        Else
        AlreadyAppliedICC = "+ " + ConvertedBitmapData
        ApplyICC = False
        End If
Else
        If ApplyICC = False Then
        AlreadyAppliedICC = ConvertedBitmapData
        Else
        End If
End If


'Manulipulate the bitmap
Set ConvertedBitmap = SelectedBitmap.ConvertToBitmapEx(cdrGrayscaleImage, False, TransparentBG, DPI, Antialiasing, ApplyICC, False, 95)


'Process and insert data in object fields

'The value for Profile Data noting if a profile was previously applied
Dim ProfileVal As String
If ApplyICC = True Then
        ProfileVal = CMYKProfileUsed
    Else
        ApplyICC = False
        ProfileVal = AlreadyAppliedICC
End If

'Insert Object Data Profile
CheckDataItem ("Profile")
ConvertedBitmap.ObjectData("Profile").Value = ProfileVal

'Convert variable to a string for object field
Dim TransparentVal As String
If TransparentBG = True Then
        TransparentVal = "Transparent"
    Else
        TransparentBG = False
        TransparentVal = "Opaque"
End If

'Insert Object Data for Transparent
CheckDataItem ("Transparent")
ConvertedBitmap.ObjectData("Transparent").Value = TransparentVal

'Convert variable to a string for object field
Dim AntialiasingVal As String
If Antialiasing = 0 Then
        AntialiasingVal = "None"
    Else
        Antialiasing = 1
        AntialiasingVal = "Standard"
End If

'Insert Object Data Anti-Aliasing
CheckDataItem ("Anti-Aliasing")
ConvertedBitmap.ObjectData("Anti-Aliasing").Value = AntialiasingVal

'Conversion is not required for DPI
'Insert Object Data DPI
CheckDataItem ("DPI")
ConvertedBitmap.ObjectData("DPI").Value = DPI

End Sub

'Check for the existance of object field
Private Sub CheckDataItem(diName As String)

Dim bFound As Boolean
Dim df As DataField

bFound = False

For Each df In ActiveDocument.DataFields
    If df.Name = diName Then
        bFound = True
        Exit For
    End If
Next df

If bFound = False Then ActiveDocument.DataFields.Add diName, , True, True

End Sub

'The cancel button
Private Sub QTCancel_Click()
    End
End Sub
Note that I've renamed all the Vars so it can be understood easily...

Only issue now is why when using Case 2 Whole Document it deletes bitmaps on all the pages except the current page. I checked and it's only the bitmaps it processes it is deleting, not whole pages or anything weird like that.

Yani

Last edited by akayani; 06-02-2006 at 06:21.
Reply With Quote
  #9  
Old 06-02-2006, 06:52
akayani
Guest
 
Posts: n/a
Default

Alex,

I tired Case 2 like this too...

Code:
Case 2 'This Document
    Response = MsgBox("Warning all greyscale bitmaps in the current DOCUMENT will be converted as per your settings!", 1)
    If Response = 1 Then
        Dim p As Page
        Dim n As Integer
       
        For n = 1 To ActiveDocument.Pages.Count
        Set p = ActiveDocument.Pages(n)
            
             For Each SelectedBitmap In p.Shapes.FindShapes(Type:=cdrBitmapShape)
                    If SelectedBitmap.Type = cdrBitmapShape Then
    
                        If SelectedBitmap.Bitmap.Mode = cdrGrayscaleImage Then
                        ProcessBitmap SelectedBitmap 'Calls the bitmap processing
                        End If
    
                    End If
             Next SelectedBitmap

        Next n
        
    Else
    End If
Exit Sub
With the same result... all viable bitmap objects on pages other than the current page are deleted.

Yani
Reply With Quote
  #10  
Old 06-02-2006, 07:15
akayani
Guest
 
Posts: n/a
Default

The code is actually not deleting the bitmap but reducing it to 1 pixel and centering it on the page. As seen in object manager.

I've uploaded the form with the code here...

http://people.aapt.net.au/~theyan/testmacros/

I think that is the easy way to see what's happening.

Yani
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
Glitches with Names of Objects Granite Golem CorelDRAW/Corel DESIGNER VBA 14 01-06-2005 03:38
How to get objects from another opened corel document ama CorelDRAW/Corel DESIGNER VBA 12 24-02-2004 07:11
I need to update objects visibility faster NEHovis Corel Photo-Paint VBA 0 18-07-2003 07:54
Copying objects to clipboard then closing document. CORNMEN CorelDRAW/Corel DESIGNER VBA 4 31-03-2003 09:52
Active document issues.. wbochar CorelDRAW/Corel DESIGNER VBA 2 19-03-2003 15:15


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


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