topic Re: VBA Printing to PDF in VBA Forum

VBA Printing to PDF

basnederveen — Mon, 22 Oct 2018 08:41:44 GMT

Hello everyone,

I can't manage to set any print configurations, everytime I open a drawing it resets to what is default in the drawing. The problem occurs with some drawings exported from another program (cadmatic... ) and trying to print to PDF.

---- edit -----

Now I am loading a few preset plot configurations from another drawing, which seems to be working. Only I would like to use the button 'Apply to layout'. Does anyone know if this is possible thourhg VBA?

Function DoPdf(dwg As AcadDocument, pdfFile As String, config As String) As Boolean
    
    ' Initialize the acad plot, configs and configurations
    Dim ptObj As AcadPlot
    Dim ptConfigs As AcadPlotConfigurations
    Dim plotConfig As AcadPlotConfiguration

    ' Create a new plot configuration with all needed parameters
    Set ptObj = dwg.Plot
    Set ptConfigs = dwg.PlotConfigurations
    
    ' Add a plotconfiguration
    ThisDrawing.SendCommand "filedia" & vbCr & "0" & vbCr
    ThisDrawing.SendCommand ".-psetupin" & vbCr & "PATH" & vbCr & "*" & vbCr & vbCr & vbCr
    ThisDrawing.SendCommand "filedia" & vbCr & "1" & vbCr
    
    ' Set the configuration
    Select Case config
        Case "a3"
            Set plotConfig = ptConfigs.Item("Spools_a3")
        Case "a2"
            Set plotConfig = ptConfigs.Item("Spools_a2")
        Case "a1"
            Set plotConfig = ptConfigs.Item("Spools_a1")
    End Select
    
    ' Set background plotting to off so autocad will wait till print is finished. Prevents errors.
    Call ThisDrawing.SetVariable("BACKGROUNDPLOT", 0)
    
    ' Updates the plot
    plotConfig.RefreshPlotDeviceInfo

    ' Create a variable to see if print was succesfull
    Dim success As Boolean
    
    ' Catch the error
    On Error Resume Next
        success = ptObj.PlotToFile(pdfFile, plotConfig.ConfigName)
    If Err Then
        'MsgBox "Not printed"
    End If
        
    ' Delete the previous config
    Set plotConfig = Nothing

    ' Return the result
    DoPdf = success
    
End Function

Re: VBA Printing to PDF

maratovich — Mon, 22 Oct 2018 09:08:53 GMT

Yes, it is possible.
I don't have the code at hand right now, but it works.

Re: VBA Printing to PDF

basnederveen — Mon, 22 Oct 2018 10:56:57 GMT

It's just the apply to layout I need. The rest is working now.

Re: VBA Printing to PDF

Ed__Jobe — Tue, 23 Oct 2018 18:07:25 GMT

Use your plotconfig to set the ActiveLayout.ConfigName property.

ActiveLayout.ConfigName = myPlotConfig.Name

Re: VBA Printing to PDF

basnederveen — Wed, 24 Oct 2018 12:30:54 GMT

Sub TEST()

    ' Initialize the acad plot, configs and configurations
    Dim ptObj As AcadPlot
    Dim ptConfigs As AcadPlotConfigurations
    Dim plotConfig As AcadPlotConfiguration

    ' Create a new plot configuration with all needed parameters
    Set ptObj = ThisDrawing.Plot
    Set ptConfigs = ThisDrawing.PlotConfigurations

    ' Test
    Set plotConfig = ptConfigs.Item("Spools_a2")
    ThisDrawing.ActiveLayout.ConfigName = plotConfig.Name

End Sub

That does not work, but this is setting the Plot config, not the page setup. What I am doing manually is

- Set the printer/plotter -> dwg to pdf.pc3

- select a page setup

- apply to layout

Re: VBA Printing to PDF

Ed__Jobe — Wed, 24 Oct 2018 14:41:19 GMT

Sorry, its been a few years since I worked with page setups. I was going from memory and its not what it used to be. 😉

First of all, plot configs are page setups. To set a layout's page setup, use the CopyFrom method.

objLayout.CopyFrom ThisDrawing.PlotConfigurations.Item("Spools_a2")

Re: VBA Printing to PDF

basnederveen — Wed, 24 Oct 2018 15:14:47 GMT

Thank you! That works when printing. It does not show the actual changed setup in the screen though, but it works when printing. So fine for me 🙂

Thanks again!!

Re: VBA Printing to PDF

buianhtuan.cdt — Mon, 11 Jan 2021 13:08:09 GMT

Sub TH0202AutomaticPrint()

'Chon doi tuong bang select on screen
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)

Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = 0: FD(1) = "LWPolyline"
FT(2) = 8: FD(2) = "04_HIDDEN"
FT(3) = -4: FD(3) = "AND>"

objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
If objSelectOnScreen.count = 0 Then Exit Sub

Dim ThisPlot As AcadPlot
Set ThisPlot = Thisdrawing.Plot

Dim temp As Variant
'Set so to can in
ThisPlot.NumberOfCopies = 1
ThisPlot.QuietErrorMode = True
Dim Thislayout As AcadLayout
Set Thislayout = Thisdrawing.ActiveLayout

Thislayout.ConfigName = "Adobe PDF.pc3" 'Plot device
Thislayout.CanonicalMediaName = "A3" 'Paper Size
Thislayout.CenterPlot = True 'Center the plot
Thislayout.StandardScale = acScaleToFit 'Scale to fit
Thislayout.PaperUnits = acMillimeters 'Paper unit is mm
Thislayout.PlotHidden = False 'N/A
Thislayout.PlotRotation = ac90degrees 'in nam ngang

Thislayout.StyleSheet = "monochrome.ctb" 'Plot style
Thislayout.PlotWithLineweights = True
Thislayout.PlotWithPlotStyles = True

Dim EachobjSelectOnScreen As AcadEntity
Dim MinPoint, MaxPoint As Variant

For Each EachobjSelectOnScreen In objSelectOnScreen
EachobjSelectOnScreen.GetBoundingBox MinPoint, MaxPoint
'translate the points which are in World UCS to Display coordinates
MinPoint = Thisdrawing.Utility.TranslateCoordinates(MinPoint, acWorld, acDisplayDCS, False)
MaxPoint = Thisdrawing.Utility.TranslateCoordinates(MaxPoint, acWorld, acDisplayDCS, False)
ReDim Preserve MinPoint(0 To 1)
ReDim Preserve MaxPoint(0 To 1)
Thislayout.SetWindowToPlot MinPoint, MaxPoint
Thislayout.PlotType = acWindow 'Print by Window
ThisPlot.PlotToDevice
Next
objSelectOnScreen.Delete

End Sub

Function Func15ACopyFileFollowLArr(FilesList As Variant, CopyFileList As Variant, CopyToFolderPath As String, WS As Worksheet, RefColumn As Integer, RefEndRow As Integer) As Integer
'Kiem tra trong cac phan tu cua mang ListText, co phan tu nao nam trong SearchInText hay khong

Dim File As Variant
Dim NeedCopyFilename As String
Dim NeedCopyFullFilename As String
Dim FilePath As String
Dim CopyFilePath As String
Dim FileName As String
Dim CopiedFileCount As Integer

For i = LBound(CopyFileList) To UBound(CopyFileList)
NeedCopyFilename = CopyFileList(i)
CopyFilePath = ""
For Each File In FilesList
'Lay file name, dinh dang aaaaa-bbb
FilePath = File
FileName = Func05CreatFilenameFromPath(FilePath, "FileName")
'Kiem tra xem text filename co trong NeedCopyFilename hay khong
If InStr(FileName, NeedCopyFilename) <> 0 Then 'neu co file
If StrComp(FileName, NeedCopyFullFilename) >= 0 Then
CopyFilePath = FilePath
NeedCopyFullFilename = FileName
End If
End If
Next
If CopyFilePath <> "" Then
Call Func14CopyFileFromFilePathToFolder(CopyFilePath, NeedCopyFullFilename, CopyToFolderPath)
CopiedFileCount = CopiedFileCount + 1
'Viet Ï vao excel
For k = 3 To RefEndRow
If WS.Cells(k, RefColumn).Value = NeedCopyFilename Then
WS.Cells(k, RefColumn).Value = NeedCopyFullFilename
WS.Cells(k, RefColumn + 1).Value = "Ï"
End If
Next
End If
Next
Func15ACopyFileFollowLArr = CopiedFileCount
End Function

Re: VBA Printing to PDF

buianhtuan.cdt — Sun, 17 Jan 2021 12:34:51 GMT

;(VBA AutoCad)Creat Centerline, shorcutkey [CCL]
(defun C:CCL()
(command "-vbarun" "TBR11CreatCenterLine")
)

;(VBA AutoCad)Creat Phantom Line Throught 2 Point, shorcutkey [PL2P]
(defun C:PL2P()
(command "-vbarun" "TBR10PhantomLine2Point")
)

;(VBA AutoCad)Increase, Decrease Length of Line, shorcutkey [LENDE]
(defun C:LENDE()
(command "-vbarun" "TBR09LengthDelta")
)

;(VBA AutoCad)Convert Text to MText and BringToFront, shorcutkey [T2MT]
(defun C:T2MT()
(command "-vbarun" "TBR08ConvertText2MTextBringToFront")
)

