默认头像
路人甲
路人甲
  • 注册日期2004-10-30
  • 发帖数94
  • QQ
  • 铜币294枚
  • 威望0点
  • 贡献值0点
  • 银元0个
10楼#
发布于:2005-01-20 21:30

高手!

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2004-10-28
  • 发帖数40
  • QQ
  • 铜币189枚
  • 威望0点
  • 贡献值0点
  • 银元0个
11楼#
发布于:2004-11-28 10:28
好人啊!
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2004-03-16
  • 发帖数16
  • QQ
  • 铜币207枚
  • 威望0点
  • 贡献值0点
  • 银元0个
12楼#
发布于:2004-11-28 09:37

to cnlyh:好哥们

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2003-12-25
  • 发帖数768
  • QQ28796446
  • 铜币27枚
  • 威望0点
  • 贡献值0点
  • 银元0个
13楼#
发布于:2004-11-22 09:41
关注
西门吹血,有了鼓风机,就不用吹啦!
举报 回复(0) 喜欢(0)     评分
默认头像
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15951
  • QQ
  • 铜币25345枚
  • 威望15368点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
14楼#
发布于:2004-11-19 09:38
楼上好人,已给你加分
GIS麦田守望者,期待与您交流。
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2004-09-24
  • 发帖数15
  • QQ
  • 铜币273枚
  • 威望0点
  • 贡献值0点
  • 银元0个
15楼#
发布于:2004-11-19 09:24

form1代码

Option Explicit

Dim mCurPoint As Integer Dim mPoints(1 To 3) As MapObjects2.Point Dim mArc As MapObjects2.Line

Dim mPointSym As MapObjects2.Symbol Dim mLineSym As MapObjects2.Symbol

Private Sub Form_Load()

Dim e As New MapObjects2.Rectangle

mCurPoint = 1

Set mPointSym = New MapObjects2.Symbol mPointSym.SymbolType = moPointSymbol mPointSym.Style = moCircleMarker mPointSym.Color = moBlack mPointSym.Size = 4

Set mLineSym = New MapObjects2.Symbol mLineSym.SymbolType = moLineSymbol mLineSym.Color = moGreen mLineSym.Size = 2

e.Left = 0 e.Bottom = 0 e.Right = 1000 e.Top = 1000

Map1.FullExtent = e Map1.Extent = Map1.FullExtent

End Sub

Private Sub Map1_BeforeTrackingLayerDraw(ByVal hDC As Stdole.OLE_HANDLE)

Dim i As Integer

If mPoints(mCurPoint) Is Nothing Then Exit Sub

If mCurPoint > 1 Then   Map1.DrawShape mArc, mLineSym End If

For i = 1 To mCurPoint   Map1.DrawShape mPoints(i), mPointSym Next i

End Sub

Private Sub Map1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

Set mPoints(mCurPoint) = Map1.ToMapPoint(x, y) Map1.TrackingLayer.Refresh True

mCurPoint = (mCurPoint Mod 3) + 1 Set mPoints(mCurPoint) = Nothing

End Sub

Private Sub Map1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)

Dim pnts As MapObjects2.Points

Set mPoints(mCurPoint) = Map1.ToMapPoint(x, y)

If mCurPoint > 1 Then   If mCurPoint = 2 Then     Set pnts = New MapObjects2.Points     pnts.Add mPoints(1)     pnts.Add mPoints(2)     Set mArc = New MapObjects2.Line     mArc.Parts.Add pnts   Else     Set mArc = MakeArc(mPoints(1), mPoints(2), mPoints(3))   End If End If

Map1.TrackingLayer.Refresh True

End Sub

模块代码

' '  Module Name:  modArc ' '  Description:  Arc Generation Routines ' '     Requires:  (nothing) ' '     Routines:  MakeArc - given three MapObjects Points, returns a Line '                    the approximates the circular arc which passes through '                    them; the optional sweep angle, in degrees, determines '                    the spacing of the vertices '                GetCenter - given three MapObjects Points, returns the '                    Point at the center of the circle that passes through '                    them; returns Nothing if no center point can be found ' '      History:  Peter Girard, ESRI - 5/00 - original coding ' '=============================================================================

Public Function MakeArc(a As MapObjects2.Point, b As MapObjects2.Point, _     c As MapObjects2.Point, Optional sweep As Integer = 3) As MapObjects2.Line

Dim cen As MapObjects2.Point, p As MapObjects2.Point Dim l As MapObjects2.Line, pts As MapObjects2.Points

Dim cosSweep As Double, sinSweep As Double Dim rad As Double, dChord As Double Dim dab As Double, dac As Double, sideb As Integer, sidec As Integer Dim dir As Integer, done As Boolean, bInserted As Boolean Dim dx As Double, dy As Double

' -- degrees to radians conversion

Const PI = 3.14159265359 Const ToRadians = PI / 180

' -- create the line and add the first point

Set l = New MapObjects2.Line Set pts = New MapObjects2.Points pts.Add a

' -- find the center of the circle passing through the three points; if there ' -- is no center (coincident points or a straight line), simply connect the ' -- points

Set cen = GetCenter(a, b, c) If cen Is Nothing Then   pts.Add b   pts.Add c   l.Parts.Add pts   Set MakeArc = l   Exit Function End If

' -- get the cosine and sine of the sweep angle, the radius of the arc, and ' -- the chord distance relative to the sweep angle and radius

