كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
السلام عليكم ...
سؤالي : لدي الكود التالي وهو يستخدم لفصل الخطوط في منطقة الاتصال مع النقاط...اي ان هنالك مجموعة من النقاط point تتصل تماما مع الخطوط والمطلوب هو فصل الخط split في نقطة الاتصال iintersect ...
فأين اكتب هذا الكود ضمن arcinfo ....
.................................................. .....
A gentleman in the Data Editing forum gave me this code to split all lines in one layer by all points in another. Note: It works funny while in an edit session. So, it is better to NOT Start Editing when using this code.
Brad
Sub SplitAll()
Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pPointL As IFeatureLayer
Set pPointL = pMap.Layer(0) 'point layer to split lines with
Dim pLineL As IFeatureLayer
Set pLineL = pMap.Layer(1) 'line layer to be split
Dim pLineFC As IFeatureClass
Set pLineFC = pLineL.FeatureClass
Dim pPointFC As IFeatureClass
Set pPointFC = pPointL.FeatureClass
Dim pPointCursor As IFeatureCursor
Set pPointCursor = pPointFC.Search(Nothing, False)
Dim pPointF As IFeature
Set pPointF = pPointCursor.NextFeature
Do Until pPointF Is Nothing
Dim pPoint As IPoint
Set pPoint = pPointF.Shape
Dim pSF As ISpatialFilter
Set pSF = New SpatialFilter
With pSF
Set .Geometry = pPoint
.GeometryField = "Shape"
.SpatialRel = esriSpatialRelIntersects
End With
Dim pLineCursor As IFeatureCursor
Set pLineCursor = pLineFC.Search(pSF, True)
Dim pLineF As IFeature
Set pLineF = pLineCursor.NextFeature
Do Until pLineF Is Nothing
Dim pPolyCurve As IPolycurve
Set pPolyCurve = pLineF.Shape
Dim pToPoint As IPoint
Set pToPoint = pPolyCurve.ToPoint
Dim pFromPoint As IPoint
Set pFromPoint = pPolyCurve.FromPoint
If (pFromPoint.x = pPoint.x And pFromPoint.y = pPoint.y) Then
'do nothing
ElseIf (pToPoint.x = pPoint.x And pToPoint.y = pPoint.y) Then
'do nothing
Else
Dim pFeatureEdit As IFeatureEdit
Set pFeatureEdit = pLineF
pFeatureEdit.Split pPointF.Shape
End If
Set pLineF = pLineCursor.NextFeature
Loop
Set pPointF = pPointCursor.NextFeature
Loop
End Sub
..................
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
السلام عليكم
اذا كنت تعرف topology
وعلاقة كل طبقة مع غيرها او مع نفسها
وما يسمى behavior
يمكن ب topology عمل ذالك
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
السلام عليكم الاخ عبادة الكود يعمل بدقة وجودة عالية حيث انني قمت بتجربة الكود داخل بيئة ArcInfo
وكانت النتائج ايجابية والمكان المخصص للكود من خلال
Customize
الاخ عبادة الكود الذي بعثته هو عبارة عن
procedure
sub statement
يعني لا تاخذ متغيرات ويجب استدعاء هذا البروسيجر تحت كبسة
واستخدام الطبقات المناسبة
في النهاية الكود صحيح 100%
وشكرا
م.نجد جمال الحناحنه
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
اشكرك الاخ نجد ..
لكن هل تكرمت بالشرح التفصيلي عن طريقة اضافة هذا الكود ..حيث لم يسبق لي باضافة ذلك ...فكيف يتم ذلك من خلال
customize
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
الاخ العزيز هذا فيديو يبين الية عمل الاداة وشكلها
http://sendinto.com/84l9o1uk1pzq/Costomization.exe.html
م.نجد جمال الحناحنه
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
اشكرك الاخ نجد ..لكن ..اريد الطريقة في صناعة هذه الاداة الجديدة ..كيف لي ان اضيف هذا الكود ..ما هي الطريقة لصناعة الكود ..
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
الاخ عبادة هذا الشرح الكامل لكيفية تنزيل الاداة وتفعيلها
وقمت برفع فيديو يبن هذه العملية
PASSWORD
51B92KL
وهذا هو رابط الفيديو:
http://sendinto.com/1uoyk7lohxir/GIS_CUSTOM.exe.html
م.نجد جمال الحناحنه
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
جزاك الله خيرا ..لكن للاسف لم افلح بذلك ...ظهرت رسائل خطأ ..الرجاء فقط نسخ الكود في الرد ..كامل الكود الذي ينبغي علي اضافته ..حيث لاحظت ان هنالك عبارة في اول السطر كما هو مشروح في الفديو وهي عبارة غير موجودة في الكود الذي كتبته انا ....الرجاء اعادة نسخ كامل الكود من البداية الى نهايتة ..وارفع لك صورة تمثل رسالة الخطأ ..ولاحظ بداية الكود .اي اول سطر فيه فهل هذا صحيح ام علي اضافة سطر قبل كتابة الكود ...
http://dc04.arabsh.com/i/01650/d0yusckhw2sg.bmp
رد : كيف يتم كتابة codes ضمن arcinfo .؟؟ليصبح اداة تحرير جديدة؟؟
الاخ عبادة تحية طيبة وبعد:
في البداية الخطاء هو انك وضعت الكود خارج الكبسة فاذا لاحظت اني قمت بوضع كبسة اسمهاPrivate Sub UIButtonControl1
الاخ عبادة ضع الكود في الداخل:
[align=center]Private Sub UIButtonControl1_Click()
[all1=#3E804A][align=center]الكود هنا[/align][/all1]End Sub[/align]
وهذا الكود
:
[all1=#FF4D00]Private Sub UIButtonControl1_Click()[/all1]Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument
Dim pMap As IMap
Set pMap = pMxDoc.FocusMap
Dim pPointL As IFeatureLayer
Set pPointL = pMap.Layer(0) 'point layer to split lines with
Dim pLineL As IFeatureLayer
Set pLineL = pMap.Layer(1) 'line layer to be split
Dim pLineFC As IFeatureClass
Set pLineFC = pLineL.FeatureClass
Dim pPointFC As IFeatureClass
Set pPointFC = pPointL.FeatureClass
Dim pPointCursor As IFeatureCursor
Set pPointCursor = pPointFC.Search(Nothing, False)
Dim pPointF As IFeature
Set pPointF = pPointCursor.NextFeature
Do Until pPointF Is Nothing
Dim pPoint As IPoint
Set pPoint = pPointF.Shape
Dim pSF As ISpatialFilter
Set pSF = New SpatialFilter
With pSF
Set .Geometry = pPoint
.GeometryField = "Shape"
.SpatialRel = esriSpatialRelIntersects
End With
Dim pLineCursor As IFeatureCursor
Set pLineCursor = pLineFC.Search(pSF, True)
Dim pLineF As IFeature
Set pLineF = pLineCursor.NextFeature
Do Until pLineF Is Nothing
Dim pPolyCurve As IPolycurve
Set pPolyCurve = pLineF.Shape
Dim pToPoint As IPoint
Set pToPoint = pPolyCurve.ToPoint
Dim pFromPoint As IPoint
Set pFromPoint = pPolyCurve.FromPoint
If (pFromPoint.X = pPoint.X And pFromPoint.Y = pPoint.Y) Then
'do nothing
ElseIf (pToPoint.X = pPoint.X And pToPoint.Y = pPoint.Y) Then
'do nothing
Else
Dim pFeatureEdit As IFeatureEdit
Set pFeatureEdit = pLineF
pFeatureEdit.Split pPointF.Shape
End If
Set pLineF = pLineCursor.NextFeature
Loop
Set pPointF = pPointCursor.NextFeature
Loop
[all1=#FF3600]End Sub[/all1]