;(VBA AutoCad)Duplicate Obj, shorcutkey [DUP]
(defun C:DUP()
(command "-vbarun" "TBR07DuplicateObj")
)

;(VBA AutoCad)Only select dimension, shorcutkey [SD]
(defun C:SD()
(command "-vbarun" "TBR03SelectDimension")
)

;(VBA AutoCad)Only select Text and MText, shorcutkey [ST]
(defun C:ST()
(command "-vbarun" "TBR04SelectTextMText")
)

;(VBA AutoCad)Only select Block, shorcutkey [SB]
(defun C:SB()
(command "-vbarun" "TBR05SelectBlock")
)

;(VBA AutoCad)Select Obj By Layer, shorcutkey [SBL]
(defun C:SBL()
(command "-vbarun" "TBR06SelectByLayer")
)

;(VBA AutoCad) Noi tam cac duong tron thang hang
(defun C:C2C()
(command "-vbarun" "TBR02ConnectCenter2Center")
)

;(VBA AutoCad)(Dimension),shorcutkey "DN"
(defun C:DN()
(command "-vbarun" "TBR01EditDimensionDongMoNgoac")
)

;(VBA AutoCad)Quick Print to PDF
(defun C:QPRINT()
(command "-vbarun" "TH0202AutomaticPrint")
)

;(VBA AutoCad)Creat Pitch Dimension (P***x***=****)
(defun C:CPD()
(command "-vbarun" "TH0201CreatPitchDimension")
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TH0201CreatPitchDimension()
'Creat Pitch Dimension (P***x***=****), shortcut key [CPD]
Thisdrawing.Utility.Prompt (vbCrLf & "Creat Pitch Dimension")

'Get Pitch and sum
Dim ObjPitchDim As AcadDimension
Dim ObjSumDim As AcadDimension
Dim Pitch As Double
Dim Sum As Double
Dim TmpQty As Double
Dim Qty As Integer
Dim TextOverride As String
Dim ObjArr As AcadDimension
Dim TmpObjArr As Variant
Thisdrawing.Utility.Prompt (vbCrLf & "Select Picth and Sum Dimension")
TmpObjArr = Func68SelectOnScreenByType("DIMENSION", "", "", "", "", 2)
If VarType(TmpObjArr) = vbEmpty Then
Exit Sub
Else
Set ObjPitchDim = TmpObjArr(0)
Set ObjSumDim = TmpObjArr(1)
Pitch = Func67GetDimensionMeasurement(ObjPitchDim)
Sum = Func67GetDimensionMeasurement(ObjSumDim)
If Pitch > Sum Then
Set ObjPitchDim = TmpObjArr(1)
Set ObjSumDim = TmpObjArr(0)
Pitch = Func67GetDimensionMeasurement(ObjPitchDim)
Sum = Func67GetDimensionMeasurement(ObjSumDim)
End If
End If

'Define Qty
TmpQty = Sum / Pitch
Qty = Int(TmpQty)
If Qty = 1 Then
MsgBox "Px1???"
Exit Sub
End If
If Qty = TmpQty Then
TextOverride = "P" & Pitch & "x" & Qty & "=" & "<>"
Call Func69ChangeDimensionProperty(ObjSumDim, TextOverride, "", "")
Else
MsgBox "P" & Pitch & "x" & Qty & "<>" & Sum
End If

End Sub
Sub TBR01EditDimensionDongMoNgoac()
'Dong mo ngoac doi tuong kich thuoc, neu kich thuoc da dong mo ngoac thi xoa
'Shorcut "DN", dong ngoac

Dim DimTextOverride As String
Dim DimPrefix As String: DimPrefix = "("
Dim DimSuffix As String: DimSuffix = ")"
Dim OldPrefix As String
Dim OldTextOverride As String

'Chon doi tuong bang select on screen
Dim ObjDim As AcadDimension
Dim ObjDimName As String
Dim objSelectOnScreen As AcadSelectionSet
Dim EachobjSelectOnScreen As AcadDimension
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(2) As Integer
Dim FD(2) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "DIMENSION"
FT(2) = -4: FD(2) = "OR>"
Thisdrawing.Utility.Prompt vbCrLf & "Select Dimension to Edit:"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "Please select dimension"
objSelectOnScreen.Delete
Exit Sub
End If
For Each EachobjSelectOnScreen In objSelectOnScreen
Set ObjDim = EachobjSelectOnScreen
OldTextOverride = ObjDim.TextOverride
OldPrefix = ObjDim.TextPrefix
Select Case ObjDim.ObjectName
Case "AcDbRadialDimension", "AcDbDiametricDimension"
If InStr(OldTextOverride, "(") <> 0 Then
DimTextOverride = ""
Else
DimTextOverride = "(<>)"
End If
ObjDim.TextOverride = DimTextOverride
Case Else
If InStr(OldPrefix, "(") <> 0 Then
ObjDim.TextPrefix = ""
ObjDim.TextSuffix = ""
Else
ObjDim.TextPrefix = DimPrefix
ObjDim.TextSuffix = DimSuffix
End If
End Select
ObjDim.Update
Next

objSelectOnScreen.Delete

End Sub
Sub TBR02ConnectCenter2Center()
'Connent Circle to circle by centerline

'Select Circle by select on screen
Dim objSelectOnScreen As AcadSelectionSet
Dim EachobjSelectOnScreen As AcadCircle
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "CIRCLE"
Thisdrawing.Utility.Prompt vbCrLf & "Select Circle:"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Obj"
objSelectOnScreen.Delete
Exit Sub
End If
Dim PointArr() As Variant
Dim CenterPoint As Variant
Dim CenterPointX As Double
Dim CenterPointY As Double
Dim TmpPoint As Variant
Dim TmpPointX As Double
Dim TmpPointY As Double
Dim k As Integer
Dim CheckHave As Boolean
ReDim PointArr(0)
For Each EachobjSelectOnScreen In objSelectOnScreen
CheckHave = False
CenterPoint = EachobjSelectOnScreen.Center
CenterPointX = CenterPoint(0)
CenterPointY = CenterPoint(1)
For i = LBound(PointArr) To UBound(PointArr)
TmpPoint = PointArr(i)
If VarType(TmpPoint) <> vbEmpty Then
TmpPointX = TmpPoint(0)
TmpPointY = TmpPoint(1)
If CenterPointX = TmpPointX And CenterPointY = TmpPointY Then CheckHave = True
End If
Next
If CheckHave = False Then
ReDim Preserve PointArr(O To k)
PointArr(k) = CenterPoint
k = k + 1
End If
Next

'Creat XYArray From PointArr
Dim XYArr As Variant
ReDim XYArr(0 To UBound(PointArr), 0 To 1)
For i = LBound(PointArr) To UBound(PointArr)
TmpPoint = PointArr(i)
XYArr(i, 0) = Round(TmpPoint(0), 2)
XYArr(i, 1) = Round(TmpPoint(1), 2)
Next

'Creat XArr(XValue,Ymin,Ymax)
Dim TmpXArr() As Variant
Dim XArr() As Variant
Dim MinY As Double
Dim MaxY As Double
Dim TmpDouble As Double
TmpXArr = Func71CreatListFromArr(XYArr, 0)
ReDim XArr(0 To UBound(TmpXArr), 0 To 2)
For i = LBound(XArr) To UBound(XArr)
TmpDouble = TmpXArr(i)
MinY = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "YMIN")
MaxY = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "YMAX")
XArr(i, 0) = TmpDouble
XArr(i, 1) = MinY
XArr(i, 2) = MaxY
Call Func73DrawLineThrough2Point(TmpDouble, MinY, TmpDouble, MaxY, CenterLayerName)
Next

'Creat YArr(YValue,Xmin,Xmax)
Dim TmpYArr() As Variant
Dim YArr() As Variant
Dim MinX As Double
Dim MaxX As Double
TmpYArr = Func71CreatListFromArr(XYArr, 1)
ReDim YArr(0 To UBound(TmpYArr), 0 To 2)
For i = LBound(YArr) To UBound(YArr)
TmpDouble = TmpYArr(i)
MinX = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "XMIN")
MaxX = Func72FindMinMaxFromXYArr(XYArr, TmpDouble, "XMAX")
YArr(i, 0) = TmpDouble
YArr(i, 1) = MinX
YArr(i, 2) = MaxX
Call Func73DrawLineThrough2Point(MinX, TmpDouble, MaxX, TmpDouble, CenterLayerName)
Next
objSelectOnScreen.Delete

End Sub

Sub TBR03SelectDimension()
'(VBA AutoCad)Only select dimension, shorcutkey [SD]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
'FT(0) = -4: FD(0) = "<OR"
'FT(1) = 0: FD(1) = ObjType1
'FT(2) = 0: FD(2) = ObjType2
'FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR04SelectTextMText()
'(VBA AutoCad)Only select Text and MText, shorcutkey [ST]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(3) As Integer
Dim FD(3) As Variant

FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "TEXT"
FT(2) = 0: FD(2) = "MTEXT"
FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR05SelectBlock()
'(VBA AutoCad)Only select Block, shorcutkey [SB]
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR06SelectByLayer()
'(VBA AutoCad)Select Obj By Layer, shorcutkey [SBL]

