các hàm vba để chuẩn bị thi vba mọi nguoi nên chuẩn bị

Các hàm cơ bản lập trình vba
Function kichthuoc(ktx1 As Double, kty1 As Double, ktx2 As Double, kty2 As Double, ta As Double, tb As Double)
Dim tx1(0 To 2) As Double
Dim tx2(0 To 2) As Double
Dim hkt(0 To 2) As Double
tx1(0) = ktx1
tx1(1) = kty1
tx1(2) = 0
tx2(0) = ktx2
tx2(1) = kty2
tx2(2) = 0
hkt(0) = ktx1 + ta
hkt(1) = kty1 + tb
hkt(2) = 0
Dim kt As AcadDimAligned
Set kt = ThisDrawing.ModelSpace.AddDimAligned(tx1, tx2, hkt)
Set kichthuoc = kt
End Function

Function trong modul vẽ hình

Function duongthang(x1 As Double, y1 As Double, x2 As Double, y2 As Double)
Dim point1(0 To 2) As Double
Dim point2(0 To 2) As Double
point1(0) = x1
point1(1) = y1
point1(2) = 0
point2(0) = x2
point2(1) = y2
point2(2) = 0
Dim line As AcadLine
Set line = ThisDrawing.ModelSpace.AddLine(point1, point2)
Set duongthang = line
End Function

Function duongpline(x3 As Double, y3 As Double, x4 As Double, y4 As Double, x5 As Double, y5 As Double, x6 As Double, y6 As Double)
Dim point(0 To 7) As Double
Dim pline As AcadLWPolyline
point(0) = x3
point(1) = y3
point(2) = x4
point(3) = y4
point(4) = x5
point(5) = y5
point(6) = x6
point(7) = y6
Set pline = ThisDrawing.ModelSpace.AddLightWeightPolyline(point)
Set duongpline = pline
End Function

Function duongtron(tam1 As Double, tam2 As Double, bakinh As Double)
Dim tam(0 To 2) As Double
Dim radian As Double
tam(0) = tam1
tam(1) = tam2
tam(2) = 0
radian = bakinh
Dim circe As AcadCircle
Set circe = ThisDrawing.ModelSpace.AddCircle(tam, radian)
Set duongtron = circe

End Function


Function cungtron(arcx As Double, arcy As Double, bankinhcung As Double, gocbatdau As Double, goccuoi As Double)
Dim tamcungtron(0 To 2) As Double
Dim bankinh As Double
Dim gocdau As Double
Dim goccungcuoi As Double
tamcungtron(0) = arcx
tamcungtron(1) = arcy
tamcungtron(2) = 0
bankinh = bankinhcung
gocdau = gocbatdau * 3.1416 / 180
goccungcuoi = goccuoi * 3.1416 / 180
Dim arc As AcadArc
Set arc = ThisDrawing.ModelSpace.AddArc(tamcungtron, bankinh, gocdau, goccungcuoi)
Set cungtron = arc
End Function

Khai báo
'Khai bao cac bien layer
Dim kichthuoc As AcadLayer
Dim cotdai As AcadLayer
Dim vienmong As AcadLayer
Dim thep As AcadLayer
Dim thep1 As AcadLayer
Dim thepngang As AcadLayer
Dim truc As AcadLayer
Dim an As AcadLayer
Dim netdut As AcadLayer
'Khai bao toa do ban dau
Dim px As Double
Dim py As Double
'Khai bao bien cua hatch
Dim hatchobj As AcadHatch
Dim lopp(0 To 0) As AcadEntity
'Khai bao 2 diem cua mirror
Dim mr1(0 To 2) As Double
Dim mr2(0 To 2) As Double
'Khai bao cau Array
Dim sohang As Double
Dim socot As Double
Dim kch As Double
Dim kcc As Double
Dim lever As Double
Dim lever2 As Double
'Khai Bao SelectionSet
Dim sset As AcadSelectionSet

Các sub
********************************************
'Sub tao SelectionSet
'********************************************
Sub taoselecyion(setx1 As Double, sety1 As Double, setx2 As Double, sety2 As Double)
Dim mode As Integer
On Error Resume Next
Set sset = ThisDrawing.SelectionSets("sset1")
If Err <> 0 Then
Err.Clear
Set sset = ThisDrawing.SelectionSets.Add("sset1")
Else
sset.Clear
End If
Dim setpoint1(0 To 2) As Double
Dim setpoint2(0 To 2) As Double
setpoint1(0) = setx1
setpoint1(1) = sety1
setpoint1(2) = 0
setpoint2(0) = setx2
setpoint2(1) = sety2
setpoint2(2) = 0
mode = 1
sset.Select mode, setpoint1, setpoint2
End Sub
'********************************************
'Sub tao hatch
'********************************************

