Вспомогательные функции

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

' Пример запроса у пользователя папки с помощью
' 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