VBA Insert Block from Another Drawing

Anonymous — Thu, 18 Jun 2015 06:05:40 GMT

Hi all,

I am using the following method to insert autocad blocks into my drawing:

Set objBRef = acadDoc.ModelSpace.InsertBlock(InsertionPt, DwgBlock, XYZScale, XYZScale, XYZScale, Rotation)

The program works fine when the block I want to insert is already included in the drawing.

I would like to know if it is possible to insert a block from a separate drawing.

I assume I replace 'DwgBlock' with the filepath/drawing.dwg I want to include but I cannot get it to work.

Help would be greatly apreciated.

Cheers,
Th1nkQuick.

Re: VBA Insert Block from Another Drawing

Ed__Jobe — Thu, 18 Jun 2015 14:42:23 GMT

The method will only insert another dwg as a block. It will not find blocks defined in the external file. What you would have to do is first insert the external file and then delete the insert. This will bring in block def's, text and dim styles, etc. Then you can just insert the block by its name.

Re: VBA Insert Block from Another Drawing

Anonymous — Mon, 22 Jun 2015 03:16:40 GMT

@eljobe wrote:
The method will only insert another dwg as a block. It will not find blocks defined in the external file. What you would have to do is first insert the external file and then delete the insert. This will bring in block def's, text and dim styles, etc. Then you can just insert the block by its name.

Thank you eljobe. I have solved my issue after following your advice.

Re: VBA Insert Block from Another Drawing

buianhtuan.cdt — Mon, 08 Mar 2021 12:31:44 GMT

Sub Sub4001_InsertTBLibrary()
'(VBA AutoCad) Insert TuanBui Library,[ITBL]

'Define Library FilePath
Dim Folder As String
Dim Filename As String
Dim FilePath As String
Folder = "C:\Users\buian\Desktop\TEST BRICS\02-INSERT NOTE"
Filename = "00-TBLIBRARY.dwg"
FilePath = Folder & "\" & Filename

'Check Exists file
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.fileExists(FilePath) Then 'kiem tra trong thu muc co ton tai file k
Set FSO = Nothing
Else
Set FSO = Nothing
MsgBox "Please check File Path"
Exit Sub
End If

'Insert
Dim ScaleMode As String: ScaleMode = "Scale"
'"Automatic","SelectPoint","Point00","DrawingOutside"
Dim InsertPointMode As String: InsertPointMode = "DrawingOutside"
Dim StrInsertPointX As Double
Dim StrInsertPointY As Double
Dim RotateAngle As Double
Dim DeleteExplode As String: DeleteExplode = "Explode"
'Define Pathname and blockname
Dim ExternalBlockname As String
ExternalBlockname = "UpdateBlock" & Func31HourMinute
Call HCF4003_InsertExternalDrawing(Thisdrawing, FilePath, ExternalBlockname, ScaleMode, InsertPointMode, StrInsertPointX, StrInsertPointY, RotateAngle, DeleteExplode)
End Sub

Sub Sub4002_A_InsertSurfaceTexture0()
'(VBA AutoCad) Insert Surface Texture Ra0,[RA0]

Dim BeginBlockname As String: BeginBlockname = "RA0_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub

Sub Sub4002_B_InsertSurfaceTexture25()
'(VBA AutoCad) Insert Surface Texture Ra25,[RA25]

Dim BeginBlockname As String: BeginBlockname = "RA25_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_C_InsertSurfaceTexture125()
'(VBA AutoCad) Insert Surface Texture Ra125,[RA125]

Dim BeginBlockname As String: BeginBlockname = "RA125_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_D_InsertSurfaceTexture63()
'(VBA AutoCad) Insert Surface Texture Ra63,[RA63]

Dim BeginBlockname As String: BeginBlockname = "RA63_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_E_InsertSurfaceTexture32()
'(VBA AutoCad) Insert Surface Texture Ra32,[RA32]

Dim BeginBlockname As String: BeginBlockname = "RA32_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub
Sub Sub4002_F_InsertSurfaceTexture16()
'(VBA AutoCad) Insert Surface Texture Ra16,[RA16]

Dim BeginBlockname As String: BeginBlockname = "RA16_"
Call Func5012_InsertSurfaceTexture(BeginBlockname)

End Sub

';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func5011_GetInsertPointAndDirectionPoint() As Variant

'Select Insert Point and Direction Point
Dim InsertPoint As Variant
Dim DirectionPoint As Variant
Dim Result(0 To 1) As Variant

On Error GoTo Step1
InsertPoint = Thisdrawing.Utility.GetPoint(, "Select InsertPoint:")
DirectionPoint = Thisdrawing.Utility.GetPoint(InsertPoint, "Select DirectionPoint:")
Step1:
If Err Then
Result(0) = False
Func5011_GetInsertPointAndDirectionPoint = False
Else
Result(0) = InsertPoint
Result(1) = DirectionPoint
Func5011_GetInsertPointAndDirectionPoint = Result
End If

End Function

Function Func5012_InsertSurfaceTexture(BeginBlockname As String)