'Define layername from GetEntity
Dim LayerName As String
Dim varPick As Variant
Dim Msg As String: Msg = "Select Layer by Object:"
Dim objSelect As AcadEntity
Dim CountLoop As Integer
On Error Resume Next
Do While objSelect Is Nothing
If CountLoop = 3 Then Exit Sub
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
CountLoop = CountLoop + 1
Loop
LayerName = objSelect.layer
objSelect.Highlight True

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 8: FD(0) = LayerName
objSelectOnScreen.SelectOnScreen FT, FD
objSelect.Highlight False
Thisdrawing.SendCommand "select" & vbCr & "P" & vbCr & vbCr
objSelectOnScreen.Delete

End Sub

Sub TBR07DuplicateObj()
'(VBA AutoCad)Duplicate Obj, shorcutkey [DUP]

'Select any entity select on screen
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadEntity
Dim CopyEachEntity As AcadEntity
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
EntitySelect.SelectOnScreen
If EntitySelect.count = 0 Then
EntitySelect.Delete
Exit Sub
End If
For Each EachEntity In EntitySelect
Set CopyEachEntity = EachEntity.Copy
Next
EntitySelect.Delete

End Sub

Sub TBR08ConvertText2MTextBringToFront()
'(VBA AutoCad)Convert Text to MText and BringToFront, shorcutkey [T2MT]

'Select any entity select on screen
Dim EntitySelect As AcadSelectionSet
Dim EachEntity As AcadText
Dim EachMText As AcadMText
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "TEXT"
Set EntitySelect = Thisdrawing.SelectionSets.Add("EntitySelect" & Now)
EntitySelect.SelectOnScreen FT, FD
If EntitySelect.count = 0 Then
EntitySelect.Delete
Exit Sub
End If
For Each EachEntity In EntitySelect
Set EachMText = Func74ConvertText2MText(EachEntity)
' EachMText.BackgroundFill = True
Call Func75DrawOrder(EachMText, "Front")
Next
EntitySelect.Delete

End Sub

Sub TBR09LengthDelta()
'(VBA AutoCad)Increase, Decrease Length of Line, shorcutkey [LENDE]

'Select any entity select on screen
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "LINE"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If

'Get Delta
Dim Delta As Double
On Error GoTo ResumeNext
Delta = Thisdrawing.Utility.GetReal("Delta=")
ResumeNext:
If Delta = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If

Dim OldLine As AcadLine
Dim OldStartPoint As Variant
Dim OldEndPoint As Variant
Dim Angle As Double
Dim NewLine As AcadLine
Dim NewStartPoint As Variant
Dim NewEndPoint As Variant
For Each OldLine In objSelectOnScreen
OldStartPoint = OldLine.StartPoint
OldEndPoint = OldLine.EndPoint
Angle = OldLine.Angle
'Creat Newline
NewStartPoint = Thisdrawing.Utility.PolarPoint(OldStartPoint, Angle, -Delta)
NewEndPoint = Thisdrawing.Utility.PolarPoint(OldEndPoint, Angle, Delta)
Set NewLine = Thisdrawing.ModelSpace.AddLine(NewStartPoint, NewEndPoint)
Call Func76MatchObj(OldLine, NewLine)
OldLine.Delete
Next
objSelectOnScreen.Delete

End Sub
Sub TBR10PhantomLine2Point()
'(VBA AutoCad)Creat Phantom Line Throught 2 Point, shorcutkey [PL2P]

'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr

'Get StartPoint and EndPoint
Dim OldStartPoint As Variant
Dim OldEndPoint As Variant
Dim Angle As Double
On Error GoTo ExitSub
OldStartPoint = Thisdrawing.Utility.GetPoint(, "Start Point select")
OldEndPoint = Thisdrawing.Utility.GetPoint(OldStartPoint, "End Point select")
Angle = Func23AngleOfLineThrough2Point(OldStartPoint, OldEndPoint)

'Define Delta
Dim Delta As Double: Delta = -1

'Creat Newline
Dim NewLine As AcadLine
Dim NewStartPoint As Variant
Dim NewEndPoint As Variant
NewStartPoint = Thisdrawing.Utility.PolarPoint(OldStartPoint, Angle, -Delta)
NewEndPoint = Thisdrawing.Utility.PolarPoint(OldEndPoint, Angle, Delta)
Set NewLine = Thisdrawing.ModelSpace.AddLine(NewStartPoint, NewEndPoint)

'Set layer for NewLine
NewLine.layer = PhantomLayerName
Call Func43SetBylayer(NewLine)

ExitSub:
End Sub
Sub TBR11CreatCenterLine()
'(VBA AutoCad)Creat Centerline, shorcutkey [CCL]

Thisdrawing.Utility.Prompt (vbCrLf & "Creat Centerline")
'Define pi
Dim pi As Double
pi = 4 * Atn(1)
'Define Delta=DIMSCALE*1.5
Dim Delta As Double
Dim Dimscale As Double
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Delta = 1.5 * Dimscale

'Get 2 lines
Thisdrawing.Utility.Prompt (vbCrLf & "Select 2 Lines")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FTL(0) As Integer
Dim FDL(0) As Variant
FTL(0) = 0: FDL(0) = "LINE"
objSelectOnScreen.SelectOnScreen FTL, FDL
If objSelectOnScreen.count <> 2 Then
objSelectOnScreen.Delete
Exit Sub
End If
Dim EachobjSelectOnScreen As AcadEntity
Dim LineArr(0 To 1) As AcadLine
Dim ObjLine0 As AcadLine
Dim Objline1 As AcadLine
Dim i As Integer
For Each EachobjSelectOnScreen In objSelectOnScreen
Set LineArr(i) = EachobjSelectOnScreen
i = i + 1
Next
Set ObjLine0 = LineArr(0)
Set Objline1 = LineArr(1)
objSelectOnScreen.Clear

'Select Circle or Arc
Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles or Arcs")
Dim FT(3) As Integer
Dim FD(3) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = "CIRCLE"
FT(2) = 0: FD(2) = "ARC"
FT(3) = -4: FD(3) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
objSelectOnScreen.Delete
Exit Sub
End If
Dim ObjCircle As AcadCircle
Dim ObjArc As AcadArc
'Creat TmpLine
Dim TmpLine As AcadLine
Dim TmpPoint1 As Variant
Dim TmpPoint2 As Variant
Dim TmpAngle As Double
TmpAngle = ObjLine0.Angle + pi / 2
'Creat centerline
Dim CenterLine As AcadLine
Dim Point1 As Variant
Dim Point2 As Variant
'Extent Centerline with delta
Dim NewPoint1 As Variant
Dim NewPoint2 As Variant
For Each EachobjSelectOnScreen In objSelectOnScreen
Select Case EachobjSelectOnScreen.ObjectName
Case "AcDbCircle"
Set ObjCircle = EachobjSelectOnScreen
TmpPoint1 = ObjCircle.Center
Case "AcDbArc"
Set ObjArc = EachobjSelectOnScreen
TmpPoint1 = ObjArc.Center
End Select
TmpPoint2 = Thisdrawing.Utility.PolarPoint(TmpPoint1, TmpAngle, 1)
Set TmpLine = Thisdrawing.ModelSpace.AddLine(TmpPoint1, TmpPoint2)
'Creat centerline
Point1 = TmpLine.IntersectWith(ObjLine0, acExtendThisEntity)
Point2 = TmpLine.IntersectWith(Objline1, acExtendThisEntity)
TmpLine.Delete
'Extent Centerline with delta
NewPoint1 = Thisdrawing.Utility.PolarPoint(Point1, TmpAngle, -Delta)
NewPoint2 = Thisdrawing.Utility.PolarPoint(Point2, TmpAngle, Delta)
Set CenterLine = Thisdrawing.ModelSpace.AddLine(NewPoint1, NewPoint2)
'Set layer
CenterLine.layer = CenterLayerName
Call Func43SetBylayer(CenterLine)
Next

objSelectOnScreen.Delete

End Sub

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func67GetDimensionMeasurement(ObjDim As AcadDimension) As Double
'Get Measurement of Dimension

Dim DimMeasure As Double
Dim UnitPrecision As Integer
Dim L As Double
DimMeasure = ObjDim.Measurement
UnitPrecision = ObjDim.PrimaryUnitsPrecision
L = Round(DimMeasure, UnitPrecision)
Func67GetDimensionMeasurement = L
End Function
Function Func68SelectOnScreenByType(ObjType1 As String, ObjType2 As String, ObjType3 As String, ObjType4 As String, ObjType5 As String, Qty As Variant) As Variant

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(6) As Integer
Dim FD(6) As Variant
FT(0) = -4: FD(0) = "<OR"
FT(1) = 0: FD(1) = ObjType1
FT(2) = 0: FD(2) = ObjType2
FT(3) = 0: FD(3) = ObjType3
FT(4) = 0: FD(4) = ObjType4
FT(5) = 0: FD(5) = ObjType5
FT(6) = -4: FD(6) = "OR>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Select"
objSelectOnScreen.Delete
Exit Function
End If
If VarType(Qty) = vbInteger Then
If objSelectOnScreen.count <> Qty Then
MsgBox "Obj Qty <> " & Qty
objSelectOnScreen.Delete
Exit Function
End If
End If
Dim EachObj As AcadEntity
Dim ObjArr() As Variant
Dim i As Integer
For Each EachObj In objSelectOnScreen
ReDim Preserve ObjArr(0 To i)
Set ObjArr(i) = EachObj
i = i + 1
Next
objSelectOnScreen.Delete
Func68SelectOnScreenByType = ObjArr
End Function
Function Func69ChangeDimensionProperty(DimObj As AcadDimension, TextOverride As String, DimPrefix As String, DimSuffix As String)
If TextOverride <> "" Then DimObj.TextOverride = TextOverride
If DimPrefix <> "" Then DimObj.TextPrefix = DimPrefix
If DimSuffix <> "" Then DimObj.TextSuffix = DimSuffix
DimObj.Update
End Function
Function Func70IsEmptyArray(anArray As Variant)

