导线计算(自动装载数据vb程序)【范本模板】

目的：进行导线计算
界面
装载数据
源码
Const PI As Double = 3。

14159265
Private Sub fwjjs（xa As Double，xb As Double, ya As Double，yb As Double, t）dx = xb - xa
dy = yb — ya
If dx = 0 Then t = Sgn（dy) ＊90 Else t = Atn（dy / dx) ＊180 / PI
If dx 〈0 Then t = t + 180
If t < 0 Then t = t + 360
End Sub
Private Function deg(a As Double)
sign = Sgn(a)
a = Abs（a) + 0。

0000000001
b = Int(a）
c = Int(（a - b）＊100）
d = a — b - c / 100
deg = sign * （b + c / 60 + d / 0.36)
End Function
Private Sub cmdjs_Click（）
xa = Val（txtxa。

Text): xb = Val（txtxb。

Text): ya = Val（txtya.Text）: yb = Val（txtyb.Text) xc = Val（txtxc.Text)：xd = Val（txtxd.Text）: yc = Val(txtyc。

Text): yd = Val(txtyd.Text) Call fwjjs(xa，xb，ya, yb, tq）
txtfwj1。

Text = Format（dms1（tq），"0.0000")
Call fwjjs（xc, xd, yc, yd，tz)
txtfwj2。

Text = Format（dms1(tz), ”0。

0000”）
a = txtb.Text
a = Replace（a，” ”, ”")
a = Replace(a，vbCrLf，" ")
c = Split(a，" ”)
num = UBound（c)
Dim t() As Double, b(）As Double，s（）As Double
ReDim t（0 To UBound（c）+ 1), b(0 To UBound（c）），s（0 To UBound（c) - 1）
For i = 0 To UBound（c) Step 1
b(i) = Val(c（i)）
Next i
d = txts。

Text
d = Replace（d, " ”, "”)
d = Replace(d, vbCrLf，" ”）
E = Split（d, " ”)
t(0) = tq
For i = 1 To UBound（c) + 1
t(i) = t(i — 1）— 180 + deg(b(i — 1)）
If t(i）> 360 Then t（i) = t(i）— 360
If t(i）〈0 Then t（i) = t(i) + 360
Next i
fb = t(num + 1）- tz
For i = 1 To num + 1
t(i）= t（i）— fb / (num + 1) ＊i
Next i
Dim dx() As Double，dy（) As Double
ReDim x(0 To num + 2)，y（0 To num + 2）, dx(1 To num）, dy（1 To num)
For i = 1 To num
dx（i) = Cos(t（i) ＊PI / 180) * Val(E（i — 1）)
dy(i) = Sin(t（i）＊PI / 180) * Val(E（i — 1))
Next i
x（0）= xa：y（0) = ya：y(1）= yb：x（1) = xb:
x(num + 1) = xc: y(num + 1）= yc：x（num + 2）= xd: y(num + 2）= yd
hs = 0
For i = 2 To num + 1
hs = hs + Val（E(i - 2))
x(i）= Cos（t（i — 1）＊PI / 180) * Val（E（i — 2）) + x（i — 1）
y(i) = Sin(t(i - 1) * PI / 180) ＊Val(E（i — 2）) + y(i - 1)
Next i
fx = x（num + 1）- xc：fy = y(num + 1) - yc
fs = Sqr（fx ^ 2 + fy ^ 2)
Debug。

Print fx, fy，fs
k = 1 / （hs / fs）
Rem CmD。

DialogTitle = ”保存文件”
Rem CmD。

Filter = "txt文件｜*.txt|all files（＊。

＊)｜*.*”
Rem CmD.FilterIndex = 2
Rem CmD.Flags = 1
Rem CmD。

Action = 2
Rem CmD。

ShowSave
Rem Open CmD.FileName For Output As #2
Rem Print ＃2, ”点号X点坐标Y点坐标"
For i = 2 To num + 1
x（i) = Cos（t（i — 1）* PI / 180) ＊Val（E(i — 2））+ x（i - 1）- fx ＊Val(E（i — 2)) / hs y(i) = Sin(t（i — 1）＊PI / 180) ＊Val（E(i — 2)）+ y(i - 1）- fy * Val(E(i - 2)) / hs
Rem Debug。

Print x（i), y(i)
Rem Print #2, i; x(i）; y(i）
Next i
Rem Close ＃2
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Set xlapp = CreateObject（"excel.application”）
Set xlbook = xlapp.workbooks。

Add
Set xlsheet = xlbook。

worksheets(1)
xlsheet。

Name = "单导线计算成果表”
xlsheet。

cells(1, 1).Value = ”单导线计算”
xlsheet。

