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

飞一飞 发表于 2006-5-25 16:47:00

哪位大哥帮帮忙，小弟做毕业设计急用．
　如何用ＶＢ　ActiveX技术实现CAD中的图案填充呀
   另外,在CAD中用VB能不能实现图形的打断?

ycp9 发表于 2006-5-29 20:25:00

我也是刚学的，从明经通道出的书上看的一点点上面有图案填充源代码，摘录下来让你看看，我试过可行
'创建渐变填充 '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 发表于 2006-5-29 20:25:00

页: [1]

明经CAD社区's Archiver

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