Dim i As Integer

On Error Resume Next
i = UBound(anArray, 1)
If Err.Number = 0 Then
Func70IsEmptyArray = False
Else
Func70IsEmptyArray = True
End If

End Function
Function Func71CreatListFromArr(Arr As Variant, ColumnNumber As Integer) As Variant
'Function dung tao list cac doi tuong k trung nhau
If Func70IsEmptyArray(Arr) = True Then Exit Function

Dim TmpArr() As Variant
Dim TmpValue As Variant
Dim CheckHave As Boolean
Dim k As Integer
Dim j As Integer
ReDim TmpArr(0)
For i = LBound(Arr) To UBound(Arr)
TmpValue = Arr(i, ColumnNumber)
CheckHave = False
For k = LBound(TmpArr) To UBound(TmpArr)
If TmpValue = TmpArr(k) Then
CheckHave = True
End If
Next
If CheckHave = False Then
ReDim Preserve TmpArr(0 To j)
TmpArr(j) = TmpValue
j = j + 1
End If
Next
Func71CreatListFromArr = TmpArr
End Function
Function Func72FindMinMaxFromXYArr(XYArr As Variant, XYValue As Double, ValueType As String) As Double

If Func70IsEmptyArray(XYArr) = True Then Exit Function

'Define ValueColumn, MinMaxColumn
Dim MinMaxColumn As Integer
Dim ValueColumn As Integer
Select Case ValueType
Case "XMAX"
MinMaxColumn = 0
ValueColumn = 1
Case "XMIN"
MinMaxColumn = 0
ValueColumn = 1
Case "YMAX"
MinMaxColumn = 1
ValueColumn = 0
Case "YMIN"
MinMaxColumn = 1
ValueColumn = 0
End Select

Dim TmpValue As Double
Dim TmpMinMaxValue As Double
Dim MinValue As Double
Dim MaxValue As Double
'Define MinValue,MaxValue
For i = LBound(XYArr) To UBound(XYArr)
TmpValue = XYArr(i, ValueColumn)
TmpMinMaxValue = XYArr(i, MinMaxColumn)
If TmpValue = XYValue Then
MaxValue = TmpMinMaxValue
MinValue = TmpMinMaxValue
End If
Next

For i = LBound(XYArr) To UBound(XYArr)
TmpValue = XYArr(i, ValueColumn)
TmpMinMaxValue = XYArr(i, MinMaxColumn)
If TmpValue = XYValue Then
If TmpMinMaxValue >= MaxValue Then MaxValue = TmpMinMaxValue
If TmpMinMaxValue <= MinValue Then MinValue = TmpMinMaxValue
End If
Next
Select Case ValueType
Case "XMAX"
Func72FindMinMaxFromXYArr = MaxValue
Case "YMAX"
Func72FindMinMaxFromXYArr = MaxValue
Case "XMIN"
Func72FindMinMaxFromXYArr = MinValue
Case "YMIN"
Func72FindMinMaxFromXYArr = MinValue
End Select
End Function
Function Func73DrawLineThrough2Point(Point1X As Double, Point1Y As Double, Point2X As Double, Point2Y As Double, LayerName As String)

Dim Point1(0 To 2) As Double
Dim Point2(0 To 2) As Double
Point1(0) = Point1X
Point1(1) = Point1Y
Point2(0) = Point2X
Point2(1) = Point2Y
Dim Line As AcadLine
If Point1X = Point2X And Point1Y = Point2Y Then
Else
Set Line = Thisdrawing.ModelSpace.AddLine(Point1, Point2)
Line.layer = LayerName
End If

End Function

Function Func74ConvertText2MText(ObjText As AcadText) As AcadMText
'Function Convert Text to MText

Dim ObjMText As AcadMText

'Get infomation from ObjText
Dim InsertPoint As Variant
Dim TextAlignment As AcAlignment
Dim TextString As String
InsertPoint = ObjText.InsertionPoint
TextString = ObjText.TextString
TextAlignment = ObjText.Alignment

'Define AttachmentPoint follow Alignment
Dim AttachmentPoint As AcAttachmentPoint
Select Case TextAlignment
Case acAlignmentBottomCenter, acAlignmentCenter
AttachmentPoint = acAttachmentPointBottomCenter
Case acAlignmentBottomLeft, acAlignmentLeft
AttachmentPoint = acAttachmentPointBottomLeft
Case acAlignmentBottomRight, acAlignmentRight
AttachmentPoint = acAttachmentPointBottomRight
Case acAlignmentMiddleCenter, acAlignmentMiddle
AttachmentPoint = acAttachmentPointMiddleCenter
Case acAlignmentMiddleLeft
AttachmentPoint = acAttachmentPointMiddleLeft
Case acAlignmentMiddleRight
AttachmentPoint = acAttachmentPointMiddleRight
Case acAlignmentTopCenter
AttachmentPoint = acAttachmentPointTopCenter
Case acAlignmentTopLeft
AttachmentPoint = acAttachmentPointTopLeft
Case acAlignmentTopRight
AttachmentPoint = acAttachmentPointTopRight
End Select

Set ObjMText = Thisdrawing.ModelSpace.AddMText(InsertPoint, 0, TextString)
ObjMText.layer = ObjText.layer
ObjMText.Height = ObjText.Height
Call Func43SetBylayer(ObjMText)
ObjMText.AttachmentPoint = AttachmentPoint
ObjMText.Rotation = ObjText.Rotation

'Move Text
Dim FromPoint As Variant
Dim ToPoint As Variant
FromPoint = Func19ObjectCenterPoint(ObjMText)
ToPoint = Func19ObjectCenterPoint(ObjText)
Call FuncMoveX(ObjMText, FromPoint, ToPoint)
Call FuncMoveY(ObjMText, FromPoint, ToPoint)

Set Func74ConvertText2MText = ObjMText
ObjText.Delete
End Function

Function Func75DrawOrder(Obj As AcadEntity, FrontBack As String)
'Bring Obj to Front, Send Obj to Back
Dim ObjHandle As String
Dim ObjHandent As String
ObjHandle = Obj.Handle
ObjHandent = "(handent " & Chr(34) & ObjHandle & Chr(34) & ")"
FrontBack = UCase(FrontBack)
Select Case FrontBack
Case "FRONT"
Thisdrawing.SendCommand "DRAWORDER" & vbCr & ObjHandent & vbCr & vbCr & "F" & vbCr
Case "BACK"
Thisdrawing.SendCommand "DRAWORDER" & vbCr & ObjHandent & vbCr & vbCr & "B" & vbCr
End Select

End Function

Function Func76MatchObj(OriginObj As AcadEntity, MatchObj As AcadEntity)
'Function Match: Color, layer, linetype, lineweight, linetypescale=1

MatchObj.Color = OriginObj.Color
MatchObj.layer = OriginObj.layer
MatchObj.Linetype = OriginObj.Linetype
MatchObj.Lineweight = acLnWtByLayer
MatchObj.LinetypeScale = 1

End Function

Re: VBA Printing to PDF

buianhtuan.cdt — Sun, 24 Jan 2021 14:01:40 GMT

;(VBA AutoCad)Ordinate Dimension Check Origin,[ODCO]
(defun C:ODCO()
(command "-vbarun" "TBR23OrdinateDimensionCheckOrigin")
)

;(VBA AutoCad)Ordinate Dimension Copy,[ODC]
(defun C:ODC()
(command "-vbarun" "TBR22OrdinateDimensionCopy")
)

;(VBA AutoCad)Ordinate Dimension Move,[ODM]
(defun C:ODM()
(command "-vbarun" "TBR21OrdinateDimensionMove")
)

;(VBA AutoCad)Ordinate Dimension UCS,[ODUCS]
(defun C:ODUCS()
(command "-vbarun" "TBR20OridinateDimensionUCS")
)

;(VBA AutoCad)Ordinate Dimension Straighten Manual,[ODSM]
(defun C:ODSM()
(command "-vbarun" "TBR19OrdinateDimensionStraightenManual")
)

;(VBA AutoCad)Ordinate Dimension Straighten,[ODS]
(defun C:ODS()
(command "-vbarun" "TBR18OrdinateDimensionStraighten")
)

;Ordinate Dimension Arrange,[ODA]
(defun C:ODA()
(command "-vbarun" "TBR17OrdinateDimensionArrange")
)

