cehuisource.txt

测绘相关源码 包括：角度化弧度、弧度化角度、计算两点间的方位角、B_三次样条函数（曲线拟合）、贝赛尔曲线。

'角度化弧度
Public Function Radian(a As Double) As Double
  Dim Ra As Double
  Dim c As Double
  Dim FS As Double
  Dim Ib As Integer
  Dim Ic As Integer
  Ra = pi / 180#
  Ib = Int(a)
  c = (a - Ib) * 100#
  Ic = Int(c)
  FS = (c - Ic) * 100#
  Radian = (Ib + Ic / 60# + FS / 3600#) * Ra
End Function
'弧度化角度
Public Function Degree(a As Double) As Double
  Dim B As Double
  Dim Fs1 As Double
  Dim Im1 As Integer
  Dim Id1 As Integer
  B = a
  Call DMS(B, Id1, Im1, Fs1)
  Degree = Id1 + Im1 / 100# + Fs1 / 10000#
End Function

Public Sub DMS(a As Double, ID As Integer, IM As Integer, FS As Double)
  Dim B As Double
  Dim c As Double
  c = a
  c = 180# / pi * c
  ID = Int(c + 0.0000005)
  B = (c - ID) * 60 + 0.0005
  IM = Int(B)
  FS = (B - IM) * 60

End Sub

'计算两点间的方位角
Public Function azimuth(x1 As Double, y1 As Double, x2 As Double, y2 As Double) As Single
  Dim dx As Double
  Dim dy As Double
  Dim fwj As Double
  dx = x2 - x1
  dy = y2 - y1
  If dy <> 0 Then
    fwj = pi * (1 - Sgn(dy) / 2) - Atn(dx / dy)
    azimuth = Degree(fwj)
  Else
    If dx > 0 Then
      azimuth = 0
    Else
      azimuth = 180
    End If
  End If

End Function





B_三次样条函数（曲线拟合）VB6代码如下：
Option Explicit
Dim t() As Single

Dim k As Integer

Dim PtX(5) As Single
Dim pty(5) As Single
Dim MaxPt As Integer

Dim bClosed As Boolean

' 
Private Function Blend(i As Integer, k As Integer, U As Single) As Single
Dim numer As Single
Dim denom As Single
Dim V1 As Single
Dim V2 As Single
Dim newU As Single

If i > 0 And bClosed Then
  newU = U - i + MaxPt + 1
  Do While newU >= MaxPt + 1
    newU = newU - (MaxPt + 1)
  Loop
  Do While newU < 0
    newU = newU + (MaxPt + 1)
  Loop
  Blend = Blend(0, k, newU)
  Exit Function
End If

'Base case for the recursion
If k = 1 Then
  If t(i) <= U And U < t(i + 1) Then
    Blend = 1
  ElseIf U = MaxPt And t(i) <= U And U <= t(i + 1) Then
    Blend = 1
  Else
    Blend = 0
  End If
  Exit Function
End If

denom = t(i + k - 1) - t(i)
If denom = 0 Then
  V1 = 0
Else
  numer = (U - t(i)) * Blend(i, k - 1, U)
  V1 = numer / denom
End If

denom = t(i + k) - t(i + 1)
If denom = 0 Then
  V2 = 0
Else
  numer = (t(i + k) - U) * Blend(i + 1, k - 1, U)
  V2 = numer / denom
End If

Blend = V1 + V2

End Function

Private Function X(U As Single) As Single
Dim i As Integer
Dim v As Single

 
  For i = 0 To MaxPt
    v = v + PtX(i) * Blend(i, k, U) '/ 2 'zoom x
  Next i
  X = v
End Function

Private Function Y(U As Single) As Single
Dim i As Integer
Dim v As Single

  For i = 0 To MaxPt
    v = v + pty(i) * Blend(i, k, U) ' / 2 'zoom y
  Next i
  Y = v
End Function

Private Sub Fill_T()
Dim i As Integer
ReDim t(MaxPt + k + 1)

If bClosed Then
  For i = 0 To UBound(t)
    t(i) = i
  Next i
Else
  For i = 0 To UBound(t)
    If i < k Then
       t(i) = 0
    ElseIf i <= MaxPt Then
       t(i) = i - k + 1
    Else
       t(i) = MaxPt - k + 2
    End If
  Next i
End If
End Sub

Private Sub DrawCurve()


On Error Resume Next
Dim i As Integer, r As Integer
Dim U As Single

'Me.Scale (0, 0)-(640, 480)
Me.Cls
Me.ForeColor = vbBlack
Me.DrawStyle = vbDot
Me.PSet (PtX(0), pty(0))
For i = 0 To MaxPt
  Me.Line -(PtX(i), pty(i))
Next i
Me.ForeColor = vbRed
Me.DrawStyle = vbSolid

Call Fill_T

If bClosed Then
  r = MaxPt + 1
Else
  r = MaxPt - k + 2
End If

Me.PSet (X(0), Y(0))

For i = 1 To r * 20 - 1
  U = i / 20
  Me.Line -(X(U), Y(U))
Next i

If bClosed Then Me.Line -(X(0), Y(0))

End Sub

Private Sub chkClosed_Click()
bClosed = -1 * chkClosed.Value
DrawCurve
End Sub

Private Sub cmbK_Click()
k = Val(cmbK.Text)
DrawCurve
End Sub

Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
Source.Move X, Y
PtX(Source.indeX) = X: pty(Source.indeX) = Y
DrawCurve
End Sub

Private Sub Form_Load()

MaxPt = UBound(PtX)
k = 3
PtX(0) = 50: pty(0) = 300
PtX(1) = 150: pty(1) = 250
PtX(2) = 240: pty(2) = 310
PtX(3) = 350: pty(3) = 300

PtX(4) = 370: pty(4) = 400
PtX(5) = 550: pty(5) = 330

cmbK.ListIndex = 0

End Sub

Private Sub Form_Resize()
Dim i As Integer
  On Error GoTo endd
Me.Scale (0, 0)-(800, 600)
For i = 0 To MaxPt
  pControl(i).Move PtX(i), pty(i)
Next i
DrawCurve
endd:
End Sub






VB6 贝赛尔曲线!


Dim x(10) As Single, y(10) As Single
Dim Num As Integer

Private Sub Command1_Click()
 Picture1.Scale (0, 0)-(640, 480)
 x(0) = 80: y(0) = 280
 x(1) = 350: y(1) = 200
 x(2) = 180: y(2) = 140
 x(3) = 200: y(3) = 200
 For i = 0 To 2
  Picture1.Line (x(i), y(i))-(x(i + 1), y(i + 1)), QBColor(13)
 Next i
 Num = 3
 Bezier Num
End Sub

Private Sub Command2_Click()
 End
End Sub
Sub Bezier(ByVal Num As Integer)
 Dim c(10) As Single, b(10) As Single, p(10) As Single, q(10) As Single
 Dim t As Single, xe As Single, ye As Single
 Dim i As Integer, j As Integer, k As Integer
 Picture1.PSet (x(0), y(0))
 For i = 0 To Num
  c(i) = 1
 Next i
 For i = 2 To Num
  For j = 1 To i - 1
   b(j) = c(j - 1) + c(j)
  Next j
  For j = 1 To i - 1
   c(j) = b(j)
  Next j
 Next i
 For i = 0 To Num * 4
  t = i / (Num * 4)
  p(0) = 1: q(0) = 1
  For j = 1 To Num
   p(j) = p(j - 1) * t
   q(j) = q(j - 1) * (1 - t)
  Next j
  For j = 0 To Num
   b(j) = p(j) * q(Num - j)
  Next j
  xe = 0: ye = 0
  For j = 0 To Num
   xe = xe + c(j) * b(j) * x(j)
   ye = ye + c(j) * b(j) * y(j)
  Next j
Picture1.DrawWidth = 1
  Picture1.Line -(xe, ye)
 Next i
End Sub