Originally Posted by
Mike_S_Jones
Going on three months and not one reply - no luck on my end either.
create .XlSM file then add this code in module named
modTestAcad, but before run this module select single cell before
Code:
Option Explicit
' require references to:
'Windows Script Host Object model
'AutoCAD 20XX Type Library
'AutoCAD Focus Control for VBA Type Library
'in the Tools -> Options -> General -> Error Trapping box -> Check "Break on Unhandled Errors"
Function acadVerNum() As String
Dim verNum As String
verNum = "HKEY_CLASSES_ROOT\AutoCAD.Drawing\CurVer\"
Dim wsh As Object
On Error GoTo ErrorHandler
'access Windows scripting
Set wsh = CreateObject("WScript.Shell")
'read key from registry
Dim resKey As String
resKey = wsh.RegRead(verNum)
acadVerNum = Right(resKey, 2)
Exit Function
ErrorHandler:
'key was not found
acadVerNum = ""
End Function
Public Sub testOpenAutoCAD()
Dim acad As AutoCAD.AcadApplication
Dim appNum As String
On Error GoTo ErrorHandler
appNum = acadVerNum
If appNum = "" Then
Exit Sub
End If
On Error Resume Next
Set acad = GetObject(, "Autocad.Application." & appNum)
If Err.Number = 429 Then
Err.Clear
On Error GoTo 0
Set acad = CreateObject("Autocad.Application." & appNum)
If Err Then
Exit Sub
End If
End If
acad.WindowState = acMax
Dim adoc As AutoCAD.AcadDocument
Set adoc = acad.ActiveDocument
Dim selRng As Range
Set selRng = Selection
selRng.Value2 = "Tested on: " & adoc.Name
Dim aspace As AutoCAD.AcadBlock
Set aspace = adoc.ActiveLayout.Block
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
Dim lw As Double
Dim clr As Integer
p1(0) = 0#: p1(1) = 0#: p1(2) = 0#
p2(0) = 100#: p2(1) = 100#: p2(2) = 0#
lw = acLnWt060
clr = "0"
Dim oLine As AcadLine
Set oLine = aspace.AddLine(p1, p2)
oLine.Lineweight = lw
oLine.Color = acMagenta
adoc.SetVariable "lwdisplay", 1
adoc.SetVariable "ltscale", 0.25
ZoomExtents
Set aspace = Nothing
Set adoc = Nothing
Set acad = Nothing
MsgBox "Pokey"
ErrorHandler:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub