Option Explicit
Dim objDBX As Object            ' ObjectDBX对象
Private Sub cmdBrowser_Click()
' 设置标准对话框
With dlgCommon
.DialogTitle = "选择图形文件"
.Filter = "图形文件(*.dwg)|*.dwg|所有文件(*.*)|*.*"
.InitDir = ThisDrawing.Application.Path
.ShowOpen
End With
' 文件类型错误的判断
If StrComp(Right(dlgCommon.FileName, 3), "dwg", vbTextCompare) <> 0 Then
MsgBox "不支持的文件类型!", vbCritical, "警告"
Exit Sub
End If
' 在文本框中显示文件的名称
txtFileName.Text = dlgCommon.FileName
End Sub
Private Sub cmdCancel_Click()
End
End Sub
Private Sub cmdOk_Click()
If chkLinetype.Value = True Then
Call ImportLinetypes
End If
' 如果导入图层，必须首先导入线型
If chkLayer.Value = True Then
If chkLinetype.Value = False Then Call ImportLinetypes
Call ImportLayers(chkOverWrite.Value)
End If
If chkTextStyle.Value = True Then
Call ImportTextStyles
End If
If chkDimStyle.Value = True Then
Call ImportDimStyles
End If
If chkTitle.Value = True Then
Call ImportEnts(cboLayers.Text)
End If
End
End Sub
Private Sub txtFileName_Change()
' 根据选择文件的有效性，设置控件的状态
If Len(Dir(txtFileName.Text)) <> 0 Then
cmdOk.Enabled = True
' 获得选择的图形的图层列表
objDBX.Open txtFileName.Text
Dim objLayer As AcadLayer
For Each objLayer In objDBX.Layers
cboLayers.AddItem objLayer.Name
Next objLayer
cboLayers.ListIndex = 0
Else
lblErrMsg.ForeColor = vbRed
lblErrMsg.Caption = "所指定的图形文件不存在…"
' 修改控件状态
cmdOk.Enabled = False
cboLayers.Clear
End If
End Sub
Private Sub UserForm_Initialize()
' 根据AutoCAD的版本来确定使用ObjectDBX的版本
If Left(Version, 2) = "15" Then
Set objDBX = CreateObject("ObjectDBX.AxDbDocument.1")
ElseIf Left(Version, 2) = "16" Then
Set objDBX = CreateObject("ObjectDBX.AxDbDocument.16")
End If
' 设置控件的状态
cmdOk.Enabled = False
chkLayer.Value = True
chkLinetype.Value = True
chkTextStyle.Value = True
chkDimStyle.Value = True
chkTitle.Value = True
chkOverWrite.Value = True
End Sub
' 导入其他图形的图层配置
Private Sub ImportLayers(ByVal bOverWrite As Boolean)
Dim objLayer As AcadLayer
For Each objLayer In objDBX.Layers
If Not HasLayer(objLayer.Name) Then
ThisDrawing.Layers.Add objLayer.Name
Call CopyLayerSetting(ThisDrawing.Layers(objLayer.Name), objLayer)
Else
If bOverWrite Then
Call CopyLayerSetting(ThisDrawing.Layers(objLayer.Name), objLayer)
End If
End If
Next objLayer
End Sub
' 判断当前图形中是否存在某个名称的图层
Private Function HasLayer(ByVal strLayer As String) As Boolean
HasLayer = False
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.Layers
If StrComp(objLayer.Name, strLayer) = 0 Then
HasLayer = True
Exit Function
End If
Next objLayer
End Function
' 在两个图层之间复制属性
Private Sub CopyLayerSetting(ByVal objLayer1 As AcadLayer, ByVal objLayer2 As AcadLayer)
objLayer1.linetype = objLayer2.linetype
objLayer1.LayerOn = objLayer2.LayerOn
objLayer1.Lineweight = objLayer2.Lineweight
objLayer1.Lock = objLayer2.Lock
objLayer1.TrueColor = objLayer2.TrueColor
objLayer1.ViewportDefault = objLayer2.ViewportDefault
End Sub
' 导入其他图形的线型
Private Sub ImportLinetypes()
Dim linetype(0) As AcadLineType
Dim objLinetype As AcadLineType
For Each objLinetype In objDBX.Linetypes
If Not HasLinetype(objLinetype.Name) Then
Set linetype(0) = objLinetype
objDBX.CopyObjects linetype, ThisDrawing.ModelSpace
End If
Next objLinetype
End Sub
' 判断当前图形中是否存在某个名称的线型
Private Function HasLinetype(ByVal strLinetype As String) As Boolean
HasLinetype = False
Dim objLinetype As AcadLineType
For Each objLinetype In ThisDrawing.Linetypes
If StrComp(objLinetype.Name, strLinetype) = 0 Then
HasLinetype = True
Exit Function
End If
Next objLinetype
End Function
' 导入其他图形中的文字样式
Private Sub ImportTextStyles()
Dim textStyle(0) As AcadTextStyle
Dim objTextStyle As AcadTextStyle
For Each objTextStyle In objDBX.TextStyles
If Not HasTextStyle(objTextStyle.Name) Then
Set textStyle(0) = objTextStyle
objDBX.CopyObjects textStyle, ThisDrawing.ModelSpace
End If
Next objTextStyle
End Sub
' 判断当前图形中是否存在某个名称的文字样式
Private Function HasTextStyle(ByVal strTextStyle As String) As Boolean
HasTextStyle = False
Dim objTextStyle As AcadTextStyle
For Each objTextStyle In ThisDrawing.TextStyles
If StrComp(objTextStyle.Name, strTextStyle) = 0 Then
HasTextStyle = True
Exit Function
End If
Next objTextStyle
End Function
' 导入其他图形的标注样式
Private Sub ImportDimStyles()
Dim dimStyle(0) As AcadDimStyle
Dim objDimStyle As AcadDimStyle
For Each objDimStyle In objDBX.DimStyles
If Not HasDimStyle(objDimStyle.Name) Then
Set dimStyle(0) = objDimStyle
objDBX.CopyObjects dimStyle, ThisDrawing.ModelSpace
End If
Next objDimStyle
End Sub
' 判
断当前图形中是否存在某个名称的标注样式
Private Function HasDimStyle(ByVal strDimStyle As String) As Boolean
HasDimStyle = False
Dim objDimStyle As AcadDimStyle
For Each objDimStyle In ThisDrawing.DimStyles
If StrComp(objDimStyle.Name, strDimStyle) = 0 Then
HasDimStyle = True
Exit Function
End If
Next objDimStyle
End Function
' 导入其他图形中某个图层上的所有实体
Private Sub ImportEnts(ByVal strLayer As String)
Dim objEnt(0) As AcadEntity
Dim ent As AcadEntity
textstyleFor Each ent In objDBX.ModelSpace
If StrComp(ent.Layer, strLayer) = 0 Then
Set objEnt(0) = ent
objDBX.CopyObjects objEnt, ThisDrawing.ModelSpace
End If
Next ent
End Sub

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。