cosSweep = Cos(sweep * ToRadians) sinSweep = Sin(sweep * ToRadians) rad = cen.DistanceTo(a) dChord = Sqr(((rad - (cosSweep * rad)) ^ 2) + ((sinSweep * rad) ^ 2))

' -- get the distances from point A to B and C; determine to which side of ' -- the A radius vector lie points B and C using vector cross products

dab = a.DistanceTo(b) sideb = Sgn(((b.x - a.x) * (cen.y - a.y)) - ((b.y - a.y) * (cen.x - a.x))) dac = a.DistanceTo(c) sidec = Sgn(((c.x - a.x) * (cen.y - a.y)) - ((c.y - a.y) * (cen.x - a.x)))

' -- if points B and C are on the same side of the A radius vector, point B ' -- is closer to A than is C, and both B and C are closer to A than the chord ' -- distance, simply connect the points

If sideb = sidec And dab <= dac And dac <= dChord Then   pts.Add b

Else

 ' -- if points B and C are on the same side of the A radius vector and   ' -- C is closer to A than is B, then take the long way around the circle   ' -- from A to B      If sideb = sidec And dab > dac Then     dir = -sideb        ' -- otherwise, take the short way around the circle from A to B; add   ' -- point B as a vertex if it's within the chord distance      Else     dir = sideb     If dab < dChord Then       pts.Add b       bInserted = True     End If   End If      ' -- loop to generate the vertices      Set p = New MapObjects2.Point   p.x = a.x   p.y = a.y   While Not done     dx = p.x - cen.x     dy = p.y - cen.y     p.x = cen.x + (dx * cosSweep) - (dir * dy * sinSweep)     p.y = cen.y + (dy * cosSweep) + (dir * dx * sinSweep)     pts.Add p     If Not bInserted And p.DistanceTo(b) < dChord Then       pts.Add b       bInserted = True     End If     done = (p.DistanceTo(c) <= dChord)   Wend End If

' -- add point C to the vertices and create the Line

pts.Add c l.Parts.Add pts

Set MakeArc = l

End Function

Public Function GetCenter(a As MapObjects2.Point, b As MapObjects2.Point, _    c As MapObjects2.Point) As MapObjects2.Point

Dim ax As Double, ay As Double, bx As Double, by As Double, cx As Double, cy As Double Dim dx1 As Double, dy1 As Double, dx2 As Double, dy2 As Double Dim m1 As Double, m2 As Double, b1 As Double, b2 As Double Dim center As MapObjects2.Point

' -- exit if any two points are coincident

If (a.x = b.x And a.y = b.y) Or (b.x = c.x And b.y = c.y) Or _     (c.x = a.x And c.y = a.y) Then   Exit Function End If

' -- exit if any error is encountered; this would probably be a division by zero ' -- error that occurs all three points lie on the same line

On Error GoTo Exit_GetCenter

Set center = New MapObjects2.Point

' -- calculate the center points of the lines AB and BC

ax = (a.x + b.x) / 2 ay = (a.y + b.y) / 2 bx = b.x by = b.y cx = (c.x + b.x) / 2 cy = (c.y + b.y) / 2

' -- calculate the XY deltas for the perpendicular bisectors of lines AB and BC

dx1 = by - ay dy1 = -(bx - ax) dx2 = by - cy dy2 = -(bx - cx)

' -- if either perpendicular bisector is a vertical line, find the center point ' -- where the other perpendicular bisector intersects that vertical line

If dx1 = 0 Then   center.x = ax   m2 = dy2 / dx2   b2 = cy - (m2 * cx)   center.y = (m2 * center.x) + b2    Else   If dx2 = 0 Then     center.x = cx     m1 = dy1 / dx1     b1 = ay - (m1 * ax)     center.y = (m1 * center.x) + b1      ' -- otherwise, find the center point by solving the simultaneous equations   ' -- of both perpendicular bisectors      Else     m1 = dy1 / dx1     b1 = ay - (m1 * ax)     m2 = dy2 / dx2     b2 = cy - (m2 * cx)     center.x = (b2 - b1) / (m1 - m2)     center.y = (m1 * center.x) + b1   End If End If

Set GetCenter = center

Exit_GetCenter:

End Function

 

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2004-11-15
  • 发帖数20
  • QQ
  • 铜币192枚
  • 威望0点
  • 贡献值0点
  • 银元0个
16楼#
发布于:2004-11-17 10:40

那在VB中如何声明polyline呢?

Dim line1 As New MapObjects2.polyline? 好像是不行的

举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2003-12-01
  • 发帖数158
  • QQ
  • 铜币622枚
  • 威望0点
  • 贡献值0点
  • 银元0个
17楼#
发布于:2004-11-16 16:52

恩,应该要用图形算法来实现.

举报 回复(0) 喜欢(0)     评分
默认头像
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15951
  • QQ
  • 铜币25345枚
  • 威望15368点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
18楼#
发布于:2004-11-16 10:08

这在mo中好象没有提供直接的方法,圆和椭圆都比较容易

我想可以利用polyline来实现,但需要对poly的坐标进行转换,可以参看一些底层的算法,例如绘制besizer曲线的算法

GIS麦田守望者,期待与您交流。
举报 回复(0) 喜欢(0)     评分
默认头像
路人甲
路人甲
  • 注册日期2004-11-15
  • 发帖数20
  • QQ
  • 铜币192枚
  • 威望0点
  • 贡献值0点
  • 银元0个
19楼#
发布于:2004-11-16 09:57
对阿,我也正想知道
举报 回复(0) 喜欢(0)     评分
上一页 下一页
默认头像

返回顶部