CorelDRAW二次开发源码

liukaimin

本人写的用于从CorelDRAW获取图形数据的源码，因为VB使用指针很麻烦，所以就使用access数据库存储图形数据。请多指教。
Dim m_oAdoCnn As ADODB.Connection
Public Sub output()
    ActiveDocument.Unit = cdrMillimeter
    ActiveDocument.ReferencePoint = cdrBottomLeft
    Set m_oAdoCnn = New ADODB.Connection
    m_oAdoCnn.Mode = adModeShareExclusive
    m_oAdoCnn.Open "Provider=Microsoft.jet.OLEDB.4.0;Data Source=filename.mdb;User ID=;Password=;Jet OLEDB:Database Password=;"
    Dim lShapeCount As Long
    lShapeCount = get_coreldraw_shape(m_oAdoCnn, ActivePage.Shapes, True)
    m_oAdoCnn.Close
    Set m_oAdoCnn = Nothing
End Sub
Private Function get_coreldraw_shape(ByVal m_oAdoCnn As ADODB.Connection, ByVal vShapes As Variant, Optional ByVal isResetId As Boolean = False) As Long
    Static lShapeId As Long
    If isResetId Then lShapeId = 1
    ActiveDocument.Unit = cdrMillimeter
    Dim oShape As CorelDRAW.Shape
    Dim oColorShape As CorelDRAW.Color
    Dim lEntityColor As Long
    Dim sObjectName As String
   
    For Each oShape In vShapes
        Select Case oShape.Type
            Case cdrRectangleShape, cdrEllipseShape, cdrPolygonShape, cdrCurveShape, cdrTextShape
                If oShape.Type <> cdrCurveShape Then
                    oShape.ConvertToCurves
                End If
                If oShape.Type <> cdrCurveShape Then
                    get_coreldraw_shape m_oAdoCnn, oShape.Shapes
                Else
                    If oShape.Outline.Type = cdrOutline Then
                        Set oColorShape = oShape.Outline.Color
                        oColorShape.ConvertToRGB
                        lEntityColor = RGB(oColorShape.RGBRed, oColorShape.RGBGreen, oColorShape.RGBBlue)
                    Else
                        lEntityColor = RGB(255, 255, 255)
                    End If
                    
                    Dim fX As Double, fY As Double, fWidth As Double, fHeight As Double
                    oShape.GetBoundingBox fX, fY, fWidth, fHeight
                    m_oAdoCnn.Execute "insert into Shapes (fShapeId,fShapeType,fShapeLength,fShapeColor,fBoundingBoxLeft,fBoundingBoxBottom,fBoundingBoxRight,fBoundingBoxTop) values (" & lShapeId & "," & cdrCurveShape & "," & oShape.Curve.Length & "," & lEntityColor & "," & fX & "," & fY & "," & fX + fWidth & "," & fY + fHeight & ")"
                    get_curve m_oAdoCnn, oShape.Curve, lShapeId, lEntityColor
   
                    lShapeId = lShapeId + 1
                End If
            Case cdrGroupShape
                get_coreldraw_shape m_oAdoCnn, oShape.Shapes
            Case Else
                If MsgBox("", vbYesNo, "") = vbNo Then
                    get_coreldraw_shape = 0
                    Exit Function
                End If
        End Select
    Next
    get_coreldraw_shape = lShapeId
End Function
Private Sub get_curve(ByVal m_oAdoCnn As ADODB.Connection, ByVal oCurve As CorelDRAW.Curve, ByVal lShapeId As Long, ByVal lEntityColor As Long)
    Dim isCurve As Integer
    Dim oSubPath As CorelDRAW.SubPath
    Dim oNode As CorelDRAW.Node
    Dim fLength As Double
    Dim fX As Double, fY As Double
   
    For Each oSubPath In oCurve.Subpaths
        oSubPath.GetPosition fX, fY
        If oSubPath.Closed Then
            m_oAdoCnn.Execute "insert into Subpaths (fShapeId, fSubpathId,fShapeColor,fSubpathStartPositionX,fSubpathStartPositionY,fSubpathEndPositionX,fSubpathEndPositionY,fStartToLastLength,fEndToLastLength) values (" & lShapeId & "," & oSubPath.Index & "," & lEntityColor & "," & oSubPath.StartNode.PositionX & "," & oSubPath.StartNode.PositionY & "," & oSubPath.StartNode.PositionX & "," & oSubPath.StartNode.PositionY & "," & fX & "," & fY & ")"
        Else
            m_oAdoCnn.Execute "insert into Subpaths (fShapeId, fSubpathId,fShapeColor,fSubpathStartPositionX,fSubpathStartPositionY,fSubpathEndPositionX,fSubpathEndPositionY,fStartToLastLength,fEndToLastLength) values (" & lShapeId & "," & oSubPath.Index & "," & lEntityColor & "," & oSubPath.StartNode.PositionX & "," & oSubPath.StartNode.PositionY & "," & oSubPath.EndNode.PositionX & "," & oSubPath.EndNode.PositionY & "," & fX & "," & fY & ")"
        End If
        
        For Each oNode In oSubPath.Nodes
            isCurve = False
            fLength = 0#
            If Not oNode.Segment Is Nothing Then
                fLength = oNode.Segment.Length
                If oNode.Index = 1 Then
                    If oNode.Segment.Type = cdrCurveSegment Then
                        m_oAdoCnn.Execute "insert into CurveSegments (fShapeId, fSubpathId, fNodeId, fSegmentLength, fNodePositionX, fNodePositionY, fStartControlPointX, fStartControlPointY, fEndControlPointX, fEndControlPointY) values (" & lShapeId & "," & oSubPath.Index & "," & oSubPath.Nodes.Count + 1 & "," & fLength & "," & oNode.PositionX & "," & oNode.PositionY & "," & oNode.Segment.StartingControlPointX & "," & oNode.Segment.StartingControlPointY & "," & oNode.Segment.EndingControlPointX & "," & oNode.Segment.EndingControlPointY & ")"
                    ElseIf oNode.Segment.Type = cdrLineSegment Then
                        m_oAdoCnn.Execute "insert into Nodes (fShapeId, fSubpathId, fNodeId, fSegmentLength, fNodePositionX, fNodePositionY) values (" & lShapeId & "," & oSubPath.Index & "," & oSubPath.Nodes.Count + 1 & "," & fLength & "," & oNode.PositionX & "," & oNode.PositionY & ")"
                    End If
                    fLength = 0#
                Else
                    If oNode.Segment.Type = cdrCurveSegment Then
                        isCurve = True
                        m_oAdoCnn.Execute "insert into CurveSegments (fShapeId, fSubpathId, fNodeId, fSegmentLength, fNodePositionX, fNodePositionY, fStartControlPointX, fStartControlPointY, fEndControlPointX, fEndControlPointY) values (" & lShapeId & "," & oSubPath.Index & "," & oNode.Index & "," & fLength & "," & oNode.PositionX & "," & oNode.PositionY & "," & oNode.Segment.StartingControlPointX & "," & oNode.Segment.StartingControlPointY & "," & oNode.Segment.EndingControlPointX & "," & oNode.Segment.EndingControlPointY & ")"
                    End If
                End If
            End If
            If isCurve = False Then
                m_oAdoCnn.Execute "insert into Nodes (fShapeId, fSubpathId, fNodeId, fSegmentLength, fNodePositionX, fNodePositionY) values (" & lShapeId & "," & oSubPath.Index & "," & oNode.Index & "," & fLength & "," & oNode.PositionX & "," & oNode.PositionY & ")"
            End If
        Next oNode
    Next oSubPath
End Sub