'Get Dimscale and Define BlockScale
Dim DimScale As Integer
DimScale = Thisdrawing.GetVariable("DIMSCALE")

'Othor On
Thisdrawing.SetVariable "ORTHOMODE", 1

'Set UCS is World UCS
Dim Point00(0 To 2) As Double
Call FuncCadHome05SetUCSFromPoint(Point00)

'Select Insert Point and Direction Point and insert block
Dim Get2Point As Variant
Dim InsertPoint As Variant
Dim DirectionPoint As Variant
Do
Get2Point = Func5011_GetInsertPointAndDirectionPoint
If VarType(Get2Point) = vbBoolean Then Exit Function
InsertPoint = Get2Point(0)
DirectionPoint = Get2Point(1)
Call Func5012_A_InsertSurfaceTexture(BeginBlockname, DimScale, InsertPoint, DirectionPoint)
Loop While VarType(Get2Point) <> vbBoolean

End Function
Function Func5012_A_InsertSurfaceTexture(BeginBlockname As String, DimScale As Integer, InsertPoint As Variant, DirectionPoint As Variant)

'Dim
Dim ObjBlockRef As AcadBlockReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim RotationAngle As Double
Dim Blockname As String
Dim EndBlockname As String

'Get Dimscale and Define BlockScale
XScale = DimScale
YScale = DimScale
ZScale = DimScale

'Define Blockname
Dim InsertPointX As Double
Dim InsertPointY As Double
Dim DirectionPointX As Double
Dim DirectionPointY As Double
InsertPointX = Round(InsertPoint(0), 2)
InsertPointY = Round(InsertPoint(1), 2)
DirectionPointX = Round(DirectionPoint(0), 2)
DirectionPointY = Round(DirectionPoint(1), 2)
If InsertPointX = DirectionPointX Then
'90,270
If DirectionPointY > InsertPointY Then
EndBlockname = "90"
Else
EndBlockname = "270"
End If
Else
'0,180
If DirectionPointX > InsertPointX Then
EndBlockname = "0"
Else
EndBlockname = "180"
End If
End If
Blockname = BeginBlockname & EndBlockname
Set ObjBlockRef = Thisdrawing.ModelSpace.InsertBlock(InsertPoint, Blockname, XScale, YScale, ZScale, RotationAngle)

'Explode Block Reference
Dim ExplodeArr As Variant
ExplodeArr = ObjBlockRef.Explode

End Function

Function HCF4003_InsertExternalDrawing(Thisdrawing As AcadDocument, FilePath As String, Blockname As String, ScaleMode As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, RotateAngle As Double, DeleteExplode As String)

'Define PageSize
Dim TitleBlock As AcadBlockReference
Set TitleBlock = HCF4004_GetPartPropertyBlockRef(Thisdrawing)
Dim PaperSize As String
PaperSize = HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing, TitleBlock, "}–ÊƒTƒCƒY")

'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
InsertBlockScale = HCF4003_A_DefineInsertBlockScale(Thisdrawing, ScaleMode)

'Define InsertPoint
Dim InsertPoint As Variant
InsertPoint = HCF4003_B_DefineInsertPoint(Thisdrawing, PaperSize, InsertPointMode, StrInsertPointX, StrInsertPointY, InsertBlockScale)

'Define InsertPoint from PageSize,InsertPointMode,DimScale
Call HCF4003_C_InsertExternalDrawing(Thisdrawing, FilePath, Blockname, InsertPoint, InsertBlockScale, RotateAngle, DeleteExplode)

