|
Option Base 1
Public Const PI = 3.14159265358979
'csqj()为坐标转换参数求解的自定义函数
Function csqj(zhq As Range, zhh As Range) As Variant
Dim b(), bt(), l(), cs, bbtn, zhqi, zhhi, sc(4, 2)
Dim X1!, y1!, x2!, y2!, i%, j%, k%
sc(1, 1) = "△X(米)": sc(2, 1) = "△y(米)"
sc(3, 1) = "旋转角a(秒)": sc(4, 1) = "尺度m"
' 统计公共点的个数
i = 0
For Each zhqi In zhq
i = i + 1
Next zhqi
n = i
If n = 2 Then '当n=2时,只有一个已知公共点
i = 0
For Each zhqi In zhq
i = i + 1
If i = 1 Then
X1 = zhqi.Value
Else
y1 = zhqi.Value
End If
Next zhqi
i = 0
For Each zhhi In zhh
i = i + 1
If i = 1 Then
x2 = zhhi.Value
Else
y2 = zhhi.Value
End If
Next zhhi
sc(1, 2) = x2 - X1
sc(2, 2) = y2 - y1
sc(3, 2) = 0
sc(4, 2) = 1#
Else
ReDim b(n, 4): ReDim bt(4, n): ReDim l(n)
'组成B数组
i = 0
k = 1
For Each zhqi In zhq
i = i + 1
If (i + 2) Mod 2 <> 0 Then
b(k, i + 2) = zhqi.Value
b(k + 1, 4) = zhqi.Value
Else
b(k, i + 2) = -zhqi.Value
b(k + 1, 3) = zhqi.Value
End If
If i Mod 2 = 0 Then
k = k + 2
i = 0
End If
Next zhqi
For i = 1 To n
For j = 1 To 4
If j = 1 And i Mod 2 <> 0 Then
b(i, j) = 1
ElseIf j = 1 And i Mod 2 = 0 Then
b(i, j) = 0
ElseIf j = 2 And i Mod 2 <> 0 Then
b(i, j) = 0
ElseIf j = 2 And i Mod 2 = 0 Then
b(i, j) = 1
End If
Next j
Next i
'组成B数组
i = 0
For Each zhhi In zhh
i = i + 1
l(i) = zhhi.Value
Next zhhi
bt = Application.WorksheetFunction.Transpose(b)
bbtn = Application.WorksheetFunction.MInverse(Application.WorksheetFunction.MMult(bt, b))
cs = Application.WorksheetFunction.MMult(Application.WorksheetFunction.MMult(bbtn, bt), Application.WorksheetFunction.Transpose(1))
For i = 1 To 4
sc(i, 2) = cs(i, 1)
Next i
sc(3, 2) = Application.WorksheetFunction.Atan2(sc(3, 2), sc(4, 2))
If sc(3, 2) < 0 Then
sc(3, 2) = sc(3, 2) + 2 * PI
End If
sc(4, 2) = sc(4, 2) / Sin(sc(3, 2))
sc(3, 2) = sc(3, 2) * 180 / PI * 3600
End If
csqj = sc
End Function
'zbzh( )为坐标转换自定义函数
Function zbzh(yzb As Range, scs As Range) As Variant ’这个位置会出错。。结果也没有
Dim b(2, 4), cs(4), bbtn, yzbi, scsi
Dim a#, i%, k%
'组成B数组
i = 0
k = 1
For Each yzbi In yzb
i = i + 1
If (i + 2) Mod 2 <> 0 Then
b(k, i + 2) = yzbi.Value
b(k + 1, 4) = yzbi.Value
Else
b(k, i + 2) = yzbi.Value
b(k + 1, 3) = yzbi.Value
End If
Next yzbi
b(1, 1) = 1: b(1, 2) = 0
b(2, 1) = 0: b(2, 2) = 1
i = 0
For Each scsi In scs
i = i + 1
cs(i) = scsi.Value
Next scsi
a = cs(3) / 3600 / 180 * PI
cs(3) = cs(4) * Cos(a)
cs(4) = cs(4) * Sin(a)
zbzh = Application.WorksheetFunction.MMult(b.Application.WorksheetFunction.Transpose(cs))
zbzh = Application.WorksheetFunction.Transpose(zbzh)
End Function
|
|