[求助]怎么用VB在CAD中图案填充呀

飞一飞

    哪位大哥帮帮忙，小弟做毕业设计急用．

　如何用ＶＢ　ActiveX技术实现CAD中的图案填充呀

   另外,在CAD中用VB能不能实现图形的打断?

ycp9

    我也 是刚学的，从明经通道出的书上看的一点点 上面有图案填充源代码，摘录下来让你看看，我试过可行

'创建渐变填充
'patType:0为预定义图案，1为用户定义图案
'patName:包括LINEAR, CYLINDER, INVCYLINDER, SPHERICAL HEMISPHERICAL, CURVED, INVSPHERICAL, INVHEMISPHERICAL和INVCURVED
Public Function AddHatchGC(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal patName As String, _
    ByVal associativity As Boolean, ByVal color1 As AcadAcCmColor, ByVal color2 As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    '定义填充对象
    Dim objHatch As AcadHatch
   
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, True, acGradientObject)
   
    objHatch.GradientColor1 = color1
    objHatch.GradientColor2 = color2
   
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
   
    Set AddHatchGC = objHatch
    Exit Function
errHandle:
    If Err.Number = -2145386493 Then
        MsgBox "填充定义边界未闭合！", vbCritical
    End If
    Err.Clear
End Function

'创建真彩色填充
'patType:0为预定义图案，1为用户定义图案
'patName:包括LINEAR, CYLINDER, INVCYLINDER, SPHERICAL HEMISPHERICAL, CURVED, INVSPHERICAL, INVHEMISPHERICAL和INVCURVED
Public Function AddHatchTC(ByRef objList() As AcadEntity, ByVal patType As Integer, _
    ByVal associativity As Boolean, ByVal color As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    '定义填充对象
    Dim objHatch As AcadHatch
   
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, "LINEAR", True, acGradientObject)
   
    objHatch.GradientColor1 = color
    objHatch.GradientColor2 = color
   
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
   
    Set AddHatchTC = objHatch
    Exit Function
errHandle:
    If Err.Number = -2145386493 Then
        MsgBox "填充定义边界未闭合！", vbCritical
    End If
    Err.Clear
End Function

'直接根据X、Y方向增量移动实体
Public Function MoveEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, _
    Optional z As Double = 0)
    Dim ptBase(2) As Double
    Dim ptDest(2) As Double
   
    '基点和目标点的位置
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
   
    objEntity.Move ptBase, ptDest
End Function

'复制对象，并将复制得到的对象移动一定的位置
Public Function CopyEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, _
    Optional z As Double = 0) As AcadEntity
    Dim ptBase(2) As Double
    Dim ptDest(2) As Double
    Dim objCopy As AcadEntity
   
    '基点和目标点的位置
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
   
    Set objCopy = objEntity.Copy
    objCopy.Move ptBase, ptDest
   
    Set CopyEntity = objCopy
End Function

ycp9

    我也 是刚学的，从明经通道出的书上看的一点点 上面有图案填充源代码，摘录下来让你看看，我试过可行

'创建渐变填充
'patType:0为预定义图案，1为用户定义图案
'patName:包括LINEAR, CYLINDER, INVCYLINDER, SPHERICAL HEMISPHERICAL, CURVED, INVSPHERICAL, INVHEMISPHERICAL和INVCURVED
Public Function AddHatchGC(ByRef objList() As AcadEntity, ByVal patType As Integer, ByVal patName As String, _
    ByVal associativity As Boolean, ByVal color1 As AcadAcCmColor, ByVal color2 As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    '定义填充对象
    Dim objHatch As AcadHatch
   
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, patName, True, acGradientObject)
   
    objHatch.GradientColor1 = color1
    objHatch.GradientColor2 = color2
   
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
   
    Set AddHatchGC = objHatch
    Exit Function
errHandle:
    If Err.Number = -2145386493 Then
        MsgBox "填充定义边界未闭合！", vbCritical
    End If
    Err.Clear
End Function

'创建真彩色填充
'patType:0为预定义图案，1为用户定义图案
'patName:包括LINEAR, CYLINDER, INVCYLINDER, SPHERICAL HEMISPHERICAL, CURVED, INVSPHERICAL, INVHEMISPHERICAL和INVCURVED
Public Function AddHatchTC(ByRef objList() As AcadEntity, ByVal patType As Integer, _
    ByVal associativity As Boolean, ByVal color As AcadAcCmColor) As AcadHatch
    On Error GoTo errHandle
    '定义填充对象
    Dim objHatch As AcadHatch
   
    Set objHatch = ThisDrawing.ModelSpace.AddHatch(patType, "LINEAR", True, acGradientObject)
   
    objHatch.GradientColor1 = color
    objHatch.GradientColor2 = color
   
    objHatch.AppendOuterLoop (objList)
    objHatch.Evaluate
    ThisDrawing.Regen True
   
    Set AddHatchTC = objHatch
    Exit Function
errHandle:
    If Err.Number = -2145386493 Then
        MsgBox "填充定义边界未闭合！", vbCritical
    End If
    Err.Clear
End Function

'直接根据X、Y方向增量移动实体
Public Function MoveEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, _
    Optional z As Double = 0)
    Dim ptBase(2) As Double
    Dim ptDest(2) As Double
   
    '基点和目标点的位置
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
   
    objEntity.Move ptBase, ptDest
End Function

'复制对象，并将复制得到的对象移动一定的位置
Public Function CopyEntity(ByVal objEntity As AcadEntity, ByVal x As Double, ByVal y As Double, _
    Optional z As Double = 0) As AcadEntity
    Dim ptBase(2) As Double
    Dim ptDest(2) As Double
    Dim objCopy As AcadEntity
   
    '基点和目标点的位置
    ptBase(0) = 0: ptBase(1) = 0: ptBase(2) = 0
    ptDest(0) = x: ptDest(1) = y: ptDest(2) = z
   
    Set objCopy = objEntity.Copy
    objCopy.Move ptBase, ptDest
   
    Set CopyEntity = objCopy
End Function