End Function
Function HCF4004_GetPartPropertyBlockRef(Thisdrawing As AcadDocument) As AcadBlockReference

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)
Dim ObjAttBlock As AcadSelectionSet
Set ObjAttBlock = Thisdrawing.SelectionSets.Add("objAttBlock" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = 0: FD(1) = "INSERT"
FT(2) = 2: FD(2) = PartPropertyBlock
FT(3) = -4: FD(3) = "AND>"
ObjAttBlock.Select acSelectionSetAll, , , FT, FD
If ObjAttBlock.Count = 0 Then
ObjAttBlock.Delete
Exit Function
End If

Dim TitleBlock As AcadBlockReference
For Each TitleBlock In ObjAttBlock
Set HCF4004_GetPartPropertyBlockRef = TitleBlock
Next
ObjAttBlock.Delete
'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)

End Function
Function HCF4005_GetAttValueOfPartPropertyBlockRef(Thisdrawing As AcadDocument, TitleBlock As AcadBlockReference, TagName As String) As String

'Call Function Unlock layer Frame
Call Func06UnlockLayer(Thisdrawing, FrameLayerName)

If TitleBlock Is Nothing Then
Exit Function
End If

Dim varAttributes As Variant
Dim AttTextString As String

varAttributes = TitleBlock.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = TagName Then
AttTextString = varAttributes(i).TextString
End If
Next

'Call Function Lock Layer Frame
Call Func07LockLayer(Thisdrawing, FrameLayerName)
HCF4005_GetAttValueOfPartPropertyBlockRef = AttTextString

End Function

Function HCF4003_A_DefineInsertBlockScale(Thisdrawing As AcadDocument, ScaleMode As String) As Integer
'Define InsertBlockScale from Dimscale and ScaleMode
Dim InsertBlockScale As Integer
Dim DimScale As Integer
DimScale = Thisdrawing.GetVariable("DIMSCALE")
Select Case ScaleMode
Case "Scale"
InsertBlockScale = DimScale
Case "NoScale"
InsertBlockScale = 1
Case Else
InsertBlockScale = 1
End Select
HCF4003_A_DefineInsertBlockScale = InsertBlockScale
End Function
Function HCF4003_B_DefineInsertPoint(Thisdrawing As AcadDocument, PaperSize As String, InsertPointMode As String, StrInsertPointX As Variant, StrInsertPointY As Variant, InsertBlockScale As Integer) As Variant

'Define InsertPointMode from Excel
Select Case InsertPointMode
Case "Automatic"
If VarType(StrInsertPointX) <> vbDouble Or VarType(StrInsertPointY) <> vbDouble Then
InsertPointMode = "SelectPoint"
End If
Select Case PaperSize
Case "A4"
Case "A3"
Case "A2"
Case Else
InsertPointMode = "SelectPoint"
End Select
Case "SelectPoint"
Case "Point00"
Case "DrawingOutside"
If PaperSize = "" Then InsertPointMode = "SelectPoint"
Case Else
InsertPointMode = "SelectPoint"
End Select

'Define InsertPoint
Dim BasicInsertPoint(0 To 2) As Double
Dim AfterInsertPoint(0 To 2) As Double
Dim SelectPoint As Variant
Select Case InsertPointMode
Case "Automatic"
AfterInsertPoint(0) = CDbl(StrInsertPointX) * InsertBlockScale
AfterInsertPoint(1) = CDbl(StrInsertPointY) * InsertBlockScale
Case "SelectPoint"
On Error GoTo next01
SelectPoint = Thisdrawing.Utility.GetPoint(, "Select Insert Point:")
AfterInsertPoint(0) = SelectPoint(0)
AfterInsertPoint(1) = SelectPoint(1)
next01:
If Err Then GoTo next02
Case "DrawingOutside"
next02:
Select Case PaperSize
Case "A4"
AfterInsertPoint(0) = A4X11 * InsertBlockScale
Case "A3"
AfterInsertPoint(0) = A3X11 * InsertBlockScale
Case "A2"
AfterInsertPoint(0) = A2X11 * InsertBlockScale
End Select
Case "Point00"
AfterInsertPoint(0) = 0
AfterInsertPoint(1) = 0
End Select

HCF4003_B_DefineInsertPoint = AfterInsertPoint

End Function

Function HCF4003_C_InsertExternalDrawing(Thisdrawing As AcadDocument, Pathname As String, Blockname As String, InsertPoint As Variant, InsertBlockScale As Integer, RotateAngle As Double, DeleteExplodeMode As String)
'Mode(Delete,Explode,Block)
'Add External Reference
Dim ObjExternalReference As AcadExternalReference
Dim XScale As Integer
Dim YScale As Integer
Dim ZScale As Integer
Dim Overlay As Boolean: Overlay = False

'Define XScale,YScale,ZScale
XScale = InsertBlockScale
YScale = InsertBlockScale
ZScale = InsertBlockScale

'Attach ObjExternalReference
Set ObjExternalReference = Thisdrawing.ModelSpace.AttachExternalReference(Pathname, Blockname, InsertPoint, XScale, YScale, ZScale, RotateAngle, False)
Thisdrawing.Blocks.Item(ObjExternalReference.Name).Bind True

'Explode Block,DeleteBlock
Dim ObjSelectSet As AcadSelectionSet
Dim EachObj As AcadEntity
Dim ObjBlockRef As AcadBlockReference
Dim ObjBlock As AcadBlock
Set ObjSelectSet = Thisdrawing.SelectionSets.Add("ObjSelectSet" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = 0: FD(1) = "INSERT"
FT(2) = 2: FD(2) = Blockname
FT(3) = -4: FD(3) = "AND>"
ObjSelectSet.Select acSelectionSetAll, , , FT, FD
Set ObjBlockRef = ObjSelectSet.Item(0)
ObjSelectSet.Delete
Select Case DeleteExplodeMode
Case "Delete"
ObjBlockRef.Delete
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "Explode"
'Explode
Call HCF4007_ExplodeBlockReference(Thisdrawing, ObjBlockRef)
Set ObjBlock = Thisdrawing.Blocks(Blockname)
ObjBlock.Delete
Case "DeleteBlockRef"
ObjBlockRef.Delete
Case Else
End Select

End Function
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Public Const LibraryPath As String = "C:\Users\buian\Desktop\TEST BRICS\TBLibrary"
'PageSize
Public Const A4X11 As Integer = 210
Public Const A3X11 As Integer = 420
Public Const A2X11 As Integer = 594

topic VBA Insert Block from Another Drawing in VBA Forum

VBA Insert Block from Another Drawing

Re: VBA Insert Block from Another Drawing

Re: VBA Insert Block from Another Drawing

Re: VBA Insert Block from Another Drawing