;Set Dimension Linear Scale,[SDLS]
(defun C:SDLS()
(command "-vbarun" "TBR16SetDimensionLinearScale")
)

;Rotate Finishing Sysbol,[ROFS]
(defun C:ROFS()
(command "-vbarun" "TBR15RotateFinishingSysbol")
)

;Change Entity in block to byLayer, [C2BL]
(defun C:C2BL()
(command "-vbarun" "TBR14Change2ByLayer")
)

;Change Entity in block to byBlock, [C2BB]
(defun C:C2BB()
(command "-vbarun" "TBR13Change2ByBlock")
)

;Creat Multi Centerline, shortcut key [MCL]
(defun C:MCL()
(command "-vbarun" "TBR12CreatMultiCenterline")
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Function Func77CircleABisConcentic(CircleA As AcadCircle, CircleB As AcadCircle) As Integer

Dim CenterA As Variant
Dim CenterB As Variant
Dim XA As Double
Dim YA As Double
Dim XB As Double
Dim YB As Double
CenterA = CircleA.Center
CenterB = CircleB.Center
XA = Round(CenterA(0), 2)
YA = Round(CenterA(1), 2)
XB = Round(CenterB(0), 2)
YB = Round(CenterB(1), 2)
If XA = XB And YA = YB Then
Func77CircleABisConcentic = 1
Else
Func77CircleABisConcentic = 0
End If

End Function
Function Func78CircleCenterlineKKS(Object As AcadCircle)

Dim CircleCenter As Variant
Dim point1 As Variant
Dim point2 As Variant
Dim point3 As Variant
Dim point4 As Variant
Dim radius As Double
Dim Pi As Double
Pi = 4 * Atn(1)

CircleCenter = Object.Center
radius = Object.radius
radius = radius + 3
point1 = Thisdrawing.Utility.PolarPoint(CircleCenter, Pi, radius)
point2 = Thisdrawing.Utility.PolarPoint(CircleCenter, 0, radius)
point3 = Thisdrawing.Utility.PolarPoint(CircleCenter, Pi / 2, radius)
point4 = Thisdrawing.Utility.PolarPoint(CircleCenter, -Pi / 2, radius)

Dim Centerline1 As AcadLine
Dim Centerline2 As AcadLine
Set Centerline1 = Thisdrawing.ModelSpace.AddLine(point1, point2)
Set Centerline2 = Thisdrawing.ModelSpace.AddLine(point3, point4)
Centerline1.layer = CenterLayerName
Centerline2.layer = CenterLayerName

End Function
Function Func79PointAisEndPointOfLineB(PointA As Variant, LineB As AcadLine) As Boolean

Dim StartPoint As Variant
Dim EndPoint As Variant
StartPoint = LineB.StartPoint
EndPoint = LineB.EndPoint
Dim PointAx, PointAy As Double
Dim StartPointx, StartPointy As Double
Dim EndPointx, EndPointy As Double

PointAx = Round(PointA(0), 3)
PointAy = Round(PointA(1), 3)
StartPointx = Round(StartPoint(0), 3)
StartPointy = Round(StartPoint(1), 3)
EndPointx = Round(EndPoint(0), 3)
EndPointy = Round(EndPoint(1), 3)

If PointAx = StartPointx And PointAy = StartPointy Then Func79PointAisEndPointOfLineB = True
If PointAx = EndPointx And PointAy = EndPointy Then Func79PointAisEndPointOfLineB = True

End Function
Function FuncCadHome01MaxMinXYFrom2Point(PointA As Variant, PointB As Variant) As Variant
'Function Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim XYArr(0 To 3) As Variant
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
Dim TmpDouble As Double
MinX = PointA(0)
MinY = PointA(1)
MaxX = PointB(0)
MaxY = PointB(1)
If MaxX < MinX Then
TmpDouble = MaxX
MaxX = MinX
MinX = TmpDouble
End If
If MaxY < MinY Then
TmpDouble = MaxY
MaxY = MinY
MinY = TmpDouble
End If
XYArr(0) = MinX
XYArr(1) = MaxX
XYArr(2) = MinY
XYArr(3) = MaxY
FuncCadHome01MaxMinXYFrom2Point = XYArr

End Function

Function FuncCadHome03OrdinateDimDirection(OridinateDimObj As AcadDimOrdinate, MinMaxArr As Variant) As String
'Function xac nhan vi tri cua Ordinate Dim so voi MinPoint va MaxPoint
Dim DimDirection As String
Dim MinX As Double
Dim MaxX As Double
Dim MinY As Double
Dim MaxY As Double
MinX = MinMaxArr(0)
MaxX = MinMaxArr(1)
MinY = MinMaxArr(2)
MaxY = MinMaxArr(3)
Dim TextPoint As Variant
Dim TextPointX As Double
Dim TextPointY As Double
TextPoint = OridinateDimObj.TextPosition
TextPointX = TextPoint(0)
TextPointY = TextPoint(1)
Dim DeltaMinX As Double
Dim DeltaMaxX As Double
Dim DeltaMinY As Double
Dim DeltaMaxY As Double
DeltaMinX = TextPointX - MinX
DeltaMaxX = TextPointX - MaxX
DeltaMinY = TextPointY - MinY
DeltaMaxY = TextPointY - MaxY

'Define Direction Up
If MinX > TextPointX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "LEFT"
End If
If MaxX < TextPointX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "RIGHT"
End If
If MinX <= TextPointX And TextPointX <= MaxX And MinY <= TextPointY And TextPointY <= MaxY Then
DimDirection = "IN"
End If
If DeltaMaxY >= 0 Then
Select Case TextPointX
Case Is < MinX
If Abs(DeltaMaxY) >= Abs(DeltaMinX) Then
DimDirection = "UP"
Else
DimDirection = "LEFT"
End If
Case Is > MaxX
If Abs(DeltaMaxY) >= Abs(DeltaMaxX) Then
DimDirection = "UP"
Else
DimDirection = "RIGHT"
End If
Case Else
DimDirection = "UP"
End Select
End If
If DeltaMinY <= 0 Then
Select Case TextPointX
Case Is < MinX
If Abs(DeltaMinY) >= Abs(DeltaMinX) Then
DimDirection = "DOWN"
Else
DimDirection = "LEFT"
End If
Case Is > MaxX
If Abs(DeltaMinY) >= Abs(DeltaMaxX) Then
DimDirection = "DOWN"
Else
DimDirection = "RIGHT"
End If
Case Else
DimDirection = "DOWN"
End Select
End If
FuncCadHome03OrdinateDimDirection = DimDirection
End Function
Function FuncCadHome04DefineDeltaDistanceFromDirection(DimDirection As String) As Variant
Dim Delta(0 To 1) As Integer
Dim DeltaX As Integer
Dim DeltaY As Integer
Select Case DimDirection
Case "IN"
DeltaX = 0
DeltaY = 0
Case "UP"
DeltaX = 0
DeltaY = 1
Case "DOWN"
DeltaX = 0
DeltaY = -1
Case "LEFT"
DeltaX = -1
DeltaY = 0
Case "RIGHT"
DeltaX = 1
DeltaY = 0
End Select
Delta(0) = DeltaX
Delta(1) = DeltaY
FuncCadHome04DefineDeltaDistanceFromDirection = Delta
End Function
Sub FuncCadHome05SetUCSFromPoint(origin As Variant)
Dim Pi As Double: Pi = 4 * Atn(1)

Dim ucsObj As AcadUCS
Dim xAxisPnt As Variant
Dim yAxisPnt As Variant

xAxisPnt = Thisdrawing.Utility.PolarPoint(origin, 0, 10)
yAxisPnt = Thisdrawing.Utility.PolarPoint(origin, Pi / 2 + LineAngle, 10)

' Add the UCS to the UserCoordinatesSystems collection
Set ucsObj = Thisdrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "New_UCS")

' Display the UCS icon
Thisdrawing.ActiveViewport.UCSIconAtOrigin = True
Thisdrawing.ActiveViewport.UCSIconOn = True

' Make the new UCS the active UCS
Thisdrawing.ActiveUCS = ucsObj

End Sub
Function FuncCadHome06MoveOrdinateDimension(objSelect As AcadDimOrdinate, PointA As Variant, MinPoint As Variant, MaxPoint As Variant, OldDelete As Boolean)

'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)

'Define Dim Direction From 2Point
Dim DimDirection As String
DimDirection = FuncCadHome03OrdinateDimDirection(objSelect, MinXMaxXMinYMaxY)

'Define NewTexPositon
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
OldTextPosition = objSelect.TextPosition
OldTextPositionX = OldTextPosition(0)
OldTextPositionY = OldTextPosition(1)
Select Case DimDirection
Case "LEFT", "RIGHT"
NewTextPosition(0) = OldTextPositionX
NewTextPosition(1) = PointA(1)
Case "UP", "DOWN"
NewTextPosition(0) = PointA(0)
NewTextPosition(1) = OldTextPositionY
Case Else
MsgBox "In Limited"
Exit Function
End Select

