10楼#
发布于:2005-01-20 21:30
高手! |
|
11楼#
发布于:2004-11-28 10:28
好人啊! ![]() ![]() ![]() ![]() ![]() ![]() ![]() |
|
12楼#
发布于:2004-11-28 09:37
to cnlyh:好哥们 |
|
13楼#
发布于:2004-11-22 09:41
关注
|
|
|
14楼#
发布于:2004-11-19 09:38
楼上好人,已给你加分 ![]() |
|
|
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
|
|
16楼#
发布于:2004-11-17 10:40
那在VB中如何声明polyline呢? Dim line1 As New MapObjects2.polyline? 好像是不行的 ![]() |
|
17楼#
发布于:2004-11-16 16:52
恩,应该要用图形算法来实现. |
|
18楼#
发布于:2004-11-16 10:08
这在mo中好象没有提供直接的方法,圆和椭圆都比较容易 我想可以利用polyline来实现,但需要对poly的坐标进行转换,可以参看一些底层的算法,例如绘制besizer曲线的算法 |
|
|
19楼#
发布于:2004-11-16 09:57
对阿,我也正想知道
|
|