First of all i should say that this problem is solved by EXplant module of PDMS. When i wrote this script i hadn't access to this module. With this module you can directly export to dgn!!
In that time our company design in Aveva PDMS and we in GIS division model all piping and other structures in ArcGIS. Piping Discipline give us only some reports from PDMS and we should redesign them in Auto CAD then import AutoCAD 3D Models into ArcGIS. We decide to automate this sequence. So I began to search.
I searched the entire web and finally I find out Aveva has "Explant-I" to do this. I couldn’t find it in that time.
At last I decide to write some code in AutoCAD VBA to convert PDMS report to AutoCAD objects and i did it.
We build a DWG template that includes some piping elements as blocks including valves and other piping equipments and VBA application read the positions and type of them from PDMS report and then import them in right place in DWG template.
Because of some modeling points in ArcGIS, I categorized objects in layers with special names special line types and special color (depend on pipe size).
This code is fully customized for our problem. but if your Report from PDMS be exactly same as this Excel file, this program surely works for you.
You can download All of my works HERE.
4Files included. after extraction do following works:
- open Excel file and leave it aside.( This is the report from PDMS produced From Piping Discipline)
- open dwg file (Template file included all blocks and ... we needed)
- put dvb file in the path of your AutoCAD. For example C:\Program Files\AutoCadPath\Support folder
- load lsp & dvb file from AutoCAD menu-> Tools -> Load application
- type pdms in command prompt in AutoCAD to run application
- Enter a Number that indicate how many line from Excel file you want to be Drawn in Autocad. & press Enter. and Please Wait ...
- After all works done "zoom extent" to see what is drawn.
Attention to blocks and poly lines( color number, line type scale), Layers,...
ٍ
Leaving Comments Make me happy.
And this is my VBA code:
Option Explicit
Private RowC(1 To 12), RowB
Private CurrentRow As Long
Private CurrentDir As Variant
Private MaxRecord As Integer
Private WorkSheet As Excel.WorkSheet
Private oExcel As Excel.Application
Private polyObj As Acad3DPolyline
Private textObj As AcadText
Private Mean As Variant
Private WarN As Integer
Private Const pi = 3.14159265358979
Public Sub main()
WarN = 0
Dim FMoment As Date
FMoment = Now()
Dim LMoment As Date
On Error GoTo errorhandler
'Start Excel Application
'******Read Excel Sheet Till Row MaxRecord********
'MaxRecord = 1931
MaxRecord = ThisDrawing.Utility.GetInteger("Enter Max Number in Excel Sheet:")
Mean = StartApp()
CreateReportHeader
'From STD of All points==Mean(2,3)==(StdX,StdY)->Compute The direction of plant
Dim Entity As AcadEntity
Dim PlntDir As Double
PlntDir = 1 '1 Means that Plant Elongs in X Direction
If Mean(3) > Mean(2) Then PlntDir = 0
'A Temporary Variable
Dim tmp1, tmp2, tmp3 As Variant
Dim Point(0 To 2) As Double
Dim Spoint() As Double
Dim blockRefObj As AcadBlockReference
'Create The Gauge Layer
Dim GaugeLayerName As String: GaugeLayerName = "0Gauges": CheckLayer (GaugeLayerName)
'Create The Valve Layer
Dim ValveLayerName As String: ValveLayerName = "0Valves": CheckLayer (ValveLayerName)
'Create The Flange Layer
Dim FlangeLayerName As String: FlangeLayerName = "0Flange": CheckLayer (FlangeLayerName)
'Create The Text Layer
Dim TextLayerName As String: TextLayerName = "0Text": CheckLayer (TextLayerName)
'Create The Reducer Layer
Dim ReducerLayerName As String: ReducerLayerName = "0Reducer": CheckLayer (ReducerLayerName)
CurrentRow = 1
'Read First Record Of Excel File
Dim I As Integer
For I = 1 To 10
RowC(I) = WorkSheet.Cells(CurrentRow, I)
Next I
'Declaring The First Record Layer->(11) & Branch->(12)
RowC(11) = "none": RowC(12) = "none"
RowB = RowC()
'Initializing Max Value Of ProgressBar
UF.PBar.Max = 1
'Read Next Record While 1
Begin:
Do
Do
ReadNewRecord
Loop While CurrentRow < MaxRecord And StrComp(RowC(2), Empty) = 0
'Outer Loop Ends When Following Condition Satisfiy
If CurrentRow > MaxRecord Then
'Clean Up Drawing From 0 Length 3Dpoly
For Each Entity In ThisDrawing.ModelSpace
If TypeName(Entity) = "IAcad3DPolyline" Then
If Entity.Length < 0.001 Then
Entity.Delete
End If
End If
Next Entity
'Hide The ProgressBar
UF.Hide
LMoment = Now()
'MsgBox "Elapsed Time =" & Format(CDbl(LMoment - FMoment) * 3600 * 24, "###")
Exit Sub
End If
'If Current Layer Is Not == Layer Name Of Current Record ==RowC(11)
'Check For Existence Of Layer==Rowc(11)
Dim strLayerName As String
strLayerName = "Pipe " + RowC(11)
CheckLayer (strLayerName)
'Add The Text Of Point
AddNewText TextLayerName
Select Case RowC(2)
Case "ELBO"
InsertElbow
GoTo Begin
Case "ATTA"
'If Object is Attach 150mm it is Pressure Gauge and should insert it's Block
If (CInt(RowC(5)) = 15) Then
'INSER GAUGE BLOCK
Set blockRefObj = InsertBlock("Pressure gauge 1p", PlntDir)
blockRefObj.Layer = GaugeLayerName
End If
Case "VALV"
'Recognizing Valves For Substituting Proper BlockRefrence
Dim Descr() As String
Dim PipeDim As Double
Dim Rating As Integer
'Diameter Of Pipe converted From mm to inch
PipeDim = Fix(CLng(RowC(5)) / 6.25) * 0.25
'Split The DESCRIPTION Row to 6 Part (0 to 5) and Copy it Into Descr
Descr = Split(RowC(3), ",", 6, vbTextCompare)
'Trim and Convert to UpperCase All Desc Fields
For I = 0 To UBound(Descr)
Descr(I) = UCase(Trim(Descr(I)))
Next I
'Try To Extract Rating (Distinguished With # Sign) From Text
'Position Of # Sign -> tmp1
tmp1 = InStr(1, RowC(3), "#", vbTextCompare)
'Position of All "'" Signs
Dim pos(0 To 9) As Integer
I = 0
'Find place of "," Just Before the "#" Sign ->pos(i-1)
Do
I = I + 1
pos(I) = InStr(pos(I - 1) + 1, RowC(3), ",", vbTextCompare)
Loop While pos(I) < tmp1
'Calulatin The Digits Of Rating and Extract it to ->Rating
Rating = Mid(RowC(3), pos(I - 1) + 1, (tmp1 - pos(I - 1) - 1))
'Recognizing Differentt Type Of Valves
Select Case Descr(1)
'IF Valve IS ANY KIND OF GATE VALVE Then ->
Case "GATE"
Select Case Rating
Case 150, 1500
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 34, 36
Set blockRefObj = InsertBlock("Gate-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 300
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 30
Set blockRefObj = InsertBlock("Gate-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 600
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 28
Set blockRefObj = InsertBlock("Gate-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 800
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 26, 28, 30, 34, 36
Set blockRefObj = InsertBlock("Gate-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 900
Select Case PipeDim
Case 3, 4, 5, 6, 8, 10, 12, 14, 16, 18
Set blockRefObj = InsertBlock("Gate-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
End Select
Case "BALL"
If Descr(2) = "REDUCED BORE" Then
If Rating = 150 Or Rating = 300 Or Rating = 600 Then
Select Case PipeDim
Case 2, 3, 4, 6, 8, 10, 12, 14, 16, 18, 20 _
, 22, 24, 26, 28, 30, 32, 36, 42
Set blockRefObj = InsertBlock("Ball-Reduced-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End If
ElseIf Descr(2) = "FULL BORE" Then
Select Case Rating
Case 150, 300
Select Case PipeDim
Case 2, 3, 4, 6, 8, 10, 12, 14, 16, 18, 20 _
, 22, 24, 26, 28, 30, 34, 36, 40, 42
Set blockRefObj = InsertBlock("Ball-Full-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName 'Ball-Full-150 Rat-22
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 600
Select Case PipeDim
Case 0.75, 2, 3, 4, 6, 8, 10, 12, 14, 16, 18, 20 _
, 22, 24, 26, 28, 30, 34, 36, 40, 42
Set blockRefObj = InsertBlock("Ball-Full-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 800
Select Case PipeDim
Case 0.25, 0.38, 0.5, 0.75, 1, 1.25, 1.5, 2
Set blockRefObj = InsertBlock("Ball-Full-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End If
Case "GLOBE"
Select Case Rating
Case 150, 300, 600
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10, 12
Set blockRefObj = InsertBlock("Globe-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 900
Select Case PipeDim
Case 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10, 12
Set blockRefObj = InsertBlock("Globe-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 1500
Select Case PipeDim
Case 1.5, 2, 2.5, 3, 4, 5, 6
Set blockRefObj = InsertBlock("Globe-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
End Select
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case "CHECK"
Select Case Rating
Case 150
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 24, 28, 30, 36
Set blockRefObj = InsertBlock("Check-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 300
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 28, 30, 40
Set blockRefObj = InsertBlock("Check-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case 600
Select Case PipeDim
Case 0.5, 0.75, 1, 1.5, 2, 2.5, 3, 4, 5, 6, 8, 10 _
, 12, 14, 16, 18, 20, 22, 24, 30
Set blockRefObj = InsertBlock("Check-" & Rating & " Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
End Select
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case "BUTTERFLY"
Select Case PipeDim
Case 2, 2.5, 3 To 6, 8, 10, 12, 14, 16, 18, 20, 22, 24, 28, 32, 36, 40, 48
Set blockRefObj = InsertBlock("Butterfly-150 Rat-" & PipeDim, PlntDir)
blockRefObj.Layer = ValveLayerName
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case Else
msgNoBlock Descr, Rating, PipeDim
'Exit Sub
End Select
Case "FLAN"
Set blockRefObj = InsertBlock("Flange", PlntDir)
blockRefObj.Layer = FlangeLayerName
Case "REDU"
Spoint = InsertReducer3Dmesh(ReducerLayerName)
GoTo Begin
'point(0) = Spoint(1): point(1) = Spoint(2): point(2) = Spoint(3)
'AddNew3dpoly point 'Spoint is From 1 to 3 but this Func Accept arrays(0 to 2)
End Select
'If First Field Changed -> 3Dpl Should Be Renewd
If 0 <> StrComp(Trim(WorkSheet.Cells(CurrentRow, 1)), Trim(WorkSheet.Cells(CurrentRow - 1, 1)), vbTextCompare) Then
'If 3Dpl should change, Looks one Record Before And if it is Forbidden Object Adds Its Node BEFORE
'Making A new 3Dpoly.Forbiden objects if Lye in Begining OR End Of Line Should Be Included in Line
Dim NewVertex(0 To 2) As Double
'Looks One Record Befor
tmp2 = Trim(WorkSheet.Cells(CurrentRow - 1, 2))
Select Case tmp2
'If It Is Forbidden Object So it was missed Before, So Add it's Node Now
Case "GASK", "INST", "PCOM", "TRAP", "ATTA"
tmp1 = CurrentRow - 1
NewVertex(0) = WorkSheet.Cells(tmp1, 8) / 1000
NewVertex(1) = WorkSheet.Cells(tmp1, 9) / 1000
NewVertex(2) = WorkSheet.Cells(tmp1, 10) / 1000
polyObj.AppendVertex NewVertex
polyObj.Update
'If It Was Empty Object Looks 2 Record Before Now And Test It
Case Empty
tmp2 = Trim(WorkSheet.Cells(CurrentRow - 2, 2))
Select Case tmp2
'If Record Befor Empty Record Was a Forbidden Object So It's Node Is Missed And Should Be Added Now
Case "GASK", "INST", "PCOM", "TRAP", "ATTA"
tmp1 = CurrentRow - 2
NewVertex(0) = WorkSheet.Cells(tmp1, 8) / 1000
NewVertex(1) = WorkSheet.Cells(tmp1, 9) / 1000
NewVertex(2) = WorkSheet.Cells(tmp1, 10) / 1000
polyObj.AppendVertex NewVertex
polyObj.Update
End Select
End Select
'**MAKE A NEW 3DPOLY** IF CurrentLayer == Last | Layer==layer dosn't changed
'Make a New 3Dpol no Matter Is Forbidden Obj or Not (First Record Should Be included)
'Dim point(1 To 3) As Double
Point(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
Point(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
Point(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
AddNew3dpoly Point
UF.Show (vbModeless) 'Show progressbar and add an increment
UF.PBar.value = (CurrentRow - 1) / MaxRecord
UF.Caption = "áØÝÇ ãäÊÙÑ ÈãÇäíÏ ...." & CStr(Round(((CurrentRow - 1) / MaxRecord) * 100)) & " %"
'IF we are in the Same 3dPl & If object is Not forbidden then go ADD Nodes
ElseIf StrComp(RowC(2), "GASK") <> 0 And StrComp(RowC(2), "INST") <> 0 And _
StrComp(RowC(2), "PCOM") <> 0 And StrComp(RowC(2), "TRAP") <> 0 And _
StrComp(RowC(2), "TYPE") <> 0 And StrComp(RowC(2), "ATTA") <> 0 Then
'ATTENTION: If obj=Reducer Program Donot Enter This part Bec It Included in Perivious If So This ElseIf Will be Skipped By Reducer
'Reducer is IN LINE so HERE is the apropriate place for Checking & Inserting Reducer
'If Object Bore Change Insert ReDucer
'ADD A NODE TO CURRENT 3DPOLY
NewVertex(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
NewVertex(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
NewVertex(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
polyObj.AppendVertex NewVertex
polyObj.Update
'%End of Using RowB =>IF Object is Any thing Unless Empty Baking it UP
RowB = RowC()
End If
Loop While 1
errorhandler:
MsgBox "ÎØÇ ÏÑ ÊÑÓíã ÓØÑ " & CurrentRow & " ÝÇíá ǘÓá", vbCritical, Err.Description
Err.Clear
'Clean Up Drawing From 0 Length 3Dpoly
For Each Entity In ThisDrawing.ModelSpace
If TypeName(Entity) = "IAcad3DPolyline" Then
If Entity.Length < 0.001 Then
Entity.Delete
End If
End If
Next Entity
UF.Hide
End Sub
Private Sub CreateReportHeader()
WorkSheet.Activate
With oExcel
.ActiveCell = WorkSheet.Range("M3:V3").Select
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
.ActiveCell.Select
.Selection.Borders(xlDiagonalDown).LineStyle = xlNone
.Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With .Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
With .Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 5
End With
.ActiveCell.Offset(0, 1).Range("A1:I1").Select
With .Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
.Selection.Merge
.Selection.Interior.ColorIndex = 40
.ActiveCell.Offset(0, -1).Range("A1").Select
With .Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
End With
.ActiveCell.Select
.ActiveCell.FormulaR1C1 = "ÔãÇÑå ÎØ"
.ActiveCell.Offset(0, 1).Range("A1:I1").Select
.ActiveCell.FormulaR1C1 = "äæÚ ÎØÇ"
.ActiveCell.Offset(1, 0).Range("A1").Select
End With
End Sub
Private Sub CreateReportbody(WarnRow As Integer, WarN As Integer, WarnStr As String)
oExcel.ActiveCell = WorkSheet.Range("N" & CStr(WarN + 3) & ":V" & CStr(WarN + 3)).Select
'oExcel.ActiveCell.Offset(0, 1).Range("A1:I1").Select
With oExcel
With .Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With
End With
WorkSheet.Cells(WarN + 3, 13) = WarnRow
WorkSheet.Cells(WarN + 3, 14) = WarnStr
End Sub
Private Sub InsertElbow()
Dim SsetObj As AcadSelectionSet
Dim ArcObj As AcadArc
Dim obj3DPoly As Acad3DPolyline
Dim lineObj(0 To 2) As AcadLine
Dim SPt(0 To 2) As Double: Dim EPt1(0 To 2) As Double: Dim EPt2(0 To 2) As Double
Dim commStr, WarnStr As String
Dim Filrad, Dist, DisLast As Double
Dim I As Integer
Dim ErrTag(1 To 2) As Integer: ErrTag(1) = 0: ErrTag(2) = 0
Dim WarnRow As Integer
'Static WarN
'Set Spt To Start point==Point Of Current Node==Elbow Node
SPt(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
SPt(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
SPt(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
'Create 2 Lines From current Node To Last & Next Nodes
I = 0
Filrad = WorkSheet.Cells(CurrentRow, 5) * 1.5 / 1000 'Compute Fillet Radious
Do 'Find The TUBI or ELBO Before Current Elbow
I = I - 1
If 0 <> StrComp(Trim(WorkSheet.Cells(CurrentRow, 1)), Trim(WorkSheet.Cells(CurrentRow + I, 1)), vbTextCompare) Then
'The Elbow is in the First of Pipe Line and Could Not Be Created
WarnStr = "Elbow is First Item in Line -> Skipped"
WarN = WarN + 1: ErrTag(1) = WarN
WarnRow = CurrentRow
CreateReportbody WarnRow, WarN, WarnStr
Exit Sub
End If
EPt1(0) = WorkSheet.Cells(CurrentRow + I, 8) / 1000
EPt1(1) = WorkSheet.Cells(CurrentRow + I, 9) / 1000
EPt1(2) = WorkSheet.Cells(CurrentRow + I, 10) / 1000
DisLast = Dist
Dist = Sqr((SPt(0) - EPt1(0)) ^ 2 + (SPt(1) - EPt1(1)) ^ 2 + (SPt(2) - EPt1(2)) ^ 2)
If Dist > Filrad Then
'**************************Reporting Warning Nodes****************************************
If Abs(I) >= 2 Then 'Generating Report if Fillet Radious is Bigger than Distance to the Next Node
WarnRow = CurrentRow + I
WarN = WarN + 1
WorkSheet.Cells(WarN + 3, 13) = WarnRow
'WorkSheet.Cells(WarN + 3, 14) = "Dist to This Node =" & CStr(Round((Dist), 2)) & _
"Is Smaller Than Elbow Radious =" & CStr(Filrad)
WarnStr = "Distance to This Node =" & CStr(Round((DisLast), 2)) & " < Elbow_Radious =" & CStr(Filrad)
ErrTag(1) = WarN
CreateReportbody WarnRow, ErrTag(1), WarnStr
'WorkSheet.Columns("N:N").EntireColumn.EntireColumn.AutoFit
End If
Exit Do
End If
Loop While (Trim(WorkSheet.Cells(CurrentRow + I, 2)) <> "TUBI" And Trim(WorkSheet.Cells(CurrentRow + I, 2)) <> "ELBO")
Set lineObj(0) = ThisDrawing.ModelSpace.AddLine(SPt, EPt1) 'Create Line ONE
I = 0
Do 'Find The TUBI or ELBO Next to Current Elbow
I = I + 1
If 0 <> StrComp(Trim(WorkSheet.Cells(CurrentRow, 1)), Trim(WorkSheet.Cells(CurrentRow + I, 1)), vbTextCompare) Then
'The Elbow is in the First of Pipe Line and Could Not Be Created
WarnStr = "Elbow is Last Item in Line -> Skipped"
WarN = WarN + 1: ErrTag(1) = WarN
WarnRow = CurrentRow
CreateReportbody WarnRow, WarN, WarnStr
Exit Sub
End If
EPt2(0) = WorkSheet.Cells(CurrentRow + I, 8) / 1000
EPt2(1) = WorkSheet.Cells(CurrentRow + I, 9) / 1000
EPt2(2) = WorkSheet.Cells(CurrentRow + I, 10) / 1000
DisLast = Dist
Dist = Sqr((SPt(0) - EPt1(0)) ^ 2 + (SPt(1) - EPt1(1)) ^ 2 + (SPt(2) - EPt1(2)) ^ 2)
If Dist > Filrad Then
'**************************Reporting Warning Nodes****************************************
If Abs(I) >= 2 Then 'Generating Report if Fillet Radious is Bigger than Distance to the Next Node
WarN = CurrentRow + I
WarN = WarN + 1
WarnRow = CurrentRow + I
'WorkSheet.Cells(WarN + 3, 13) = WarnRow
'WorkSheet.Cells(WarN + 3, 14) = "Dist to This Node =" & CStr(Round((Dist), 2)) & _
"Is Smaller Than Elbow Radious =" & CStr(Filrad)
WarnStr = "Distance to This Node =" & CStr(Round((DisLast), 2)) & " < Elbow_Radious =" & CStr(Filrad)
ErrTag(2) = WarN
CreateReportbody WarnRow, ErrTag(2), WarnStr
'WorkSheet.Columns("N:N").EntireColumn.EntireColumn.AutoFit
'ErrTag(2) = 1
End If
Exit Do
End If
'************************** Creating Elbow ****************************************
Loop While (Trim(WorkSheet.Cells(CurrentRow + I, 2)) <> "TUBI" And Trim(WorkSheet.Cells(CurrentRow + I, 2)) <> "ELBO")
Set lineObj(1) = ThisDrawing.ModelSpace.AddLine(SPt, EPt2) 'Create Line TWO
ThisDrawing.SetVariable "FILLETRAD", Filrad 'Set R to Coresponding System Variable
'Constructing Apropriate String To Be Sent To SendCommand-Now Fillet Between LineObj 0,1
commStr = "_FILLET " & "(handent " & Chr(34) & lineObj(0).Handle & Chr(34) & ")" & _
" (handent " & Chr(34) & lineObj(1).Handle & Chr(34) & ")" & vbCr
ThisDrawing.SendCommand commStr 'Filleting Two Lines
'lineObj(0).Delete: lineObj(1).Delete 'Do NOT Deleting Guided Lines
ThisDrawing.SendCommand Chr(27) 'Sending Escape Char(To Confirm Exiting Current Command)
'********************Installing Arc-Elbow in the Plines************************************
commStr = "(setq Lispss (ssget " & Chr(34) & "L" & Chr(34) & "))" & vbCr
ThisDrawing.SendCommand commStr 'Select (in LISP) The Last Drawn Obj==Elbow
ThisDrawing.SendCommand Chr(27) 'Sending Esc Char(To Confirm Exiting Current Command)
Set SsetObj = ThisDrawing.ActiveSelectionSet 'Select The Last SSet In VBA==Elbow
Set ArcObj = SsetObj.Item(0) 'Set ArcObj The only Entity that exist in SSet == Elbow Arc(Just Created)
'*******************setting Ltscale And Layer of Lines and Elbow Arc**********************
Set obj3DPoly = ConvertArcTo3DPlyline(ArcObj) 'Convert Arc to 3DpolyObj
ArcObj.Delete
Filrad = Fix(CLng(RowC(5)) / 6.25) * 0.25 'is Ltscale of Lines & Elbow Arc
lineObj(0).LinetypeScale = Filrad
lineObj(1).LinetypeScale = Filrad
obj3DPoly.LinetypeScale = Filrad
'Floorig The Ltscale (Rounding it UP) For using instead of COLOR
Filrad = Abs(Int(-Filrad)) 'is Color of Lines & Elbow ARC
lineObj(0).color = Filrad
lineObj(1).color = Filrad
obj3DPoly.color = Filrad
'Dim StartPt, EndPt, Coord As Variant
'StartPt = Obj.StartPoint: EndPt = Obj.EndPoint
Filrad = UBound(polyObj.Coordinates): Filrad = (Filrad - 2) / 3 'filrad now is the index of last Coordinate
polyObj.Coordinate(Filrad) = EPt1 'Take PolyObj One Vertex Back To Fit With Inserted Elbow
'**************************** If Next Node is Also an Elbow ******************************
If Trim(WorkSheet.Cells(CurrentRow + 1, 2)) = "ELBO" Then
CurrentRow = CurrentRow + 1 'Shift Node to the Next Elbow=Net Node
' SPt is now Coordinate Of the Second Elbow
SPt(0) = EPt2(0)
SPt(1) = EPt2(1)
SPt(2) = EPt2(2)
'Set EPt2 to point Next to The Second Elbow
EPt2(0) = WorkSheet.Cells(CurrentRow + 1, 8) / 1000
EPt2(1) = WorkSheet.Cells(CurrentRow + 1, 9) / 1000
EPt2(2) = WorkSheet.Cells(CurrentRow + 1, 10) / 1000
Set lineObj(2) = ThisDrawing.ModelSpace.AddLine(SPt, EPt2) 'Create Line Three
Filrad = WorkSheet.Cells(CurrentRow, 5) * 1.5 / 1000 'Compute Fillet Radious
ThisDrawing.SetVariable "FILLETRAD", Filrad 'Set R to Coresponding System Variable
'Constructing Apropriate String To Be Sent To SendCommand-Now Fillet Between LineObj 1,2
commStr = "_FILLET " & "(handent " & Chr(34) & lineObj(1).Handle & Chr(34) & ")" & _
" (handent " & Chr(34) & lineObj(2).Handle & Chr(34) & ")" & vbCr
ThisDrawing.SendCommand commStr 'Filleting Two Lines
ThisDrawing.SendCommand Chr(27) 'Sending Escape Char(To Confirm Exiting Current Command)
'Select (in LISP) The Last Drawn Obj==Elbow
commStr = "(setq Lispss (ssget " & Chr(34) & "L" & Chr(34) & "))" & vbCr
ThisDrawing.SendCommand commStr
ThisDrawing.SendCommand Chr(27) 'Sending Esc Char(To Confirm Exiting Current Command)
Set SsetObj = ThisDrawing.ActiveSelectionSet 'Select The Last SSet In VBA==Elbow
Set ArcObj = SsetObj.Item(0) 'Set ArcObj The only Entity that exist in SSet == Elbow Arc(Just Created)
Set obj3DPoly = ConvertArcTo3DPlyline(ArcObj) 'Convert Arc to 3DpolyObj
ArcObj.Delete
'Setting LtScale Of New Created Obj
Filrad = Fix(CLng(RowC(5)) / 6.25) * 0.25 'is Ltscale of Lines & Elbow Arc
lineObj(2).LinetypeScale = Filrad
obj3DPoly.LinetypeScale = Filrad
'Setting Color Of New Created Obj
Filrad = Abs(Int(-Filrad)) 'is Color of Lines & Elbow ARC
lineObj(2).color = Filrad
obj3DPoly.color = Filrad
End If
AddNew3dpoly EPt2
'After Insertng A New 3Dpline The Stream of Prog GOTO Begin To Continue
End Sub
Private Function ConvertArcTo3DPlyline(ArcObj As AcadArc) As Acad3DPolyline
'*************************** convert Arc to 3DpolyObj ********************
Dim varXYZ, PolyNormal As Variant
Dim j As Long, index As Long, CoordinatesOriginal() As Double, CoordinateTransformed() As Double, CurrentVertex(2) As Double
Dim obj3DPoly As Acad3DPolyline
Dim DeltaS As Double
Dim TotalSegment As Integer
Dim EndAngle As Double
Dim DeltaAngle As Double
PolyNormal = ArcObj.Normal
'index = index + 1
DeltaS = 0.25
TotalSegment = (ArcObj.ArcLength / DeltaS)
If TotalSegment < 5 Then
TotalSegment = 5
DeltaS = ArcObj.ArcLength / 5
End If
EndAngle = ArcObj.EndAngle
DeltaAngle = (ArcObj.TotalAngle / TotalSegment)
ReDim CoordinateTransformed((TotalSegment + 1) * 3 - 1)
For j = 0 To TotalSegment - 1
ArcObj.EndAngle = ArcObj.StartAngle + j * DeltaAngle
varXYZ = ArcObj.endPoint
CoordinateTransformed(3 * j) = varXYZ(0): CoordinateTransformed(3 * j + 1) = varXYZ(1): CoordinateTransformed(3 * j + 2) = varXYZ(2)
Next j
ArcObj.EndAngle = EndAngle
varXYZ = ArcObj.endPoint
CoordinateTransformed(3 * j) = varXYZ(0): CoordinateTransformed(3 * j + 1) = varXYZ(1): CoordinateTransformed(3 * j + 2) = varXYZ(2)
Set obj3DPoly = ThisDrawing.ModelSpace.Add3DPoly(CoordinateTransformed)
Set ConvertArcTo3DPlyline = obj3DPoly
End Function
Private Function InsertReducer3Dmesh(ReducerLayerName As String) As Double()
Dim pointObj As AcadPoint
Dim C1(1 To 3) As Double
Dim C2(1 To 3) As Double
Dim C(1 To 3) As Double
Dim Point(0 To 2) As Double
Dim Dircos(0 To 2) As Double
Dim Bore As Double
Dim I, ErrTag, WarnRow As Integer
Dim RedLen, Length As Double
Dim Direction As Double
Dim WarnStr As String
' Define the location of the point==Centre of Circl'S
C1(1) = WorkSheet.Cells(CurrentRow, 8) / 1000
C1(2) = WorkSheet.Cells(CurrentRow, 9) / 1000
C1(3) = WorkSheet.Cells(CurrentRow, 10) / 1000
C2(1) = WorkSheet.Cells(CurrentRow - 1, 5) / 1000
C2(2) = WorkSheet.Cells(CurrentRow + 1, 5) / 1000
Dim R(1 To 2) As Double 'Radious of Two Circles==Reducer Bore and Last Node(mm)
Dim D(1 To 2) As Double
''Number 2 in (2 * 1000) is because in Bore (Diameter) is in excel file but we use Radious to Draw Circles
R(1) = WorkSheet.Cells(CurrentRow, 5) / (2 * 1000) 'The Bigger Circle== in Reducer node
R(2) = WorkSheet.Cells(CurrentRow, 6) / (2 * 1000) ' Little Circle (Last or Next Node)
D(1) = R(1) * 2: D(2) = R(2) * 2
'Check Reduced Pipe is Befoe Reducer or Afret it
If 0 <> StrComp(Trim(WorkSheet.Cells(CurrentRow, 1)), Trim(WorkSheet.Cells(CurrentRow + 1, 1)), vbTextCompare) Then
'If The Reducer is in the First or Last of Pipe Line and Could Not Be Created
WarnStr = "Reducer is at the End of the Line -> Skipped"
WarN = WarN + 1: ErrTag = WarN
WarnRow = CurrentRow
CreateReportbody WarnRow, WarN, WarnStr
Exit Function
ElseIf 0 <> StrComp(Trim(WorkSheet.Cells(CurrentRow, 1)), Trim(WorkSheet.Cells(CurrentRow - 1, 1)), vbTextCompare) Then
WarnStr = "Reducer is at the Begining of the Line -> Skipped"
WarN = WarN + 1: ErrTag = WarN
WarnRow = CurrentRow
CreateReportbody WarnRow, WarN, WarnStr
Point(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
Point(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
Point(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
AddNew3dpoly Point
Exit Function
Else
If CDbl(C2(1)) = D(2) Then
I = CurrentRow - 1
Direction = -1
ElseIf CDbl(C2(2)) = D(2) Then
I = CurrentRow + 1
Direction = 1
End If
End If
C2(1) = WorkSheet.Cells(I, 8) / 1000
C2(2) = WorkSheet.Cells(I, 9) / 1000
C2(3) = WorkSheet.Cells(I, 10) / 1000
Length = Sqr((C1(1) - C2(1)) ^ 2 + (C1(2) - C2(2)) ^ 2 + (C1(3) - C2(3)) ^ 2) 'Dist Between 2 Nodes
Bore = Fix(CLng(WorkSheet.Cells(CurrentRow, 5)) / 6.25) * 0.25 'Bore Of Reducer "inch"
Select Case Bore 'Assing Apropriate Length of Reducer According To it's Bigger Bore
Case 1
RedLen = 0.051
Case 1.5
RedLen = 0.064
Case 2
RedLen = 0.076
Case 2.5, 3
RedLen = 0.089
Case 4
RedLen = 0.102
Case 5
RedLen = 0.127
Case 6
RedLen = 0.14
Case 8
RedLen = 0.152
Case 10
RedLen = 0.178
Case 12
RedLen = 0.203
Case 14
RedLen = 0.33
Case 16
RedLen = 0.356
Case 18
RedLen = 0.381
Case 20, 22, 24
RedLen = 0.508
Case 26, 28, 30, 32, 34, 36, 38, 40, 42, 44
RedLen = 0.61
Case Else 'If The Bore Doesn't Exist Connect Reducer To Next Node
RedLen = Length
End Select
'Computing Next Node According The Reducer Length
Dircos(0) = (C2(1) - C1(1)) / Length 'Compute Direction cosine From Start to End Of Reducer
Dircos(1) = (C2(2) - C1(2)) / Length
Dircos(2) = (C2(3) - C1(3)) / Length
C(1) = C1(1) + RedLen * Dircos(0)
C(2) = C1(2) + RedLen * Dircos(1)
C(3) = C1(3) + RedLen * Dircos(2)
'tmp is an Arbitarry Vector.Must Not Be Paralel to Circle Normal
Dim tmp(1 To 3) As Double
tmp(1) = 1: tmp(2) = 1: tmp(3) = 1
ComputeDir 'Compute Curren Direction Update the "CurrentDir" Array Variable
'Normal Vector of Circle is Direction Cosine of Current Line
Dim N(1 To 3) As Double: N(1) = CurrentDir(0): N(2) = CurrentDir(1): N(3) = CurrentDir(2)
Dim U(1 To 3) As Double 'U is an Arbitrary Vector(depend on tmp) in Crcle Plane
Dim V(1 To 3) As Double 'V is a Vector Perpendicular to U in Circle Plane
Dim dU As Double 'Length of U Vector
dU = Sqr((N(2) - N(3)) ^ 2 + (N(3) - N(1)) ^ 2 + (N(1) - N(2)) ^ 2) 'tmp(i,j,k) ==1 skipped
'U is Unit Length of Cross Product of ||N x tmp||
U(1) = (N(2) - N(3)) / dU: U(2) = (N(3) - N(1)) / dU: U(3) = (N(1) - N(2)) / dU
Dim dV As Double
dV = Sqr((N(2) * U(3) - N(3) * U(2)) ^ 2 + (N(3) * U(1) - N(1) * U(3)) ^ 2 + (N(1) * U(2) - N(2) * U(1)) ^ 2)
'V is Unit Length of Cross Product of ||N x U||
V(1) = (N(2) * U(3) - N(3) * U(2)) / dV: V(2) = (N(3) * U(1) - N(1) * U(3)) / dV: V(3) = (N(1) * U(2) - N(2) * U(1)) / dV
'Build More Than Needed (up to (1000/3)/2=166 Node in Each Circle) Vertex and also Face list Vector.Will Be Trimed Later With Redim
Const Nver = 1000
Dim Vertex() As Double
ReDim Vertex(Nver)
Dim Nnode As Integer: Nnode = 20 'Number of Nodes in Each Circle (max=166)
Dim Node1(1 To 3) As Double 'Node on Circle 1
Dim Node2(1 To 3) As Double 'Node on Circle 2
Dim t As Double 'parameter == angle
t = (2 * pi) / Nnode
'Compute the Nodes on First Circle
For I = 0 To Nnode
Node1(1) = C1(1) + R(1) * Cos(t * I) * U(1) + R(1) * Sin(t * I) * V(1): Vertex(3 * I) = Node1(1)
Node1(2) = C1(2) + R(1) * Cos(t * I) * U(2) + R(1) * Sin(t * I) * V(2): Vertex(3 * I + 1) = Node1(2)
Node1(3) = C1(3) + R(1) * Cos(t * I) * U(3) + R(1) * Sin(t * I) * V(3): Vertex(3 * I + 2) = Node1(3)
Next I
tmp(1) = Nnode * 3 + 2
'Compute the Nodes on Second Circle
For I = 0 To Nnode
Node2(1) = C(1) + R(2) * Cos(t * I) * U(1) + R(2) * Sin(t * I) * V(1): Vertex(tmp(1) + 3 * I + 1) = Node2(1)
Node2(2) = C(2) + R(2) * Cos(t * I) * U(2) + R(2) * Sin(t * I) * V(2): Vertex(tmp(1) + 3 * I + 2) = Node2(2)
Node2(3) = C(3) + R(2) * Cos(t * I) * U(3) + R(2) * Sin(t * I) * V(3): Vertex(tmp(1) + 3 * I + 3) = Node2(3)
Next I
t = Nnode * 6 + 5
ReDim Preserve Vertex(t)
' Create the 3DMesh size(2 x nNode+1)
Dim meshObj As AcadPolygonMesh
Dim mSize, nSize, Count As Integer
mSize = 2: nSize = Nnode + 1 '+1 is Bec Of Completing A Ring == Sewing First Node To Last
Set meshObj = ThisDrawing.ModelSpace.Add3DMesh(mSize, nSize, Vertex)
''Sets the Red Layer (contetnt of this block have same layer as what block is made of)
meshObj.Layer = ReducerLayerName
'******** Continue Line to fill Gap between Red and Next (or Previous) Node************
D(1) = Fix(CLng(D(1) * 1000) / 6.25) * 0.25 'Converting Bore From mm -> inch
D(2) = Fix(CLng(D(2) * 1000) / 6.25) * 0.25 'For Naming it's block
Dim NewVertex(0 To 2) As Double
'Dim tmpoly As Acad3DPolyline
Dim points(0 To 5) As Double
If Direction = 1 Then
'If Red is in this Direction, New 3Dpl From Little Circle Centre (C) Should be Drawn
'NewVertex(0) = C1(1): NewVertex(1) = C1(2): NewVertex(2) = C1(3)
'polyObj.AppendVertex NewVertex
NewVertex(0) = C1(1): NewVertex(1) = C1(2): NewVertex(2) = C1(3)
polyObj.AppendVertex NewVertex
points(0) = C(1) 'First Node is centre of Little Circle
points(1) = C(2)
points(2) = C(3)
'Second Node is next Node==( C2 )
points(3) = C2(1): points(4) = C2(2): points(5) = C2(3)
Set polyObj = ThisDrawing.ModelSpace.Add3DPoly(points)
'Converting Rowc(5)==Diameter of Pipe in mm TO inch According Special circumstances
polyObj.LinetypeScale = D(2)
'Floorig The Ltscale (Rounding it UP) For using instead of COLOR
polyObj.color = Abs(Int(-polyObj.LinetypeScale))
ElseIf Direction = -1 Then
'if reducer is in this direction just need to ad this new vertex
NewVertex(0) = C(1): NewVertex(1) = C(2): NewVertex(2) = C(3)
polyObj.AppendVertex NewVertex
points(0) = C1(1): points(1) = C1(2): points(2) = C1(3)
AddNew3dpoly points
End If
'************************************************************************
''converting 3Dmesh object to a Block==Create A Arbitrary Unique Block For Each 3Dmesh Obj
Dim objBlock As AcadBlock
Dim BlockName As String
Dim tmpBlockname As String
BlockName = RowC(11) & " - " & D(1) & " to " & D(2)
'BlockName = "Red"
tmpBlockname = BlockName
''check if block already exists
On Error Resume Next
Set objBlock = ThisDrawing.Blocks.Item(BlockName)
I = 65 '65 == ASCII code of Charachter ""A""
Do While Not objBlock Is Nothing 'Block already exists
'Crate A unique Name For Block.If Name ALready Exist Add Alphabet to it
BlockName = tmpBlockname & Chr(I)
Set objBlock = Nothing
Set objBlock = ThisDrawing.Blocks.Item(BlockName)
I = I + 1
Loop
Dim varEnt As Variant
Dim varDestEnts As Variant
Dim dblOrigin(2) As Double
dblOrigin(0) = 0: dblOrigin(1) = 0: dblOrigin(2) = 0
'' create the block
Set objBlock = ThisDrawing.Blocks.Add(dblOrigin, BlockName)
'' put selected entities into an array for CopyObjects
Dim explodedObjects As Variant
Dim objSourceEnts() As Object
objSourceEnts = meshObj.Explode 'Explode Mesh Obj
'' copy the Exploded entities into block
varDestEnts = ThisDrawing.CopyObjects(objSourceEnts, objBlock)
For Each varEnt In objSourceEnts
varEnt.Delete 'Del Exploded Objects
Next
meshObj.Delete 'Del Mesh Obj
For Each varEnt In varDestEnts
varEnt.Move C1, dblOrigin 'Move Created Block to It's Position
Next
Dim blockRefObj As AcadBlockReference
'Insert A Block Ref of Created Block.C1 is Insertion Pt,Xsc=Ysc=Zsc=1,Rot_Ang=0
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(C1, BlockName, 1, 1, 1, 0)
blockRefObj.Layer = ReducerLayerName 'Setting 3Dmesh Layer
InsertReducer3Dmesh = C2
End Function
Private Sub InsertReducerPFaceMesh(ReducerLayerName As String)
'This Sub just exist for history. previous sub is used in program body
'This a Sub similar to InsertReducer3Dmesh Execpt "Converting Mesh obj to Block" Section
'Bec 3Dmesh hase Explode Evenet but PolyFaceMesh doesn't Have it We Donot Use this Sub
Dim pointObj As AcadPoint
Dim C1(1 To 3) As Double
Dim C2(1 To 3) As Double
' Define the location of the point==Centre of Circl'S
C1(1) = WorkSheet.Cells(CurrentRow, 8) / 1000
C1(2) = WorkSheet.Cells(CurrentRow, 9) / 1000
C1(3) = WorkSheet.Cells(CurrentRow, 10) / 1000
C2(1) = WorkSheet.Cells(CurrentRow - 1, 8) / 1000
C2(2) = WorkSheet.Cells(CurrentRow - 1, 9) / 1000
C2(3) = WorkSheet.Cells(CurrentRow - 1, 10) / 1000
Dim R(1 To 2) As Double 'Radious of Two Circles==Reducer Bore and Last Node(mm)
R(1) = WorkSheet.Cells(CurrentRow, 5) / 1000
R(2) = WorkSheet.Cells(CurrentRow - 1, 5) / 1000
'tmp is an Arbitarry Vector.Must Not Be Paralel to Circle Normal
Dim tmp(1 To 3) As Double
tmp(1) = 1: tmp(2) = 1: tmp(3) = 1
ComputeDir 'Compute Curren Direction Update the "CurrentDir" Variable
'Normal Vector of Circle is Direction Cosine of Current Line
Dim N(1 To 3) As Double: N(1) = CurrentDir(0): N(2) = CurrentDir(1): N(3) = CurrentDir(2)
Dim U(1 To 3) As Double 'U is an Arbitrary Vector(depend on tmp) in Crcle Plane
Dim V(1 To 3) As Double 'V is a Vector Perpendicular to U in Circle Plane
Dim dU As Double 'Length of U Vector
dU = Sqr((N(2) - N(3)) ^ 2 + (N(3) - N(1)) ^ 2 + (N(1) - N(2)) ^ 2) 'tmp(i,j,k) ==1 skipped
'U is Unit Length of Cross Product of ||N x tmp||
U(1) = (N(2) - N(3)) / dU: U(2) = (N(3) - N(1)) / dU: U(3) = (N(1) - N(2)) / dU
Dim dV As Double
dV = Sqr((N(2) * U(3) - N(3) * U(2)) ^ 2 + (N(3) * U(1) - N(1) * U(3)) ^ 2 + (N(1) * U(2) - N(2) * U(1)) ^ 2)
'V is Unit Length of Cross Product of ||N x U||
V(1) = (N(2) * U(3) - N(3) * U(2)) / dV: V(2) = (N(3) * U(1) - N(1) * U(3)) / dV: V(3) = (N(1) * U(2) - N(2) * U(1)) / dV
'Build More Than Needed (up to (1000/3)/2=166 Node in Each Circle) Vertex and also Face list Vector.Will Be Trimed Later With Redim
Const Nver = 1000
Dim Vertex() As Double
ReDim Vertex(Nver)
' Define the face list
Dim FaceList() As Integer
ReDim FaceList(Nver)
Dim Nnode As Integer: Nnode = 20 'Number of Nodes in Each Circle (max=166)
Dim I As Integer
Dim Node1(1 To 3) As Double 'Node on Circle 1
Dim Node2(1 To 3) As Double 'Node on Circle 2
Dim t As Double 'parameter == angle
t = (2 * pi) / Nnode
For I = 0 To Nnode - 1
Node1(1) = C1(1) + R(1) * Cos(t * I) * U(1) + R(1) * Sin(t * I) * V(1): Vertex(6 * I) = Node1(1)
Node1(2) = C1(2) + R(1) * Cos(t * I) * U(2) + R(1) * Sin(t * I) * V(2): Vertex(6 * I + 1) = Node1(2)
Node1(3) = C1(3) + R(1) * Cos(t * I) * U(3) + R(1) * Sin(t * I) * V(3): Vertex(6 * I + 2) = Node1(3)
Node2(1) = C2(1) + R(2) * Cos(t * I) * U(1) + R(2) * Sin(t * I) * V(1): Vertex(6 * I + 3) = Node2(1)
Node2(2) = C2(2) + R(2) * Cos(t * I) * U(2) + R(2) * Sin(t * I) * V(2): Vertex(6 * I + 4) = Node2(2)
Node2(3) = C2(3) + R(2) * Cos(t * I) * U(3) + R(2) * Sin(t * I) * V(3): Vertex(6 * I + 5) = Node2(3)
FaceList(4 * I) = 2 * I + 1: FaceList(4 * I + 1) = 2 * I + 2
FaceList(4 * I + 2) = 2 * I + 4: FaceList(4 * I + 3) = 2 * I + 3
Next I
t = Nnode * 6 - 1
ReDim Preserve Vertex(t)
t = Nnode * 4 - 1
ReDim Preserve FaceList(t)
'Sewing End Of Patch to The First
FaceList(UBound(FaceList) - 1) = 2: FaceList(UBound(FaceList)) = 1
' Create the polyface mesh
Dim polyfaceMeshObj As AcadPolyfaceMesh
Set polyfaceMeshObj = ThisDrawing.ModelSpace.AddPolyfaceMesh(Vertex, FaceList)
polyfaceMeshObj.Layer = ReducerLayerName 'Changing It's Layer
End Sub
Private Sub msgNoBlock(Descr As Variant, Rating As Integer, PipeDim As Double)
'Display a Message & Inform When A block Symbol Doesn't Exist In Template DWG To be Inserted
Dim RetVal As Integer
RetVal = MsgBox("NO " & Descr(1) & "-" & Descr(2) & "-" & Rating & "#" & "-" & PipeDim & _
" (in)" & " | line=" & CurrentRow & " Excel", vbOKCancel, "NO Apropiate Block in Template")
If RetVal = vbCancel Then CurrentRow = MaxRecord
End Sub
Private Sub ComputeDir()
'Computes The Current Direction Of Line
Dim L As Double
Dim dl(0 To 2) As Double
Dim Prow, Nrow As Integer
'Direction Between Last & Perevious Row Of Current Row
Nrow = CurrentRow + 1: Prow = CurrentRow - 1
'If Last Or Perevious Row Be Different Branch, Jump 2 Row Before Or After CurrentRow
If 0 <> StrComp(WorkSheet.Cells(CurrentRow, 1), WorkSheet.Cells(Nrow, 1), vbTextCompare) Then
Nrow = CurrentRow: Prow = CurrentRow - 2
End If
If 0 <> StrComp(WorkSheet.Cells(CurrentRow, 1), WorkSheet.Cells(Prow, 1), vbTextCompare) Then
Prow = CurrentRow: Nrow = CurrentRow + 2
End If
'Because Direction Has Not UNIT We Do not Convert Coordinates From mm To Meter
dl(0) = (WorkSheet.Cells(Nrow, 8) - WorkSheet.Cells(Prow, 8))
dl(1) = (WorkSheet.Cells(Nrow, 9) - WorkSheet.Cells(Prow, 9))
dl(2) = (WorkSheet.Cells(Nrow, 10) - WorkSheet.Cells(Prow, 10))
L = Sqr(dl(0) ^ 2 + dl(1) ^ 2 + dl(2) ^ 2) 'In mm
'Computer Direction Cosine Of Line
dl(0) = dl(0) / L: dl(1) = dl(1) / L: dl(2) = dl(2) / L
CurrentDir = dl
End Sub
Private Sub CheckLayer(strLayerName As String)
'This Function Check The Existence Of Layer and If Dosn't Exist Make It and Current IT
Dim objLayer As AcadLayer
For Each objLayer In ThisDrawing.Layers ' iterate layers
If 0 = StrComp(objLayer.Name, strLayerName, vbTextCompare) Then
'If Layer Name Exist, Make It Current Layer==Active Layer
ThisDrawing.ActiveLayer = ThisDrawing.Layers(strLayerName)
Exit For
End If
Next objLayer
'IF Layer Name Dosn't Exist Make it and Make it Current
If 0 <> StrComp(ThisDrawing.ActiveLayer.Name, strLayerName, vbTextCompare) Then
Set objLayer = ThisDrawing.Layers.Add(strLayerName)
ThisDrawing.ActiveLayer = ThisDrawing.Layers(strLayerName)
End If
End Sub
Private Function InsertBlock(BlockName As String, PlntDir As Double) As AcadBlockReference
'This Function Gets The Block Name And Insert a BlockRefrence In CAD(Block Should Exist Before)
'Dim blockObj As AcadBlock
Dim InsertionPnt(0 To 2) As Double
Dim tmp(0 To 2) As Double
Dim RotatePt As Variant
Dim RotateAngle As Double
Dim Xsc As Double
Dim Ysc As Double
Dim Zsc As Double
InsertionPnt(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
InsertionPnt(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
InsertionPnt(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
RotateAngle = 0: Xsc = 1: Ysc = 1: Zsc = 1
' Insert the block
Dim blockRefObj As AcadBlockReference
' For Flange Block Scale and 3drotate should change
Dim PipeDim As Double
'Scale OF FLanges are (Diameter of Pipe)/4 Because Flange block is Drawn For 4in Pipe
PipeDim = Fix(CLng(RowC(5)) / 6.25) * 0.25
Select Case BlockName
Case "Flange"
Xsc = PipeDim / 4: Ysc = Xsc: Zsc = Xsc
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(InsertionPnt, BlockName, Xsc, Ysc, Zsc, RotateAngle)
RotatePt = InsertionPnt
'First Call For New Line Direction
ComputeDir
'Compute The rotation angle of flange == angle between line and normal to XY plane (k(0,0,1))
RotateAngle = WorkSheet.Application.WorksheetFunction.Acos(CurrentDir(2))
'Constructing Second Point of Rotation Axis t=100
Dim t As Integer: t = 1000
RotatePt(0) = InsertionPnt(0) + t * CurrentDir(1)
RotatePt(1) = InsertionPnt(1) - t * CurrentDir(0)
RotatePt(2) = InsertionPnt(2) + t * 0
'Check Rotation /Angle <> 0 Else Rotate3d Makes An Error
If Round(Sin(RotateAngle), 1) <> 0 Then
blockRefObj.Rotate3D InsertionPnt, RotatePt, RotateAngle
End If
Case "Pressure gauge 1p" 'For This Kind Of Block No Rotation Needed
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(InsertionPnt, BlockName, Xsc, Ysc, Zsc, RotateAngle)
Case Else 'For all Valve Blocks
Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock _
(InsertionPnt, BlockName, Xsc, Ysc, Zsc, RotateAngle)
RotateAngle = -90 * pi / 180#
RotatePt = InsertionPnt()
'rotate about X axis
RotatePt(0) = RotatePt(0) + 10
If Round(Abs(RowC(10) - WorkSheet.Cells(CurrentRow - 1, 10)), 0) <> 0 Then
'According the Y of Current Point to Left or Right side of the mean Angle Differs
'(For Better Apearance of Valves)
Dim PDir As Integer
'Pdir(perpenducular direction) is->1 if plant be in Y direction
PDir = Abs(PlntDir - 1)
If Abs(PlntDir * CDbl(RowC(9)) + PDir * CDbl(RowC(10))) < Abs(PlntDir * Mean(1) + PDir * Mean(2)) Then
RotateAngle = -RotateAngle
End If
blockRefObj.Rotate3D InsertionPnt, RotatePt, RotateAngle
End If
'Sets The Block Layer aCoording The Pipe inch
'(inch<1) ->200 , (1<=inch<=6) ->201 , (inch>=6) ->202
If PipeDim <= 1 Then
blockRefObj.color = 200
ElseIf PipeDim < 6 Then
blockRefObj.color = 201
ElseIf PipeDim >= 6 Then
blockRefObj.color = 202
End If
End Select
Set InsertBlock = blockRefObj
End Function
Private Sub AddNewText(TextLayerName As String)
'Dim textObj As AcadText
Dim textString As String
Dim InsertionPnt(0 To 2) As Double
Dim height As Double
' Define the text object
textString = RowC(2) + str(CurrentRow)
InsertionPnt(0) = WorkSheet.Cells(CurrentRow, 8) / 1000
InsertionPnt(1) = WorkSheet.Cells(CurrentRow, 9) / 1000
InsertionPnt(2) = WorkSheet.Cells(CurrentRow, 10) / 1000
height = 0.01
' Create the text object in model space
Set textObj = ThisDrawing.ModelSpace.AddText(textString, InsertionPnt, height)
textObj.ScaleFactor = 0.5
' Rotate the Text vertically
Dim RotatePt As Variant
Dim RotateAngle As Double
RotatePt = InsertionPnt()
'rotate about Y axis
RotatePt(1) = RotatePt(1) + 10
RotateAngle = -90 * pi / 180#
textObj.Rotate3D InsertionPnt, RotatePt, RotateAngle
textObj.Layer = TextLayerName
End Sub
Private Sub AddNew3dpoly(Point() As Double)
Dim points(0 To 5) As Double
Dim NewVertex(0 To 2) As Double
points(0) = Point(0) ' WorkSheet.Cells(CurrentRow, 8) / 1000
points(1) = Point(1) ' WorkSheet.Cells(CurrentRow, 9) / 1000
points(2) = Point(2) 'WorkSheet.Cells(CurrentRow, 10) / 1000
'The 3dPoly Coldn't be Built By ONE Vertex So Duplicate It
points(3) = points(0): points(4) = points(1): points(5) = points(2)
Set polyObj = ThisDrawing.ModelSpace.Add3DPoly(points)
'Converting Rowc(5)==Diameter of Pipe in mm TO inch According Special circumstances
polyObj.LinetypeScale = Fix(CLng(RowC(5)) / 6.25) * 0.25
'Floorig The Ltscale (Rounding it UP) For using instead of COLOR
polyObj.color = Abs(Int(-polyObj.LinetypeScale))
End Sub
Private Sub StartExcel(App As Excel.Application, Visible As Boolean)
'handle errors inline
On Error Resume Next
Set App = GetObject(, "Excel.Application") 'depends on application
'check to see if application is running
If Err Then
'no, application will need to be started
Err.Clear
Set App = CreateObject("Excel.Application") 'depends on application
'check to see if application was started
If Err Then
'no, application could not be started - exit
Exit Sub
End If
End If
'set the application visibility
App.Visible = Visible
End Sub
Private Function StartApp() As Double()
'Dim oExcel As Excel.Application
'attempt to start Excel
StartExcel oExcel, True
If Not oExcel Is Nothing Then
'MsgBox "Success"
Set WorkSheet = oExcel.Worksheets(1)
Dim Mean(0 To 3) As Double
WorkSheet.Range("Z1").Formula = "=Average(H2:H" & CStr(MaxRecord) & ")"
Mean(0) = WorkSheet.Range("Z1").value
WorkSheet.Range("Z1").Formula = "=Average(I2:I" & CStr(MaxRecord) & ")"
Mean(1) = WorkSheet.Range("Z1").value
WorkSheet.Range("Z1").Formula = "=Stdev(H2:H" & CStr(MaxRecord) & ")"
Mean(2) = WorkSheet.Range("Z1").value
WorkSheet.Range("Z1").Formula = "=Stdev(I2:I" & CStr(MaxRecord) & ")"
Mean(3) = WorkSheet.Range("Z1").value
WorkSheet.Range("Z1").ClearContents
StartApp = Mean()
Else
MsgBox "Could not start Excel, exiting ...", vbCritical
Exit Function
End If
End Function
Private Sub ReadNewRecord()
Dim I As Integer
CurrentRow = CurrentRow + 1
'Reading Next Record From Excel Sheet
For I = 1 To 10
RowC(I) = Trim(WorkSheet.Cells(CurrentRow, I))
Next I
'Making Layer Name Of Current Record and Copy it to the End Of Record
Dim pos(0 To 6) As Integer
Dim Tmpstr As String
'Control do not Acting on Empty or Ilegal Records
If InStr(1, RowC(1), "-", vbTextCompare) <> 0 Then
'Finding The Occurance and Yhe Position Of Deliminator Char "-"
'It Is Sopposed That "Layed Name"Is Made Of 4th+5th
'and "Branch name" is Last Information In Firts Record (RowC(1))
For I = 1 To 6 'Bec Of Programing Problems Pos start from 0 But Fills From 1
pos(I) = InStr(pos(I - 1) + 1, RowC(1), "-", vbTextCompare)
Next I
'Extracting the 4th+5th patch of First Field That Makes The Layer Name
Tmpstr = Trim(Mid(RowC(1), pos(2) + 1, pos(5) - pos(2) - 1))
'Now Adding This Name to The End Of Record
RowC(11) = Tmpstr
''Extracting Branch Name And Addint to 12th elemnt
Tmpstr = Trim(Right(RowC(1), Len(RowC(1)) - pos(6)))
RowC(12) = Tmpstr
End If
End Sub
'*******************************************************************************************************************************
Private Sub test()
'Here 's an example of reading the command line:
ThisDrawing.SendCommand "AMVER" & vbCrLf
Debug.Print "AMVER: " & ThisDrawing.GetVariable("LASTPROMPT")
'
'If you just need to pass the occasional variable from lisp to vba, you could
'use the USERS1 or USERI1 system variables:
'sMyVar = ThisDrawing.GetVariable "USERS1"
End Sub
Sub Ch3_UserInput()
' The first parameter of InitializeUserInput (6)
' restricts input to positive and non-negative
' values. The second parameter is the list of
' valid keywords.
ThisDrawing.Utility.InitializeUserInput 6, "Big Small Regular"
' Set the prompt string variable
Dim promptStr As String
promptStr = vbCrLf & "Enter the size or (Big/Small/<Regular>):"
' At the GetInteger prompt, entering a keyword or pressing
' ENTER without entering a value results in an error. To allow
' your application to continue and check for the error
' description, you must set the error handler to resume on error.
On Error Resume Next
' Get the value entered by the user
Dim returnInteger As Integer
returnInteger = ThisDrawing.Utility.GetInteger(promptStr)
' Check for an error. If the error number matches the
' one shown below, then use GetInput to get the returned
' string; otherwise, use the value of returnInteger.
If Err.Number = -2145320928 Then
Dim returnString As String
Debug.Print Err.Description
returnString = ThisDrawing.Utility.GetInput()
If returnString = "" Then 'ENTER returns null string
returnString = "Regular" 'Set to default
End If
Err.Clear
Else 'Otherwise,
returnString = returnInteger 'Use the value entered
End If
' Display the result
MsgBox returnString, , "InitializeUserInput Example"
End Sub
Sub FilletLWPoly()
Dim oPline As AcadLWPolyline
Dim varPt As Variant
On Error GoTo Error_Trapp
ThisDrawing.Utility.GetEntity oPline, varPt, "Select polyline"
If Err Then
Err.Clear
Exit Sub
ElseIf Not TypeOf oPline Is AcadLWPolyline Then
MsgBox "This is not a LightWeightPolyline"
Else
Dim Filrad As Double
Filrad = CDbl(InputBox(vbCr & vbCr & "Specify fillet radii: ", _
"Filleting LWPolyline", "10,0"))
ThisDrawing.SetVariable "FILLETRAD", Filrad
Dim commStr As String
commStr = "_FILLET _P " & _
"(handent " & Chr(34) & oPline.Handle & Chr(34) & ")" & vbCr
ThisDrawing.SendCommand commStr
End If
Error_Trapp:
If Err.Number = 13 Then
MsgBox "This is not a polyline" & vbCr _
& "Error number: " & Err.Number & vbCr & Err.Description
End If
End Sub