Sub taohatch(name As String)
Dim ptname As String
Dim pttype As Long
Dim bass As Boolean
ptname = name
pttype = 0
bass = True
Set hatchobj = ThisDrawing.ModelSpace.AddHatch(pttype, ptname, bass)

End Sub


'********************************************
'Khoi tao cac layer cho ban ve
'********************************************
Sub taolayer()
Set kichthuoc = ThisDrawing.Layers.Add("kichthuoc")
Set cotdai = ThisDrawing.Layers.Add("cotdai")
cotdai.color = acBlue
Set vienmong = ThisDrawing.Layers.Add("vienmong")
vienmong.color = acGreen
Set thep = ThisDrawing.Layers.Add("thep")
thep.color = acYellow
Set thep1 = ThisDrawing.Layers.Add("thep1")
thep1.color = acCyan
Set thepngang = ThisDrawing.Layers.Add("thepngang")
Set truc = ThisDrawing.Layers.Add("truc")
truc.color = acRed


Set an = ThisDrawing.Layers.Add("an")
Set netdut = ThisDrawing.Layers.Add("netdut")
End Sub

'********************************************
'Ve Hinh
'********************************************

Private Sub CommandButton1_Click()
vehinh2
Label2.Caption = " Hoan Thanh..."
Application.Update
ZoomAll
End Sub

'********************************************
'Nua Bat Diem
'********************************************
Private Sub CommandButton2_Click()
frmmain.Hide 'An Form
Dim toado As Variant
toado = ThisDrawing.Utility.GetPoint(, "Chon 1 diem") 'Dung getpoint de lay toa do
txtx = toado(0) 'gan vao 2 o textbox
txty = toado(1)
frmmain.Show 'Hien Form
End Sub

'********************************************
'Chuong Trinh Con Xoa Toan man Hinh
'********************************************
Sub deleteall()
Dim deleteall As AcadSelectionSet
Dim mode2 As Integer
On Error Resume Next
Set deleteall = ThisDrawing.SelectionSets("deletea")
If Err <> 0 Then
Err.Clear
Set deleteall = ThisDrawing.SelectionSets.Add("deletea")
Else
deleteall.Clear
End If
mode2 = 5
deleteall.Select mode2
Dim list As AcadEntity
For Each list In deleteall
list.Delete
Next list
End Sub
'********************************************
'Chuong Trinh Con Dung De Viet Chu
'********************************************
Sub ghichu(txta As Double, txtb As Double, texts As String, tlchu As Double)
Dim tpefara As String
Dim bod As Boolean
Dim itali As Boolean
Dim char As Long
Dim pit As Long
ThisDrawing.ActiveTextStyle.GetFont tpefara, bod, itali, char, pit
bod = True
tpefara = "Arial"
ThisDrawing.ActiveTextStyle.SetFont tpefara, bod, itali, char, pit
Dim mtext As AcadMText
Dim txtstring As String
Dim txtpoint(0 To 2) As Double
txtpoint(0) = px + txta
txtpoint(1) = py + txtb
txtpoint(2) = 0
Dim txthigh As Double
txthigh = 100
txtstring = texts
Set mtext = ThisDrawing.ModelSpace.AddMText(txtpoint, txthigh, txtstring)
Dim txttl As Double
txttl = tlchu
mtext.ScaleEntity txtpoint, txttl
End Sub

'********************************************
'An Hien Form
'********************************************

Private Sub CommandButton5_Click()
frmmain.Hide
Dim gettxt As String
gettxt = ThisDrawing.Utility.GetString(False, "Hien chuong trinh (Y/N) :")
If gettxt = "Y" Or gettxt = "y" Then
frmmain.Show
Else
Exit Sub
End If
End Sub


Đoạn ghi kích thước
Dim dimste As AcadDimStyle
Set dimste = ThisDrawing.DimStyles.Add("1-30") Tên của DIM
ThisDrawing.SetVariable "DIMBLK", "OBLIQUE"
ThisDrawing.SetVariable "DIMDEC", 0
ThisDrawing.SetVariable "DIMSCALE", 500 (tỷ lê scale)
ThisDrawing.SetVariable "DIMTAD", 1
ThisDrawing.SetVariable "DIMTIH", 0
ThisDrawing.SetVariable "DIMTOH", 1
dimste.CopyFrom ThisDrawing
ThisDrawing.ActiveDimStyle = dimste
Dim dim1 As AcadDimAligned
Set dim1 = ghikt.kichthuoc(I(0) - b / 2, I(1), I(0) - b / 2, I(1) + h, I(0) - b / 2, I(1) + h / 2)
Dim dim2 As AcadDimAligned
Set dim2 = ghikt.kichthuoc(I(0) - b / 2, I(1) - b / 2, I(0) + b / 2, I(1) - b / 2, I(0) + b / 2, (I(1) - b / 2))
ZoomAll


