|
阅读：3023回复：9
移动选择的地理要素？
用选择工具选择一多边形、直线、点
将其选择集拖动到任意地方，松开鼠标数据集更新为拖放后的数据 要实现移动功能？ 请版主 帮忙 谢谢 |
|
|
1楼#
发布于：2004-07-09 12:38
thanks
|
|
|
2楼#
发布于：2004-05-27 10:39
<P>真不错。谢谢</P>
|
|
|
3楼#
发布于：2003-10-15 15:03
斑竹好！
|
|
|
4楼#
发布于：2003-10-08 15:36
为版主加油
|
|
|
5楼#
发布于：2003-08-27 09:45
很有帮助
|
|
|
6楼#
发布于：2003-08-26 17:40
斑竹太伟大了!谢谢!
|
|
|
7楼#
发布于：2003-08-21 21:19
Function DDrawLinesMove(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point)
Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim dx As Long, dy As Long dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y Dim Line As Object GetLineFromMapFalse map, Line, layerNum, lineNum DDrawLinePan map, Line, dx, dy map.FromMapPoint point, newX, newY prevP1.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP1.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y DDrawLinePan map, Line, dx, dy End Function Function DDrawPolygonMove(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim dx As Long, dy As Long dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y Dim Line As Object GetLineFromMapFalse map, Line, layerNum, lineNum DDrawLinePan1 map, Line, dx, dy map.FromMapPoint point, newX, newY prevP1.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP1.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y DDrawLinePan1 map, Line, dx, dy End Function Function DDrawLinesMoveSel(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point, selPart As Long, selVer As Long) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim dx As Long, dy As Long dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y Dim Line As Object 'mapobjects2.line GetLineFromMapFalse map, Line, layerNum, lineNum DDrawLinePanSel map, Line, dx, dy, selPart, selVer map.FromMapPoint point, newX, newY prevP1.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP1.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y DDrawLinePanSel map, Line, dx, dy, selPart, selVer End Function Function DDrawPolygonMoveSel(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point, selPart As Long, selVer As Long) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim dx As Long, dy As Long dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y Dim Line As Object 'mapobjects2.line GetLineFromMapFalse map, Line, layerNum, lineNum DDrawLinePanSel1 map, Line, dx, dy, selPart, selVer map.FromMapPoint point, newX, newY prevP1.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP1.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y DDrawLinePanSel1 map, Line, dx, dy, selPart, selVer End Function Function DDrawEnd() SetROP2 m_hDC, R2_NOTXORPEN ReleaseDC m_hWnd, m_hDC ReleaseCapture End Function Function DDrawLinesEnd(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim dx As Long, dy As Long dx = prevP1.x - prevP.x dy = prevP1.y - prevP.y Dim Line As Object 'As MapObjects2.line GetLineFromMapFalse map, Line, layerNum, lineNum DDrawLinePan map, Line, dx, dy ReleaseDC m_hWnd, m_hDC ReleaseCapture End Function Function DDrawLineBegin(map As MapObjects2.map, x1 As Single, y1 As Single, x2 As Single, y2 As Single) Set m_map = map m_hWnd = m_map.hwnd SetCapture (m_hWnd) m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN Dim a, B, c, d As Integer a = m_map.Parent.ScaleX(x1, vbTwips, vbPixels) B = m_map.Parent.ScaleY(y1, vbTwips, vbPixels) c = m_map.Parent.ScaleX(x2, vbTwips, vbPixels) d = m_map.Parent.ScaleY(y2, vbTwips, vbPixels) GdiMoveTo m_hDC, a, B, 0 GdiLineTo m_hDC, c, d prevP.x = a prevP.y = B prevP1.x = c prevP1.y = d End Function Sub DDrawARectangle(m_hDC As Long, a As Long, B As Long) GdiMoveTo m_hDC, a - 3, B - 3, 0 GdiLineTo m_hDC, a + 3, B - 3 GdiLineTo m_hDC, a + 3, B + 3 GdiLineTo m_hDC, a - 3, B + 3 GdiLineTo m_hDC, a - 3, B - 3 End Sub Function DDrawPointEnd(map As MapObjects2.map, x1 As Single, y1 As Single) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN DDrawARectangle m_hDC, prevP.x, prevP.y ReleaseDC m_hWnd, m_hDC ReleaseCapture End Function Function DDrawPointBegin(map As MapObjects2.map, x1 As Single, y1 As Single) Set m_map = map m_hWnd = m_map.hwnd SetCapture (m_hWnd) m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN Dim a21 As Long Dim bb As Long a21 = m_map.Parent.ScaleX(x1, vbTwips, vbPixels) bb = m_map.Parent.ScaleY(y1, vbTwips, vbPixels) DDrawARectangle m_hDC, a21, bb prevP.x = a21 prevP.y = bb End Function Function DDrawLineMove(map As MapObjects2.map, x1 As Single, y1 As Single, x2 As Single, y2 As Single) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim a, B, c, d As Integer a = m_map.Parent.ScaleX(x1, vbTwips, vbPixels) B = m_map.Parent.ScaleY(y1, vbTwips, vbPixels) c = m_map.Parent.ScaleX(x2, vbTwips, vbPixels) d = m_map.Parent.ScaleY(y2, vbTwips, vbPixels) GdiMoveTo m_hDC, prevP.x, prevP.y, 0 GdiLineTo m_hDC, prevP1.x, prevP1.y GdiMoveTo m_hDC, a, B, 0 GdiLineTo m_hDC, c, d prevP.x = a prevP.y = B prevP1.x = c prevP1.y = d End Function Function DDrawLineEnd(map As MapObjects2.map) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN GdiMoveTo m_hDC, prevP.x, prevP.y, 0 GdiLineTo m_hDC, prevP1.x, prevP1.y ReleaseDC m_hWnd, m_hDC ReleaseCapture End Function Function DDrawPointMove(map As MapObjects2.map, x As Single, y As Single) Set m_map = map SetROP2 m_hDC, R2_NOTXORPEN Dim a As Long Dim B As Long a = m_map.Parent.ScaleX(x, vbTwips, vbPixels) B = m_map.Parent.ScaleY(y, vbTwips, vbPixels) DDrawARectangle m_hDC, prevP.x, prevP.y DDrawARectangle m_hDC, a, B prevP.x = a prevP.y = B End Function Function DragFinish(x As Single, y As Single) As MapObjects2.Rectangle GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax ReleaseDC m_hWnd, m_hDC Dim r As New MapObjects2.Rectangle PixelsRectToMap m_xMin, m_yMin, m_xMax, m_yMax, r Set DragFinish = r End Function Sub DragMove(x As Single, y As Single) Dim xNext As Long, yNext As Long xNext = m_map.Parent.ScaleX(x, vbTwips, vbPixels) yNext = m_map.Parent.ScaleY(y, vbTwips, vbPixels) GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax m_xMin = m_xMin + (xNext - m_xPrev) m_xMax = m_xMax + (xNext - m_xPrev) m_yMin = m_yMin + (yNext - m_yPrev) m_yMax = m_yMax + (yNext - m_yPrev) GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax m_xPrev = xNext m_yPrev = yNext End Sub Sub DLineStart(map As MapObjects2.map, recs As MapObjects2.Recordset, point As MapObjects2.point) Dim Line As MapObjects2.Line Set Line = recs.Fields("Shape").Value Set m_map = map m_hWnd = m_map.hwnd m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN Dim pts As MapObjects2.points Dim p As MapObjects2.point Dim partj As Long partj = 0 Dim x, y As Single For Each pts In Line.Parts partj = 0 For Each p In pts Set Loc = p m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, x, y, 0 Else GdiLineTo m_hDC, x, y End If partj = partj + 1 Next p Next pts prevP.x = point.x prevP.y = point.y prevP1.x = point.x prevP1.y = point.y End Sub |
|
|
|
8楼#
发布于：2003-08-21 21:18
Sub DLineMove(map As MapObjects2.map, recs As MapObjects2.Recordset, point As MapObjects2.point)
Dim Line As MapObjects2.Line Set Line = recs.Fields("Shape").Value Dim pts As MapObjects2.points Dim p As MapObjects2.point Dim partj As Long partj = 0 Dim x, y As Single Dim dx, dy As Single Set Loc = prevP1 m_map.FromMapPoint Loc, newX, newY dx = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) dy = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) Set Loc = prevP m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) dx = dx - x dy = dy - y For Each pts In Line.Parts partj = 0 For Each p In pts Set Loc = p m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, x + dx, y + dy, 0 Else GdiLineTo m_hDC, x + dx, y + dy End If partj = partj + 1 Next p Next pts Set Loc = point m_map.FromMapPoint Loc, newX, newY dx = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) dy = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) Set Loc = prevP m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) dx = dx - x dy = dy - y For Each pts In Line.Parts partj = 0 For Each p In pts Set Loc = p m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, x + dx, y + dy, 0 Else GdiLineTo m_hDC, x + dx, y + dy End If partj = partj + 1 Next p Next pts prevP1.x = point.x prevP1.y = point.y End Sub Sub DLineEnd(map As MapObjects2.map, recs As MapObjects2.Recordset, point As MapObjects2.point) Dim Line As MapObjects2.Line Set Line = recs.Fields("Shape").Value Dim pts As MapObjects2.points Dim p As MapObjects2.point Dim partj As Long partj = 0 Dim x, y As Single Dim dx, dy As Single Set Loc = prevP1 m_map.FromMapPoint Loc, newX, newY dx = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) dy = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) Set Loc = prevP m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) dx = dx - x dy = dy - y For Each pts In Line.Parts partj = 0 For Each p In pts Set Loc = p m_map.FromMapPoint Loc, newX, newY x = m_map.Parent.ScaleX(newX, vbTwips, vbPixels) y = m_map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, x + dx, y + dy, 0 Else GdiLineTo m_hDC, x + dx, y + dy End If partj = partj + 1 Next p Next pts ReleaseDC m_hWnd, m_hDC End Sub Sub DragStart(Rect As MapObjects2.Rectangle, map As MapObjects2.map, x As Single, y As Single) Set m_map = map m_hWnd = m_map.hwnd m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN MapRectToPixels Rect, m_xMin, m_yMin, m_xMax, m_yMax GdiRectangle m_hDC, m_xMin, m_yMin, m_xMax, m_yMax m_xPrev = m_map.Parent.ScaleX(x, vbTwips, vbPixels) m_yPrev = m_map.Parent.ScaleY(y, vbTwips, vbPixels) End Sub Private Sub MapRectToPixels(r As MapObjects2.Rectangle, xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer) Dim p As New MapObjects2.point Dim xc As Single, yc As Single p.x = r.Left p.y = r.Top m_map.FromMapPoint p, xc, yc xMin = m_map.Parent.ScaleX(xc, vbTwips, vbPixels) yMin = m_map.Parent.ScaleY(yc, vbTwips, vbPixels) p.x = r.Right p.y = r.Bottom m_map.FromMapPoint p, xc, yc xMax = m_map.Parent.ScaleX(xc, vbTwips, vbPixels) yMax = m_map.Parent.ScaleY(yc, vbTwips, vbPixels) End Sub Sub PixelsRectToMap(xMin As Integer, yMin As Integer, xMax As Integer, yMax As Integer, r As MapObjects2.Rectangle) Dim xc As Single, yc As Single xc = m_map.Parent.ScaleX(xMin, vbPixels, vbTwips) yc = m_map.Parent.ScaleY(yMin, vbPixels, vbTwips) Dim p As MapObjects2.point Set p = m_map.ToMapPoint(xc, yc) r.Left = p.x r.Top = p.y xc = m_map.Parent.ScaleX(xMax, vbPixels, vbTwips) yc = m_map.Parent.ScaleY(yMax, vbPixels, vbTwips) Set p = m_map.ToMapPoint(xc, yc) r.Right = p.x r.Bottom = p.y End Sub Function CalOsnapPoint1(Map1 As MapObjects2.map, point As MapObjects2.point, layerNum As Long, outterMinDis As Double, selLayerNum As Long, selVertex As Long) selLayerNum = layerNum selVertex = -1 Dim f As Double f = Map1.ToMapDistance(outterMinDis) Dim recsCount As Long Dim recs As MapObjects2.Recordset Set recs = Map1.Layers(layerNum).Records Dim pointr As MapObjects2.point recsCount = GetRecsCount(recs) recs.MoveFirst Dim i As Long For i = 0 To recsCount - 1 If recs.EOF Then Exit For Set pointr = recs.Fields("Shape").Value If pointr.DistanceTo(point) < f Then selVertex = i Exit For End If recs.MoveNext Next selVertex = selVertex End Function Function CalOsnapPoint(Map1 As MapObjects2.map, point As MapObjects2.point, layerNum As Long, outterMinDis As Double, selLayerNum As Long, selVertex As Long) On Error Resume Next Dim sT As New VBA.Collection 'Exit Function selLayerNum = -1 selVertex = -1 Dim f As Double f = Map1.ToMapDistance(outterMinDis) Dim recsCount As Long Dim recs As MapObjects2.Recordset If Map1.Layers.Count <= layerNum Then Exit Function Set recs = Map1.Layers(layerNum).Records Dim pointr As MapObjects2.point recsCount = GetRecsCount(recs) recs.MoveFirst Dim i As Long For i = 0 To recsCount - 1 If recs.EOF Then Exit For If (recs.Fields("Shape") Is Nothing) Then Exit Function Set pointr = recs.Fields("Shape").Value If pointr.DistanceTo(point) < f Then selVertex = i sT.Add CStr(i) 'Exit For Map1.FlashShape pointr, 2 End If recs.MoveNext Next selVertex = selVertex Dim typea As Long typea = 1 GetOnlyId sT, selVertex, typea, selLayerNum, pointr, recs If selVertex < 0 Then selLayerNum = -1 Else selLayerNum = layerNum End If Exit Function s1: End Function Function CalOsnapPoints(Map1 As MapObjects2.map, point As MapObjects2.point, layerNum As Long, outterMinDis As Double, selLayerNum As Long, selVertex As Long) On Error Resume Next Dim sT As New VBA.Collection 'Exit Function selLayerNum = -1 selVertex = -1 Dim f As Double f = Map1.ToMapDistance(outterMinDis) Dim recsCount As Long Dim recs As MapObjects2.Recordset If Map1.Layers.Count <= layerNum Then Exit Function Set recs = Map1.Layers(layerNum).Records Dim pointr As MapObjects2.point Dim pointrs As MapObjects2.points recsCount = GetRecsCount(recs) recs.MoveFirst Dim i As Long For i = 0 To recsCount - 1 If recs.EOF Then Exit For If (recs.Fields("Shape") Is Nothing) Then Exit Function Set pointrs = recs.Fields("Shape").Value Set pointr = pointrs.Item(0) If pointr.DistanceTo(point) < f Then selVertex = i sT.Add CStr(i) 'Exit For Map1.FlashShape pointr, 2 End If recs.MoveNext Next selVertex = selVertex Dim typea As Long typea = 1 GetOnlyId sT, selVertex, typea, selLayerNum, pointr, recs If selVertex < 0 Then selLayerNum = -1 Else selLayerNum = layerNum End If Exit Function s1: End Function Function CalOsnapPoints1(Map1 As MapObjects2.map, point As MapObjects2.point, layerNum As Long, outterMinDis As Double, selLayerNum As Long, selVertex As Long) On Error GoTo exit1 selLayerNum = layerNum selVertex = -1 Dim f As Double f = Map1.ToMapDistance(outterMinDis) Dim recsCount As Long Dim recs As MapObjects2.Recordset Set recs = Map1.Layers(layerNum).Records Dim pointr As MapObjects2.point Dim pointrs As MapObjects2.points recsCount = GetRecsCount(recs) recs.MoveFirst Dim i As Long For i = 0 To recsCount - 1 If recs.EOF Then Exit For If (recs.Fields("Shape") Is Nothing) Then Exit Function Set pointrs = recs.Fields("Shape").Value Set pointr = pointrs.Item(0) If pointr.DistanceTo(point) < f Then selVertex = i Exit For End If recs.MoveNext Next selVertex = selVertex exit1: End Function |
|
|
|
9楼#
发布于：2003-08-21 21:15
最近太忙了，无法给你写出详细的解决方法
一些函数，很难看懂，不过我想还应该有点用处
Private Declare Function GdiLineTo Lib "gdi32" Alias "LineTo" (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long) As Long Private Declare Function GdiMoveTo Lib "gdi32" Alias "MoveToEx" (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal pp As Long) As Long Private Declare Function GdiRectangle Lib "gdi32" Alias "Rectangle" (ByVal hDC As Long, ByVal x1 As Long, ByVal y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function ReleaseCapture Lib "user32" () As Long Private Declare Function SetROP2 Lib "gdi32" (ByVal hDC As Long, ByVal nDrawMode As Long) As Long Private Const R2_NOTXORPEN = 10 Dim m_map As MapObjects2.map Dim picmap As PictureBox Dim m_hDC As Long Dim m_hWnd As Long Dim m_xMin As Integer, m_yMin As Integer Dim m_xMax As Integer, m_yMax As Integer Dim m_xPrev As Integer Dim m_yPrev As Integer Dim prevP As New MapObjects2.point Dim prevP1 As New MapObjects2.point Dim pointNew As New MapObjects2.point '''''' Dim mprevP As New MapObjects2.point Dim mprevP1 As New MapObjects2.point Dim mpointNew As New MapObjects2.point Dim osnapShape As Object Dim Loc As New MapObjects2.point Dim newX As Single Dim newY As Single Function GetRecsCount(recs As MapObjects2.Recordset) As Long recs.MoveFirst Do While Not recs.EOF recs.MoveNext Loop GetRecsCount = recs.Count recs.MoveFirst End Function Function SetMap(map As MapObjects2.map) Set m_map = map End Function Function DDrawLinePan(map As MapObjects2.map, Line As Object, x As Long, y As Long) Dim a As Long, B As Long Dim pts As MapObjects2.points Dim partj As Long Dim newX As Single, newY As Single Dim p As MapObjects2.point For Each pts In Line.Parts partj = 0 For Each p In pts map.FromMapPoint p, newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, a + x, B + y, 0 Else GdiLineTo m_hDC, a + x, B + y End If partj = partj + 1 Next p Next pts End Function Function DDrawLinePan1(map As MapObjects2.map, Line As Object, x As Long, y As Long) Dim a As Long, B As Long Dim pts As MapObjects2.points Dim partj As Long Dim newX As Single, newY As Single Dim p As MapObjects2.point Dim eCount As Long For Each pts In Line.Parts partj = 0 eCount = pts.Count For Each p In pts map.FromMapPoint p, newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, a + x, B + y, 0 Else GdiLineTo m_hDC, a + x, B + y End If partj = partj + 1 If partj = eCount Then map.FromMapPoint pts.Item(0), newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) GdiLineTo m_hDC, a + x, B + y End If Next p Next pts End Function Function DDrawPolygonPan(map As MapObjects2.map, Line As MapObjects2.Polygon, x As Long, y As Long) Dim a As Long, B As Long Dim pts As MapObjects2.points Dim partj As Long Dim newX As Single, newY As Single Dim p As MapObjects2.point For Each pts In Line.Parts partj = 0 For Each p In pts map.FromMapPoint p, newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = 0 Then GdiMoveTo m_hDC, a + x, B + y, 0 Else GdiLineTo m_hDC, a + x, B + y End If partj = partj + 1 Next p Next pts End Function Function DDrawLinePanSel(map As MapObjects2.map, Line As Object, x As Long, y As Long, selPart As Long, selVer As Long) Dim a As Long, B As Long Dim pts As MapObjects2.points Dim partj As Long Dim newX As Single, newY As Single Dim p As MapObjects2.point Dim ppp As Long partj = 0 For Each pts In Line.Parts ppp = 0 For Each p In pts map.FromMapPoint p, newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = selPart And ppp = selVer Then If ppp = 0 Then GdiMoveTo m_hDC, a + x, B + y, 0 Else GdiLineTo m_hDC, a + x, B + y End If Else If ppp = 0 Then GdiMoveTo m_hDC, a, B, 0 Else GdiLineTo m_hDC, a, B End If End If ppp = ppp + 1 Next p partj = partj + 1 Next pts End Function Function DDrawLinePanSel1(map As MapObjects2.map, Line As Object, x As Long, y As Long, selPart As Long, selVer As Long) Dim a As Long, B As Long Dim pts As MapObjects2.points Dim partj As Long Dim newX As Single, newY As Single Dim p As MapObjects2.point Dim eCount As Long Dim ppp As Long partj = 0 For Each pts In Line.Parts ppp = 0 eCount = pts.Count For Each p In pts map.FromMapPoint p, newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = selPart And ppp = selVer Then If ppp = 0 Then GdiMoveTo m_hDC, a + x, B + y, 0 Else GdiLineTo m_hDC, a + x, B + y End If Else If ppp = 0 Then GdiMoveTo m_hDC, a, B, 0 Else GdiLineTo m_hDC, a, B End If End If If eCount = ppp - 1 Then map.FromMapPoint pts(0), newX, newY a = map.Parent.ScaleX(newX, vbTwips, vbPixels) B = map.Parent.ScaleY(newY, vbTwips, vbPixels) If partj = selPart And ppp = selVer Then GdiLineTo m_hDC, a + x, B + y Else GdiLineTo m_hDC, a, B End If End If ppp = ppp + 1 Next p partj = partj + 1 Next pts End Function Function DDrawLinesStart(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point) Set m_map = map m_hWnd = m_map.hwnd SetCapture (m_hWnd) m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN Dim Line As Object 'As MapObjects2.line GetLineFromMapFalse map, Line, layerNum, lineNum map.FromMapPoint point, newX, newY prevP.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) prevP1.x = prevP.x prevP1.y = prevP.y End Function Function DDrawPolygonStart(map As MapObjects2.map, layerNum As Long, lineNum As Long, point As MapObjects2.point) Set m_map = map m_hWnd = m_map.hwnd SetCapture (m_hWnd) m_hDC = GetDC(m_hWnd) SetROP2 m_hDC, R2_NOTXORPEN Dim Line As Object 'As MapObjects2.line GetLineFromMapFalse map, Line, layerNum, lineNum map.FromMapPoint point, newX, newY prevP.x = map.Parent.ScaleX(newX, vbTwips, vbPixels) prevP.y = map.Parent.ScaleX(newY, vbTwips, vbPixels) prevP1.x = prevP.x prevP1.y = prevP.y End Function |
|
|