cells(2，1）.Value = "点号"
xlsheet.cells(2, 2)。

Value = ”观测角"
xlsheet。

cells(2, 3).Value = "方位角"
xlsheet.cells（2, 4）.Value = "边长”
xlsheet.cells(2，5）。

Value = "dx”
xlsheet.cells(2，6).Value = ”Vx(mm）"
xlsheet.cells(2，7）。

Value = "dy”
xlsheet.cells（2，8）。

Value = ”Vy(mm）”
xlsheet.cells(2，9)。

Value = ”X点坐标”
xlsheet。

cells（2，10)。

Value = ”Y点坐标"
xlsheet.cells(3，1）.Value = ”A”
xlsheet。

cells（3，2).Value = ””
xlsheet.cells(3，3）.Value = ””
xlsheet。

cells（3, 4）.Value = "”
xlsheet.cells(3, 5）。

Value = ””
xlsheet。

cells（3, 6）.Value = ””
xlsheet.cells（3, 7）。

Value = ””
xl sheet.cells(3, 8).Value = ”"
xlsheet。

cells（3, 9）。

Value = xa
xlsheet。

cells（3，10).Value = ya
xlsheet。

cells(4，1）。

Value = ”B”
xlsheet.cells(4，2)。

Value = b(0）
xlsheet。

cells(4, 3）.Value = dms1(tq)
xlsheet.cells(4，4).Value = E(0）
xlsheet.cells（4, 5)。

Value = dx（1)
xlsheet.cells（4，6)。

Value = -1000 ＊fx ＊Val(E（0)）/ hs xlsheet。

cells(4，7）。

Value = dy(1)
xlsheet。

cells（4, 8).Value = —1000 ＊fy * Val(E（0)）/ hs xlsheet.cells（4，9).Value = xb
xlsheet。

cells（4，10).Value = yb
For i = 1 To num — 1
xlsheet.cells（i + 4，1）.Value = i
xlsheet。

cells(i + 4，2).Value = b（i）
xlsheet。

cells（i + 4，3）.Value = dms1（t(i)）
xlsheet.cells（i + 4，4)。

Value = E（i）
xlsheet。

cells（i + 4, 5）。

Value = dx（i + 1）
xlsheet。

cells(i + 4，6）。

Value = —1000 ＊fx * Val（E(i）) / hs xlsheet。

cells(i + 4，7）。

Value = dy(i + 1)
xlsheet。

cells（i + 4，8）。

Value = -1000 ＊fy * Val（E(i）) / hs xlsheet.cells(i + 4，9）.Value = x（i + 1)
xlsheet.cells（i + 4，10）.Value = y(i + 1）
Next i
If Option2。

Value = True Then xlsheet。

cells（num + 4，1）.Value = "B”If Option1.Value = True Then xlsheet.cells(num + 4，1)。

Value = ”C”xlsheet。

cells（num + 4, 2).Value = b(num)
xlsheet.cells（num + 4, 3）。

Value = dms1（t（num)）
xlsheet。

cells(num + 4，4）。

Value = ”"
xlsheet。

cells（num + 4，5).Value = ""
xlsheet.cells(num + 4, 6）.Value = ”"
xlsheet。

cells（num + 4，7）。

Value = ””
xlsheet。

cells（num + 4, 8）.Value = ""
xlsheet。

cells(num + 4，9)。

Value = xc
xlsheet.cells（num + 4，10).Value = yc
If Option2.Value = True Then xlsheet。

cells(num + 5，1).Value = ”A”If Option1。

Value = True Then xlsheet.cells（num + 5, 1）.Value = ”D" xlsheet.cells(num + 5, 2）.Value = ””
xlsheet。

cells（num + 5, 3）.Value = dms1（t（num + 1）) xlsheet。

cells（num + 5，4）。

Value = "”
xlsheet.cells（num + 5，5).Value = ”"
xlsheet。

cells(num + 5，6）.Value = ""
xlsheet。

cells（num + 5, 7)。

Value = ””
xlsheet。

cells（num + 5, 8）。

Value = ”"
xlsheet。

cells（num + 5，9）.Value = xd
xlsheet。

cells(num + 5, 10).Value = yd
xlsheet。

cells(num + 6, 2）。

Value = ”闭合差”
xlsheet。

cells（num + 6, 3)。

Value = ”fx”
xlsheet.cells(num + 6，4).Value = ”fy"
xlsheet.cells（num + 6, 5)。

Valu e = "fs”
xlsheet。

cells(num + 6，9）。

Value = ”相对闭合差”
xlsheet。

cells（num + 6, 10）.Value = ”日期”
xlsheet。

cells(num + 7, 2).Value = dms1(fb）
xlsheet.cells（num + 7, 3).Value = Format(fx，”0.000")
xlsheet.cells(num + 7, 4）.Value = Format(fy，”0。

000") xlsheet。

cells（num + 7, 5).Value = Format（fs, ”0。

0000"）xlsheet。

cells（num + 7，9).Value = k
xlsheet.cells(num + 7, 10）。

Value = Date
xlapp。

Visible = ture
xlapp.quit
Set xlsheet = Nothing
End Sub
Public Function dms1（du As Double）
sign = Sgn（du)
du = Abs（du）+ 0。

000000001
d = Int（du)
f1 = （du - d) * 60
f = Int（f1)
m = （f1 — f）＊60
dms1 = sign ＊（d + f / 100 + m / 10000)
End Function
Private Sub Command1_Click(）
CmD。

DialogTitle = ”打开文件”
CmD。

Filter = ”txt文件｜*。

txt|all files（*。

*)｜＊.*”CmD.FilterIndex = 2
CmD。

