VB6 源代码,喜欢的朋友一起探讨。全部代码为本人自编,本人借楼主帖发放。 ^X\{MW'>4
Public BhachNumber As String 1b``y
Dim fso As New FileSystemObject, fldr As Folder sUe<21:
(_ TKDx_
]r&dWF
Option Explicit E9N.b.Q)
Dim AcadDoc As AcadDocument ]DJ]L=T7
Dim FilPath As String '设置系统路迳 *B*dWMh
Dim AcadApp As Object 'AcadApplication 5f}GV0=n
Dim AcadColr As Integer 'CAD线色 8+|7*Ud
Dim ReturnPnt As Variant |V
dr/'
Dim LayerObj As AcadLayer 'CAD图层 <&CzM"\Em
Dim LayerStr As String GZx?vSoHh
Dim PolObj As AcadLWPolyline
26[. te9
Dim TextObj As AcadText h\<;N*Xi
Dim VaraTtributes As Variant h.t2 ;O, b
Dim KK As Integer '定义玫瑰花图分度间隔 [&MhAzF
Dim KL As Integer '定义玫瑰花图最大半径条数 35}]U=
Dim StartPnt(0 To 2) As Double hLo'q^mGr
Dim EndPnt(0 To 2) As Double h0c&}kM
Dim II As Integer FfSKE
Dim K As Integer fU^6h`t
Dim TextString As String L"x9O'U
Dim InsertionPoint(0 To 2) As Double O!3`^_.
Dim HeightString As Double TBU.%3dEyI
Dim BlockObj As AcadBlockReference >|W\8dTQ
Dim DrawNum1 As Double {G i:W/jJ
Dim LTName As String 6\5"36&/rQ
Dim i As Integer b^dBX
Dim X0 As Single, Y0 As Single, X2 As Single, Y2 As Single zNh$d;(O$^
Dim R1 As Single, R2 As Single, Ang1 As Single, Ang2 As Single 2EAY`}Rl6.
Dim Dat(4, 200) .dw;b~p
Dim CirclObj As Object
\LP?,<
Const Pi = 3.1415926 _GtG8ebr
Dim R As Double "k>;K,:
Dim dwPath As String 5^0K5R6GQf
Dim dwPath1 As String X/AA8QV o
Dim dwPath2 As String #J w\pOn
Dim dwPath3 As String $T2n^yz
Dim ArcObj As AcadArc #Zq[.9!q{
Dim ArcStrA As AcadArc `21$e
Dim LineObj As AcadLine eb*w$|y6"
Dim LWPLObj As AcadLWPolyline G5Z_[Q~z
Dim centerPoint(0 To 2) As Double n38l!m(.
Dim radius As Double j0(+Kq:J
Dim startAngleInDegree As Double 6Gj69Lr
Dim endAngleInDegree As Double X"fSM
#
Dim startAngleInRadian As Double @C"w
1}
Dim endAngleInRadian As Double ^v+7IFn
;p8,=w
Private Sub Command1_Click() *Q`y'6S
StartPnt(0) = DrawNum1 R64/m9
StartPnt(1) = 0 wK*b2r}0/
StartPnt(2) = 0 O_^X:0}
R = 100 0(h'ZV
FilPath = App.Path & "\CPTY.dwg" "raC?H
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(StartPnt, FilPath, 1, 1, 1, 0) -;s-*$I
Call DrawArc z$]HZ#aRE
dwPath1 = "-赤平投影图" ^2<nn op
MsgBox "赤平投影结束,可以进行其它工作!" r>kDRIHB
DrawNum1 = DrawNum1 + 300 R![)B97^
End Sub i-W!`1LH'
{)y8Y9G
Private Sub Command2_Click() 6$'0^Ftm'
StartPnt(0) = DrawNum1: StartPnt(1) = 0: StartPnt(2) = 0 ]
RLEyDB
FilPath = App.Path & "\Rose.dwg" Qh{]gw-6
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(StartPnt, FilPath, 1, 1, 1, 0) _[p@V_my
BlockObj.Update iosL&*'8
Call DrwRose O{&wqV5m"
dwPath2 = "-玫瑰花图" :G/.h[\R|
MsgBox "玫瑰花图结束,可以进行其它工作!" 7a#zr_r
DrawNum1 = DrawNum1 + 300 Op
0Qpn
End Sub Xhk_h2F[
HLYo+;j3|
Private Sub Command3_Click() nNP{>\x;"
Call SelectDat P$hmDTn72
End Sub #- z(]Y,y
o4d[LV4DS
Private Sub Command4_Click() ;e#bl1%#
dwPath = App.Path & "\" & BeginFrm.BhachNumber & "\" _ =5D@~?W ZG
& BeginFrm.BhachNumber & dwPath1 & dwPath2 & dwPath3 & ".dwg" I]jK]]@
AcadDoc.SaveAs (dwPath) Z.{r%W{2
Unload BeginFrm S!{Kn ;@
Unload MaiDatFrm
$hgsWa
Unload Me tLc~]G*\`s
End Sub y0b FzR9
2nv-/%]
Private Sub DrawArc() <pp<%~_Z
Dim DI As Integer #Py\'
Adodc1.Refresh wPRs.(]_
If Adodc1.Recordset.RecordCount = 0 Then Exit Sub Ynx.$$`$=
Adodc1.Recordset.MoveFirst Zt{\<5j
For DI = 1 To Adodc1.Recordset.RecordCount Step 1 ;sZHE&+
Dat(1, DI) = Adodc1.Recordset("结构面倾角").Value * Pi / 180 B`;DAsmT
Dat(2, DI) = Adodc1.Recordset("结构面倾向").Value * Pi / 180 mEVne.D
_
ATIV
R1 = R * (1 - Dat(1, DI) / (Pi / 2)) noSBwP|v*
X2 = R1 * Sin(Dat(2, DI) - Pi) \!Fx,#r$7-
Y2 = R1 * Cos(Dat(2, DI) - Pi) bqI| wGCA"
Ang2 = Pi - 2 * Atn(R / R1) uEE#A0
R2 = R / Sin(Ang2) Q%Y rm
k_A
9gj1
X0 = (R1 - R2) * Sin(Dat(2, DI) - Pi) 67b[T~92o
Y0 = (R1 - R2) * Cos(Dat(2, DI) - Pi) 0o*
lKA2~ o
;Y"*Z2U
' Define the circle $@}\T
centerPoint(0) = StartPnt(0) + X0: centerPoint(1) = StartPnt(1) + Y0: centerPoint(2) = 0 H'2Un(#Al
radius = R2 ZnXq+^Z4
startAngleInDegree = 270 - (Dat(2, DI) + Ang2) * 180 / Pi eGW~4zU
If startAngleInDegree >= 360 Then startAngleInDegree = startAngleInDegree - 360 j|c6BdROl
If startAngleInDegree < 0 Then startAngleInDegree = startAngleInDegree + 360 RxrUnMF
M\w%c5
endAngleInDegree = 270 - (Dat(2, DI) - Ang2) * 180 / Pi c
;@k\6
If endAngleInDegree >= 360 Then endAngleInDegree = endAngleInDegree - 360 R3!3TJ
If endAngleInDegree < 0 Then endAngleInDegree = endAngleInDegree + 360 :978D0}{p
uJ_"gPO
' Convert the angles in degrees to angles in radians ANWUo}j
startAngleInRadian = startAngleInDegree * Pi / 180 @;T?R
endAngleInRadian = endAngleInDegree * Pi / 180 y|O)i
I/g
1Zi(5S)
' Create the arc object in model space P;~P:qKd
Set ArcObj = AcadDoc.ModelSpace.AddArc(centerPoint, radius, startAngleInRadian, endAngleInRadian) .:?cU#.
If DI = 1 Then Ag@R 60#
LTName = "10411" 6H:'_|G
Set ArcStrA = ArcObj
}29Cm$p
ArcStrA.Linetype = LTName Xw<5VIAHm;
ArcStrA.Update N^U<;O?YDW
End If 3^%sz!jK+
ArcObj.Update lBcRt)_O7
Adodc1.Recordset.MoveNext otSF8[
Next DI AOVoOd+6
{S=gXIh(y
End Sub A_}%YHb
TkjPa};R
Private Sub DrwRose() JzZ9ua
K = 0 L|pJ\~
Adodc2.Refresh K26x,m]p
Adodc2.Recordset.MoveFirst QU%'z/dip
For i = 1 To Adodc2.Recordset.RecordCount 1u\kxlZ
Dat(1, i) = Adodc2.Recordset("统计方向").Value $" `9QD~
If Dat(1, i) >= 90 And Dat(1, i) < 180 Then Dat(1, i) = Dat(1, i) + 180 v>]^wH>/"
If Dat(1, i) >= 180 And Dat(1, i) < 270 Then Dat(1, i) = Dat(1, i) - 180 h6Q-+_5
Dat(2, i) = Adodc2.Recordset("统计条数").Value vo3[)BDbT
Adodc2.Recordset.MoveNext eK_Yt~dj
Next i -7\6j#;l
For i = 270 To 450 Step KK 5^GFN*poig
K = 0: EndPnt(0) = DrawNum1: EndPnt(1) = 0 '调整玫瑰花图位置 ;DN:AgXP
For II = 1 To Adodc2.Recordset.RecordCount VQ]MJjvb
If i < 360 Then oEuo@\U05v
If ((Dat(1, II) >= i) And (Dat(1, II) < (i + KK))) Then K = K + Dat(2, II) a8[Q1Fa4|
Else uom~,k$|
If ((Dat(1, II) >= (i - 360)) And (Dat(1, II) < (i + KK - 360))) Then K = K + Dat(2, II) %. -nZ C
End If % m0x]
Next II R`F8J}X_
EndPnt(0) = (K * Sin(((i)) * Pi / 180)) * 100 / KL + DrawNum1 69tT'U3vb$
EndPnt(1) = (K * Cos(((i)) * Pi / 180)) * 100 / KL `<x|<ey
Set LineObj = AcadDoc.ModelSpace.AddLine(StartPnt, EndPnt) l0g`;BI_
LineObj.Update ab-MEN`5
Da WzQe=
StartPnt(0) = EndPnt(0): StartPnt(1) = EndPnt(1) sXmo.{Ayb
Next i /c9%|<O%
'制作标尺 y|0I3n]e
HeightString = 5 8QaF(?
TextString = Str(KL) D-!#TN`Y
InsertionPoint(0) = DrawNum1 - 105: InsertionPoint(1) = 7 AXOR<Ns`
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) Pln*?o
InsertionPoint(0) = DrawNum1 + 90: InsertionPoint(1) = 7 @[] A&)B
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) jy2@t *
TextString = Str(Int(KL / 2 + 0.5)) Xy'qgK?
InsertionPoint(0) = DrawNum1 + 45: InsertionPoint(1) = 7 B$kp\yL
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) .jps6{
InsertionPoint(0) = DrawNum1 - 55: InsertionPoint(1) = 7 .}||!
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) 3NA
G}S
End Sub 4}t&AW4
Private Sub cmdAdd1_Click() ;rJ
On Error GoTo AddErr v*.#LJEm
Adodc1.Recordset.MoveLast 9X[}ik0
DataGrid1.SetFocus #&jr9RB
SendKeys "{down}" /naGn@m5u
9'S~zG%{
Exit Sub 7IV:X
_y
AddErr: r")zR,
MsgBox Err.Description 9e xHR&>{
End Sub 2xJT!lN
i@|.1dWh
Private Sub cmdDelete1_Click() my(yN|
On Error GoTo DeleteErr 0-{l4;o
With Adodc1.Recordset h1uD >heGl
.Delete G*$a81dAX
.MoveNext c$w} h[
If .EOF Then .MoveLast 4 fxD$%9
End With q7'[II;
Exit Sub ?=lnYD j
DeleteErr: TV&4m5
MsgBox Err.Description ;N/=)m
End Sub {aRZBIv
~RS^Opoa
Private Sub cmdUpdate1_Click() Vy:MK9U2
On Error GoTo UpdateErr {Q@pF
eODprFkt}
Adodc1.Recordset.UpdateBatch adAffectAll |}y6U< I
Adodc1.Refresh ^68BxYUoD\
Exit Sub afWEt -
UpdateErr: H@R2mw
MsgBox Err.Description eS{ xma
End Sub 7Yjxx+X9
Private Sub cmdAdd2_Click() GOeYw[Vh
On Error GoTo AddErr 05>xQx?"m4
Adodc2.Recordset.MoveLast xK8R![x
DataGrid2.SetFocus FII>6c
SendKeys "{down}" S3( 2.c~
gc6T`O-_;
Exit Sub >|e>=
AddErr: 0XNj!^&
MsgBox Err.Description mK2M1r
End Sub T2$V5RyX
w}jH,Ew
Private Sub cmdDelete2_Click() Fo1|O&>
On Error GoTo DeleteErr bk#t+tuk
With Adodc2.Recordset mlmXFEC
.Delete }hjJt,m
.MoveNext ~jqh&u$(
If .EOF Then .MoveLast :/
yR
End With =*u:@T=d5
Exit Sub /Vy8%
DeleteErr: Q(e 3-a
MsgBox Err.Description .O+qtk!
End Sub 0Q_@2
d{LQr}_o$$
Private Sub cmdUpdate2_Click() al3[Ph5G
On Error GoTo UpdateErr rH<iUiA?O
k-M-=VvA
Adodc2.Recordset.UpdateBatch adAffectAll $CYB&|d
Adodc2.Refresh b[I;6HW
Exit Sub Nu%JI6&R
UpdateErr: 2r]!$ hto
MsgBox Err.Description |UO&18Y7-
End Sub U2(|/M+
h c9?z}
Private Sub cmdAdd3_Click() ZdJer6:Z}
On Error GoTo AddErr .+"SDtoX
Adodc3.Recordset.MoveLast ?-e'gC
DataGrid3.SetFocus T'TxC)
SendKeys "{down}" i%R2#F7I
`*1059
Exit Sub :8<\]}J
AddErr: ^9Je8 @Yu
MsgBox Err.Description Q hHexr6
End Sub bC mhlSNi
fDa$TbhjI
Private Sub cmdDelete3_Click() 8/|~E
On Error GoTo DeleteErr .C2.j[>
With Adodc3.Recordset oQvG3(.
.Delete H@8g 9;+
.MoveNext A-dL_3
If .EOF Then .MoveLast 8'kA",P
End With H#joc0?P
Exit Sub B?xu!B,
DeleteErr: F
;m1I+;
MsgBox Err.Description ZoiCdXvTN
End Sub Jc#()4
9g*MBe:
Private Sub cmdUpdate3_Click() %Jr6pmc
On Error GoTo UpdateErr R{"7q:-
= +uUWJ&1G
Adodc3.Recordset.UpdateBatch adAffectAll $*Q_3]AY]
Adodc3.Refresh ?+bDFM}
Exit Sub $K,6!FyBa
UpdateErr: 5_mb+A n,
MsgBox Err.Description ^5l4D3@E
End Sub 1Jx|0YmO
Private Sub Command5_Click() Q3vWwP;t~
Dim circleObj As AcadCircle Kb# }f/
Dim radius As Double %joIe w]V3
bh8IF,@a
FilPath = App.Path & "\JdCir.dwg" v$`AN4)}
InsertionPoint(0) = DrawNum1 Dl#%tYL+3h
InsertionPoint(1) = 0 rl,6ru
InsertionPoint(2) = 0 w C0fPPeA
Call InstBlock :_qgpE<
Z`l97$\
Adodc3.Refresh Hkv4t5F
Adodc3.Recordset.MoveFirst EPz$`#Sh"
For i = 1 To Adodc3.Recordset.RecordCount U*'
YGv
InsertionPoint(0) = DrawNum1 + 90 * Sin(Adodc3.Recordset("裂隙倾角").Value * Pi / 180) * Sin(Adodc3.Recordset("裂隙倾向").Value * Pi / 180) 7 vS]O$w<4
InsertionPoint(1) = 90 * Sin(Adodc3.Recordset("裂隙倾角").Value * Pi / 180) * Cos(Adodc3.Recordset("裂隙倾向").Value * Pi / 180) z
<"7vR
?=]*r>a3
' Define the circle h4GR:`
radius = 0.1 F<UEipe/N
2Q,8@2w;
' Create the Circle object in model space 3ppY@_1
Set circleObj = AcadDoc.ModelSpace.AddCircle(InsertionPoint, radius) mYudUn4Wo
ZoomAll |x AwiF_
k_=~ObA$g
Adodc3.Recordset.MoveNext cXJtNW@
Next i BlVk?n
"DFj4XKXY9
dwPath3 = "-裂隙极点散点图" ?6bk&"T?
MsgBox "裂隙极点散点图结束,可以进行其它工作!" tN5brf
DrawNum1 = DrawNum1 + 300 (zFUC]
End Sub Rp 2~d
V+()`>44
Private Sub DataGrid1_DblClick() ve#cz2Z
On Error Resume Next 1MV\
^l_
Adodc1.Refresh oJk$ +v6
KK = Adodc1.Recordset.RecordCount [Q/')5b
For K = 1 To KK M- 2:$;D
With Adodc1.Recordset U?6YY`A8
.Delete "$Wi SR
.MoveNext gJVakR&
End With <9S?wju4W'
Next K cs ?@Ri=g
DataGrid1.Refresh KJwkkCE/=
jG3}V3|.
End Sub &B^vHH
S"iQQV{)Z
Private Sub DataGrid2_DblClick() eqSCNYN
On Error Resume Next X`ifjZ9}d
Adodc2.Refresh G~{xTpL
KK = Adodc2.Recordset.RecordCount {)t6DH#
For K = 1 To KK X^#.4:>.
With Adodc2.Recordset *6)u5
.Delete ;n*N9-|.
.MoveNext %^l77:O
End With O/IW.t
Next K m4@y58n=
DataGrid2.Refresh qO<'_7TN[
End Sub *XmOWV2Y_
|f^/((:D
Private Sub DataGrid3_DblClick() +|OkT
On Error Resume Next 27vLI~
Adodc3.Refresh !P, 9Sg&5)
KK = Adodc3.Recordset.RecordCount 3mIX9&/
For K = 1 To KK <:u)C;
With Adodc3.Recordset \kiCczW_
.Delete _[SP*"
]H
.MoveNext -o+_PL
$\
End With 2&W(@wT$
Next K 6/9h=-w&
DataGrid3.Refresh -ANp88a
Musz+<]
End Sub F*QD\sG:
Qr;es,f
Private Sub Form_Load() =GQ?P*x|$
FilPath = App.Path "Yn<]Pa_
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ yD`{9'L
-
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" 62}bs/%
Adodc1.RecordSource = "select * from 赤平投影" >?,arER
Adodc1.Refresh G6zFCgFJ^y
Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ ?wps_XU
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" gz[Ng> D+
Adodc2.RecordSource = "select * from 玫瑰花图" #;RP ?s
Adodc2.Refresh `he{"0U~S
Adodc3.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ C61KY7iyR
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" eB:obz
Adodc3.RecordSource = "select * from 极点裂隙" !}()mrIlP
Adodc3.Refresh O,_2djd
KL = Val(Text2.Text) '最大条数 'nNw
KK = Val(Text1.Text) '间隔度数 icF -`m
R = 100 ?S8cl7;+
DrawNum1 = 0 _c|>m4+X
On Error Resume Next Y962rZ
Set AcadApp = GetObject(, "AutoCAD.Application") *n0k2 p
If Err.Number Then /FiFtAbb
Err.Clear WT!8.M;Kv
Set AcadApp = CreateObject("AutoCAD.Application") q4$R?q:^
If Err Then ]t|KFk!)
MsgBox Err.Description rG"}CX`]:
Exit Sub oy'Q#!
End If aW3yl}`{
End If $}S5&
Set AcadDoc = AcadApp.ActiveDocument j=)%~@
autocad.Visible = True }TRr*]
P<%
PZ-|W
Dim linetypeColl As AcadLineTypes fV3!x,H
Dim entr As AcadLineType %HuQc^
Dim msg As String S\Qh#yFT
[&rW+/
' Return the linetype collection object of the active document #](k,% 2
Set linetypeColl = AcadDoc.Linetypes unmuY^+<
' List all available linetypes 4];Qpln
For Each entr In linetypeColl n>\BPiz
If entr.Name = "10411" Then msg = "ok" 2I:vie
Next YtNoYOB
b9(d@2MtK
LTName = "10411" AQ-P3`bCb
FilPath = App.Path & "\" & "acad.lin" Y#c11q Z
If msg <> "ok" Then AcadDoc.Linetypes.Load LTName, FilPath VG'oy
End Sub E~zLhJTUL'
/D_8uTS>d[
IPcAE!h6zN
Private Sub InstBlock() #UC4l]Ru A
o(~>a
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(InsertionPoint, FilPath, 1, 1, 1, 0) fp9ksxb@m
VaraTtributes = BlockObj.GetAttributes piO+K!C0n:
xZS
End Sub Ifu$p]~z$
:H<u@%
F'Fc)9qFa<
Private Sub SelectDat() ?T5^hQT
Adodc2.Refresh WjGv%^?
Adodc2.Recordset.AddNew _f,q8ZkSr
For i = 0 To 360 Step KK J%xp1/=2
pF.Ws,nQ5
Adodc3.RecordSource = "select * from 极点裂隙 where 裂隙倾向 >= " & i _ .9WUp>
& " and 裂隙倾向 < " & (i + KK) n(a7%Hx2
M~7?m/Wj
Adodc3.Refresh F5%-6@=
K = Adodc3.Recordset.RecordCount 3Fh<%<=
If K <> 0 Then 4i[3|hv'
If i < 90 Then :*1Gs,
Adodc2.Recordset("统计方向") = i + 90 +I2P{7
Else `4Z#/g
Adodc2.Recordset("统计方向") = i - 90 pM\)f
End If h^$>{0"
Adodc2.Recordset("统计条数") = K B4&@PX"'>,
Adodc2.Recordset.UpdateBatch (adAffectCurrent) dH!k{3bL
Adodc2.Recordset.AddNew IgC)YIhd
End If @6i^wC
K = 0 4(&00#Yxg2
Next i d
{moU\W
Adodc3.RecordSource = "select * from 极点裂隙" "8Pxf=
Adodc3.Refresh C4Q^WU+$j
`NV =2T
End Sub