Public Function GetLength(varStart As Variant, varEnd As Variant)_
As Double
  Dim dblLen As Double
  On Error GoTo Err_Control
  dblLen = Sqr((varStart(0) - varEnd(0)) ^ 2 + _
  (varStart(1) - varEnd(1)) ^ 2 + _
  (varStart(2) - varEnd(2)) ^ 2)
  GetLength = dblLen
Exit_here:
  Exit Function
Err_Control:
  MsgBox Err.Description
End Function 
 

Public Function NearestTo(objLine As AcadLine, _
varPoint As Variant) As Variant
  Dim objUtil As Object
  Dim varTemp As Variant
  Dim dblSlope As Double
  Dim dblInvSlope As Double
  Dim dblTemp(0 To 2) As Double
  Dim dblAng As Double
  Dim vStart As Variant
  Dim vEnd As Variant
  Dim x1 As Double
  Dim y1 As Double
  Dim x2 As Double
  Dim y2 As Double
  Dim x3 As Double
  Dim y3 As Double
  Dim Y1Intercept As Double
  Dim Y2Intercept As Double

  On Error GoTo Err_Control
  vStart = objLine.StartPoint
  vEnd = objLine.EndPoint
  x1 = vStart(0)
  y1 = vStart(1)
  x2 = vEnd(0)
  y2 = vEnd(1)
  x3 = varPoint(0)
  y3 = varPoint(1)
  dblSlope = (y2 - y1) / (x2 - x1)
  If dblSlope <> 0 Then
    dblInvSlope = -1 / dblSlope
  Else
    dblInvSlope = 0
  End If
  Y1Intercept = y1 - (dblSlope * x1)
  Y2Intercept = y3 - (dblInvSlope * x3)
  If dblSlope <> 0 Then
    dblTemp(0) = (Y1Intercept - Y2Intercept) / _
    (dblInvSlope - dblSlope)
  Else
    dblTemp(0) = x3
  End If
  dblTemp(1) = (dblSlope * dblTemp(0)) + Y1Intercept
  Set objUtil = ThisDrawing.Utility
  objUtil.CreateTypedArray varTemp, vbDouble, _
  dblTemp(0), dblTemp(1), dblTemp(2)
  NearestTo = varTemp
Exit_Here:
  Exit Function
Err_Control:
  MsgBox Err.Description
  Resume Exit_Here
End Function
 