Flags = 1
CmD。

ShowOpen
Dim ds As Single
num = ds + 1
ReDim b（0 To num）, s(0 To num — 1) Open CmD.FileName For Input As #1 Input #1, ds
If Option1。

Value = True Then
Input ＃1, xa，ya
Input ＃1，xb，yb
Input #1, xc，yc
Input ＃1, xd, yd
txtxa.Text = xa
txtxb.Text = xb
txtya.Text = ya
txtyb。

Text = yb
txtxc。

Text = xc
txtxd。

Text = xd
txtyc。

Text = yc
txtyd。

Text = yd
End If
If Option2.Value = True Then
Input ＃1，xa，ya
Input ＃1, xb, yb
txtxa.Text = xa
txtxb.Text = xb
txtya.Text = ya
txtyb.Text = yb
txtxc。

Text = xb
txtxd。

Text = xa
txtyc。

Text = yb
txtyd。

Text = ya
End If
Line Input #1，m＄
m = Replace（m, ” ”, ””）
m = Replace（m, ”,”, vbCrLf）
txtb.Text = m
Line Input ＃1, n$
n = Replace(n, " ”，”"）
n = Replace(n, ”,”，vbCrLf）
txts。

Text = n
Close #1
End Sub
Private Sub Command2_Click（)
Form3。

Show
End Sub
Private Sub Option1_Click（）
Label1(4）。

Caption = ”c点x坐标”Label1(5).Caption = "c点y坐标" Label1(6)。

Caption = ”d点x坐标" Label1（7).Caption = "a点y坐标”End Sub
Private Sub Option2_Click()
Label1(4）。

Caption = ”b点x坐标" Label1（5）.Caption = "b点y坐标" Label1（6)。

Caption = "a点x坐标”Label1(7)。

Caption = "a点y坐标”End Sub
生成excel
绘图
Private Sub Form_Load（)
xmIN = xa: ymin = ya
xmax = xa: ymAX = ya
Debug。

Print xmIN, xmax，ymin，ymAX
For i = 1 To UBound（x)
If xmIN > x（i）Then xmIN = x(i）
If xmax < x(i) Then xmax = x(i)
If ymin > y(i）Then ymin = y（i)
If ymAX < y（i）Then ymAX = y(i)
Next i
Pic1。

Scale (ymin - 50，-xmax - 50）-（ymAX + 50, —（xmIN — 50)）
’以下四行画Y轴
Pic1.Line (ymin — 20，-(xmIN — 30))—(ymAX + 30, -(xmIN - 30）)，RGB（0, 0，255）
Pic1.Line （ymAX + 15，—(xmIN - 10）)-（ymAX + 30，-（xmIN - 30）), RGB（0，0，255）Pic1.Line （ymAX + 15, —(xmIN — 50））—(ymAX + 30, -（xmIN — 30）)，RGB（0，0，255）Pic1。

Print ”Y"
’以下四行画X轴
Pic1。

Line (ymin - 20，—(xmIN - 30))—（ymin — 20, -xmax — 30), RGB(0, 0，255)
Pic1。

Line （ymin — 40, -xmax + 10)-（ymin — 20，-xmax — 30), RGB(0, 0, 255）
Pic1.Line （ymin，—xmax + 10)—（ymin — 20, —xmax - 30), RGB（0，0, 255)
Pic1.PSet （ymin + 15，—xmax — 35)，RGB（255, 250，250）
Pic1.Print ”X”
For i = 0 To UBound(x）- 1
Pic1.Line （y（i），—x(i)）—(y(i + 1）, -x（i + 1）), RGB（250, 0，0）Next i
’以下画点号
For i = 0 To UBound（x)
Pic1。

PSet （y（i)，-x（i)）, RGB（250，0，0)
If i = 0 Then Pic1.Print "A"
If i = 1 Then Pic1。

Print "B”
If i = UBound（x）- 1 Then Pic1。

Print ”C"
If i = UBound（x) Then Pic1。

Print "D”
Pic1.Print i — 1
Next i
Rem If x(UBound(x) - 1) = x(1) And y(UBound(x) - 1) = y（1) Then Pic1.Print ”B" Rem If x(UBound(x)) = x（0) And y（UBound(x）) = y(0) Then Pic1。

Print "A”End Sub。