.3.1. Nhập số liệu:
- Sơ đồ kết cấu nhịp
- Góc mở của từng nhịp cong trên sơ đồ.
- Chiều quay của nhịp: Thuận hay ngợc chiều kim đồng hồ. - Bán kính cong của từng nhịp.
- Điều kiện biên(Liên kết tại các gối): + Gối tựa trên một điểm
+ Gối tựa trên hai điểm(chống xoắn) - Đặc trng hình học của mặt cắt ngang
3.2. Tính toán :
- Lập các ma trận nhịp Fi : Xây dựng lớp modul các phép toán về ma trận (MT) trong đó có chứa modul ma trận nhịp.
- Xử lý điều kiện biên : Tại các gối cầu thờng có các điều kiện về chuyển vị và nội lực bằng không vì vậy từ đó ta thiết lập đợc hệ phơng trình tuyến tính chứa ẩn số của các chuyển vị và nội lực tại các gối. Giải hệ phơng trình này bằng modul KhuGauss(trong lớp modul ma trận) ta đợc các ẩn số của bài toán.
- Tính toán tung độ đờng ảnh hởng nội lực và chuyển vị: Từ kết quả trên(ẩn của bài toán) ta xác định đợc tung độ của các đờng ảnh hởng nội lực và chuyển vị tại các điểm trên dầm.
3.3. Xuất kết quả:
- Xuất biểu đồ đờng ảnh hởng nội lc và chuyên vị: Từ kết quả tính toán ở trên ta
vẽ đợc biểu đồ đờng ảnh hởng bằng chơng trình Auto CAD, xây dựng modul vẽ CAD. - Xuất bảng tung độ đờng ảnh hởng.
3.4. Mã nguồn:
a. Lớp Modul ma trận: CMT.cls
'Class Ma tran: lop cac phep toan ve ma tran va vecto
'********************************************************** 'Ham nhan 2 vecto
'********************************************************** Private Function VAxVB(a!(), b!()) As Single()
Dim i&, x!()
ReDim x!(LBound(a, 1) To LBound(a, 1)) For i = LBound(a, 1) To UBound(a, 1) x(i) = x(i) + a(i) * b(i)
Next
VAxVB = x End Function
'********************************************************** 'Ham nhan vecto voi Ma tran
Dim i&, j&, x!()
ReDim x!(LBound(b, 2) To UBound(b, 2)) For i = LBound(b, 2) To UBound(b, 2) x(i) = 0
For j = LBound(b, 1) To UBound(b, 1) x(i) = x(i) + a(j) * b(j, i)
Next Next
VAxMB = x End Function
'********************************************************** 'Ham nhan ma tran voi vecto
'********************************************************** Private Function MAxVB(a!(), b!()) As Single()
Dim i&, j&, x!()
ReDim x!(LBound(a, 1) To UBound(a, 1)) For i = LBound(a, 1) To UBound(a, 1) x(i) = 0
For j = LBound(a, 2) To UBound(a, 2) x(i) = x(i) + a(i, j) * b(j)
Next Next
MAxVB = x End Function
'********************************************************** 'Ham nhan 2 ma tran
'********************************************************** Private Function MAxMB(a!(), b!()) As Single()
Dim i&, j&, k&, x!()
ReDim x!(LBound(a, 1) To UBound(a, 1), LBound(b, 2) To UBound(b, 2)) For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(b, 2) To UBound(b, 2) For k = LBound(a, 2) To UBound(a, 2) x(i, j) = x(i, j) + a(i, k) * b(k, j) Next Next Next MAxMB = x End Function '*************************************************************** *********
'Kiem tra roi nhan
'*************************************************************** *********
Public Function Nhan(a!(), b!(), Optional Done As Boolean) As Single() Dim Up&, CheckA As Boolean, CheckB As Boolean
Done = False: CheckA = False: CheckB = False On Error GoTo A_la_vecto
Up = UBound(a, 1): Up = UBound(a, 2) 'neu A khong phai la matran thi loi CheckA = True
A_la_vecto:
On Error GoTo B_la_vecto
Up = UBound(b, 1): Up = UBound(b, 2) 'neu B khong pai la matran thi loi CheckB = True
B_la_vecto:
On Error GoTo ErrNhan If Not CheckA Then If Not CheckB Then Nhan = VAxVB(a, b) Else
Nhan = VAxMB(a, b) End If
Else
If Not CheckB Then Nhan = MAxVB(a, b) Else Nhan = MAxMB(a, b) End If End If Done = True Exit Function ErrNhan:
MsgBox "Loi khi nhan ma tran hoac vecto", vbOKOnly, "Loi"
End Function
'********************************************************** 'Ham Cong 2 ma tran
'********************************************************** Private Function MAcMB(a!(), b!()) As Single()
Dim i&, j&, x!()
ReDim x!(LBound(a, 1) To UBound(a, 1), LBound(b, 2) To UBound(b, 2)) For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(b, 2) To UBound(b, 2) x(i, j) = a(i, j) + b(i, j)
Next Next
MAcMB = x End Function
'********************************************************** 'Ham Cong 2 vecto
'********************************************************** Private Function VAcVB(a!(), b!()) As Single()
Dim i&, j&, x!()
ReDim x!(LBound(a, 1) To UBound(a, 1)) For i = LBound(a, 1) To UBound(a, 1)
Next
VAcVB = x End Function
'*************************************************************** *********
'Kiem tra roi cong
'*************************************************************** *********
Public Function Cong(a!(), b!(), Optional Done As Boolean) As Single() Dim Up&, CheckA As Boolean, CheckB As Boolean
Done = False: CheckA = False: CheckB = False On Error GoTo A_la_vecto
Up = UBound(a, 1): Up = UBound(a, 2) 'neu A khong pai la matran thi loi CheckA = True
A_la_vecto:
On Error GoTo B_la_vecto
Up = UBound(b, 1): Up = UBound(b, 2) 'neu B khong pai la matran thi loi CheckB = True
B_la_vecto:
On Error GoTo ErrCong
If (Not CheckA) And (Not CheckB) Then Nhan = VAcVB(a, b)
ElseIf (CheckA = True) And (CheckB = True) Then Nhan = MAcMB(a, b)
End If Done = True Exit Function ErrNhan:
MsgBox "Loi khi cong ma tran hoac vecto", vbOKOnly, "Loi" End Function
'*************************************************************** *********
' Ham nghich dao ma tran theo Jordance
'*************************************************************** *********
Public Function Nghichdao(x!(), Optional Done As Boolean) As Single() Dim i&, j&, k&, r&, Up&, Low&, tg!, y!()
ReDim y!(LBound(x, 1) To UBound(x, 1), LBound(x, 2) To UBound(x, 2)) Done = False
On Error GoTo Loinghichdao
Up = UBound(x, 1): Low = LBound(x, 1) For i = Low To Up For j = Low To Up If i = j Then y(i, j) = 1 Else: y(i, j) = 0 End If Next
Next
For k = Low To Up r = k
For i = k + 1 To Up
If (Abs(x(i, k)) > Abs(x(r, k))) Then r = i End If If (Abs(x(r, k)) < 0.00000001) Then GoTo Loinghichdao End If Next 'Hoan vi hang r va k For j = Low To Up tg = x(k, j) x(k, j) = x(r, j) x(r, j) = tg tg = y(k, j) y(k, j) = y(r, j) y(r, j) = tg Next
'chia hang k cho X(k,k) tg = 1 / x(k, k) For j = Low To Up x(k, j) = x(k, j) * tg y(k, j) = y(k, j) * tg Next
'khu cot k: lam cho x(i,k)=0 voi i<>k For i = Low To Up
If (i <> k) Then tg = x(i, k)
For j = Low To Up
x(i, j) = x(i, j) - tg * x(k, j) y(i, j) = y(i, j) - tg * y(k, j) Next End If Next Next Nghichdao = x Done = True Exit Function Loinghichdao:
MsgBox "Loi nghich dao ma tran", vbOKOnly, "Loi" End Function
'********************************************************** 'Ma tran nhip thuan
Public Function nhip(r As Double, x As Double, m As Double, j As Double, t As Boolean) As Single()
Dim E As Double E = 2 * 10 ^ 5 ReDim f(1 To 7, 1 To 7) If t = True Then f(1, 1) = 1 f(1, 2) = r * Sin(x) f(1, 3) = r * (1 - Cos(x)) f(1, 4) = ((r ^ 2) / (2 * m * E * j)) * (2 * (1 - Cos(x)) - (1 + m) * x * Sin(x)) f(1, 5) = ((r ^ 3) / (2 * m * E * j)) * (2 * x - (3 + m) * Sin(x) + (1 + m) * x * Cos(x)) f(1, 6) = ((1 + m) / (2 * m * E * j)) * (r ^ 2) * (Sin(x) - x * Cos(x)) f(1, 7) = 0 f(2, 1) = 0 f(2, 2) = Cos(x) f(2, 3) = Sin(x) f(2, 4) = (r / (2 * m * E * j)) * ((1 - m) * Sin(x) - (1 + m) * x * Cos(x)) f(2, 5) = ((r ^ 2) / (2 * m * E * j)) * (2 * (1 - Cos(x)) - (1 + m) * x * Sin(x)) f(2, 6) = ((1 + m) / (2 * m * E * j)) * r * x * Sin(x) f(2, 7) = 0 f(3, 1) = 0 f(3, 2) = -Sin(x) f(3, 3) = Cos(x) f(3, 4) = ((1 + m) / (2 * m * E * j)) * r * x * Sin(x) f(3, 5) = ((1 + m) / (2 * m * E * j)) * (r ^ 2) * (Sin(x) - x * Cos(x)) f(3, 6) = (r / (2 * m * E * j)) * ((1 - m) * Sin(x) - (1 + m) * x * Cos(x)) f(3, 7) = 0 f(4, 1) = 0 f(4, 2) = 0 f(4, 3) = 0 f(4, 4) = Cos(x) f(4, 5) = r * Sin(x) f(4, 6) = -Sin(x) f(4, 7) = 0 f(5, 1) = 0 f(5, 2) = 0 f(5, 3) = 0 f(5, 4) = 0 f(5, 5) = 1 f(5, 6) = 0 f(5, 7) = 0 f(6, 1) = 0 f(6, 2) = 0 f(6, 3) = 0 f(6, 4) = Sin(x) f(6, 5) = r * (1 - Cos(x)) f(6, 6) = Cos(x) f(6, 7) = 0 f(7, 1) = 0
f(7, 2) = 0 f(7, 3) = 0 f(7, 4) = 0 f(7, 5) = 0 f(7, 6) = 0 f(7, 7) = 1 End If If t = False Then f(1, 1) = 1 f(1, 2) = r * Sin(x) f(1, 3) = -r * (1 - Cos(x)) f(1, 4) = ((r ^ 2) / (2 * m * E * j)) * (2 * (1 - Cos(x)) - (1 + m) * x * Sin(x)) f(1, 5) = ((r ^ 3) / (2 * m * E * j)) * (2 * x - (3 + m) * Sin(x) + (1 + m) * x * Cos(x)) f(1, 6) = -((1 + m) / (2 * m * E * j)) * (r ^ 2) * (Sin(x) - x * Cos(x)) f(1, 7) = 0 f(2, 1) = 0 f(2, 2) = Cos(x) f(2, 3) = -Sin(x) f(2, 4) = (r / (2 * m * E * j)) * ((1 - m) * Sin(x) - (1 + m) * x * Cos(x)) f(2, 5) = ((r ^ 2) / (2 * m * E * j)) * (2 * (1 - Cos(x)) - (1 + m) * x * Sin(x)) f(2, 6) = -((1 + m) / (2 * m * E * j)) * r * x * Sin(x) f(2, 7) = 0 f(3, 1) = 0 f(3, 2) = Sin(x) f(3, 3) = Cos(x) f(3, 4) = -((1 + m) / (2 * m * E * j)) * r * x * Sin(x) f(3, 5) = -((1 + m) / (2 * m * E * j)) * (r ^ 2) * (Sin(x) - x * Cos(x)) f(3, 6) = (r / (2 * m * E * j)) * ((1 - m) * Sin(x) - (1 + m) * x * Cos(x)) f(3, 7) = 0 f(4, 1) = 0 f(4, 2) = 0 f(4, 3) = 0 f(4, 4) = Cos(x) f(4, 5) = r * Sin(x) f(4, 6) = Sin(x) f(4, 7) = 0 f(5, 1) = 0 f(5, 2) = 0 f(5, 3) = 0 f(5, 4) = 0 f(5, 5) = 1 f(5, 6) = 0 f(5, 7) = 0 f(6, 1) = 0 f(6, 2) = 0 f(6, 3) = 0
f(6, 5) = -r * (1 - Cos(x)) f(6, 6) = Cos(x) f(6, 7) = 0 f(7, 1) = 0 f(7, 2) = 0 f(7, 3) = 0 f(7, 4) = 0 f(7, 5) = 0 f(7, 6) = 0 f(7, 7) = 1 End If nhip = f() End Function
Public Function F0(n As Integer) As Single() Dim f() As Single Dim i As Integer Dim j As Integer ReDim f(1 To 7, 1 To n + 3) For i = 1 To 7 For j = 1 To n + 3 f(i, j) = 0 Next Next f(2, 1) = 1 f(5, 2) = 1 f(6, 3) = 1 f(7, n + 3) = 1 F0 = f() End Function
Public Function Em() As Single() Dim f() As Single Dim i As Integer Dim j As Integer ReDim f(1 To 7, 1 To 7) For i = 1 To 7 For j = 1 To 7 f(i, j) = 0 f(i, i) = 1 Next Next f(2, 7) = -1 Em = f() End Function
Public Function KhuGauss(a!(), b!()) As Single()
'm la so hang cua ma tran hay la so phuong trinh hoac so an Dim m As Integer
Dim n As Integer Dim l As Integer Dim t As Boolean
Dim i, mm, kk As Integer Dim k, j As Integer Dim max, cc As Double m = UBound(a, 1) t = True i = 1 Do While t If (a(i, i) = 0) Then max = 0 mm = i For kk = i + 1 To m
If max < Abs(a(kk, i)) Then mm = kk
max = Abs(a(kk, i)) End If If mm <> i Then For j = i To m cc = a(i, j) a(i, j) = a(m, j) a(m, j) = cc Next j cc = b(i) b(i) = b(m) b(m) = cc End If If mm = i Then
MsgBox ("MA TRAN CAC HE SO SUY BIEN") t = False End If Next kk End If If a(i, i) <> 0 Then cc = 1 / a(i, i) For j = i + 1 To m a(i, j) = a(i, j) * cc Next j b(i) = b(i) * cc For k = i + 1 To m For j = i + 1 To m
a(k, j) = a(k, j) - a(i, j) * a(k, i) Next j
End If i = i + 1 If i = m + 1 Then t = False End If Loop If i = m + 1 Then For i = m - 1 To 1 Step -1 For j = i + 1 To m
b(i) = b(i) - a(i, j) * b(j) Next j
Next i
'For i = 1 To m
' MsgBox("NGHIEM CUA HE LA: X" & i & "=" & Format(b(i), "###0.00")) ' c(i) = b(i) 'Next i End If KhuGauss = b End Function '********************************************************** 'Ma tran chua luc cat
'********************************************************** Public Function luccat(a As Double) As Single()
Dim f!() Dim i As Integer Dim j As Integer ReDim f(1 To 7, 1 To 7) For i = 1 To 7 For j = 1 To 7 If i = j Then f(i, i) = 1 Else f(i, j) = 0 End If Next Next f(5, 7) = a luccat = f() End Function
b. Modul Vẽ CAD: Vecad.bas
Type Diem x As Double
y As Double End Type
Public p(100) As Diem Public Sub noicad() On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument Dim dwgName As String
dwgName = "Vidu.dwg" If Dir(dwgName) <> "" Then
acadApp.Application.Documents.Open dwgName, False Else
MsgBox "File " & dwgName & " does not exist." End If
End Sub
Public Function ALWPline(p() As Diem, Optional LW As Double = 0, Optional mau As Integer = 0, Optional ByRef DrawingSpace As Integer = -1) As Object
'Function to create a LWPline object On Error Resume Next
If objAcad Is Nothing Then
Set objAcad = GetObject(, "AutoCAD.Application") On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description End If
End If
Set acadDoc = acadApp.ActiveDocument End If
Dim points() As Double Dim u As Integer Dim l As Integer Dim i As Integer Dim t As Integer u = UBound(p(), 1) l = LBound(p(), 1)
Dim PLineObj As AcadLWPolyline
ReDim points(0 To (u - l) * 2 + 1) As Double t = 0
For i = l To u
points(t) = p(i).x: points(t + 1) = p(i).y t = t + 2
Next
If DrawingSpace = -1 Then 'nothing passed
If objAcad.ActiveDocument.ActiveSpace = acModelSpace Then
Set PLineObj = objAcad.ActiveDocument.ModelSpace.AddLightWeightPolyline(points) Else Set PLineObj = objAcad.ActiveDocument.PaperSpace.AddLightWeightPolyline(points) End If Else If DrawingSpace Then Set PLineObj = objAcad.ActiveDocument.ModelSpace.AddLightWeightPolyline(points) Else Set PLineObj = objAcad.ActiveDocument.PaperSpace.AddLightWeightPolyline(points) End If End If If Err Then On Error GoTo 0
Err.Raise 1234 + vbObjectError, , "Co loi, Kiem tra lai lenh nay" Exit Function End If 'Set Width For i = 0 To u - l PLineObj.SetWidth i, LW, LW Next 'Set color PLineObj.color = mau 'Zoom ZoomAll
PLineObj.Update
Set ALWPline = PLineObj End Function
Public Sub CTA()
Dim acadApp As AcadApplication On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
MsgBox "Now running " + acadApp.Name + _ " version " + acadApp.Version
End Sub
Public Sub vetron(x As Double, y As Double, r As Double) On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument 'Opening a drawing
'Dim dwgName As String 'dwgName = "drawing.dwg" 'If Dir(dwgName) <> "" Then
'acadApp.Application.Documents.Open dwgName, False 'Else
'MsgBox "File " & dwgName & " does not exist." 'End If
Dim vetron As AcadCircle Dim center(0 To 2) As Double
center(0) = x center(1) = y 'center(2) = 0# radius = r
Set vetron = acadDoc.ModelSpace.AddCircle(center, radius) vetron.Update
' Save the active drawing under the current name 'acadDoc.Save
'Save the active drawing under a new name 'acadDoc.Close True
'acadApp.Quit End Sub
Public Sub vedthang(x1, y1, x2, y2 As Double, Optional mau As Integer) On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument 'Opening a drawing
'Dim dwgName As String 'dwgName = "drawing.dwg" 'If Dir(dwgName) <> "" Then
'acadApp.Application.Documents.Open dwgName, False 'Else
'MsgBox "File " & dwgName & " does not exist." 'End If
' Establish the endpoints of the line Dim lineobj As AcadLine
Dim startPoint(0 To 2) As Double Dim endPoint(0 To 2) As Double startPoint(0) = x1
startPoint(1) = y1 'startPoint(2) = 0
endPoint(0) = x2 endPoint(1) = y2 'endPoint(2) = 100
' Create a Line object in model space
Set lineobj = acadDoc.ModelSpace.AddLine(startPoint, endPoint) If mau = 1 Then lineobj.color = acBlue
lineobj.Update
' Save the active drawing under the current name 'acadDoc.Save
'acadDoc.Close True
'Save the active drawing under a new name 'acadApp.Quit
End Sub
Public Sub veSpline() On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument
' This example creates a spline object in model space. ' Declare the variables needed
Dim splineObj As AcadSpline Dim noOfPoints As Integer Dim startTan(0 To 2) As Double Dim endTan(0 To 2) As Double Dim fitPoints(0 To 8) As Double ' Define the variables
noOfPoints = 3
startTan(0) = 0.5: startTan(1) = 0.5: startTan(2) = 0 endTan(0) = 0.5: endTan(1) = 0.5: endTan(2) = 0 fitPoints(0) = 5: fitPoints(1) = 5: fitPoints(2) = 0 fitPoints(3) = 5.5: fitPoints(4) = 4: fitPoints(5) = 0
' Create the spline
Set splineObj = acadDoc.ModelSpace.AddSpline(fitPoints, startTan, endTan) splineObj.Update
End Sub
Public Sub Hatch(P1 As Diem, P2 As Diem, P3 As Diem, P4 As Diem, tenlop As String)
On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument
' This example creates an associative hatch in model space.
Dim hatchObj As AcadHatch Dim patternName As String Dim PatternType As Long Dim tl As Double
Dim bAssociativity As Boolean
' Define the hatch
If tenlop = "Đất lấp" Then patternName = "ANSI37" tl = 1
ElseIf tenlop = "Sét" Then patternName = "ANSI31" tl = 1
ElseIf tenlop = "Sét pha" Then patternName = "ANSI33" tl = 1
ElseIf tenlop = "Cát" Then patternName = "AR-SAND" tl = 0.05
ElseIf tenlop = "Cát bụi" Then patternName = "AR-SAND" tl = 0.2
ElseIf tenlop = "Cát pha" Then patternName = "AR-CONC" tl = 0.05
ElseIf tenlop = "Cát hạt trung" Then patternName = "DOTS"
tl = 1
ElseIf tenlop = "Đá phiến" Then patternName = "CROSS" tl = 0.5 End If PatternType = 0 bAssociativity = True
' Create the associative Hatch object in model space
Set hatchObj = acadDoc.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj.PatternScale = tl
' Create the outer boundary for the hatch. (a circle) Dim outerLoop(0 To 3) As AcadEntity
Dim diem1(0 To 2) As Double Dim diem2(0 To 2) As Double
diem1(0) = P1.x: diem1(1) = P1.y: diem1(2) = 0 diem2(0) = P2.x: diem2(1) = P2.y: diem2(2) = 0
Set outerLoop(0) = acadDoc.ModelSpace.AddLine(diem1, diem2)
diem1(0) = P2.x: diem1(1) = P2.y: diem1(2) = 0 diem2(0) = P3.x: diem2(1) = P3.y: diem2(2) = 0
Set outerLoop(1) = acadDoc.ModelSpace.AddLine(diem1, diem2)
diem1(0) = P3.x: diem1(1) = P3.y: diem1(2) = 0 diem2(0) = P4.x: diem2(1) = P4.y: diem2(2) = 0
Set outerLoop(2) = acadDoc.ModelSpace.AddLine(diem1, diem2)
diem1(0) = P4.x: diem1(1) = P4.y: diem1(2) = 0 diem2(0) = P1.x: diem2(1) = P1.y: diem2(2) = 0
Set outerLoop(3) = acadDoc.ModelSpace.AddLine(diem1, diem2)
' Append the outerboundary to the hatch object, and display the hatch hatchObj.AppendOuterLoop (outerLoop) hatchObj.Evaluate acadDoc.Regen True For i = 0 To 3 outerLoop(i).Delete Next End Sub
Public Sub vbaPolyline()
Dim pline2DObj As AcadLWPolyline Dim pline3DObj As AcadPolyline Dim points2D(0 To 5) As Double Dim points3D(0 To 8) As Double ' Define three 2D polyline points points2D(0) = 1: points2D(1) = 1 points2D(2) = 1: points2D(3) = 2 points2D(4) = 2: points2D(5) = 2 ' Define three 3D polyline points
points3D(0) = 1: points3D(1) = 1: points3D(2) = 0 points3D(3) = 2: points3D(4) = 1: points3D(5) = 0 points3D(6) = 2: points3D(7) = 2: points3D(8) = 0 ' Create the 2D light weight Polyline
Set pline2DObj = Thisdrawing.ModelSpace. _ AddLightWeightPolyline(points2D)
pline2DObj.color = acRed pline2DObj.Update
' Create the 3D polyline
Set pline3DObj = Thisdrawing.ModelSpace. _ AddPolyline(points3D)
pline3DObj.color = acBlue pline3DObj.Update
' Query the coordinates of the polylines Dim get2Dpts As Variant
Dim get3Dpts As Variant
get2Dpts = pline2DObj.Coordinates get3Dpts = pline3DObj.Coordinates ' Display the coordinates
MsgBox ("2D polyline (red): " & vbCrLf & _ get2Dpts(0) & ", " & get2Dpts(1) & vbCrLf & _ get2Dpts(2) & ", " & get2Dpts(3) & vbCrLf & _ get2Dpts(4) & ", " & get2Dpts(5))
MsgBox ("3D polyline (blue): " & vbCrLf & _ get3Dpts(0) & ", " & get3Dpts(1) & ", " & _ get3Dpts(2) & vbCrLf & _
get3Dpts(3) & ", " & get3Dpts(4) & ", " & _ get3Dpts(5) & vbCrLf & _
get3Dpts(6) & ", " & get3Dpts(7) & ", " & _ get3Dpts(8))
End Sub
Public Sub Polyline() On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument Dim pline2DObj As AcadLWPolyline Dim points2D(0 To 5) As Double ' Define three 2D polyline points points2D(0) = 1: points2D(1) = 1 points2D(2) = 1: points2D(3) = 2 points2D(4) = 2: points2D(5) = 2
Set pline2DObj = acadDoc.ModelSpace.AddLightWeightPolyline(points2D) pline2DObj.color = acRed
pline2DObj.Update End Sub
Public Sub chu(x As Double, y As Double, text As String, cao As Double, Optional color As Integer)
On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument Dim textObj As AcadText
Dim textString As String
Dim insertionPoint(0 To 2) As Double Dim height As Double
' Dim pointObj As AcadPoint
' Define the text object textString = text
insertionPoint(0) = x: insertionPoint(1) = y: insertionPoint(2) = 0 alignmentPoint(0) = x: alignmentPoint(1) = y: alignmentPoint(2) = 0 height = cao
' Create the text object in model space
Set textObj = acadDoc.ModelSpace.AddText(textString, insertionPoint, height)
' oldPDMODE = acadDoc.GetVariable("PDMODE")
' Set pointObj = acadDoc.ModelSpace.AddPoint(alignmentPoint) If IsMissing(color) = False Then
textObj.color = acRed End If textObj.StyleName = "Kieu2" textObj.Alignment = acAlignmentRight textObj.TextAlignmentPoint = alignmentPoint textObj.Update End Sub
Public Sub Vedt(P1 As Diem, P2 As Diem) On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application") If Err Then
MsgBox Err.Description Exit Sub
End If End If
'Connect to the AutoCAD drawing Dim acadDoc As AcadDocument
Set acadDoc = acadApp.ActiveDocument Dim lineobj As AcadLine
Dim startPoint(0 To 2) As Double Dim endPoint(0 To 2) As Double startPoint(0) = P1.x
startPoint(1) = P1.y 'startPoint(2) = 0 endPoint(0) = P2.x endPoint(1) = P2.y
'endPoint(2) = 100
' Create a Line object in model space
Set lineobj = acadDoc.ModelSpace.AddLine(startPoint, endPoint) lineobj.Update
End Sub
Public Sub ddong(P1 As Diem, P2 As Diem, Kc As Double, Optional text As Double)
On Error Resume Next
'Connect to the AutoCAD application Dim acadApp As AcadApplication
Set acadApp = GetObject(, "AutoCAD.Application") If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")