Private Function Perpendicular(Lin As AcadLine, _
Point As Variant) As Variant
  Dim L1 As AcadLine, L2 As AcadLine, L3 As AcadLine, _
  X1 As AcadXline, X2 As AcadXline
  Dim Ang As Double, Ang2 As Double, PP1, PP2, Inter1, Inter2
  Set L1 = ThisDrawing.ModelSpace.AddLine(Lin.StartPoint, Point)
  If L1.Angle > Lin.Angle Then
    Ang = L1.Angle - Lin.Angle
  Else
    Ang = Lin.Angle - L1.Angle
  End If
  Ang2 = 90 - Degrees(Ang)
  PP1 = ThisDrawing.Utility.PolarPoint(Point, L1.Angle + _
  Radians(180 - Ang2), 1#)
  PP2 = ThisDrawing.Utility.PolarPoint(Point, L1.Angle + _
  Radians(180 + Ang2), 1#)
  Set X1 = ThisDrawing.ModelSpace.AddXline(Point, PP1)
  Set X2 = ThisDrawing.ModelSpace.AddXline(Point, PP2)
  Inter1 = Lin.IntersectWith(X1, acExtendBoth)
  Inter2 = Lin.IntersectWith(X2, acExtendBoth)
  Set L2 = ThisDrawing.ModelSpace.AddLine(Point, Inter1)
  Set L3 = ThisDrawing.ModelSpace.AddLine(Point, Inter2)
  If L2.Length < L3.Length Then
    Perpendicular = L2.EndPoint
  Else
    Perpendicular = L3.EndPoint
  End If
  L1.Delete
  L2.Delete
  L3.Delete
  X1.Delete
  X2.Delete
End Function

'Функция возвращает число Pi (3.14159265359)'
Public Function PI() As Double
  PI = Atn(1) * 4
End Function

'Функция преобразует угол, заданный в радианах, в градусы'
Private Function Degrees(Radians As Double) As Double
  Degrees = Radians / PI * 180
End Function

'Функция преобразует угол, заданный в градусах, в радианы'
Private Function Radians(Degrees As Double) As Double
  Radians = Degrees / 180 * PI
End Function

Public Sub TEST_Perpendicular()
' Используйте эту процедуру для проверки пробы
' функции Perpendicular
  Dim Lin As AcadLine
  Dim Lin2 As AcadLine
  Dim Obj As AcadEntity
  Dim Pt As Variant
  Dim Pt2 As Variant
  Dim dummyPt As Variant
  Pt = ThisDrawing.Utility.GetPoint
  ThisDrawing.Utility.GetEntity Obj, dummyPt, "Select a Line :"
  Set Lin = Obj
  Pt2 = Perpendicular(Lin, Pt)
  Set Lin2 = ThisDrawing.ModelSpace.AddLine(Pt, Pt2)
End Sub
 

Option Explicit

' ВНИМАНИЕ!
' Для использования этой процедуры необходимо
' сделать ссылку на Windows Scripting host object model
' Для этого выберите в редакторе VBA пункт меню
' Tools -> References...
Public Sub vbaShortcut(MyPath As String, strName As String)
  Dim WSHShell As Object
  Dim objShortCut As IWshShortcut_Class
  Dim strDesktop As String
  
  'create an instance of the scripting host
  Set WSHShell = CreateObject("WScript.Shell")
  'Get the desktop folder path
  strDesktop = WSHShell.SpecialFolders("Desktop")
  'Make the shortcut in the desktop folder
  Set objShortCut = WSHShell.CreateShortcut(strDesktop & "\" & strName & ".lnk")
  'The target is the file or folder the shortcut activates
  objShortCut.TargetPath = MyPath
  'Give the shortcut an icon from an exe dll or icon file.
  'if you use an exe or dll you must specify the index of the icon like this:
  'objShortCut.IconLocation = "C:\Program Files\AutoCAD\acad.exe, 0"
  objShortCut.IconLocation = "Moricons.dll, 40"
  'Set a hot key combo
  objShortCut.Hotkey = "ALT+CTRL+F"
  'Add a description
  objShortCut.Description = "Sample short cut."
  'You have to save it, its a file
  objShortCut.Save
End Sub

'And here is a fast test:
Public Sub TEST_vbaShortcut()
  vbaShortcut "C:\WINDOWS\TEMP", "Temp Folder"
End Sub
'End code block
 

Option Explicit

' Пример запроса у пользователя папки с помощью
' API функции SHBrowseForFolder из файла shell32.dll
Public FileInfo() As String
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Public Const MAX_PATH = 260

Declare Function SHBrowseForFolder Lib "shell32.dll" alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, ByVal _
lpWindowName As String) As Long

Declare Function SHGetPathFromIDList Lib _
"shell32.dll" Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long

Public Function ReturnFolder(lngHwnd As Long) As String
  Dim Browser As BROWSEINFO
  Dim lngFolder As Long
  Dim strPath As String
   
  With Browser
    .hOwner = lngHwnd
    .lpszTitle = "Select Directory to work in"
    .pszDisplayName = String(MAX_PATH, 0)
  End With
  strPath = String(MAX_PATH, 0) '<-- VERY Important!!
  lngFolder = SHBrowseForFolder(Browser)
  If lngFolder Then
    SHGetPathFromIDList lngFolder, strPath
    ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
  End If
End Function

Public Function ParseOut(strIn As String, strChar As String) As String
  Dim intCnt As Integer
  Dim strfile As String

  intCnt = 1
  Do
    If Mid(strIn, intCnt, 1) = strChar Then
      strfile = Mid(strIn, 1, intCnt - 1)
      strIn = Mid(strIn, intCnt + 1, Len(strIn))
      ParseOut = strfile
      Exit Function
    End If
    intCnt = intCnt + 1
  Loop
  End Function

Public Sub OpenAndProcessAllDrawings()
  Dim objSelSet As AcadSelectionSet
  Dim objDoc As AcadDocument
  Dim objEnt As AcadEntity
  Dim colFiles As New Collection
  Dim strFolder As String
  Dim intCnt As Integer
  Dim strName As String

  On Error GoTo Err_Control
  strFolder = ReturnFolder(0&)
  If Len(strFolder) > 0 Then
    FindFile colFiles, strFolder, "dwg"
    For intCnt = 1 To colFiles.Count
      Set objDoc = OpenAnyMode(colFiles(intCnt))
      objDoc.Activate
      Set objSelSet = vbdPowerSet("processall")
      objSelSet.Select acSelectionSetAll
      For Each objEnt In objSelSet
        'Call your procedure here
        'Выполнение процедуры над всеми 
        'объектами открытого файла
        bjEnt.Layer = 0 ' Перемещение объектов на слой 0
      Next objEnt
      'To save your changes uncomment this line
      'objDoc.Close True
      'To close without saving uncomment this line
      'objDoc.Close False
    Next intCnt
  End If
Exit_here:
  Exit Sub
Err_Control:
  'because error handling can be varied depending
  'on what you are doing, I have left this to simply
  'dump out if an error occurs.
  MsgBox Err.Description
  Resume Exit_here
End Sub

Public Function OpenAnyMode(strFileName As String) As AcadDocument
  Dim varMode As Variant
  Dim intCnt As Integer
  Dim objDoc As AcadDocument
  On Error GoTo Err_Control
  intCnt = Application.Documents.Count
  If intCnt > 0 Then
  varMode = ThisDrawing.GetVariable("SDI")
    If varMode Then
      Set objDoc = ThisDrawing.Open(strFileName)
    Else
      Set objDoc = Application.Documents.Open(strFileName)
    End If
  Else
    Set objDoc = Application.Documents.Open(strFileName)
  End If
  Set OpenAnyMode = objDoc
Exit_here:
  Exit Function
Err_Control:
  MsgBox "Error opening " & strFileName & vbCrLf & _
  Err.Description
  Resume Exit_here
End Function

Public Sub FindFile(ByRef files As Collection, strDir, strExt)
  Dim strFileName
  If (Right(strDir, 1) <> "\") Then
    strDir = strDir & "\"
  End If
  strFileName = Dir(strDir & "*.*", vbDirectory)
  Do While (strFileName <> "")
    If (UCase(Right(strFileName, 3)) = UCase(strExt)) Then
      files.Add strDir & strFileName
    End If
  strFileName = Dir
  Loop
End Sub

Public Function vbdPowerSet(strName As String) As AcadSelectionSet
  Dim objSelSet As AcadSelectionSet
  Dim objSelCol As AcadSelectionSets
  Set objSelCol = ThisDrawing.SelectionSets
    For Each objSelSet In objSelCol
      If objSelSet.Name = strName Then
        objSelSet.Delete
        Exit For
      End If
    Next
  Set objSelSet = ThisDrawing.SelectionSets.Add(strName)
  Set vbdPowerSet = objSelSet
End Function
 

Public Function TxtSize() As Double
  Dim strPrompt As String
  Dim dblDist As Double
  Dim objUtil As AcadUtility
  On Error GoTo Err_Control
  Set objUtil = ThisDrawing.Utility
 
  ' Определение значения системной переменной
  dblDist = CDbl(ThisDrawing.GetVariable("TEXTSIZE"))
 
  With objUtil
    strPrompt = vbCrLf & "Enter Text Height <" & _
    dblDist & "> : "
    dblDist = .GetDistance(Prompt:=strPrompt)
  End With
  TxtSize = dblDist
Exit_Here:
  Exit Function
Err_Control:
  If Err.Description = "User input is a keyword" Then
    Err.Clear
    Resume Next
  Else
    MsgBox Err.Description
    Resume Exit_Here
  End If
End Function
 
Sub TEST_TxtSize()
  Dim dblH As Double

  dblH = TxtSize
  MsgBox "Высота текста задана равной " & CStr(dblH) & " мм."
End Sub
 

Public Declare Function ForceDBMod Lib "acad.exe" Alias _
"?acdbSetDbmod@@YAJPAVAcDbDatabase@@J@Z" (modified As Long) As Long

Public Sub SetDatabaseClean()
  On Error GoTo Err_Control
  ForceDBMod 0
Exit_Here:
  Exit Sub
Err_Control:
  'You will get an error so just
  'Force out
  Resume Next
End Sub 
 

Public Function ApplicationPath(strEXE As String) As String
  Dim lngInst As Long
  Dim strPath As String
  Dim lngPathLen As Long
  strPath = String(215, Chr(0))
  lngInst = GetModuleHandle(strEXE)
  lngPathLen = GetModuleFileName(lngInst, strPath, Len(strPath))
  ApplicationPath = Left(strPath, lngPathLen)
End Function

Public Sub TestPath()
  MsgBox ApplicationPath("ACAD.exe")
End Sub
 

Option Explicit

'@=========================================@'
'@ Определение текущей области документа   @'
'@-----------------------------------------@'
Public Function GetSpase() As AcadBlock
  Dim objSpace As AcadBlock
  Dim intTILEMODE As Integer
  Dim intCVPORT As Integer
  
  On Error GoTo Exit_here
  intTILEMODE = CInt(ThisDrawing.GetVariable("TILEMODE"))
  If intTILEMODE = 1 Then
    Set objSpace = ThisDrawing.ModelSpace
  Else
    intCVPORT = CInt(ThisDrawing.GetVariable("CVPORT"))
    If intCVPORT = 1 Then
      Set objSpace = ThisDrawing.PaperSpace
    Else
      Set objSpace = ThisDrawing.ModelSpace
    End If
  End If

Exit_here:
  Set GetSpase = objSpace
  Set objSpace = Nothing
End Function

Public Sub TEST_GetSpase()
  Dim objSpace As AcadBlock
  Dim objText As AcadText
  Dim varPnt As Variant
  Dim strText As String
  
  varPnt = ThisDrawing.Utility.GetPoint(Prompt:="Укажите точку: ")
  Set objSpace = GetSpase
  If objSpace Is ThisDrawing.ModelSpace Then
    strText = "Это пространство Модели"
  Else
    strText = "Это пространство Листа"
  End If
  Set objText = objSpace.AddText(strText, varPnt, 7)
End Sub

Option Explicit

'@=========================================@'
'@     Определение текущего масштаба       @'
'@-----------------------------------------@'
' Масштаб определяется согласно системной переменной DIMSCALE
' (масштаб отрисовки размеров).
' В случае, если активно пространство листа, масштаб прини-
' мается равным 1, в случае если активна область просмотра
' в пространстве листа и в текущем размерном стиле опция
' Scale Dimension to Layout (Paper Space) включена, то масштаб
' определяется согласно масштаба отображения модели в активной
' области просмотра.
' В случе, когда в текущем размерном стиле опция
' Scale Dimension to Layout (Paper Space) включена, и пользователь 
' вставляет знак находясь в пространстве модели, масштаб отрисовки 
' принимается равным 1.
Public Function GetScale() As Double
  Dim intTILEMODE As Integer
  Dim intCVPORT As Integer
  Dim intDXF(3) As Integer
  Dim varVal(3) As Variant
  Dim objSelCol As AcadSelectionSets
  Dim objSelSet As AcadSelectionSet
  Dim objEnt As AcadEntity
  Dim dblScale As Double

  On Error GoTo Exit_here
  intTILEMODE = CInt(ThisDrawing.GetVariable("TILEMODE"))
  If intTILEMODE = 1 Then
  ' Пользователь в "чистом" пространстве модели
    dblScale = CDbl(ThisDrawing.GetVariable("DIMSCALE"))
  Else
    intCVPORT = CInt(ThisDrawing.GetVariable("CVPORT"))
    If intCVPORT = 1 Then
    ' Пользователь в "чистом" пространстве листа
      dblScale = 1
    Else
    ' Активна обна из областей просмотра в пространстве листа
    ' Обеспечиваем фильтр выбора всех областей просмотра
      intDXF(0) = -4
      varVal(0) = "<AND"
      intDXF(1) = 0
      varVal(1) = "VIEWPORT"
      intDXF(2) = 69
      varVal(2) = intCVPORT
      intDXF(3) = -4
      varVal(3) = "AND>"
      Set objSelCol = ThisDrawing.SelectionSets
      For Each objSelSet In objSelCol
      ' Проверяем все существующие наборы
        If objSelSet.Name = "textindistance" Then
          ThisDrawing.SelectionSets.Item("VPort").Delete
          Exit For
        End If
      Next
      Set objSelSet = ThisDrawing.SelectionSets.Add("VPort")
      objSelSet.Select acSelectionSetAll, _
                       Filtertype:=intDXF, filterdata:=varVal
      Set objEnt = objSelSet.Item(0) ' Активная область просмотра
                                     ' будет в наборе с индексом 0
      ThisDrawing.SelectionSets.Item("VPort").Delete
      dblScale = 1 / objEnt.CustomScale ' Задаем масштаб равным
                                        ' масштабу активной
                                        ' области просмотра
    End If
  End If

Exit_here:
  If dblScale = 0 Then dblScale = 1
  GetScale = dblScale
  ' Освобождаем память от объектных переменных
  Set objSelSet = Nothing
  Set objSelCol = Nothing
  Set objEnt = Nothing
End Function

Public Sub TEST_GetScale()
  Dim dblScale As Double
  Dim strScale As String
  dblScale = GetScale
  If dblScale < 1 Then
    strScale = "1:" & CStr(1 / dblScale)
  Else
    strScale = CStr(dblScale) & ":1"
  End If
  MsgBox "Текущий масштаб " & strScale
End Sub