文本文档
'根据数据库内点坐标，自动画线成图
Private Const Pass = ""
Private Const User_Name = "admin"
Public Sub read_data_1()
Dim This_Path As String, Path As String
Dim outerLoop(0) As Object '创建外边界
Dim Conn As Object, Rs As Object
Dim Sql As String
Dim hatchObj As Object
Dim patternName As String
Dim PatternType As Long
Dim bAssociativity As Boolean
Dim Data_All() As Variant, X As Integer
Dim ptBase(2) As Double, radius As Double, CircleObj As AcadCircle, ThisDraw As Object
Dim Lay As AcadLayer
'这里初始化各种参数
This_Path = CStr(ThisDrawing.Application.Path) & "\Support\Diy_Soft\Data_Sore\celiang_data.mdb"
Set Conn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
With Conn
.Provider = "Microsoft.Jet.OLEDB.4.0;User id='" & User_Name & "';password='" & Pass & "';"
.ConnectionString = "Data Source='" & This_Path & "';"
.Open
End With
Sql = "select * from [qh_data]"
Rs.Open Sql, Conn, 1, 1
ReDim Preserve Data_All(3, (Rs.RecordCount - 1))
For X = 0 To Rs.RecordCount - 1 Step 1
Data_All(0, X) = CVar(Rs("zb_a").Value)
Data_All(1, X) = CVar(Rs("zb_b").Value)
Data_All(2, X) = CVar(Rs("zb_c").Value)
Data_All(3, X) = CStr(Rs("zb_bh").Value)
Rs.MoveNext
Next
Rs.Close
Conn.Close
Set Rs = Nothing
Set Conn = Nothing
For Y = 0 To X - 2 Step 1
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "测量线" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("测量线")
ThisDraw.color = acRed
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
Call Create_line(Data_All(0, Y), Data_All(1, Y), Data_All(2, Y), Data_All(0, Y + 1), Data_All(1, Y + 1), Data_All(2, Y + 1))
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "点号" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("点号")
ThisDraw.color = acBlue
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
If Len(CStr(Data_All(3, Y))) = 2 Then
Call Create_Text(Data_All(0, Y) - 2, Data_All(1, Y) - 1.5, Data_All(2, Y), 1, CStr(Data_All(3, Y)))
ElseIf Len(CStr(Data_All(3, Y))) = 3 Then
Call Create_Text(Data_All(0, Y) - 2.5, Data_All(1, Y) - 1.5, Data_All(2, Y), 1, CStr(Data_All(3, Y)))
Else
Call Create_Text(Data_All(0, Y) - 1, Data_All(1, Y) - 1.5, Data_All(2, Y), 1, CStr(Data_All(3, Y)))
End If
Next
If Len(CStr(Data_All(3, Y))) = 2 Then
Call Create_Text(Data_All(0, Y) - 2, Data_All(1, Y) - 1.5, Data_All(2, Y), 1, CStr(Data_All(3, Y)))
ElseIf Len(CStr(Data_All(3, Y))) = 3 Then
Call Create_Text(Data_All(0, Y) - 2.5, Data_All(1, Y) - 1.5, Data_All(2, Y), 1, CStr(Data_All(3, Y)))
Else
Call Create_Text(Data_All(0, Y) - 1, Data_All(1, Y) - 1.5, Data_All(2
, Y), 1, CStr(Data_All(3, Y)))
End If
ThisDrawing.Application.ZoomExtents
End Sub
Private Function Create_line(X, Y, Z, I, J, K)
Dim Pt0(2) As Double, pt1(2) As Double
Dim Line_obj As AcadLine
Pt0(0) = X
Pt0(1) = Y
Pt0(2) = Z
pt1(0) = I
pt1(1) = J
pt1(2) = K
Set Line_obj = ThisDrawing.ModelSpace.AddLine(Pt0(), pt1())
Line_obj.color = acByLayer
End Function
Private Function Create_Text(X, Y, Z, J, K As String)
Dim Pt0(2) As Double
Dim Text_Obj As AcadText
Pt0(0) = X
Pt0(1) = Y
Pt0(2) = Z
Set Text_Obj = ThisDrawing.ModelSpace.AddText(K, Pt0(), J)
Text_Obj.color = acByLayer
End Function
'根据图形文件中的Pline图层中的PL线，自动计算面积并标注
Sub yusuan()
On Error Resume Next
Dim Lay As Object, Pline As Object, Entobj As Object, Var As Variant, Pon(2) As Single, Area_Num As Double
For Each Entobj In ThisDrawing.ModelSpace
If StrComp(Entobj.ObjectName, "acdbPolyline", vbTextCompare) = 0 Then
If Entobj.Closed Then
If LCase(https://www.360docs.net/doc/4c17460031.html,yer) = "pline" Then
Var = Entobj.Coordinates
'For Num_I = 0 To UBound(Var) - 5 Step 1
For Num_I = 0 To 0 Step 1
If Num_I = 0 Then
Pon(0) = (Var(Num_I) + Var(Num_I + 2)) / 2
Pon(1) = (Var(Num_I + 1) + Var(Num_I + 3)) / 2
If UBound(Var) > 4 Then
Pon(0) = (Pon(0) + Var(Num_I + 4)) / 2
Pon(1) = (Pon(1) + Var(Num_I + 5)) / 2
End If
Else
Pon(0) = (Pon(0) + Var(Num_I + 4)) / 2
Pon(1) = (Pon(1) + Var(Num_I + 5)) / 2
End If
Pon(2) = 0
Next
Call Create_line(Var(0), Var(1), 0, Pon(0), Pon(1), Pon(2))
Area_Num = Round(Entobj.Area / 1000000, 2)
If Area_Num >= 1 Then
Call Create_Text(Pon(0), Pon(1), Pon(2), 500, CStr(Area_Num))
Else
Call Create_Text(Pon(0), Pon(1), Pon(2), 500, "0" & Area_Num)
End If
End If
End If
End If
Next
Set Lay = Nothing
Set Pline = Nothing
Set Entobj = Nothing
If Err Then
MsgBox Err.Description
Err.Clear
End If
End Sub
Private Function Create_Text(X, Y, Z, J, K As String) 'J 字体大小，K 文本。创建图层"面积"，颜色为红色
Dim Pt0(2) As Double, Lay As Object, Lay_B As Boolean
Dim Text_Obj As AcadText
Pt0(0) = X
Pt0(1) = Y
Pt0(2) = Z
Lay_B = True
Set Text_Obj = ThisDrawing.ModelSpace.AddText(K, Pt0(), J)
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "面积" Then
Lay_B = Fa
lse
End If
Next
If Lay_B Then
Set Lay = https://www.360docs.net/doc/4c17460031.html,yers.Add("面积")
Lay.color = acRed
Lay.ActiveLayer = Lay
Text_https://www.360docs.net/doc/4c17460031.html,yer = "面积"
Else
Text_https://www.360docs.net/doc/4c17460031.html,yer = "面积"
End If
Set Text_Obj = Nothing
Set Lay = Nothing
End Function
Private Function Create_line(X, Y, Z, I, J, K)
Dim Pt0(2) As Double, pt1(2) As Double
Dim Line_obj As AcadLine
Pt0(0) = X
Pt0(1) = Y
Pt0(2) = Z
pt1(0) = I
pt1(1) = J
pt1(2) = K
Set Line_obj = ThisDrawing.ModelSpace.AddLine(Pt0(), pt1())
Line_obj.color = acByLayer
Line_https://www.360docs.net/doc/4c17460031.html,yer = "面积"
Set Line_obj = Nothing
End Function
Sub ModifyTextFont() '关闭大字体，设置宋体
Dim typeFace As String
Dim SavetypeFace As String
Dim Bold As Boolean
Dim Italic As Boolean
Dim charSet As Long
Dim PitchandFamily As Long
ThisDrawing.ActiveTextStyle.GetFont typeFace, Bold, Italic, charSet, PitchandFamily
typeFace = "宋体"
ThisDrawing.ActiveTextStyle.SetFont typeFace, Bold, Italic, charSet, PitchandFamily
ThisDrawing.Regen acActiveViewport
End Sub
'去除教育版戳记
Sub dddddd() '去除教育版标记
Dim Path As String, Name As String
Path = ThisDrawing.Path
Name = https://www.360docs.net/doc/4c17460031.html,
Name = Left(Name, Len(Name) - 4)
ThisDrawing.SaveAs Path & "\" & Name, ac2004_dxf
ThisDrawing.Close
Application.Documents.Open Path & "\" & Name & ".dxf"
ThisDrawing.SaveAs Path & "\" & Name, ac2004_dwg
ThisDrawing.Close
Kill Path & "\" & Name & ".dxf"
Application.Documents.Open Path & "\" & Name & ".dwg"
End Sub
'根据数据（数据库数据）自动生成挡土墙截面图
Private Const Pass = "2230102330"
Private Const User_Name = "admin"
Sub DTQ_Auto()
Dim Inc_X As Double, Inc_Y As Double, Inc_Z As Double, I As Long
Dim outerLoop(0) As Object '创建外边界
Dim Conn As Object, Rs As Object
Dim Sql As String, This_Path As String
Dim hatchObj As Object
Dim patternName As String
Dim PatternType As Long
Dim Z0(2) As Double, Z1(2) As Double, Z2(2) As Double, Z3(2) As Double, Z4(2) As Double, Z5(2) As Double, Z11(2) As Double, Z12(2) As Double, intPoints As Variant, Point_First As Variant
Dim A0(2) As Double, A1(2) As Double, A2(2) As Double, A3(2) As Double, A4(2) As Double, A5(2) As Double, A11(2) As Double, A12(2) As Double, Ro_Txt As String, A13(2) As Double
Dim B10(2) As Double, Area_On As Boolean '显示面积否
Dim Date_No(5, 1) As Double, Date_Line(3, 1) As Double
Dim entLine1 As AcadLine, entLine2 As AcadLine, Ro_s As Double '旋转角度
Dim Font_Type As Double
This_Path = ThisDrawing.Application.Path & "\Support\Diy_Soft\Data_Sore\DTQ_Auto.MDB"
Set Conn = CreateObject("ADODB.Connection")
Set Rs = CreateObject("ADODB.Recordset")
With Conn
.Provider = "Microsof
t.Jet.OLEDB.4.0;User id='" & User_Name & "';Jet OLEDB:Database Password='" & Pass & "';"
.ConnectionString = "Data Source='" & This_Path & "';"
.Open
End With
Sql = "Select * From [Sys] Order By [id]"
Rs.Open Sql, Conn, 1, 1
If InputBox("0 不显示,1 显示", "是否显示面积") = 0 Then
Area_On = False
Else
Area_On = True
End If
Font_Type = CDbl(InputBox("字体比例:0~N", "字体比例")) '设置字体比例
'0、指定生成图形开始坐标
Point_First = ThisDrawing.Utility.GetPoint(, "指定生成图形开始坐标：")
For I = 0 To Rs.RecordCount - 1 Step 1
'1、坐标提取
Z0(0) = 6888 * Font_Type * I + Point_First(0): Z0(1) = Point_First(1): Z0(2) = Point_First(2)
Z1(0) = Z0(0) + CDbl(Rs("A")): Z1(1) = Z0(1): Z1(2) = 0
Z5(0) = Z0(0) - (CDbl(Rs("H")) - CDbl(Rs("F"))) * CDbl(Rs("J")): Z5(1) = Z0(1) + CDbl(Rs("F")) - CDbl(Rs("H")): Z5(2) = 0
Z4(0) = Z5(0) - CDbl(Rs("G")): Z4(1) = Z5(1): Z4(2) = 0
Z3(0) = Z4(0): Z3(1) = Z4(1) - CDbl(Rs("F")): Z3(2) = 0
Z2(0) = Z3(0) + CDbl(Rs("E")) * CDbl(Rs("D")): Z2(1) = Z3(1) - CDbl(Rs("E")): Z2(2) = 0
'3、生成图形
Date_No(0, 0) = Z0(0): Date_No(0, 1) = Z0(1)
Date_No(1, 0) = Z1(0): Date_No(1, 1) = Z1(1)
Date_No(2, 0) = Z2(0): Date_No(2, 1) = Z2(1)
Date_No(3, 0) = Z3(0): Date_No(3, 1) = Z3(1)
Date_No(4, 0) = Z4(0): Date_No(4, 1) = Z4(1)
Date_No(5, 0) = Z5(0): Date_No(5, 1) = Z5(1)
B10(0) = Z5(0) + 200: B10(1) = Z5(1) - 120: B10(2) = Z5(2)
Dim Lay As AcadLayer
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "挡墙轮廓" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("挡墙轮廓")
ThisDraw.color = acWhite
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
Set outerLoop(0) = Add_PLine(Date_No(), True, B10, Area_On)
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "图形填充" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("图形填充")
ThisDraw.color = acYellow
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
patternName = "gravel" '填充样式
PatternType = 0
bAssociativity = True
Set hatchObj = ThisDrawing.ModelSpace.AddHatch(PatternType, patternName, bAssociativity)
hatchObj.AppendOuterLoop (outerLoop)
hatchObj.PatternScale = 68 '填充比例
hatchObj.Lineweight = acLnWtByLwDefault
hatchObj.color = acByLayer
hatchObj.Evaluate
'Call Add_PLine(Date_No(), True, B10, Area_On)
'4、标注生成
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "标高标注" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("标高标注")
ThisDraw.color = acBlue
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
A0(0) = Z1(0) + 500 * Font_Type: A0(1) = Z1(1): A0(2) = Z1(2)
A1(0) = A0(0) + 200 * Font_Type: A1(1) = A0(1): A1(2) = A0(2)
A2(0) = A1(0) + 660 * Font_Type: A2(1) = A1(1): A2(2) = A1(2)
A3(0) = A1(0) - 200 * Font_Type: A3(1) = A1(1) + 280 * Font_Type: A3(2) = A1(2)
A4(0) = A1(0) + 200 * Font_Type: A4(1) = A1(1) + 280 * Font_Type: A4(2) = A1(2)
A5(0) = A4(0) + 500 * Font_Type: A5(1) = A4(1): A5(2) = A4(2)
A11(0) = A3(0): A11(1) = A3(1) + 38: A11(2) = A3(2)
A12(0) = (Z3(0) + Z2(0)) / 2 - 1150 * Font_Type * 1.2: A12(1) = Z3(1) - 1800 * Font_Type * 1.2: A12(2) = Z3(2)
Call Add_Line(A0(0), A0(1), A0(2), A2(0), A2(1), A2(2))
Date_Line(0, 0) = A4(0): Date_Line(0, 1) = A4(1)
Date_Line(1, 0) = A1(0): Date_Line(1, 1) = A1(1)
Date_Line(2, 0) = A3(0): Date_Line(2, 1) = A3(1)
Date_Line(3, 0) = A5(0): Date_Line(3, 1) = A5(1)
Call Add_PLine(Date_Line, False, B10, False)
Call Add_Text(Rs("Bg"), A11, 280 * Font_Type)
Call Add_Text(Rs("Num"), A12, 518 * Font_Type)
'5标注
Dim AA(2) As Double, AB(2) As Double, AC(2) As Double, AD(2) As Double, AE(2) As Double, AF(2) As Double, AG(2) As Double
AA(0) = Z0(0): AA(1) = (Z0(1) + Z1(1)) / 2 + 400 * Font_Type: AA(2) = Z0(2)
Call CJBZ(Z0(), Z1(), AA(), "SHUIPING")
AB(0) = (Z2(0) + Z3(0)) / 2: AB(1) = Z2(1) - 330 * Font_Type: AB(2) = Z2(2)
Call CJBZ(Z3(), Z2(), AB(), "SHUIPING")
AC(0) = Z3(0) - 330 * Font_Type: AC(1) = (Z2(1) + Z3(1)) / 2: AC(2) = Z3(2)
AG(0) = Z3(0): AG(1) = Z2(1): AG(2) = Z3(2)
Call CJBZ(AG(), Z3(), AC(), "CHUI")
AD(0) = Z4(0) - 330 * Font_Type: AD(1) = (Z3(1) + Z4(1)) / 2: AD(2) = Z4(2)
Call CJBZ(Z3(), Z4(), AD(), "CHUI")
AE(0) = (Z4(0) + Z5(0)) / 2: AE(1) = Z5(1) + 460 * Font_Type: AE(2) = Z5(2)
Call CJBZ(Z5(), Z4(), AE(), "SHUIPING")
AF(0) = Z3(0) - 800 * Font_Type: AF(1) = (Z0(1) + Z3(1)) / 2: AF(2) = Z3(2)
Call CJBZ(Z3(), Z0(), AF(), "CHUI")
'6坡度标注
Ro_s = (90 - Atn(CDbl(Rs("J"))) * 180 / (4 * Atn(1))) * 4 * Atn(1) / 180
Ro_Txt = "1:0" & Rs("J")
A13(0) = (Z0(0) + Z5(0)) / 2 - 150 * Font_Type: A13(1) = (Z0(1) + Z5(1)) / 2: A13(2) = 0
Call Add_Txt(Ro_Txt, A13(), 200 * Font_Type, Ro_s)
Rs.MoveNext
Next I
Rs.Close
Conn.Close
Set Rs = Nothing
Se
t Conn = Nothing
ThisDrawing.Application.ZoomExtents
End Sub
Private Function CJBZ(Point1() As Double, Point2() As Double, Location() As Double, Gis As String) 'Gis 表示垂直或水平标注，CHUI,SHUIPING
'该示例在模型空间中创建水平和垂直标注?
Dim LineObj As AcadLine
Dim rotAngle As Double
Dim Lay As AcadLayer
'绘制直线
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "线性标注" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("线性标注")
ThisDraw.color = acGreen
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
Set LineObj = ThisDrawing.ModelSpace.AddLine(Point1, Point2)
If UCase(Gis) = "SHUIPING" Then
' 在模型空间中创建水平标注
rotAngle = 0
rotAngle = rotAngle * 3.1415926 / 180# ' 转换为弧度
Set dimObj = ThisDrawing.ModelSpace.AddDimRotated(Point1, Point2, Location, rotAngle)
LineObj.Delete
Else
' 在模型空间中创建垂直标注
rotAngle = 90
rotAngle = rotAngle * 3.1415926 / 180# ' 转换为弧度
Set dimObj = ThisDrawing.ModelSpace.AddDimRotated(Point1, Point2, Location, rotAngle)
LineObj.Delete
End If
End Function
Private Function Add_PLine(Data_Line() As Double, C As Boolean, B10() As Double, Area_On As Boolean) 'C表示闭合否
Dim Points() As Double, I As Integer, Lay As AcadLayer
' 定义二维多段线顶点
If C Then
ReDim Points((UBound(Data_Line) + 1) * 2 + 1)
Else
ReDim Preserve Points((UBound(Data_Line) + 1) * 2 - 1)
End If
For I = LBound(Data_Line) To UBound(Data_Line) Step 1
Points(2 * I) = Data_Line(I, 0): Points(2 * I + 1) = Data_Line(I, 1)
Next
If C Then
Points(2 * I) = Data_Line(0, 0): Points(2 * I + 1) = Data_Line(0, 1)
End If
' 在模型空间中创建优化多段线
Set Add_PLine = ThisDrawing.ModelSpace.AddLightWeightPolyline(Points)
Add_PLine.color = acByLayer
'6、标注面积
If Area_On Then
For Each Lay In https://www.360docs.net/doc/4c17460031.html,yers
If https://www.360docs.net/doc/4c17460031.html, = "面积" Then
ThisDrawing.ActiveLayer = Lay
Else
Set ThisDraw = https://www.360docs.net/doc/4c17460031.html,yers.Add("面积")
ThisDraw.color = acRed
ThisDrawing.ActiveLayer = ThisDraw
End If
Next
If Round(Add_PLine.Area / 1000000, 2) < 1 Then
Call Add_Text("S=0" & Round(Add_PLine.Area / 1000000, 2), B10, 200)
Else
Call Add_Text("S=" & Round(Add_PLine.Area / 1000000, 2), B10, 200)
End If
End If
End Function
Private Function Add_Text(Str_K As String, Pt0() As Double, J As Double)
Set Add_Text = ThisDrawing.ModelSpace.AddText(Str_K, Pt0(), J)
Add_Text.color = acByLayer
End Functi
on
Private Function Add_Line(X, Y, Z, I, J, K)
Dim Pt0(2) As Double, pt1(2) As Double
Pt0(0) = X
Pt0(1) = Y
Pt0(2) = Z
pt1(0) = I
pt1(1) = J
pt1(2) = K
Set Add_Line = ThisDrawing.ModelSpace.AddLine(Pt0(), pt1())
Add_Line.color = acByLayer
End Function
Private Function Change_Str(Num As Variant) As String
If Num >= 1 Or Num <= -1 Then
Change_Str = CStr(Num)
Else
If Num < 1 And Num > 0 Then
Change_Str = "0" & Num
End If
If Num < 0 And Num > -1 Then
Change_Str = "-0" & Right(Num, Len(Num) - 1)
End If
If Num = 0 Then
Change_Str = "±0"
End If
End If
End Function
Private Function Add_Txt(Str_K As String, Pt0() As Double, J As Double, S As Double)
Set Add_Txt = ThisDrawing.ModelSpace.AddText(Str_K, Pt0(), J)
Add_Txt.color = acByLayer
Add_Txt.Rotate Pt0(), S
End Function