|
|
发表于 2008-5-13 14:09:00
|
显示全部楼层
yth1ofcadbn.JPG
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
VERSION 5.00
Begin VB.Form MakeNewBlockForm
BorderStyle = 3 'Fixed Dialog
Caption = "创建新图块"
ClientHeight = 3585
ClientLeft = 6060
ClientTop = 2085
ClientWidth = 4860
Icon = "MakeNewBlockForm.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 3585
ScaleWidth = 4860
ShowInTaskbar = 0 'False
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 2175
Left = 2400
ScaleHeight = 2175
ScaleWidth = 2385
TabIndex = 15
Top = 810
Width = 2385
Begin VB.Frame Frame1
Caption = "对象"
Height = 2085
Left = 60
TabIndex = 16
Top = 30
Width = 2265
Begin VB.CommandButton CmdSelectObjects
Height = 435
Left = 240
Picture = "MakeNewBlockForm.frx":548A
Style = 1 'Graphical
TabIndex = 20
Top = 300
Width = 465
End
Begin VB.OptionButton OptNoChange
Caption = "保留"
Height = 315
Left = 300
TabIndex = 19
Top = 960
Width = 1605
End
Begin VB.OptionButton OptBlock
Caption = "转化为块"
Height = 315
Left = 300
TabIndex = 18
Top = 1290
Value = -1 'True
Width = 1605
End
Begin VB.OptionButton OptDelect
Caption = "删除"
Height = 315
Left = 300
TabIndex = 17
Top = 1650
Width = 1605
End
Begin VB.Label SkinLabel3
Caption = "选择对象(&T):"
Height = 225
Left = 780
TabIndex = 21
Top = 405
Width = 1155
End
End
End
Begin VB.CommandButton CmdOK
Caption = "确定"
Default = -1 'True
Height = 495
Left = 1230
TabIndex = 14
Top = 3000
Width = 1065
End
Begin VB.CommandButton CmdCancle
Caption = "取消"
Height = 495
Left = 2940
TabIndex = 13
Top = 3000
Width = 1065
End
Begin VB.Frame Frame2
Caption = "基点"
Height = 2085
Left = 90
TabIndex = 4
Top = 840
Width = 2265
Begin VB.TextBox Text1
Enabled = 0 'False
Height = 270
Left = 450
TabIndex = 11
Text = "0"
ToolTipText = "插入点的Y坐标"
Top = 1620
Width = 1485
End
Begin VB.TextBox Text2
Enabled = 0 'False
Height = 270
Left = 450
TabIndex = 8
Text = "0"
ToolTipText = "插入点的X坐标"
Top = 870
Width = 1485
End
Begin VB.TextBox Text3
Enabled = 0 'False
Height = 270
Left = 450
TabIndex = 7
Text = "0"
ToolTipText = "插入点的Y坐标"
Top = 1260
Width = 1485
End
Begin VB.CommandButton CmdPickPoint
Height = 435
Left = 240
Picture = "MakeNewBlockForm.frx":5B8C
Style = 1 'Graphical
TabIndex = 5
Top = 300
Width = 465
End
Begin VB.Label SkinLabel4
Caption = "拾取点(&K):"
Height = 225
Left = 780
TabIndex = 6
Top = 405
Width = 915
End
Begin VB.Label SkinLabel16
Caption = "X:"
Height = 165
Left = 240
TabIndex = 9
Top = 900
Width = 225
End
Begin VB.Label SkinLabel17
Caption = "Y:"
Height = 165
Left = 240
TabIndex = 10
Top = 1305
Width = 225
End
Begin VB.Label SkinLabel5
Caption = "Z:"
Height = 165
Left = 240
TabIndex = 12
Top = 1665
Width = 225
End
End
Begin VB.TextBox TxtBlockName
Height = 315
Left = 1110
TabIndex = 1
Top = 60
Width = 3615
End
Begin VB.ComboBox ComFolderName
Height = 300
Left = 1110
Style = 2 'Dropdown List
TabIndex = 0
Top = 450
Width = 3615
End
Begin VB.Label SkinLabel1
Caption = "名称:"
Height = 225
Left = 90
TabIndex = 2
Top = 90
Width = 915
End
Begin VB.Label SkinLabel2
Caption = "存放目录:"
Height = 225
Left = 90
TabIndex = 3
Top = 480
Width = 915
End
End
Attribute VB_Name = "MakeNewBlockForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim SSet As Object
Dim ptBase As Variant
Dim strPath As String
Private Sub CmdCancle_Click()
Unload Me
End Sub
Private Sub CmdOK_Click()
If Trim(TxtBlockName.Text) = "" Then
If MsgBox("请输入图块名称", vbCritical + vbOKOnly, AppName) = vbOK Then Exit Sub
End If
Me.Hide
' 提示用户输入块定义的名称
'Dim strName As String
'strName = ThisDrawing.Utility.GetString(True, vbCrLf & "输入块的名称:")
' 获得相对路径
strPath = App.Path & "\BlockLib\" & ComFolderName & "\" & Trim(TxtBlockName) & ".dwg"
'strPath = App.Path & "\BlockLib\" & Trim(TxtBlockName) & ".dwg"
' 将所有的实体移动到原点附近，确保块定义的插入点无误
'Dim ptOrigin(0 To 2) As Double
'ptOrigin(0) = 0: ptOrigin(1) = 0: ptOrigin(2) = 0
'Dim Ent As OBJECT
'For Each Ent In SSet
' Ent.Move ptBase, ptOrigin
'Next
' 将块定义导出
'ThisDrawing.Wblock strPath, SSet ' 使用此方法创建的块没有浏览缩略图
ThisDrawing.SetVariable "FILEDIA", 0
' 将块定义导出
ThisDrawing.SendCommand "-WBLOCK" & vbLf & strPath & vbLf & vbLf & axPoint2lspPoint(ptBase) & vbLf & axSSet2lspEnts(SSet) & vbLf & vbLf
Call CmdOKNextCode
End Sub
Private Sub CmdOKNextCode()
ThisDrawing.SetVariable "FILEDIA", 1
If OptNoChange.Value Then
'For Each Ent In SSet
' Ent.Move ptOrigin, ptBase
'Next
End If
If OptDelect.Value Then
' 删除图形中绘制的所有对象
SSet.Delete
End If
If OptBlock.Value Then
' 删除图形中绘制的所有对象
'SSet.Erase
SSet.Delete
Dim ObjBlock As Object
Set ObjBlock = ThisDrawing.ModelSpace.InsertBlock(ptBase, strPath, 1, 1, 1, 0)
End If
Set SSet = Nothing
Unload Me
End Sub
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub CmdPickPoint_Click()
Me.Hide
' 提示用户输入块定义的基点
ptBase = ThisDrawing.Utility.GetPoint(, vbCrLf & "拾取基点:")
Me.Show
End Sub
Private Sub CmdSelectObjects_Click()
Me.Hide
Set SSet = GetSelectionSetObject
Me.Show
End Sub
Private Sub Form_Load()
On Error GoTo ErrHandle
Dim FSO As Object
Dim Fols As Object
Dim Fol As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Fols = FSO.GetFolder(App.Path & "\BlockLib\")
For Each Fol In Fols.SubFolders
ComFolderName.AddItem Fol.Name
Next
ComFolderName.ListIndex = 0
If Not GetAutoCADApplication(Me) Then CloseSubFroms: Exit Sub
Call MoveXWindowsCenter(Me)
Set FSO = Nothing
Set Fols = Nothing
Exit Sub
ErrHandle:
MsgBox Err.Description, vbCritical + vbOKOnly, AppName
Err.Clear
Unload Me
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 27 Then '用户按了ESC键，退出
Unload Me
End If
End Sub
Private Sub TextFocus(ctl As Control) '定义过程
ctl.SelStart = 0
ctl.SelLength = Len(ctl.Text)
End Sub
Private Sub Text1_GotFocus()
TextFocus Text1 '过程调用
End Sub
Public Property Set Application(ByVal vNewApplication As Object)
Set AcadApp = vNewApplication
End Property
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
|
|
置顶卡
请点击此处下载
