Объекты AutoCAD

Option Explicit
 
Public Declare Function GetSaveFileName Lib _
"comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
 
Public Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
 
Public Const OFN_HIDEREADONLY = &H4
 
Public Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File open dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowOpen() As String
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.HWND
  VertName.lpstrFilter = "Layer Files (*.lay)" + _
  Chr$(0) + "*.lay" + Chr$(0)
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = "Llamas Are Supreme"
  VertName.flags = 0
  If GetOpenFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    ShowOpen = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function
 
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
' Display and use the File Save dialog
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ShowSave() As String
  Dim strTemp As String
  Dim VertName As OPENFILENAME
  VertName.lStructSize = Len(VertName)
  VertName.hwndOwner = ThisDrawing.HWND
  VertName.lpstrFilter = "Layer Files (*.lay)" + _
  Chr$(0) + "*.lay" + Chr$(0)
  VertName.lpstrFile = Space$(254)
  VertName.nMaxFile = 255
  VertName.lpstrFileTitle = Space$(254)
  VertName.nMaxFileTitle = 255
  VertName.lpstrInitialDir = CurDir
  VertName.lpstrTitle = "Llamas Are Supreme"
  VertName.lpstrDefExt = ".lay"
  VertName.flags = OFN_HIDEREADONLY
  If GetSaveFileName(VertName) Then
    strTemp = (Trim(VertName.lpstrFile))
    ShowSave = Mid(strTemp, 1, Len(strTemp) - 1)
  End If
End Function

Option Explicit
Public Sub SaveSnapShot()
  Dim objLayers As AcadLayers
  Dim objLayer As AcadLayer
  Dim strFile As String
  Dim intFile As Integer
  strFile = ShowSave ' Отображение окна диалога "Сохранить файл"
  
    ' Открытие файла и запись в него информации о состоянии слоев
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objLayers = ThisDrawing.Layers
    Open strFile For Output As intFile
    For Each objLayer In objLayers
      Print #intFile, objLayer.Name & ","; objLayer.Color _
      & ","; objLayer.Freeze & ","; objLayer.Lock & ","; _
      objLayer.LayerOn & ","; objLayer.Linetype
    Next objLayer
  End If
  Close intFile
End Sub
 