Tô một vùng nào đó
'Ve vua lot bt
Dim pline1 As AcadLWPolyline
've pline
Set pline1 = Vehinh.duongpline(px - 1450, py, px - 1450, py + 100, px + 1450, py + 100, px + 1450, py)
pline1.Closed = True 'Dong pline
Set lopp(0) = pline1 'Gan pline vao obj de to
ThisDrawing.ActiveLayer = kichthuoc 'doi layer
'To ki hieu vua cho pline
taohatch "AR-CONC"
hatchobj.AppendOuterLoop (lopp)
hatchobj.PatternScale = 1
hatchobj.PatternScale = hatchobj.PatternScale + 20 'Thay doi ty le
hatchobj.Evaluate 'Cap nhap thay doi
Application.Update

Rãi hình theo kiểu hình chữ nhật
ThisDrawing.ActiveLayer = cotdai 'doi layer de ve cot dai
Set line1 = Vehinh.duongthang(px - 350, py + 250 + 200, px + 350, py + 250 + 200) 've cot dai duoi cung
sohang = 8
socot = 1
kch = 200
kcc = 1
arrayobj1 = line1.ArrayRectangular(sohang, socot, lever, kch, kcc, lever2) 'array cot dai do thanh nhung cai khac


ghi chú
ghichu 860, 2250, "2", 500
860,2250 là tọa độ vị trí ghi “2” là ký tự hiên trong bản vẽ 500 là cỡ chữ
ghichu 500, 1800, "4%%c16", 400
4%%c16 là ký hiệu 4 phi 16

Ghi kích thước
'Ghi Kich thuoc mat dung
Dim dimste As AcadDimStyle
Set dimste = ThisDrawing.DimStyles.Add("1-30")
ThisDrawing.SetVariable "DIMBLK", "OBLIQUE"
ThisDrawing.SetVariable "DIMDEC", 0
ThisDrawing.SetVariable "DIMSCALE", 500
ThisDrawing.SetVariable "DIMTAD", 1
ThisDrawing.SetVariable "DIMTIH", 0
ThisDrawing.SetVariable "DIMTOH", 1
dimste.CopyFrom ThisDrawing
ThisDrawing.ActiveDimStyle = dimste
Dim ktt As AcadDimAligned
Set ktt = ghikichthuoc.kichthuoc(px + 1450, py, px + 1450, py + 100, 100, 0)
100 la
Quay một đường ghi kích thước
Set ktt = ghikichthuoc.kichthuoc(px - 1025, py + 200, px - 1025, py + 600, -100, 0)
goc = 10 * 3.1416 / 180
ropoint(0) = px - 1025
ropoint(1) = py + 200
ktt.Rotate ropoint, -goc
'Ve duong truc chinh
ThisDrawing.ActiveLayer = truc
Set line1 = Vehinh.duongthang(px, py - 800, px, py + 2300)
line1.LinetypeScale = 10
Dim linetype As String
linetype = "ACAD_ISO04W100"
On Error Resume Next
ThisDrawing.Linetypes.Load linetype, "acad.lin"
Dim lineobj As AcadLineType
Set lineobj = ThisDrawing.Linetypes("ACAD_ISO04W100")
truc.linetype = "ACAD_ISO04W100"



'********************************************
Offset 1 đường thẳng
Set line1 = Vehinh.duongthang(px + 3130, py, px + 50, py)
offset = line1.offset(-20)
offset(0).color = acCyan

lấy đối xứng qua 2 điểm
Set pline1 = Vehinh.duongpline(px + 1180, py + 40, px + 1155, py + 40, px + 1155, py + 20, px + 1290, py + 20)
Set line1 = Vehinh.duongthang(px + 1290, py + 20, px + 1290, py + 275)
mr3(0) = px + 1340
mr3(1) = py
mr4(0) = px + 1340
mr4(1) = py + 275
Set mirro1 = pline1.Mirror(mr3, mr4)
Set mirro2 = line1.Mirror(mr3, mr4)