'Creat New Ordinata Dimension
'Set DimOrdinateObject = Object.AddDimOrdinate(DefinitionPoint, _ LeaderEndPoint, UseXAxis)
Dim NewOD As AcadDimOrdinate
Dim DefinitionPoint As Variant
Dim LeaderEndPoint As Variant
Dim UseXAxis As Boolean
DefinitionPoint = Thisdrawing.Utility.TranslateCoordinates(PointA, acWorld, acUCS, 0)
LeaderEndPoint = Thisdrawing.Utility.TranslateCoordinates(OldTextPosition, acWorld, acUCS, 0)

Select Case DimDirection
Case "LEFT", "RIGHT"
UseXAxis = False
Case "UP", "DOWN"
UseXAxis = True
Case Else
MsgBox "In Limited"
Exit Function
End Select
Set NewOD = Thisdrawing.ModelSpace.AddDimOrdinate(DefinitionPoint, LeaderEndPoint, UseXAxis)

'Move Dim Text
Dim NewODTextPosition As Variant
Dim Point000(0 To 2) As Double
NewODTextPosition = Thisdrawing.Utility.TranslateCoordinates(NewTextPosition, acWorld, acUCS, 0)
NewOD.TextPosition = NewODTextPosition
NewOD.VerticalTextPosition = acVertCentered
objSelect.Update
NewOD.Move Point000, MinPoint

'Set layer for New OD
NewOD.layer = DimLayerName
Call Func43SetBylayer(NewOD)

'Delete Old OD
If OldDelete = True Then objSelect.Delete

End Function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub TBR12CreatMultiCenterline()
'Creat Multi Centerline, shortcut key [MCL]
Thisdrawing.Utility.Prompt (vbCrLf & "Creat Multi Centerline")

'Select Circle
Thisdrawing.Utility.Prompt (vbCrLf & "Select Circles to creat centerline")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
'FT(0) = -4: FD(0) = "<OR"
'FT(1) = 0: FD(1) = "CIRCLE"
'FT(2) = 0: FD(2) = "ARC"
'FT(3) = -4: FD(3) = "OR>"
FT(0) = 0: FD(0) = "CIRCLE"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Circle"
objSelectOnScreen.Delete
Exit Sub
End If

'Creat Circle Arr
Dim EachobjSelectOnScreen As AcadCircle
Dim CircleArr() As AcadCircle
Dim ObjCircle As AcadCircle
Dim TmpCircle As AcadCircle
Dim k As Integer
Dim IsConcentic As Integer
Dim TmpConcentic As Integer

For Each EachobjSelectOnScreen In objSelectOnScreen
IsConcentic = 0
Set ObjCircle = EachobjSelectOnScreen
If Func70IsEmptyArray(CircleArr) = False Then
For i = LBound(CircleArr) To UBound(CircleArr)
Set TmpCircle = CircleArr(i)
TmpConcentic = Func77CircleABisConcentic(ObjCircle, TmpCircle)
If TmpConcentic = 1 And ObjCircle.radius > TmpCircle.radius Then
Set CircleArr(i) = ObjCircle
End If
IsConcentic = IsConcentic + TmpConcentic
Next
End If
If IsConcentic = 0 Then
ReDim Preserve CircleArr(O To k)
Set CircleArr(k) = ObjCircle
k = k + 1
End If
Next
For i = LBound(CircleArr) To UBound(CircleArr)
Set ObjCircle = CircleArr(i)
Call Func78CircleCenterlineKKS(ObjCircle)
Next
objSelectOnScreen.Delete

End Sub
Sub TBR13Change2ByBlock()
'Change Entity in block to byBlock, [C2BB]

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Block"
objSelectOnScreen.Delete
Exit Sub
End If

'Change entity color to byblock
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachEntity As AcadEntity
For Each EachobjSelectOnScreen In objSelectOnScreen
Set EachBlockReference = EachobjSelectOnScreen
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For Each EachEntity In EachBlock
EachEntity.Color = acByBlock
Next
EachBlockReference.Color = acRed
Next
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)

End Sub

Sub TBR14Change2ByLayer()
'Change Entity in block to byLayer, [C2BL]

Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Block"
objSelectOnScreen.Delete
Exit Sub
End If

'Change entity color to byblock
Dim EachBlockReference As AcadBlockReference
Dim EachBlock As AcadBlock
Dim EachEntity As AcadEntity
For Each EachobjSelectOnScreen In objSelectOnScreen
Set EachBlockReference = EachobjSelectOnScreen
Set EachBlock = Thisdrawing.Blocks(EachBlockReference.Name)
For Each EachEntity In EachBlock
EachEntity.Color = acByLayer
Next
EachBlockReference.Color = acByLayer
EachBlockReference.layer = NormalLayerName
Next
objSelectOnScreen.Delete
Thisdrawing.Regen (acActiveViewport)

End Sub
Sub TBR15RotateFinishingSysbol()
'Rotate Finishing Sysbol,[ROFS]

Thisdrawing.Utility.Prompt (vbCrLf & "Rotate Finishing Sysbol")
'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
Dim Pi As Double
Pi = 4 * Atn(1)

'Select Finishing Sysbol(Text,MText,Line)(LayerText)
Dim FinishingLayer As String: FinishingLayer = TextLayerName
Thisdrawing.Utility.Prompt (vbCrLf & "Select Finishing Sysbol")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(7) As Integer
Dim FD(7) As Variant
FT(0) = -4: FD(0) = "<AND"
FT(1) = -4: FD(1) = "<OR"
FT(2) = 0: FD(2) = "TEXT"
FT(3) = 0: FD(3) = "MTEXT"
FT(4) = 0: FD(4) = "LINE"
FT(5) = -4: FD(5) = "OR>"
FT(6) = 8: FD(6) = FinishingLayer
FT(7) = -4: FD(7) = "AND>"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Sub
End If

'Get StartPoint and EndPoint
Dim StartPoint As Variant
Dim EndPoint As Variant
Dim Angle As Double
On Error GoTo ExitSub
StartPoint = Thisdrawing.Utility.GetPoint(, "Start Point select")
EndPoint = Thisdrawing.Utility.GetPoint(StartPoint, "End Point select")
Angle = Func23AngleOfLineThrough2Point(StartPoint, EndPoint)

'Define BeforeAngle of Finishing Sysbol
Dim EachEntity As AcadEntity
Dim FinishingAngleLine As AcadLine
Dim BeforeAnge As Double
Dim TmpLine As AcadLine
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbLine" Then
Set TmpLine = EachEntity
If Func79PointAisEndPointOfLineB(StartPoint, TmpLine) = False Then
Set FinishingAngleLine = TmpLine
End If
End If
Next
BeforeAngle = FinishingAngleLine.Angle

'Define RotateAngle and Rotate
Dim RotateAngle As Double
RotateAngle = Angle - BeforeAngle
For Each EachEntity In objSelectOnScreen
EachEntity.Rotate StartPoint, RotateAngle
Next
ExitSub:
objSelectOnScreen.Delete

End Sub
Sub TBR16SetDimensionLinearScale()
'Set Dimension Linear Scale,[SDLS]

Thisdrawing.Utility.Prompt (vbCrLf & "Set Dimension Linear Scale")

'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimension to change Linear Scale")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity"
objSelectOnScreen.Delete
Exit Sub
End If

'Get Linear Scale
Dim LinearScale As Double
On Error Resume Next
LinearScale = Thisdrawing.Utility.GetReal("New Linear Scale = ")
If Err Then
Err.Clear
MsgBox "No Dimension Linear Scale"
objSelectOnScreen.Delete
Exit Sub
End If

'Change Dim linear scale
Dim EachEntity As AcadDimension
For Each EachEntity In objSelectOnScreen
EachEntity.LinearScaleFactor = LinearScale
Next
objSelectOnScreen.Delete
MsgBox "Finished"

End Sub
Sub TBR17OrdinateDimensionArrange()
'Ordinate Dimension Arrange,[ODA]

Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Arrange")

'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr

'Get Dimscale,Standart Distance
Dim Dimscale As Integer
Dimscale = Thisdrawing.GetVariable("DIMSCALE")
Dim Distance As Integer
Distance = 20 * Dimscale

'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Dimension to arrange:")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
objSelectOnScreen.Delete
Exit Sub
End If

'Get MinPoint and MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
Next01:
If Err.Number <> 0 Then
Err.Clear
MsgBox "Don't Select MinPoint or MaxPoint. Exit"
objSelectOnScreen.Delete
Exit Sub
End If

'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)

'Filter Only Ordinate Dimension
Dim OrdinateDimArr() As Variant
Dim kArr As Integer
Dim EachEntity As AcadDimension
Dim EachOrdinateDim As AcadDimOrdinate
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
ReDim Preserve OrdinateDimArr(0 To kArr)
Set OrdinateDimArr(kArr) = EachEntity
kArr = kArr + 1
End If
Next
Dim DimDirection As String
Dim Delta As Variant
Dim DeltaX As Integer
Dim DeltaY As Integer
Dim NewTextPosition(0 To 2) As Double
For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
Set EachOrdinateDim = OrdinateDimArr(i)
DimDirection = FuncCadHome03OrdinateDimDirection(EachOrdinateDim, MinXMaxXMinYMaxY)
Delta = FuncCadHome04DefineDeltaDistanceFromDirection(DimDirection)
DeltaX = Delta(0)
DeltaY = Delta(1)
Select Case DeltaX
Case -1
NewTextPosition(0) = MinXMaxXMinYMaxY(0) + DeltaX * Distance
Case 0
NewTextPosition(0) = EachOrdinateDim.TextPosition(0)
Case 1
NewTextPosition(0) = MinXMaxXMinYMaxY(1) + DeltaX * Distance
End Select
Select Case DeltaY
Case -1
NewTextPosition(1) = MinXMaxXMinYMaxY(2) + DeltaY * Distance
Case 0
NewTextPosition(1) = EachOrdinateDim.TextPosition(1)
Case 1
NewTextPosition(1) = MinXMaxXMinYMaxY(3) + DeltaY * Distance
End Select
EachOrdinateDim.TextPosition = NewTextPosition
EachOrdinateDim.Update
Next

