自由手記

Option Explicit

Private Sub Command1_Click()
    'Create-insert-Scale-Rotate-Explode
    'For ii = 0 To oDocument.Blocks.Count - 1
    'MsgBox oDocument.Blocks.Item(ii).Name
    'Next ii
    ' Create the block
    Dim oAutoCad As Object
    Dim oDocument As Object
    Dim oBlock As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Set oDocument = oAutoCad.ActiveDocument
    Dim insertionPnt(0 To 2) As Double
    insertionPnt(0) = 0#: insertionPnt(1) = 0#: insertionPnt(2) = 0#
    Set oBlock = oDocument.Blocks.Add(insertionPnt, "CircleBlock")
    ' Add a circle to the block
    Dim circleObj As Object
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 0: center(1) = 0: center(2) = 0
    radius = 1
    Set circleObj = oBlock.AddCircle(center, radius)
    ' Add a text to the block
    Dim startPoint(0 To 2) As Double
    Dim height As Double
    Dim textString As String
    Dim anObj As Object
    startPoint(0) = 15
    startPoint(1) = 5
    startPoint(2) = 0
    height = 2
    textString = "Block"
    Set anObj = oBlock.AddText(textString, startPoint, height)
    ' Insert the block
    Dim blockRefObj As Object
    insertionPnt(0) = 2#: insertionPnt(1) = 2#: insertionPnt(2) = 0
    Set blockRefObj = oDocument.ModelSpace.InsertBlock(insertionPnt, "CircleBlock", 1#, 1#, 1#, 0)
    ' Scale the block
    Dim basePoint(0 To 2)  As Double
    Dim scaleFactor As Double
    basePoint(0) = 0#
    basePoint(1) = 0#
    basePoint(2) = 0#
    scaleFactor = 10#
    Call blockRefObj.ScaleEntity(basePoint, scaleFactor)
    Dim rotationAngle As Double   'In Radian
    basePoint(0) = 0#
    basePoint(1) = 0#
    basePoint(2) = 0#
    rotationAngle = 1.57
    'Following code rotates anObj about base point (0,0,0) by an angle of 90 degree
    Call blockRefObj.Rotate(basePoint, rotationAngle)
    Dim objs As Variant
    objs = blockRefObj.Explode()
    Dim I As Integer
    For I = LBound(objs) To UBound(objs)
            MsgBox "Entity Name: " & objs(I).entityName
    Next
    oAutoCad.Zoomextents
End Sub

Private Sub Command10_Click()
    Dim oAutoCad As Object
    Dim oMenuBar As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim I As Integer
    For I = 0 To oAutoCad.MenuBar.Count - 1
    If oAutoCad.MenuBar.Item(I).Name = "TestMenu" Then
    oAutoCad.MenuBar.Item(I).RemoveFromMenuBar
    End If
    Next I
End Sub

Private Sub Command11_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    MsgBox oAutoCad.MenuGroups.Item(0).Name
    oAutoCad.MenuGroups.Item(0).SaveAs "MyMenu.mnc", 0 '0 MenuFile is not Compiled,to Compile;1 MenuFile has been Compiled.
    MsgBox oAutoCad.MenuGroups.Item(0).Name
End Sub

Private Sub Command12_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim preferences As Object
    Dim sysTextEditor As String
    Dim newTextEditor As String
    Set preferences = oAutoCad.Application.preferences
    ' Retrieve the current TextEditor value
    sysTextEditor = preferences.Files.TextEditor
    MsgBox "The current value for TextEditor is " & sysTextEditor, vbInformation, "TextEditor Example"
    ' Change the value for TextEditor
    newTextEditor = "c:\windows\notepad.exe"
    preferences.Files.TextEditor = newTextEditor
    MsgBox "The new value for TextEditor is " & newTextEditor, vbInformation, "TextEditor Example"
End Sub

Private Sub Command13_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim preferences As Object
    Set preferences = oAutoCad.Application.preferences
    ' Reset TextEditor to its original value
    preferences.Files.TextEditor = "内部"  '英文版中名称为“Internal”。
    MsgBox "The TextEditor value is reset to " & "内部", vbInformation, "TextEditor Example"
End Sub

Private Sub Command14_Click()
    Dim oAutoCad As Object
    Dim oDocument As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Set oDocument = oAutoCad.ActiveDocument
    '发送"ESC ESC _Copy"命令,其中Chr(32)等同"vbCr"
    oDocument.sendcommand (Chr(3) + Chr(3) + Chr(95) + "copy" + Chr(32))
End Sub

Private Sub Command15_Click()
    Dim oAutoCad As Object
    Dim oDocument As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Set oDocument = oAutoCad.ActiveDocument
    Dim solidObj As Object
    Dim point1(0 To 2) As Double
    Dim point2(0 To 2) As Double
    Dim point3(0 To 2) As Double
    Dim point4(0 To 2) As Double
    
    ' Define the solid
    point1(0) = 0#: point1(1) = 0#: point1(2) = 0#
    point2(0) = 5#: point2(1) = 0#: point2(2) = 0#
    point3(0) = 5#: point3(1) = 8#: point3(2) = 0#
    point4(0) = 0#: point4(1) = 8#: point4(2) = 0#
    ' Create the solid object in model space
    Set solidObj = oDocument.ModelSpace.AddSolid(point1, point2, point3, point4)
    oAutoCad.ZoomAll
End Sub

Private Sub Command16_Click()
'Associativity结合性
'Hatch Pattern Type and Name标识
'AppendOuterLoop添加外边界
'AppendInnerLoop添加内边界
'HatchStyle属性
    Dim oAutoCad As Object
    Dim oDocument As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Set oDocument = oAutoCad.ActiveDocument
    Dim hatchObj As Object
    Dim patternName As String
    Dim PatternType As Long
    Dim bAssociativity As Boolean
    ' Define the hatch
    patternName = "ANSI31"
    PatternType = 0
    bAssociativity = True
    ' Create the associative Hatch object
    Set hatchObj = oDocument.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
    ' Create the outer boundary for the hatch. (a circle)
    Dim outerLoop(0 To 0) As Object
    Dim center(0 To 2) As Double
    Dim radius As Double
    center(0) = 3: center(1) = 3: center(2) = 0
    radius = 100
    Set outerLoop(0) = oDocument.ModelSpace.AddCircle(center, radius)
    ' Append the outerboundary to the hatch
    ' object, and display the hatch
    hatchObj.AppendOuterLoop (outerLoop)
    hatchObj.Evaluate
    oDocument.Regen True
End Sub

Private Sub Command17_Click()
Dim oAutoCad As Object
Dim oSelSet As Object
Dim FilterType As Integer
Dim FilterData As Variant
Dim SelNum As Integer
Set oAutoCad = GetObject(, "AutoCAD.Application")
Randomize
SelNum = Int((100 * Rnd) + 1)
Set oSelSet = oAutoCad.ActiveDocument.SelectionSets.Add("SelPart" + Str(SelNum))
AppActivate "AutoCAD" '击活AutoCAD
FilterType = 0
FilterData = "TEXT"
oSelSet.SelectOnScreen FilterType, FilterData
MsgBox Str(oSelSet.Count)
End Sub

Private Sub Command18_Click()
    Dim oAutoCad As Object
    Dim oDocument As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Set oDocument = oAutoCad.ActiveDocument
    oDocument.SaveAs "Cat.dwg"
End Sub

Private Sub Command19_Click()
    Dim oAutoCad As Object
    Dim oBlock As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim P1, P2 As Variant
    P1 = oAutoCad.ActiveDocument.Utility.GetPoint(, "选择第一点")
    P2 = oAutoCad.ActiveDocument.Utility.GetPoint(P1, "选择对角点")
    Dim Pnts(0 To 7) As Double '同Dim Pnts(7) As Double
    'AddLightWeightPolyline中需二维数组
    Pnts(0) = P1(0): Pnts(1) = P1(1)
    Pnts(2) = P1(0): Pnts(3) = P2(1)
    Pnts(4) = P2(0): Pnts(5) = P2(1)
    Pnts(6) = P2(0): Pnts(7) = P1(1)
    oAutoCad.ActiveDocument.ModelSpace.AddLightWeightPolyline(Pnts).Closed = True
End Sub

Private Sub Command2_Click()

    Dim StatusArray() As Integer
    Dim NameArray() As String
    
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oPreferences As Object
    Set oPreferences = oAutoCad.preferences
    oPreferences.Display.DisplayScreenMenu = 0
    oPreferences.Display.DisplayScrollBars = 0
    oPreferences.Display.DisplayLayoutTabs = 0
    Dim I As Integer
    Dim J As Integer
    Dim Num As Integer
    Num = 0
    For I = 0 To oAutoCad.MenuGroups.Count - 1
        Num = Num + oAutoCad.MenuGroups(I).toolbars.Count
    Next I
    ReDim StatusArray(Num - 1)
    ReDim NameArray(Num - 1)
    
    Dim K As Integer
    K = -1
    For I = 0 To oAutoCad.MenuGroups.Count - 1
        For J = 0 To oAutoCad.MenuGroups(I).toolbars.Count - 1
            K = K + 1
            StatusArray(K) = oAutoCad.MenuGroups(I).toolbars(J).DockStatus
            NameArray(K) = oAutoCad.MenuGroups(I).toolbars(J).Name
            Select Case oAutoCad.MenuGroups(I).toolbars(J).DockStatus
            Case 0 To 4
                oAutoCad.MenuGroups(I).toolbars(J).Visible = 0
            End Select
        Next J
    Next I
End Sub

Private Sub Command3_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oPreferences As Object
    Set oPreferences = oAutoCad.preferences
    oPreferences.Display.DisplayScreenMenu = 1
    oPreferences.Display.DisplayScrollBars = 1
    oPreferences.Display.DisplayLayoutTabs = 1
    Dim I As Integer
    Dim J As Integer
    Dim K As Integer
    For I = 0 To oAutoCad.MenuGroups.Count - 1
    For J = 0 To oAutoCad.MenuGroups(I).toolbars.Count - 1
    For K = 0 To UBound(NameArray)
    If oAutoCad.MenuGroups(I).toolbars(J).Name = NameArray(K) Then
    If StatusArray(K) > -1 And StatusArray(K) < 4 Then
    oAutoCad.MenuGroups(I).toolbars(J).Dock StatusArray(K)
    End If
    End If
    Next K
    Next J
    Next I
End Sub

Private Sub Command4_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    MsgBox oAutoCad.Version
End Sub

Private Sub Command5_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oPreferences As Object
    Set oPreferences = oAutoCad.preferences
    oPreferences.Display.DisplayScreenMenu = 1
    oPreferences.Display.DisplayScrollBars = 1
    oPreferences.Display.DisplayLayoutTabs = 1
    Dim I As Integer
    Dim J As Integer
    For I = 0 To oAutoCad.MenuGroups.Count - 1
    For J = 0 To oAutoCad.MenuGroups(I).toolbars.Count - 1
    oAutoCad.MenuGroups(I).toolbars(J).Visible = 1
    Next J
    Next I
End Sub

Private Sub Command6_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oPreferences As Object
    Set oPreferences = oAutoCad.preferences
    oPreferences.Display.DisplayScreenMenu = 0
    oPreferences.Display.DisplayScrollBars = 0
    oPreferences.Display.DisplayLayoutTabs = 0
    Dim I As Integer
    Dim J As Integer
    For I = 0 To oAutoCad.MenuGroups.Count - 1
    For J = 0 To oAutoCad.MenuGroups(I).toolbars.Count - 1
    If oAutoCad.MenuGroups(I).toolbars(J).Name = "标准" Or oAutoCad.MenuGroups(I).toolbars(J).Name = "Standard" Then
    MsgBox oAutoCad.MenuGroups(I).toolbars(J).Name & oAutoCad.MenuGroups(I).toolbars(J).DockStatus
    End If
    Next J
    Next I
End Sub

Private Sub Command7_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oPreferences As Object
    Set oPreferences = oAutoCad.preferences
    oPreferences.Display.DisplayScreenMenu = 0
    oPreferences.Display.DisplayScrollBars = 0
    oPreferences.Display.DisplayLayoutTabs = 0
    Dim I As Integer
    Dim J As Integer
    For I = 0 To oAutoCad.MenuGroups.Count - 1
    For J = 0 To oAutoCad.MenuGroups(I).toolbars.Count - 1
    If oAutoCad.MenuGroups(I).toolbars(J).Name = "标准" Or oAutoCad.MenuGroups(I).toolbars(J).Name = "Standard" Then
    oAutoCad.MenuGroups(I).toolbars(J).Dock 0
    'oAutoCAD.MenuGroups(I).toolbars(J).Dock 1
    'oAutoCAD.MenuGroups(I).toolbars(J).Dock 2
    'oAutoCAD.MenuGroups(I).toolbars(J).Dock 3
    End If
    Next J
    Next I
End Sub

Private Sub Command8_Click()
    Dim oAutoCad As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    Dim oMenuGroup As Object
    Set oMenuGroup = oAutoCad.MenuGroups.Item(0)
    ' Create the new menu
    Dim oMenu As Object
    Set oMenu = oMenuGroup.Menus.Add("TestMenu")
    ' Add a menu item to the new menu
    Dim oMenuItem As Object
    Dim openMacro As String
    ' Assign the macro string the VB equivalent of "ESC ESC _open "
    openMacro = Chr(3) & Chr(3) & Chr(95) & "open" & Chr(32)
    Set oMenuItem = oMenu.AddMenuItem(oMenu.Count + 1, "Open", openMacro)
    ' Display the menu on the menu bar
    oMenu.InsertInMenuBar (oAutoCad.MenuBar.Count + 1)
End Sub

Private Sub Command9_Click()
    Dim oAutoCad As Object
    Dim oMenuBar As Object
    Set oAutoCad = GetObject(, "AutoCAD.Application")
    MsgBox oAutoCad.MenuBar.Count
    If oAutoCad.MenuBar.Count < 0 Then
    oAutoCad.MenuBar.Item(0).RemoveFromMenuBar
    End If
End Sub