OberonPlace.com Forums  

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

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 28-07-2004, 15:54
Anonymous
Guest
 
Posts: n/a
Default Perimeter help

Is there a way to get the length of the curve to go to the clipboard so it can be pasted into the document or be automatically placed on the page as a new text object?

Code:
Option Explicit

Public Sub measure_perimeter()
    Dim doc As Document, old_units As Long
    Dim sDupShape As Shape
    Dim length As String, shape_count As Long
   
    shape_count = ActiveSelection.Shapes.Count
    If shape_count > 0 Then
        'Set the document units to horizontal ruler units
        Set doc = ActiveDocument
        doc.BeginCommandGroup "IsoCalc.com's Perimeter temporary shapes"
        old_units = doc.Unit
        doc.Unit = doc.Rulers.HUnits
        'Get the length of the shape or shapes and tidy up
        ActiveSelection.Duplicate
        ActiveSelection.UngroupAll
        Set sDupShape = ActiveSelection.Combine
        length = (sDupShape.Curve.length * doc.WorldScale) & Choose(doc.Unit + 1, " tenth-microns", _
                    " inches", " feet", "mm", "cm", " pixels", " miles", "m", _
                    "km", " didots", " Agate", "yds", " pica", " cicero", "pt", _
                    "Q", "H")
        doc.EndCommandGroup
        doc.Undo
        doc.Unit = old_units
        'Report the length
         
        If shape_count = 1 Then
            MsgBox "The perimeter is " & length & ".", vbOKOnly, "Perimeter"
        Else
            MsgBox "The sum perimeter of all " & shape_count & " shapes is" & length & ".", vbOKOnly, "Perimeter"
        End If
    End If
End Sub
Reply With Quote
  #2  
Old 18-08-2004, 21:26
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default Re: Perimeter help

Quote:
Originally Posted by scottymoi
Is there a way to get the length of the curve to go to the clipboard so it can be pasted into the document or be automatically placed on the page as a new text object?
Yes, but you will need to use Windows API for this. Here is the code to do this. Put this in a separate VBA module so you can reuse it in your other projects, if you like:

Code:
Option Explicit

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Dest As Long, ByVal Src As String, ByVal length As Long)
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_ZEROINIT = &H40
Private Const CF_TEXT = 1

Public Sub CopyToClipboard(ByVal sText As String)
    Dim hMem As Long
    Dim pPtr As Long
    Dim dwSize As Long
    
    If OpenClipboard(AppWindow.Handle) <> 0 Then
        EmptyClipboard
        dwSize = Len(sText) + 1
        hMem = GlobalAlloc(GMEM_MOVEABLE + GMEM_ZEROINIT, dwSize)
        If hMem Then
            pPtr = GlobalLock(hMem)
            CopyMemory pPtr, sText, dwSize
            GlobalUnlock hMem
            SetClipboardData CF_TEXT, hMem
        End If
        CloseClipboard
    End If
End Sub
The function CopyToClipboard can be used to copy a text string to clipboard directly.

You can just use it like this:

Code:
CopyToClipboard "Some Text"
Now, back to your code. Personally I wouldn't duplicate your objects to determine the total length. Just use their display curves and walk through every object and add the length up. Here is a little bit reworked version of your macro:

Code:
Option Explicit

Public Sub MeasurePerimeter()
    Dim sLength As String
    Dim nShapeCount As Long
    Dim s As Shape
    Dim dLength As Double
    Dim eUnit As cdrUnit
    
    nShapeCount = ActiveSelection.Shapes.Count
    If nShapeCount > 0 Then
        dLength = 0
        For Each s In ActiveSelection.Shapes
            dLength = dLength + s.DisplayCurve.length
        Next s
        
        With ActiveDocument
            eUnit = .Rulers.HUnits
            dLength = .FromUnits(dLength * .WorldScale, eUnit)
        End With
        sLength = dLength & " " & Choose(eUnit + 1, "tenth-microns", _
                    "inches", "feet", "mm", "cm", "pixels", "miles", "m", _
                    "km", "didots", "Agate", "yds", "pica", "cicero", "pt", _
                    "Q", "H")
          
        If nShapeCount = 1 Then
            MsgBox "The perimeter is " & sLength & ".", vbOKOnly, "Perimeter"
        Else
            MsgBox "The sum perimeter of all " & nShapeCount & " shapes is " & sLength & ".", vbOKOnly, "Perimeter"
        End If
        
        CopyToClipboard sLength
    End If
End Sub
Here are a few tricks I used above:

1. Using Shape.DisplayCurve of each shape in the selection to retrieve the curve information from even non-curve objects such as Rectangles and Ellipses. Note that this method will fail for text, bitmaps, OLE objects and similar. But so will the Combine. You might want to do some extra checks in the code to avoid run-time errors.

2. I used the new method in CorelDRAW 12 Document.FromUnits to convert a value in internal VBA document units (inches by default) into the requested units (the units of the horizontal ruler)

3. Using the CopyToClipboard function shown in the previous code block to copy the actual curve length to clipboard at the end of the macro.

I hope this helps.
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
Text following perimeter of circle Ghidrah Corel Photo-Paint VBA 1 08-10-2004 21:51
CDRAW 8 - MEASURE PERIMETER colinstone New product ideas 1 23-04-2004 00:15


All times are GMT -5. The time now is 04:40.


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