objSelectOnScreen.Delete
End Sub
Sub TBR18OrdinateDimensionStraighten()
'(VBA AutoCad)Ordinate Dimension Straighten,[ODS]

Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Straighten")

'Select Dimension
Thisdrawing.Utility.Prompt (vbCrLf & "Select Ordinate Dimension to Straighten:")
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.SelectOnScreen FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
objSelectOnScreen.Delete
Exit Sub
End If

'Get MinPoint and MaxPoint
Dim MinPoint As Variant
Dim MaxPoint As Variant
'On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
'Next01:
'If Err.Number <> 0 Then
' Err.Clear
' MsgBox "Don't Select MinPoint or MaxPoint. Exit"
' objSelectOnScreen.Delete
' Exit Sub
'End If

'Set UCS to MinPoint
Call FuncCadHome05SetUCSFromPoint(MinPoint)

'Define MinX,MaxX,MinY,MaxY from MinPoint,MaxPoint
Dim MinXMaxXMinYMaxY As Variant
MinXMaxXMinYMaxY = FuncCadHome01MaxMinXYFrom2Point(MinPoint, MaxPoint)
'
'Filter Only Ordinate Dimension
Dim OrdinateDimArr() As Variant
Dim kArr As Integer
Dim EachEntity As AcadDimension
Dim EachOrdinateDim As AcadDimOrdinate
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
ReDim Preserve OrdinateDimArr(0 To kArr)
Set OrdinateDimArr(kArr) = EachEntity
kArr = kArr + 1
End If
Next
Dim DimDirection As String
Dim ChangeCount As Integer
Dim DimMeasurement As Double
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
Dim WorldNewTextPositon As Variant
For i = LBound(OrdinateDimArr) To UBound(OrdinateDimArr)
Set EachOrdinateDim = OrdinateDimArr(i)
DimDirection = FuncCadHome03OrdinateDimDirection(EachOrdinateDim, MinXMaxXMinYMaxY)
OldTextPosition = EachOrdinateDim.TextPosition
OldTextPosition = Thisdrawing.Utility.TranslateCoordinates(OldTextPosition, acWorld, acUCS, 0)
OldTextPositionX = Round(OldTextPosition(0), 2)
OldTextPositionY = Round(OldTextPosition(1), 2)
DimMeasurement = Round(EachOrdinateDim.Measurement, 2)
Select Case DimDirection
Case "UP", "DOWN"
If DimMeasurement <> OldTextPositionX Then
NewTextPosition(0) = EachOrdinateDim.Measurement
NewTextPosition(1) = OldTextPosition(1)
WorldNewTextPositon = NewTextPosition
WorldNewTextPositon = Thisdrawing.Utility.TranslateCoordinates(WorldNewTextPositon, acUCS, acWorld, 0)
EachOrdinateDim.TextPosition = WorldNewTextPositon
EachOrdinateDim.Update
ChangeCount = ChangeCount + 1
End If
Case "LEFT", "RIGHT"
If DimMeasurement <> OldTextPositionY Then
NewTextPosition(1) = EachOrdinateDim.Measurement
NewTextPosition(0) = OldTextPosition(0)
WorldNewTextPositon = NewTextPosition
WorldNewTextPositon = Thisdrawing.Utility.TranslateCoordinates(WorldNewTextPositon, acUCS, acWorld, 0)
EachOrdinateDim.TextPosition = WorldNewTextPositon
EachOrdinateDim.Update
ChangeCount = ChangeCount + 1
End If
Case Else
End Select
Next
objSelectOnScreen.Delete
MsgBox "Change Text Position of " & ChangeCount & " Ordinate Dimension"
End Sub
Sub TBR19OrdinateDimensionStraightenManual()
'(VBA AutoCad)Ordinate Dimension Straighten Manual,[ODSM]

Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Straighten Manual")

'Set UCS is world
Thisdrawing.SendCommand "UCS" & vbCr & "W" & vbCr
'Set ORTHO ON
Thisdrawing.SetVariable "ORTHOMODE", 1
Dim Pi As Double
Pi = 4 * Atn(1)

'Select Dimension
Dim varPick As Variant
Dim Msg As String: Msg = "Select Ordinate Dimension to Straighten Manual:"
Dim objSelect As AcadDimOrdinate
Dim CountLoop As Integer
On Error Resume Next
Do While objSelect Is Nothing
If CountLoop = 3 Then Exit Sub
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
CountLoop = CountLoop + 1
Loop

'Get PointA and PointB
Thisdrawing.Utility.Prompt (vbCrLf & "Select 2Point to Define dim direction")
Dim PointA As Variant
Dim PointB As Variant
On Error GoTo Next01
PointA = Thisdrawing.Utility.GetPoint(, "Select PointA:")
PointB = Thisdrawing.Utility.GetPoint(PointA, "Select PointB:")
Next01:
If Err.Number <> 0 Then
MsgBox "Don't Select PointA or PointB. Exit"
Exit Sub
End If

'Define Dim Direction From 2Point
Dim XorY As String

If Round(PointA(1), 2) = Round(PointB(1), 2) Then
XorY = "NamNgang"
Else
XorY = "ThangDung"
End If

'Define NewTexPositon
Dim OldTextPosition As Variant
Dim OldTextPositionX As Double
Dim OldTextPositionY As Double
Dim NewTextPosition(0 To 2) As Double
OldTextPosition = objSelect.TextPosition
OldTextPositionX = OldTextPosition(0)
OldTextPositionY = OldTextPosition(1)
Select Case XorY
Case "NamNgang"
NewTextPosition(0) = OldTextPositionX
NewTextPosition(1) = PointA(1)
Case "ThangDung"
NewTextPosition(0) = PointA(0)
NewTextPosition(1) = OldTextPositionY
End Select

'Move Dim Text
objSelect.TextPosition = NewTextPosition
objSelect.Update

End Sub

Sub TBR20OridinateDimensionUCS()
'(VBA AutoCad)Ordinate Dimension UCS,[ODUCS]

Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension Set UCS")

'Get UCS Point
Dim UCSPoint As Variant
Dim MaxPoint As Variant
On Error GoTo ExitSub
UCSPoint = Thisdrawing.Utility.GetPoint(, "Select UCSPoint:")

'Set UCS to UCSPoint
Call FuncCadHome05SetUCSFromPoint(UCSPoint)

ExitSub:
End Sub
Sub TBR21OrdinateDimensionMove()
'(VBA AutoCad)Ordinate Dimension Move,[ODM]

Thisdrawing.Utility.Prompt (vbCrLf & "Ordinate Dimension to Move")

'Get MinPoint and MaxPoint
Thisdrawing.Utility.Prompt (vbCrLf & "Select MinPoint and MaxPoint" & vbCrLf)
Dim MinPoint As Variant
Dim MaxPoint As Variant
On Error GoTo Next01
MinPoint = Thisdrawing.Utility.GetPoint(, "Select MinPoint:")
MaxPoint = Thisdrawing.Utility.GetPoint(, "Select MaxPoint:")
Next01:
If Err.Number <> 0 Then
MsgBox "Don't Select MinPoint or MaxPoint. Exit"
Exit Sub
End If

'Creat user UCS
Call FuncCadHome05SetUCSFromPoint(MinPoint)

'Select Dimension
'Get PointA
Dim varPick As Variant
Dim Msg As String: Msg = vbCrLf & "Select Ordinate Dimension to Move:"
Dim objSelect As AcadDimOrdinate
Dim PointA As Variant
On Error Resume Next
Do
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
PointA = Thisdrawing.Utility.GetPoint(, "Select Ordinate Dimension Point:")
If Err.Number = 0 Then
Call FuncCadHome06MoveOrdinateDimension(objSelect, PointA, MinPoint, MaxPoint, True)
End If
Loop While Err.Number = 0

End Sub
Sub TBR22OrdinateDimensionCopy()
'(VBA AutoCad)Ordinate Dimension Copy,[ODC]

Thisdrawing.Utility.Prompt (vbCrLf & "Copy Ordinate Dimension")

'Creat user UCS
Call FuncCadHome05SetUCSFromPoint(MinPoint)

'Select Dimension
'Get PointA
Dim varPick As Variant
Dim Msg As String: Msg = vbCrLf & "Select Ordinate Dimension To Copy:"
Dim objSelect As AcadDimOrdinate
On Error Resume Next
Thisdrawing.Utility.GetEntity objSelect, varPick, Msg
If Err.Number <> 0 Then
MsgBox "No Ordinate Dimension"
Exit Sub
End If