Public Sub RestoreSnapShot()
  Dim objLayers As AcadLayers
  Dim objLayer As AcadLayer
  Dim strLayerName As String
  Dim strFile As String
  Dim strActive As String
  Dim strTemp As String
  Dim strVal As String
  Dim intFile As Integer
  On Error GoTo Err_Control
  strFile = ShowOpen ' Отображение окна диалога "Открыть файл"
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objLayers = ThisDrawing.Layers
    'Find the active layer and save its name
    'Then create a temp layer and set it active
    strActive = ThisDrawing.ActiveLayer.Name
    Set objLayer = objLayers.Add("snaphold")
    ThisDrawing.ActiveLayer = objLayer
    
    ' Открытие файла и чтение из него информации о состоянии слоев
    Open strFile For Input As intFile
    Do Until EOF(intFile)
      Line Input #intFile, strVal
      strLayerName = ParseLayer(strVal)
      Set objLayer = objLayers(strLayerName)
      objLayer.Color = CInt(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Freeze = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Lock = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.LayerOn = CBool(ParseLayer(strTemp))
      strTemp = ""
      objLayer.Linetype = ParseLayer(strTemp)
      strTemp = ""
    Loop
    'Now restore the original active layer
    'And delete the temp layer.
    Set objLayer = objLayers(strActive)
    ThisDrawing.ActiveLayer = objLayer
    objLayers("snaphold").Delete
    Set objLayers = Nothing
    Set objLayer = Nothing
    Close intFile
  End If
  Set objLayers = Nothing
  ThisDrawing.Regen acActiveViewport
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
'@~~~~~~~~~~~~~ Parse Layer Info ~~~~~~~~~~~~~~~~~~~~@
' This is a simple function the parses the delimited
' String. The first time you call it for a string,
' Pass it the complete string, for each pass after that
' Pass it an empty string.
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Public Function ParseLayer(ByVal strLayerInfo As String) As String
Static strInitialVal As String
Dim intPos As Integer
  If Len(strLayerInfo) > 0 Then strInitialVal = strLayerInfo
  intPos = InStr(strInitialVal, ",")
  If intPos = 0 Then
    ParseLayer = strInitialVal
    strInitialVal = ""
  Else
    ParseLayer = Left$(strInitialVal, intPos - 1)
    strInitialVal = Mid$(strInitialVal, intPos + 1)
  End If
End Function

Option Explicit

Sub CreateLayerDB()
    Dim objDB As DAO.Database
    Dim objTbl As DAO.TableDef
    Dim objFld As DAO.Field
    Dim objRecSet As DAO.recordset
    Dim objLayer As AcadLayer
    Dim objLayers As AcadLayers
    Dim strDBName As String
    'This is a fast path builder for the database, you can just  hard
    'code it or
    'Use a dialog to get the path and name.
    Set objLayers = ThisDrawing.Layers
    strDBName = Mid(ThisDrawing.FullName, 1, _
    Len(ThisDrawing.FullName) - 3) & "mdb"
    Set objDB = DBEngine(0).CreateDatabase(strDBName, dbLangGeneral)
    'Now we add the table and fields
    With objDB
        Set objTbl = .CreateTableDef("Layers")
        With objTbl
            Set objFld = .CreateField("LName", dbText)
            .Fields.Append objFld
            Set objFld = .CreateField("LColor", dbText)
            .Fields.Append objFld
            Set objFld = .CreateField("LType", dbText)
            .Fields.Append objFld
        End With
        .TableDefs.Append objTbl
        'Open the table
        Set objRecSet = .OpenRecordset("Layers")
        With objRecSet
            'Add the layer info
            For Each objLayer In objLayers
                .AddNew
                !LName = objLayer.Name
                !LColor = objLayer.Color
                !LType = objLayer.Linetype
                .Update
            Next objLayer
        End With
        'Close shop
        objRecSet.Close
    End With
End Sub

Public Sub Test_ChangeLayerPrefix ()
  ChangeLayerPrefix "ADR", "HRV"
End Sub
 
Function ChangeLayerPrefix(OldPrefix As String, NewPrefix As String)
  Dim oLayer As AcadLayer
  For Each oLayer In ThisDrawing.Layers
    If UCase(Left(oLayer.Name, Len(OldPrefix))) = UCase(OldPrefix) Then
      oLayer.Name = NewPrefix & ParseString(oLayer.Name, 1, "-")
    End If
  Next
End Function
 
Private Function ParseString(strIn As String, intLoc As Integer,_
strDelimiter As String) As String
  Dim intPos As Integer
  Dim intStrt As Integer
  Dim intStop As Integer
  Dim intCnt As Integer
  intCnt = intLoc
  Do While intCnt > 0
    intStop = intPos
    intStrt = InStr(intPos + 1, strIn, Left$(strDelimiter, 1))
    If intStrt > 0 Then
      intPos = intStrt
      intCnt = intCnt - 1
    Else
      intPos = Len(strIn) + 1
      Exit Do
    End If
  Loop
  ParseString = Mid$(strIn, intStrt)
End Function

'BEGIN CODE BLOCK
Option Explicit


'@----------------------------------------------------@
'@       Создание текстового стиля на основании       @
'@     информации, сохраненной  в текстовом файле     @
'@----------------------------------------------------@
Public Sub CreateTxtStyles()
  Dim objDialog As New FileDialog
  Dim objStyles As AcadTextStyles
  Dim objStyle As AcadTextStyle
  Dim strStyleName As String
  Dim strFile As String
  Dim strFlag(1) As String
  Dim strVal As String
  Dim intFile As Integer
  Dim dblOblique As Double
  On Error GoTo Err_Control
  objDialog.Title = "AutoCAD Style Files"
  objDialog.Filter = "Text Style (*.ats)|*.ats"
  strFile = objDialog.ShowOpen
  If Len(strFile) > 0 Then
    intFile = FreeFile
    Set objStyles = ThisDrawing.TextStyles
    Open strFile For Input As intFile
    Do Until EOF(intFile)
      Line Input #intFile, strVal
      strStyleName = GetWord(strVal, 1)
      Set objStyle = objStyles.Add(strStyleName)
      objStyle.fontFile = GetWord(strVal, 2)
      objStyle.Height = CDbl(GetWord(strVal, 3))
      objStyle.Width = CDbl(GetWord(strVal, 4))
      'Convert degrees to radians..
      dblOblique = CDbl(GetWord(strVal, 5))
      dblOblique = dblOblique / 180 * (Atn(1) * 4)
      objStyle.ObliqueAngle = dblOblique
      strFlag(0) = GetWord(strVal, 6)
      strFlag(1) = GetWord(strVal, 7)
      'If you change "n" to 0 and "y" to 1
      'The structure could be like this
      'If CBool(strFlag(0)) Then
      If strFlag(0) = "n" Then
        If strFlag(1) = "y" Then
          objStyle.TextGenerationFlag = 2
        End If
      Else
        If strFlag(1) = "y" Then
          objStyle.TextGenerationFlag = 6
        Else
          objStyle.TextGenerationFlag = 4
        End If
      End If
      'Notice No Vertical...
    Loop
    Set objStyles = Nothing
    Set objStyle = Nothing
    Set objDialog = Nothing
    Close intFile
  End If
Exit_Here:
  Exit Sub
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Sub
 
'@~~~~~~~~~~~~~~ GetWord ~~~~~~~~~~~~~~~~~@
' Return a Whole word from a string using
' It location in the string based on a Count
' Of spaces in the string (companion to Count
' Words)
'@~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@
Function GetWord(strText, intLoc As Integer) As String
  Dim intCnt As Integer
  Dim intWordCnt As Integer
  Dim Count As Integer
  Dim intStrtPos As Integer
  Dim intEndPos As Integer
  Dim blnSpace As Integer
  Count = 0
  blnSpace = True
  For intCnt = 1 To Len(strText)
    If Mid(strText, intCnt, 1) = " " Then
      blnSpace = True
    Else
      If blnSpace Then
        blnSpace = False
        Count = Count + 1
        If Count = intLoc Then
          intStrtPos = intCnt
          Exit For
        End If
      End If
    End If
  Next intCnt
  intEndPos = InStr(intStrtPos, strText, " ") - 1
  If intEndPos <= 0 Then intEndPos = Len(strText)
  GetWord = Mid(strText, intStrtPos, _
  intEndPos - intStrtPos + 1)
End Function
'END CODE BLOCK

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@   Задание значения системной переменной  LTSCALE   @
'@----------------------------------------------------@
Public Function SetLTScale(dblNew As Double) As Boolean
  On Error Resume Next
  ThisDrawing.SetVariable "LTSCALE", dblNew
  SetLTScale = (Err.Number = 0)
End Function
'END CODE BLOCK

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@     Копирование координат точки в буфер обмена     @
'@----------------------------------------------------@
Public Sub PointOnClipboard()
  Dim objClip As New DataObject
  Dim objUtil As AcadUtility
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strPnt As String
  Set objUtil = ThisDrawing.Utility
  strPrmt = "Point to place on clipboard: "
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  strPnt = varPnt(0) & "," & varPnt(1)
  'Don't want the Z? Comment next line out
  strPnt = strPnt & "," & varPnt(2)
  objClip.SetText strPnt
  objClip.PutInClipboard
End Sub


' Еще один пример с "Работой над ошибками"
Public Sub PointOnClipboard()
  Dim objClip As New DataObject
  Dim objUtil As AcadUtility
  Dim varPnt As Variant
  Dim strPrmt As String
  Dim strPnt As String
  Dim varErr As Variant
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
  strPrmt = "Point to place on clipboard: "
  varPnt = objUtil.GetPoint(Prompt:=strPrmt)
  strPnt = Format(varPnt(0), "0.00") & "," _
  & Format(varPnt(1), "0.00")
  'Don't want the Z? Comment next line out
  strPnt = strPnt & "," & Format(varPnt(2), "0.00")
  objClip.SetText strPnt
  objClip.PutInClipboard
Exit_Here:
  Exit Sub
Err_Control:
  varErr = ThisDrawing.GetVariable("LASTPROMPT")
  If InStr(1, varErr, "*Cancel*") <> 0 Then
    Err.Clear
    Resume Exit_Here
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Sub
'END CODE BLOCK

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@           Перевод координат из WCS в UCS           @
'@----------------------------------------------------@
Public Sub CS_Trans()
  '///NEW
  Dim varStartPntTranslated As Variant
  Dim varEndPntTranslated As Variant
  '///End
  Dim Ent As AcadEntity
  Dim myent As Variant
  Dim Start_Point As Variant
  Dim End_Point As Variant
  Dim XStartPoint As Double
  Dim XEndPoint As Double
  Dim YStartPoint As Double
  Dim YEndPoint As Double
  Dim Xcheck As Double
  Dim Ycheck As Double
  Dim doc As Object
  Dim mycount As Integer
  Dim objss As Object
  Dim objSelCol As Object
  mycount = 0
  Set objSelCol = ThisDrawing.SelectionSets
  For Each objss In objSelCol
    If objss.Name = "Mysel" Then
      objss.Delete
      Exit For
    End If
  Next
  Set objss = objSelCol.Add("Mysel")
  objss.SelectOnScreen
  mycount = 0
  If objss.Count > 0 Then
    For Each Ent In objss
      If Ent.EntityName = "AcDbLine" Then
        Start_Point = Ent.StartPoint
        End_Point = Ent.EndPoint
        '///Translations Begin
        varStartPntTranslated = _
        ThisDrawing.Utility.TranslateCoordinates(Start_Point, _
        acWorld, acUCS, False)
        varEndPntTranslated = _
        ThisDrawing.Utility.TranslateCoordinates(End_Point, _
        acWorld, acUCS, False)
        '///Translation Ends
        XStartPoint = Start_Point(0)
        Debug.Print "Old: " & XStartPoint
        '///Now switch
        XStartPoint = varStartPntTranslated(0)
        Debug.Print "New: " & XStartPoint
        YStartPoint = Start_Point(1)
        Debug.Print "Old: " & YStartPoint
        '///Now switch
        YStartPoint = varStartPntTranslated(1)
        Debug.Print "New: " & YStartPoint
        XEndPoint = End_Point(0)
        Debug.Print "Old: " & XEndPoint
        '///Now switch
        XEndPoint = varEndPntTranslated(0)
        Debug.Print "New: " & XEndPoint
        YEndPoint = End_Point(1)
        Debug.Print "Old: " & YEndPoint
        '///Now switch
        YEndPoint = varEndPntTranslated(1)
        Debug.Print "New: " & XEndPoint
      End If
    Next Ent
  End If
End Sub
'END CODE BLOCK

'BEGIN CODE BLOCK
'@----------------------------------------------------@
'@    Создание копии пространства листа (Layouts)     @
'@----------------------------------------------------@
Public Sub LayOutsample(strFrom As String, strTo As String)
  Dim objLayOut As AcadLayout
  'Make sure you use AcadObject
  'So we get the VP!
  Dim objEnt As AcadObject
  Dim objNewLayOut As AcadLayout
  Dim colLayOuts As AcadLayouts
  Dim objEntArray() As Object
  Dim intCnt As Integer
  Dim blnExists As Boolean
  Set colLayOuts = ThisDrawing.Layouts
  For Each objLayOut In colLayOuts
    If objLayOut.Name = "VBD LayOut" Then
      blnExists = True
      Exit For
    End If
  Next objLayOut
  If Not blnExists Then
    Set objNewLayOut = colLayOuts.Add(strTo)
    Set objLayOut = colLayOuts.Item(strFrom)
    'The Block property is the block object
    'Associated with the layout, so get it's
    'Item count and redim the object array.
    ReDim objEntArray(objLayOut.Block.Count - 1)
    For Each objEnt In objLayOut.Block
      Set objEntArray(intCnt) = objEnt
      intCnt = intCnt + 1
    Next
    ThisDrawing.CopyObjects objEntArray, objNewLayOut.Block
    objNewLayOut.CopyFrom objLayOut
  End If
End Sub
 
Public Sub Test_LayOutsample()
  LayOutsample "Layout1", "VBA Test"
End Sub
'END CODE BLOCK