阅读:3015回复:5
copy与粘贴?
请问版主mo中如何实现复制与张贴,移动等功能
<img src="images/post/smile/dvbbs/em05.gif" /> |
|
1楼#
发布于:2003-08-17 17:52
希望你多来发发你学习的想法,多交流,多谢兄弟支持!
|
|
|
2楼#
发布于:2003-08-17 12:31
谢谢
版主 这些代码对我的启发很大 谢谢版主抽出时间来帮我解决问题? 同时祝愿版主工作顺利 <img src="images/post/smile/dvbbs/em04.gif" /><img src="images/post/smile/dvbbs/em06.gif" /> |
|
3楼#
发布于:2003-08-16 21:41
粘贴代码,大家自己看看,应该可以用,只给思路而已
菜单选择命令 Private Sub MO_MENU_PASTE_Click() Dim layerNum As Long layerNum = ActiveLayerIndex Dim recs As MapObjects2.Recordset Set recs = Map1.Layers(layerNum).Records If recs.Fields("Shape").Type = moLine Then clsMapT.UCutPasteLine Map1, layerNum, 10, 10 ElseIf recs.Fields("Shape").Type = moPolygon Then clsMapT.UCutPastePoly Map1, layerNum, 10, 10 ElseIf recs.Fields("Shape").Type = moPoint Then clsMapT.UCutPastePoint Map1, layerNum, 10, 10 ElseIf recs.Fields("Shape").Type = moPoints Then clsMapT.UCutPastePoints Map1, layerNum, 10, 10 End If End Sub 三个函数,需要自己看看哦,请不要问我,呵呵,最近太忙,难得去想,呵呵 Function UCutPastePoint(map As MapObjects2.map, layerNum As Long, x As Double, y As Double) On Error GoTo exit1 Dim xx, yy As Double xx = x yy = y Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records 'If recs.Fields("Shape").Type = moPoint Then pushTypeAStep utAddShape ' utAddPoint pushInt layerNum pushObject pointNew pushEnd recs.Edit recs.AddNew Set recs.Fields("Shape").Value = pointNew Set pointNew = Nothing Set pointsNew = Nothing recs.Update recs.StopEditing Refresh map 'Else ' MsgBox ("实体类型错误!") 'End If exit1: End Function Function UCutPastePoints(map As MapObjects2.map, layerNum As Long, x As Double, y As Double) On Error GoTo exit1 Dim xx, yy As Double xx = x yy = y Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records 'If recs.Fields("Shape").Type = moPoint Then pushTypeAStep utAddShape ' utAddPoint pushInt layerNum pushObject pointsNew pushEnd recs.Edit recs.AddNew Set recs.Fields("Shape").Value = pointsNew Set pointNew = Nothing Set pointsNew = Nothing recs.Update recs.StopEditing Refresh map 'Else ' MsgBox ("实体类型错误!") 'End If exit1: End Function Function UCutPasteLine(map As MapObjects2.map, layerNum As Long, x As Double, y As Double) On Error GoTo exit1 Dim xx, yy As Double xx = x yy = y Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records 'If recs.Fields("Shape").Type = moPoint Then pushTypeAStep utAddLine pushInt layerNum pushObject lineNew pushEnd recs.Edit recs.AddNew Set recs.Fields("Shape").Value = lineNew recs.Update recs.StopEditing Refresh map Set lineNew = Nothing 'Else ' MsgBox ("实体类型错误!") 'End If exit1: End Function Function UCutPastePoly(map As MapObjects2.map, layerNum As Long, x As Double, y As Double) On Error GoTo exit1 Dim xx, yy As Double xx = x yy = y Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records 'If recs.Fields("Shape").Type = moPoint Then Dim objectNew As Object Set objectNew = polyNew pushTypeAStep utAddShape pushInt layerNum pushObject objectNew pushEnd recs.Edit recs.AddNew Set recs.Fields("Shape").Value = polyNew recs.Update recs.StopEditing Refresh map Set polyNew = Nothing 'Else ' MsgBox ("实体类型错误!") 'End If exit1: End Function |
|
|
4楼#
发布于:2003-08-16 17:31
谢谢
版主在百忙中回答小弟的问题 上面的代码是copy的事件, 还麻烦版主能将粘贴的事件贴出来,或是发给我 HUXL688@NENU.EDU.CN 谢谢 谢谢 |
|
5楼#
发布于:2003-08-16 16:16
挑copy程序的一部分给你看看
一些定义 Public m_selVertex As Long Public m_selPart As Long Public m_selLine As Long 只是把程序里的一些部分挑了出来,肯定还运行不了,你看看吧,也不知道有没用,最近太忙,没办法,回答问题没办法静下来,慢慢做好。 从菜单选择copy项 Private Sub MO_MENU_COPY_Click() Dim layerNum As Long layerNum = ActiveLayerIndex If m_selLine = -1 And m_selPart = -1 And m_selVertex = -1 Then MsgBox ("首先必须选中一个要复制的实体!") Else Dim recs As MapObjects2.Recordset Set recs = Map1.Layers(layerNum).Records If recs.Fields("Shape").Type = moLine Then clsMapT.UCpline Map1, layerNum, m_selLine ElseIf recs.Fields("Shape").Type = moPolygon Then clsMapT.UCpPoly Map1, layerNum, m_selLine Else clsMapT.UCpPoint Map1, layerNum, m_selVertex End If End If 三个上面用到的函数 Function UCpPoint(map As MapObjects2.map, layerNum As Long, m_selVertex As Long) On Error GoTo exit1 Dim mymap As MapObjects2.map Dim mylayer As Long Dim myselvertex As Long Set mymap = map mylayer = layerNum myselvertex = m_selVertex Set m_map = map Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records recs.MoveFirst 'recs.Edit Dim i As Long For i = 0 To m_selVertex - 1 recs.MoveNext Next Dim point As MapObjects2.point Dim mpoints As MapObjects2.points If recs.Fields("Shape").Type = moPoint Then Set point = recs.Fields("Shape").Value Set pointNew = Nothing CopyPoint pointNew, point ElseIf recs.Fields("Shape").Type = moPoints Then Set mpoints = recs.Fields("Shape").Value Set pointsNew = New MapObjects2.points CopyPoints pointsNew, mpoints End If exit1: End Function Function UCpline(map As MapObjects2.map, layerNum As Long, m_selLine As Long) On Error GoTo exit1 Dim mymap As MapObjects2.map Dim mylayer As Long Dim myselline As Long Set mymap = map mylayer = layerNum myselline = m_selLine Set m_map = map Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records recs.MoveFirst 'recs.Edit Dim i As Long For i = 0 To m_selLine - 1 recs.MoveNext Next Dim Line As MapObjects2.Line Set Line = recs.Fields("Shape").Value Set lineNew = Nothing CopyLine lineNew, Line exit1: End Function Function UCpPoly(map As MapObjects2.map, layerNum As Long, m_selLine As Long) On Error GoTo exit1 Dim mymap As MapObjects2.map Dim mylayer As Long Dim myselline As Long Set mymap = map mylayer = layerNum myselline = m_selLine Set m_map = map Dim recs As MapObjects2.Recordset Set recs = map.Layers(layerNum).Records recs.MoveFirst 'recs.Edit Dim i As Long For i = 0 To m_selLine - 1 recs.MoveNext Next Dim Polygon As MapObjects2.Polygon Set Polygon = recs.Fields("Shape").Value Set polyNew = Nothing CopyPolygon polyNew, Polygon exit1: End Function End Sub [此贴子已经被作者于2003-8-16 16:17:15编辑过]
|
|
|