Dim PointA As Variant
Do
PointA = Thisdrawing.Utility.GetPoint(, "Select Ordinate Dimension Point:")
If Err.Number = 0 Then
Call FuncCadHome06MoveOrdinateDimension(objSelect, PointA, MinPoint, MaxPoint, False)
End If
Loop While Err.Number = 0

End Sub
Sub TBR23OrdinateDimensionCheckOrigin()
'(VBA AutoCad)Ordinate Dimension Check Origin,[ODCO]

Dim Point00 As Variant
Dim Point00Arr() As Variant
Dim k As Integer
On Error Resume Next
Do
Point00 = Thisdrawing.Utility.GetPoint(, "Select Ordinate Point:")
If Err.Number = 0 Then
ReDim Preserve Point00Arr(0 To k)
Point00Arr(k) = Point00
k = k + 1
End If
Loop While Err.Number = 0
If Func70IsEmptyArray(Point00Arr) = True Then Exit Sub

Dim MinPoint As Variant
Dim MaxPoint As Variant
Dim Pi As Double: Pi = 4 * Atn(1)
For i = LBound(Point00Arr) To UBound(Point00Arr)
Point00 = Point00Arr(i)
MinPoint = Thisdrawing.Utility.PolarPoint(Point00, 5 * Pi / 4, 0.001)
MaxPoint = Thisdrawing.Utility.PolarPoint(Point00, Pi / 4, 0.001)

'Select Dimension
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "DIMENSION"
objSelectOnScreen.Select acSelectionSetCrossing, MinPoint, MaxPoint, FT, FD
If objSelectOnScreen.count = 0 Then
MsgBox "No Selected Entity. Exit"
' objSelectOnScreen.Delete
' Exit Sub
End If

Dim EachEntity As AcadDimension
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" Then
EachEntity.Visible = False
End If
Next
Next
objSelectOnScreen.Clear

'Check have Ordinate Dimension?
Dim WrongCount As Integer
Set objSelectOnScreen = Thisdrawing.SelectionSets.Add("objSelectOnScreen" & Now)
objSelectOnScreen.Select acSelectionSetAll, , , FT, FD
For Each EachEntity In objSelectOnScreen
If EachEntity.ObjectName = "AcDbOrdinateDimension" And EachEntity.Visible = True Then
EachEntity.Color = acMagenta
WrongCount = WrongCount + 1
End If
Next
For Each EachEntity In objSelectOnScreen
EachEntity.Visible = True
Next

MsgBox "Wrong Ordinate Dimension: " & WrongCount

End Sub

VBA Printing to PDF

buianhtuan.cdt — Tue, 02 Feb 2021 13:48:44 GMT

Sub TBR0701CreatDataFromTable()

Dim WS As Worksheet
Set WS = Sheets("10.KKSMaterial")

'Xac dinh dong cuoi de ghi du lieu
Dim WriteEndRow As Integer
WriteEndRow = WS.Cells(Rows.Count, 3).End(xlUp).Row + 1

'Xac dinh dong dau tien va dong cuoi cung cua bang du lieu
Dim ReadTopRow As Integer
Dim ReadEndRow As Integer
ReadTopRow = 3
ReadEndRow = WS.Cells(Rows.Count, 11).End(xlUp).Row

'Xac dinh cot dau tien va cot cuoi cung cua bang du lieu
Dim ReadTopColumn As Integer
Dim ReadEndRColumn As Integer
ReadTopColumn = 12
ReadEndColumn = WS.Cells(1, Columns.Count).End(xlToLeft).Column

'Ghi du lieu
Dim YuuSenDo As String
Dim SizeType As String
Dim MatSize As String
Dim Mat As String
Dim MatType As String
Dim Note1 As String
Dim Note2 As String

MatType = WS.Range("J1").Value
Note1 = WS.Range("J2").Value
Note2 = WS.Range("J3").Value
For dong = ReadTopRow To ReadEndRow
Mat = WS.Cells(dong, ReadTopColumn - 1).Value
For Cot = ReadTopColumn To ReadEndColumn
YuuSenDo = WS.Cells(dong, Cot).Value
SizeType = WS.Cells(1, Cot).Value
MatSize = SizeType & WS.Cells(2, Cot).Value
If YuuSenDo <> "" Then
WS.Cells(WriteEndRow, 1).Value = YuuSenDo
WS.Cells(WriteEndRow, 2).Value = SizeType
WS.Cells(WriteEndRow, 3).Value = MatSize
WS.Cells(WriteEndRow, 4).Value = Mat
WS.Cells(WriteEndRow, 5).Value = MatType
WS.Cells(WriteEndRow, 6).Value = Note1
WS.Cells(WriteEndRow, 7).Value = Note2
WriteEndRow = WriteEndRow + 1
End If
Next
Next

End Sub

Re: VBA Printing to PDF

buianhtuan.cdt — Wed, 17 Feb 2021 13:08:03 GMT

';;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Sub ManyAssyPartList_DrawingManySheet()

Application.ScreenUpdating = False
Dim WS As Worksheet
Set WS = ThisWorkbook.Sheets("MANYASSYPARTLIST")
WS.Visible = True

'Clear Old Data
WS.Range("A2:L1000").ClearContents

'Thisdrawing
Dim Thisdrawing As AcadDocument
Set Thisdrawing = KhoidongAutoCad()

'Select Obj by SelectOnScreen
Dim objSelectOnScreen As AcadSelectionSet
Set objSelectOnScreen = Thisdrawing.SelectionSets.ADD("objSelectOnScreen" & Now)
Dim FT(0) As Integer
Dim FD(0) As Variant
FT(0) = 0: FD(0) = "INSERT"

Do
objSelectOnScreen.Clear
objSelectOnScreen.SelectOnScreen FT, FD
Call ManyAssyPartList_DrawingManySheet_Fun01(WS, objSelectOnScreen)
Loop While objSelectOnScreen.Count > 0

objSelectOnScreen.Delete

'Sheets("MENU").Select
'WS.Visible = False
Application.ScreenUpdating = True
MsgBox "Finish"

End Sub
Function ManyAssyPartList_DrawingManySheet_Fun01(WS As Worksheet, objSelectOnScreen As AcadSelectionSet)

'Khai bao Blockname va tagname de lay S_No va Qty
Dim SizeBlockName As String
SizeBlockName = ThisWorkbook.Sheets("SETUP").Range("B14").Value
Dim BlockNameSNo As String: BlockNameSNo = "DRAWING_TITLE3"
Dim TagNameSNo As String: TagNameSNo = "S_NO"
Dim BlockNameQty As String: BlockNameQty = "DRAWING_TITLE5"
Dim TagNameQty As String: TagNameQty = "QUAN"
Dim TagNameMat As String: TagNameMat = "MATERIAL"
Dim SNoValue As String
Dim QtyValue As String
Dim StrMaterial As String

If objSelectOnScreen.Count = 0 Then
MsgBox "No Selected Block"
Exit Function
End If

Dim EachBlockRef As AcadBlockReference
Dim EachBlockname As String
Dim PartListBlockRefArr() As Variant
Dim i As Integer

'Creat PartListArr
For Each EachBlockRef In objSelectOnScreen
EachBlockname = EachBlockRef.Name
Select Case EachBlockname
Case BlockNameSNo
SNoValue = Func03GetAttValue(EachBlockRef, TagNameSNo)
SNoValue = "-" & Left(SNoValue, 4)
Case BlockNameQty
QtyValue = Func03GetAttValue(EachBlockRef, TagNameQty)
Case SizeBlockName
StrMaterial = Func03GetAttValue(EachBlockRef, TagNameMat)
If Left(StrMaterial, 1) = "-" Then
ReDim Preserve PartListBlockRefArr(0 To i)
Set PartListBlockRefArr(i) = EachBlockRef
i = i + 1
End If
End Select
Next

'Creat WriteData
Dim WriteData() As String
Dim varAttributes As Variant
ReDim WriteData(0 To UBound(PartListBlockRefArr), 0 To 11)
For i = LBound(WriteData) To UBound(WriteData)
Set EachBlockRef = PartListBlockRefArr(i)
varAttributes = EachBlockRef.GetAttributes
WriteData(i, 0) = SNoValue
WriteData(i, 1) = QtyValue
For k = LBound(varAttributes) To UBound(varAttributes)
WriteData(i, k + 2) = varAttributes(k).TextString
Next
Next

'Write Data to Excel
Dim EndRow As Integer
EndRow = WS.Cells(Rows.Count, 1).End(xlUp).Row + 1
Dim RowNo As Integer
Dim ColumnNo As Integer
For i = LBound(WriteData) To UBound(WriteData)
RowNo = EndRow + i
For k = 0 To 11
ColumnNo = k + 1
WS.Cells(RowNo, ColumnNo).Value = WriteData(i, k)
Next
Next

End Function

Re: VBA Printing to PDF

Ed__Jobe — Wed, 01 Jan 2025 01:32:40 GMT

@buianhtuan.cdt @Please post your code in a code window. It preserves the formatting. See the link in my signature. You can edit your posts by clicking on the three vertical dots.