VB6 源代码,喜欢的朋友一起探讨。全部代码为本人自编,本人借楼主帖发放。 ~"B[6^sW
Public BhachNumber As String s*WfRY*=V
Dim fso As New FileSystemObject, fldr As Folder hfc!M2/w
N4NH)x
by[(9+/z$
Option Explicit 6Ky"4\e
Dim AcadDoc As AcadDocument @_nhA/rlc
Dim FilPath As String '设置系统路迳 ?wY.B
Dim AcadApp As Object 'AcadApplication e-meUf9
Dim AcadColr As Integer 'CAD线色 gJv^v`X
Dim ReturnPnt As Variant ];]EK6dzG
Dim LayerObj As AcadLayer 'CAD图层 Q1B!W
Dim LayerStr As String (3*Hl
Dim PolObj As AcadLWPolyline |0 %UM}
Dim TextObj As AcadText &y?B&4|hM
Dim VaraTtributes As Variant Jxp'.oo[
Dim KK As Integer '定义玫瑰花图分度间隔 8TvPCZ$x
Dim KL As Integer '定义玫瑰花图最大半径条数 ~q>ilnL"h
Dim StartPnt(0 To 2) As Double ~PAn
_]Z
Dim EndPnt(0 To 2) As Double 73`UTXvWU
Dim II As Integer $KFWV2P
Dim K As Integer n-.k&B{a
Dim TextString As String _kLoDju%
Dim InsertionPoint(0 To 2) As Double ]TOY_K8"z#
Dim HeightString As Double C#0Wo
Dim BlockObj As AcadBlockReference VX%\_@
Dim DrawNum1 As Double eci\Q,
Dim LTName As String l.)!jWY
Dim i As Integer &Wk<F3qN
Dim X0 As Single, Y0 As Single, X2 As Single, Y2 As Single AVZ@?aJgF
Dim R1 As Single, R2 As Single, Ang1 As Single, Ang2 As Single E6)mBAE
Dim Dat(4, 200) #XPU$=
Dim CirclObj As Object 9R3=h5Y
Const Pi = 3.1415926 #| Po&yu4R
Dim R As Double [uHI
6Q#
Dim dwPath As String +rX,Sl`/
Dim dwPath1 As String 5q>u
}J
Dim dwPath2 As String GTe9@d
Dim dwPath3 As String zvj >KF|y
Dim ArcObj As AcadArc bV,R*C
Dim ArcStrA As AcadArc [: j_Y3-9
Dim LineObj As AcadLine sva$@y7b
Dim LWPLObj As AcadLWPolyline 0:8'Ov(
Dim centerPoint(0 To 2) As Double S5!2%-;<k
Dim radius As Double FX 3[U+
Dim startAngleInDegree As Double )G gx
Dim endAngleInDegree As Double xI8*sTx
6
Dim startAngleInRadian As Double gJ7puN
Dim endAngleInRadian As Double |7fBiVo
L+CSF ]
Private Sub Command1_Click() XITQB|C??$
StartPnt(0) = DrawNum1 Br??Gdd
StartPnt(1) = 0 *?'T8yf^
StartPnt(2) = 0 SQk!o{
R = 100 y}`%I&]n
FilPath = App.Path & "\CPTY.dwg" !*-cf$
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(StartPnt, FilPath, 1, 1, 1, 0) +w5?{J
Call DrawArc ?g.w%Mf*
dwPath1 = "-赤平投影图" 2>s;xZ@/'R
MsgBox "赤平投影结束,可以进行其它工作!" giq`L1<
DrawNum1 = DrawNum1 + 300 s1q d/
End Sub 2kve?/
S22 ;g
Private Sub Command2_Click() K.7gd1I
StartPnt(0) = DrawNum1: StartPnt(1) = 0: StartPnt(2) = 0 uI wyan-
FilPath = App.Path & "\Rose.dwg" `9gx-')]\
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(StartPnt, FilPath, 1, 1, 1, 0) lEs/_f3;A
BlockObj.Update jm"xf7
Call DrwRose 95&HsgdxJ
dwPath2 = "-玫瑰花图" pn|{P<b\
MsgBox "玫瑰花图结束,可以进行其它工作!" ']D( ({%g
DrawNum1 = DrawNum1 + 300 7 #N
@B
End Sub 8hT>)WH}wo
c6|&?}F
Private Sub Command3_Click() 56dl;Z)
Call SelectDat Z%=E/xT
End Sub Z;:-8 HPDY
n]!H,Q1,T
Private Sub Command4_Click() S3fBZIPp
dwPath = App.Path & "\" & BeginFrm.BhachNumber & "\" _ aQ.
\!&U
& BeginFrm.BhachNumber & dwPath1 & dwPath2 & dwPath3 & ".dwg" /#5ZP\e
AcadDoc.SaveAs (dwPath) ^"- 2fJ
Unload BeginFrm p04w83 jX
Unload MaiDatFrm WGn1pW
Unload Me V5w^Le_^
End Sub jnY4(B
ZC-N4ESr
Private Sub DrawArc() 8uiQm;W
Dim DI As Integer F6/bq/s
Adodc1.Refresh w6 .HvH-@?
If Adodc1.Recordset.RecordCount = 0 Then Exit Sub 35T7g65;
Adodc1.Recordset.MoveFirst `rV,<
For DI = 1 To Adodc1.Recordset.RecordCount Step 1 7h~M&\M
Dat(1, DI) = Adodc1.Recordset("结构面倾角").Value * Pi / 180 | <$O5b'
Dat(2, DI) = Adodc1.Recordset("结构面倾向").Value * Pi / 180 VPbNLi
yhmW-#+^e
R1 = R * (1 - Dat(1, DI) / (Pi / 2)) jL$X3QS:
X2 = R1 * Sin(Dat(2, DI) - Pi) 'r
CR8>k
Y2 = R1 * Cos(Dat(2, DI) - Pi) &jcr7{cD
Ang2 = Pi - 2 * Atn(R / R1) h,g~J-x`|
R2 = R / Sin(Ang2) %Et]w
\266N;JrN
X0 = (R1 - R2) * Sin(Dat(2, DI) - Pi) -:q7"s-}b
Y0 = (R1 - R2) * Cos(Dat(2, DI) - Pi) #>'0C6Xn
{n'}S(
/-lmfpT
' Define the circle bE"CSK#
centerPoint(0) = StartPnt(0) + X0: centerPoint(1) = StartPnt(1) + Y0: centerPoint(2) = 0 uzD{ewR/.y
radius = R2 -9EbU7>!
startAngleInDegree = 270 - (Dat(2, DI) + Ang2) * 180 / Pi E{J;-+t
If startAngleInDegree >= 360 Then startAngleInDegree = startAngleInDegree - 360 m|[Hhw=f
If startAngleInDegree < 0 Then startAngleInDegree = startAngleInDegree + 360 F\;1:y~1
{HeMdGn9
endAngleInDegree = 270 - (Dat(2, DI) - Ang2) * 180 / Pi tWuQKN`_
If endAngleInDegree >= 360 Then endAngleInDegree = endAngleInDegree - 360 kOO2 ?L|Z
If endAngleInDegree < 0 Then endAngleInDegree = endAngleInDegree + 360 ?K"]XXsI
ly@CX((W
' Convert the angles in degrees to angles in radians P/5r(l5
startAngleInRadian = startAngleInDegree * Pi / 180 E*vi@aI
endAngleInRadian = endAngleInDegree * Pi / 180 E~ kmU{D
{`> x"Y5
' Create the arc object in model space ^;d;b<
Set ArcObj = AcadDoc.ModelSpace.AddArc(centerPoint, radius, startAngleInRadian, endAngleInRadian) _6(=0::x
If DI = 1 Then /_8V+@im
LTName = "10411" 5KzU&!Zh9
Set ArcStrA = ArcObj LTHS&3%2
ArcStrA.Linetype = LTName kE}?"<l
ArcStrA.Update S;~_9i]upe
End If N1rrKyL!$
ArcObj.Update F(r&:3!97
Adodc1.Recordset.MoveNext COafVlJ,l
Next DI V96BtVsB
\D=B-dREq
End Sub W0k_"uI
J/Li{xp)Lg
Private Sub DrwRose() 2~ a4ib
K = 0 +W`~bX+
Adodc2.Refresh ly2R8$Y`y`
Adodc2.Recordset.MoveFirst pppbn]%Ob
For i = 1 To Adodc2.Recordset.RecordCount
f63q
Dat(1, i) = Adodc2.Recordset("统计方向").Value )uP= o
If Dat(1, i) >= 90 And Dat(1, i) < 180 Then Dat(1, i) = Dat(1, i) + 180 KtE`L4tW6
If Dat(1, i) >= 180 And Dat(1, i) < 270 Then Dat(1, i) = Dat(1, i) - 180 W2^R$"U
Dat(2, i) = Adodc2.Recordset("统计条数").Value /~:ztv\$M"
Adodc2.Recordset.MoveNext "cx" d:
Next i <U*d
For i = 270 To 450 Step KK m" GrpE3
K = 0: EndPnt(0) = DrawNum1: EndPnt(1) = 0 '调整玫瑰花图位置 8z&9
For II = 1 To Adodc2.Recordset.RecordCount :&MiO3#+
If i < 360 Then hSmM OS{
If ((Dat(1, II) >= i) And (Dat(1, II) < (i + KK))) Then K = K + Dat(2, II) )U`
c9*.
Else gqG"t@Y+
If ((Dat(1, II) >= (i - 360)) And (Dat(1, II) < (i + KK - 360))) Then K = K + Dat(2, II) |u[gI+TUE
End If 2+HiaYDZ
Next II -}s?!Pg>
EndPnt(0) = (K * Sin(((i)) * Pi / 180)) * 100 / KL + DrawNum1 #]2u!ama
EndPnt(1) = (K * Cos(((i)) * Pi / 180)) * 100 / KL r%4:,{HF
Set LineObj = AcadDoc.ModelSpace.AddLine(StartPnt, EndPnt) .:}\Z27-c
LineObj.Update "P~>AXcq
sr4K-|@
StartPnt(0) = EndPnt(0): StartPnt(1) = EndPnt(1) CAO$Zt
Next i ORNE>6J
H
'制作标尺 % |V:F. f
HeightString = 5 y- YYDEl
TextString = Str(KL) (TPD!=
InsertionPoint(0) = DrawNum1 - 105: InsertionPoint(1) = 7 sQw-#f7t
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) Bb)J8,LQ
InsertionPoint(0) = DrawNum1 + 90: InsertionPoint(1) = 7 _+i-)
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) n)yqb
TextString = Str(Int(KL / 2 + 0.5)) l_WY];a
InsertionPoint(0) = DrawNum1 + 45: InsertionPoint(1) = 7 )XFMlSx)
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) jBM>Pe^`3
InsertionPoint(0) = DrawNum1 - 55: InsertionPoint(1) = 7 Qi M>59[
Set TextObj = AcadDoc.ModelSpace.AddText(TextString, InsertionPoint, HeightString) $8)/4P?OL
End Sub 81&!!qhfS
Private Sub cmdAdd1_Click() :>=,sLfJ
On Error GoTo AddErr i2DR}%U
Adodc1.Recordset.MoveLast NNX/2
DataGrid1.SetFocus _19k@a
SendKeys "{down}" _>.%X45xi
A}8U;<\Ig
Exit Sub 4|qp&%9-
AddErr: IftPN6(Z
MsgBox Err.Description p%BO:%v
End Sub &oBJY'1
k95vgn%
Private Sub cmdDelete1_Click() r\zK>GVm_
On Error GoTo DeleteErr SWt"QqBU
With Adodc1.Recordset P+xZaf
H
.Delete iBCM?RiG
.MoveNext &
CgLF]
If .EOF Then .MoveLast O7W}Z1G
End With O1A*-G:X
Exit Sub RN0Rk 8AC
DeleteErr: i~4Kek6,I
MsgBox Err.Description Vufw:}i+^
End Sub 2B#\683
_B2t|uQ
Private Sub cmdUpdate1_Click() %o-*~GQ@B
On Error GoTo UpdateErr Wo&i)S<i0F
D c^d$gh
Adodc1.Recordset.UpdateBatch adAffectAll %zGPF
Adodc1.Refresh h!.(7qdd
Exit Sub Rp#SqRy`
UpdateErr: {|cA[#j#
MsgBox Err.Description Dqki}k~{
End Sub Tn|reXc0e
Private Sub cmdAdd2_Click() p\ASf
On Error GoTo AddErr v|e>zm<
Adodc2.Recordset.MoveLast -Ac^#/[0
DataGrid2.SetFocus !**q20-aP
SendKeys "{down}" U
w)1yzX
tB[K4GNSQ
Exit Sub ^VQiq7 xm
AddErr: R)v`ZF,/b
MsgBox Err.Description U1Oq"Ij~
End Sub 8cHZBM7'
|kn}iA@72p
Private Sub cmdDelete2_Click() ()iJvf>@
On Error GoTo DeleteErr v'uQ'CiH
With Adodc2.Recordset I('l)^m%
.Delete IKt9=Tx
.MoveNext < mxUgU
If .EOF Then .MoveLast D~<GVp5T
End With Ur@3_F
Exit Sub =vWnqF:
DeleteErr: Aq-v3$XL
MsgBox Err.Description
=~)n,5
End Sub DE[y&]/C{
;Zw28!#Rt
Private Sub cmdUpdate2_Click() pP .
On Error GoTo UpdateErr u^uW<.#z
Tb[GZ,/%;
Adodc2.Recordset.UpdateBatch adAffectAll |R4](
Adodc2.Refresh U[ed#9l>
Exit Sub x/ez=yd*l
UpdateErr: l!1bmg #]$
MsgBox Err.Description /Wa+mp
End Sub UCQL~
V:lDR20*\
Private Sub cmdAdd3_Click() ,AJd2i x
On Error GoTo AddErr >v(Xc/oI
Adodc3.Recordset.MoveLast "H({kmR
DataGrid3.SetFocus ^0 t`EZ$
SendKeys "{down}" x-"7{@lz
5v]xk?Eb
Exit Sub N4Ym[l
AddErr: 6-o Qs?
MsgBox Err.Description nv={.H
End Sub C]k\GlhB
975KRnj
Private Sub cmdDelete3_Click() XH/|jE.9^|
On Error GoTo DeleteErr V1+IqOXAIp
With Adodc3.Recordset !vU[V,~
.Delete D^pAf/ek@i
.MoveNext =LC5o2bLy
If .EOF Then .MoveLast |:AjQ&PM)
End With g$+3IVq&
Exit Sub T@L^RaPX
DeleteErr: KP
i@wl3
MsgBox Err.Description =y<Fz*aA
End Sub ,PB?pp8C}
!j(R_wOq
Private Sub cmdUpdate3_Click()
@`T6\ 1
On Error GoTo UpdateErr _&T$0SZco
GxBj N7"
Adodc3.Recordset.UpdateBatch adAffectAll
,{%[/#~6
Adodc3.Refresh /a,q4tD@
Exit Sub `hbM2cM
UpdateErr: %V$^CWOy
MsgBox Err.Description N7[~Y2i
End Sub hX^XtIC=
Private Sub Command5_Click() &CS= *)>$
Dim circleObj As AcadCircle W uQdz&s>
Dim radius As Double %Z.!Bm:
*Q)+Y&qn
FilPath = App.Path & "\JdCir.dwg" EV}%D9:
InsertionPoint(0) = DrawNum1 )_BteLo-
InsertionPoint(1) = 0 Xd4~N:
InsertionPoint(2) = 0 ?VJ Fp^Ra
Call InstBlock N.fIg
)TLDNpH?J
Adodc3.Refresh =Ij;I~
Adodc3.Recordset.MoveFirst V/03m3!q
For i = 1 To Adodc3.Recordset.RecordCount Uc/%4Gx
InsertionPoint(0) = DrawNum1 + 90 * Sin(Adodc3.Recordset("裂隙倾角").Value * Pi / 180) * Sin(Adodc3.Recordset("裂隙倾向").Value * Pi / 180) Zy<0'k%U
InsertionPoint(1) = 90 * Sin(Adodc3.Recordset("裂隙倾角").Value * Pi / 180) * Cos(Adodc3.Recordset("裂隙倾向").Value * Pi / 180) d"V^^I)yx&
$h2h&6mH
' Define the circle </fzBaTo
radius = 0.1 !({[^[!
V3UEuA
' Create the Circle object in model space
z\\MLyS
Set circleObj = AcadDoc.ModelSpace.AddCircle(InsertionPoint, radius) n4ISHxM
ZoomAll b_B4
@+xQj.jNC
Adodc3.Recordset.MoveNext g3y44GCV
Next i H;v*/~zl
KMZ% 1=a
dwPath3 = "-裂隙极点散点图" ]UNmhF!W>u
MsgBox "裂隙极点散点图结束,可以进行其它工作!" S_)va#b#
DrawNum1 = DrawNum1 + 300 2Bx\nLf/
K
End Sub g,.iM8
Q<M>+U;t
Private Sub DataGrid1_DblClick() wBr0s*1I
On Error Resume Next Dd*C?6
Adodc1.Refresh P\Ka'i
KK = Adodc1.Recordset.RecordCount x[_+U4-/
For K = 1 To KK Mqna0"IYx*
With Adodc1.Recordset ;2U`?"
.Delete 'rSM6j
.MoveNext 2JbCYCTC
End With J[^-k!9M
Next K ej0q*TH.
DataGrid1.Refresh vnKUD|
(LnKaf8
End Sub (h
E^<jNR
\X(.%5xC
Private Sub DataGrid2_DblClick() v"^G9u
On Error Resume Next $ (GXlhA
Adodc2.Refresh #e=[W))
KK = Adodc2.Recordset.RecordCount U+\\#5$
For K = 1 To KK {3l]/X3
With Adodc2.Recordset uG/Zpi
.Delete ?&[`=ZVn
.MoveNext KjhOz%Yt[o
End With rTx]%{
Next K 5nk]{ G> V
DataGrid2.Refresh >OQ<wO6
End Sub H#f
FU
7{p,<Uz<"U
Private Sub DataGrid3_DblClick() I!{5*~ 3
On Error Resume Next ec{pWzAe
Adodc3.Refresh f\Qi()
KK = Adodc3.Recordset.RecordCount G-Y8<mEh
For K = 1 To KK 4kIy4x'*
With Adodc3.Recordset Baq&>]
.Delete
OH&&d=~
.MoveNext rx%lL
End With CrK}mbe
Next K +] FdgmK:
DataGrid3.Refresh s8R.?mhH=
N^O.P
End Sub J"|o g|Tz
_- { > e
Private Sub Form_Load() m~2PpO
FilPath = App.Path NZv1dy`fa
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ rK"x92P0
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" QqRL>.)W
Adodc1.RecordSource = "select * from 赤平投影" .(! $j-B
Adodc1.Refresh W &*0F~
Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ Ygg+*z
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" 1Ztoj}!I
Adodc2.RecordSource = "select * from 玫瑰花图" ?(E$|A
Adodc2.Refresh .8k9yk
Adodc3.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _ Mq-;sPsFP
& FilPath & "\岩土工程数据.mdb; Persist Security Info=False" O5E \#*<K
Adodc3.RecordSource = "select * from 极点裂隙" -c Mqq$
Adodc3.Refresh {`{U\w5Af
KL = Val(Text2.Text) '最大条数 f-
_~rQ
KK = Val(Text1.Text) '间隔度数 R+P1 +5
R = 100 1;>J9
DrawNum1 = 0 y3d`$'7H>
On Error Resume Next sVGyHA
Set AcadApp = GetObject(, "AutoCAD.Application") C}7Sh6
If Err.Number Then xw`Pq6
Err.Clear 9Y0w
SOSW
Set AcadApp = CreateObject("AutoCAD.Application") O
Qd,.m
If Err Then }e1f kjWk
MsgBox Err.Description 6z~6o0s~
Exit Sub h]I ^%7
End If L9@nx7D
End If Z[ys>\_To
Set AcadDoc = AcadApp.ActiveDocument yAaMYF@
autocad.Visible = True X'O3)Yg
U1I2+;"#A
Dim linetypeColl As AcadLineTypes aCQAh[T
Dim entr As AcadLineType mzDbw-#
Dim msg As String "I
u3&mc
SDZ/rC!C
' Return the linetype collection object of the active document V4_ZBeWA
Set linetypeColl = AcadDoc.Linetypes j2V^1
' List all available linetypes E-CZk_K9
For Each entr In linetypeColl WxFVbtw
If entr.Name = "10411" Then msg = "ok" f`T#=6C4|
Next HG{OkDx]fl
+dlN^P647
LTName = "10411" li(g?|AD
FilPath = App.Path & "\" & "acad.lin" |'.\}xt7
If msg <> "ok" Then AcadDoc.Linetypes.Load LTName, FilPath iOw'NxmY
End Sub xM[m(m
GP1b/n3F1
Zhf+u
r
Private Sub InstBlock() wD4Kil=v
4v Ug:'DM
Set BlockObj = AcadDoc.ModelSpace.InsertBlock(InsertionPoint, FilPath, 1, 1, 1, 0) kid@*.I
VaraTtributes = BlockObj.GetAttributes "HlT-0F
3b~k)t4R
End Sub 1a`dB
~>
X"*pt5B6`
rxt)l
Private Sub SelectDat() $)6y:t"
Adodc2.Refresh :GK]"sNC
Adodc2.Recordset.AddNew I t",WFE.
For i = 0 To 360 Step KK G{)2f&<
af.yC[
Adodc3.RecordSource = "select * from 极点裂隙 where 裂隙倾向 >= " & i _ l1nrJm8
& " and 裂隙倾向 < " & (i + KK) (V#5Cs,o:
bIR7g(PJ.b
Adodc3.Refresh
ym^
K = Adodc3.Recordset.RecordCount Rkgpa/te"
If K <> 0 Then 4/cUd=>Z
If i < 90 Then FK<1SOE
Adodc2.Recordset("统计方向") = i + 90 dxsPX=\:
Else %A%^;3@
Adodc2.Recordset("统计方向") = i - 90 |%Pd*yZA
End If T-0fVTeN
Adodc2.Recordset("统计条数") = K Ubv<3syR'
Adodc2.Recordset.UpdateBatch (adAffectCurrent) ~~z}yCl
Adodc2.Recordset.AddNew |pA3ZWm
End If IvO#tI
K = 0 z]K:Amp;Z
Next i kyMWO*>|
Adodc3.RecordSource = "select * from 极点裂隙" X$)<>e]!>
Adodc3.Refresh \s<L2uRj
bDK72cQ
End Sub