CorelDRAW二次开发源码
本人写的用于从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
页:
[1]