درباره ما
دوستان
 

ابتدا از منوی tools گزینه cusomize را کلیک کنید. در پنجره باز شده در تب Commands در قسمت categories  بر روی گزینه UIcontrols را کلیک و سپس دکمه new UIcontlos را کلیک کنید. در پنجره باز شده نوع control را UIToolControl انتخاب و بر روی گزینه create کلیک کنید.

به ادامه مطالب توجه فرمایید


سپس ابزار ایجاد شده در قسمت coomand را که با نام Normal.UIToolControl1  می باشد را دراگ و در یکی از نوار ابزارهای موجود در ArcMap قرار دهید.( خودتان نیز می توانید یک نوار ابزار در تب Toolbars با کلیک بر روی گزینه New ایجاد کنید و سپس ابزار را در داخل این نوار ابزار دراگ کنید.) پس از این کار با دو بار کلیک بر روی گزینه Normal.UIToolControl1 در قسمت commands به محیط VbaEditor وارد خواهید شد.

 ابتدا از منوی insert یک form و یک module ایجاد کنید. نام form را پیشفرض Userform1 قرار دهید و نام module را به FlashFeature تغییر دهید. حال بر روی فرم سه کنترل combobox و listview و label قرار دهید

خصوصیت showmaodal  را برای form گزینه false قرار دهید.

combobox: برای لیست کردن لایه های موجود در arcmap

listview : برای نمایش نام فیلدها و مقادیر موجود در فیلدها

خصوصیت gridline را True قرار دهید. خصوصیت view را به lvwReport قرار دهید.

label: خصوصیت caption را  به <لایه> تغییر دهید.

 

دو بار بر روی فرم کلیک کرده و کد زیر را در قسمت کد فرم قرار دهید.

Private Sub UserForm_Activate()
  Dim pMxDoc As IMxDocument
  Dim pActiveView As IActiveView
  Dim pMap As IMap
Dim i As Integer
 
  Dim pFeatureLayer As IFeature
  Set pMxDoc = Application.Document
  Set pActiveView = pMxDoc.FocusMap
Set pMap = pActiveView
For i = 0 To pMap.LayerCount - 1
ComboBox1.AddItem pMap.Layer(i).Name
Next

ListView1.ColumnHeaders.Add , "fieldname", "نام فیلد", ListView1.Width / 2
ListView1.ColumnHeaders.Add , "fieldvalue", "مقدار", ListView1.Width / 2, 2

End Sub


 سپس در پنجره project-Normal بر روی گزینه ThisDocument دو بار کلیک کنید و در محیط باز شده کد زیر را قرار دهید.

در این کد از رویدادهای mouseDown  ، tooltip ، message و select استفاده شده است.

رویداد select موقعی اجرا می شود که بر روی ابزار کلیک کنید. رویداد mousedown موقعی رخ خواهد داد که بر روی نقشه کلیک کنید. دو رویداد دیگر هم برای معرفی ابزار به صورت tooltip در و یا به صورت پیغام در قسمت statusbar استفاده می شود.


Private Function UIToolControl1_Message() As String
UIToolControl1_Message = "استخراج اطلاعات توصیفی عوارض با کلبک بر روی هر عارضه"
End Function

Private Sub UIToolControl1_Select()
UserForm1.Show
End Sub


Private Sub UIToolControl1_MouseDown(ByVal button As Long, ByVal shift As Long, ByVal x As Long, ByVal y As Long)
  UserForm1.ListView1.ListItems.Clear
  Dim pMxDoc As IMxDocument
  Dim pActiveView As IActiveView
  Dim pPoint As IPoint
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pMap As IMap
  Dim m As String
  Dim pFeature As IFeature
  Dim pfields As IFields
  Dim ListItem As ListItem
  Set pMxDoc = Application.Document
  Set pActiveView = pMxDoc.FocusMap
  Set pMap = pActiveView
 
  If UserForm1.ComboBox1.Text = "" Then Exit Sub
 
  For i = 0 To pMap.LayerCount - 1
   If pMap.Layer(i).Name = UserForm1.ComboBox1.Text Then
     Set pFeatureLayer = pMap.Layer(i)
       Exit For
    End If
  Next
  Set pFeatureClass = pFeatureLayer.FeatureClass
  Set pfields = pFeatureClass.Fields
 
  Set pPoint = pActiveView.ScreenDisplay.DisplayTransformation.ToMapPoint(x, y)
  Set pFeature = FindFeature(pMxDoc.SearchTolerance, pPoint, pMxDoc.FocusMap)
  If Not pFeature Is Nothing Then
 
  If pFeature.Class.AliasName = pFeatureClass.AliasName Then
   FlashFeature.FlashFeature pFeature.Shape, pMxDoc
   For i = 0 To pfields.FieldCount - 1
    'نباشد null
    If IsNull(pFeature.Value(i)) Then
      Set ListItem = UserForm1.ListView1.ListItems.Add(, , pfields.Field(i).AliasName)
      ListItem.SubItems(1) = "Null"
    'نباشد blob
    ElseIf Not VarType(pFeature.Value(i)) = vbDataObject Then
      Set ListItem = UserForm1.ListView1.ListItems.Add(, , pfields.Field(i).AliasName)
      ListItem.SubItems(1) = pFeature.Value(i)
    End If
  Next i
  End If
  End If
 
   
End Sub

Private Function FindFeature(SearchTol As Double, pPoint As IPoint, pMap As IMap) As IFeature
  Dim pEnvelope As IEnvelope
  Dim pSpatialFilter As ISpatialFilter
  Dim pEnumLayer As IEnumLayer
  Dim pFeatureLayer As IFeatureLayer
  Dim pFeatureClass As IFeatureClass
  Dim pFeatureCursor As IFeatureCursor
  Dim pFeature As IFeature
  Dim pLayer As ILayer
 Dim pCursor As ICursor
  Dim pUID As New UID
   Dim ShapeFieldName As String
 
    Set pQFilt = New QueryFilter
           If pMap.LayerCount = 0 Then Exit Function
    Set pEnvelope = pPoint.Envelope
  pEnvelope.Expand SearchTol, SearchTol, False
   Set pSpatialFilter = New SpatialFilter
  Set pSpatialFilter.Geometry = pEnvelope
  pSpatialFilter.SpatialRel = esriSpatialRelIntersects

  pUID = "{40A9E885-5533-11D0-98BE-00805F7CED21}" 'IFeatureLayer
 
  Set pEnumLayer = pMap.Layers(pUID, False)
  Set pLayer = pEnumLayer.Next
  pEnumLayer.Reset
  Set pFeatureLayer = pEnumLayer.Next
  Do While Not pFeatureLayer Is Nothing
   
    If pFeatureLayer.Visible Then
      ShapeFieldName = pFeatureLayer.FeatureClass.ShapeFieldName
      Set pSpatialFilter.OutputSpatialReference(ShapeFieldName) = pMap.SpatialReference
      pSpatialFilter.GeometryField = pFeatureLayer.FeatureClass.ShapeFieldName
      Set pFeatureClass = pFeatureLayer.FeatureClass
        Set pFeatureCursor = pFeatureClass.Search(pSpatialFilter, False)
          Set pFeature = pFeatureCursor.NextFeature
  
      If Not pFeature Is Nothing Then
        Set FindFeature = pFeature
               Exit Do
      End If
    End If
        Set pFeatureLayer = pEnumLayer.Next
       
  Loop
End Function

Private Function UIToolControl1_ToolTip() As String
UIToolControl1_ToolTip = "استخراج اطلاعات توصیفی"
End Function

 

حال بر روی module که با نام flashfeature ایجاد کردید دو بار کلیک کنید. از این ماژول برای فلش زدن عوارض در صورت مثبت بودن تابع findfeature استفاده می شود. در قسمت کد ماژول کد زیر را وارد کنید.

Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub FlashFeature(pGeom As IGeometry, pMxDoc As IMxDocument)
 
   pMxDoc.ActiveView.ScreenDisplay.StartDrawing 0, esriNoScreenCache
 
  Select Case pGeom.GeometryType
    Case esriGeometryPolyline
      FlashLine pMxDoc.ActiveView.ScreenDisplay, pGeom
    Case esriGeometryPolygon
      FlashPolygon pMxDoc.ActiveView.ScreenDisplay, pGeom
    Case esriGeometryPoint
      FlashPoint pMxDoc.ActiveView.ScreenDisplay, pGeom
  End Select
   pMxDoc.ActiveView.ScreenDisplay.FinishDrawing
End Sub

Public Sub FlashLine(pDisplay As IScreenDisplay, pGeometry As IGeometry)
  Dim pLineSymbol As ISimpleLineSymbol
  Dim pSymbol As ISymbol
  Dim pRgbColor As IRgbColor
 
  Set pLineSymbol = New SimpleLineSymbol
  pLineSymbol.Width = 4
 
  Set pRgbColor = New RgbColor
  pRgbColor.Green = 128
 
  Set pSymbol = pLineSymbol
  pSymbol.ROP2 = esriROPNotXOrPen
 
  pDisplay.SetSymbol pLineSymbol
  pDisplay.DrawPolyline pGeometry
  Sleep 300
  pDisplay.DrawPolyline pGeometry
End Sub

Public Sub FlashPolygon(pDisplay As IScreenDisplay, pGeometry As IGeometry)
  Dim pFillSymbol As ISimpleFillSymbol
  Dim pSymbol As ISymbol
  Dim pRgbColor As IRgbColor
 
  Set pFillSymbol = New SimpleFillSymbol
  pFillSymbol.Outline = Nothing
 
  Set pRgbColor = New RgbColor
  pRgbColor.Green = 128
 
  Set pSymbol = pFillSymbol
  pSymbol.ROP2 = esriROPNotXOrPen
 
  pDisplay.SetSymbol pFillSymbol
  pDisplay.DrawPolygon pGeometry
  Sleep 300
  pDisplay.DrawPolygon pGeometry
End Sub

Public Sub FlashPoint(pDisplay As IScreenDisplay, pGeometry As IGeometry)
  Dim pMarkerSymbol As ISimpleMarkerSymbol
  Dim pSymbol As ISymbol
  Dim pRgbColor As IRgbColor
 
  Set pMarkerSymbol = New SimpleMarkerSymbol
  pMarkerSymbol.Style = esriSMSCircle
       
  Set pRgbColor = New RgbColor
  pRgbColor.Green = 0
 
  Set pSymbol = pMarkerSymbol
  pSymbol.ROP2 = esriROPNotXOrPen
 
  pDisplay.SetSymbol pMarkerSymbol
  pDisplay.DrawPoint pGeometry
  Sleep 300
  pDisplay.DrawPoint pGeometry
End Sub

Public Sub FlashSelectedFeatures()

Dim pMxDoc As IMxDocument
Set pMxDoc = ThisDocument

Dim pMap As IMap
Set pMap = pMxDoc.FocusMap

Dim pFeature As IFeature
Dim pSelSet As ISelectionSet
Dim pFSelection As IFeatureSelection
Dim pEnumFeat As IEnumFeature
Set pEnumFeat = pMap.FeatureSelection
Set pFeature = pEnumFeat.Next
Do Until pFeature Is Nothing
FlashFeature pFeature.Shape, pMxDoc
Set pFeature = pEnumFeat.Next
Loop

End Sub

دقت کنید تمام مراحلی که ذکر شد تنها باید در یکی از گزینه های normal یا project انجام گردد. به این معنی که از موقعی که شما contlol را ایجاد می کنید به مسیر ذخیره شدن آن در قسمت normal یا project توجه کنید. در صورتی که در قست normal ذخیره کردید باید فرم و ماژول را هم در همین قسمت ایجاد کنید و بالعکس. تفاوت این دو هم در این است که در صورت ذخیره شدن در قسمت normal  کد شما جزیی از Arcmap خواهد شد و همیشه می توانید از آن استفاده کنید بون نیاز به ذخیره کردن نقشه. اما در صورت ذخیره شدن در قسمت project در صورتی که نقشه را به صورت فایل mxd ذخیره نکنید کلیه کدهای شما از بین خواهد رفت. پس برای استفاده در این حالت باید نقشه را ذخیره کنید. کد های شما هم فقط و فقط در همین نقشه ذخیره شده قابل استفاده خواهند بود. مناسب برای پروژهای درسی  چشمک

پروژه تان را در این حالت تهیه کنید و تحویل استاد دهید.

حال در پنجره VbAEditor از منوی file بروی گزینهto ArcMap  close and return کلیک کنید تا این پنجره بسته و به محیط ArcMap برگردید. بر روی ابزار ایجاد شده کلیک کنید. فرمی که آماده کردید نمایش داده می شود. از لیست کشویی لایه ای را کی میخواهد identify بگیرید مشخص کنید و بر روی یکی از عوارض آن لایه بر روی قشه کلیک کنید و نتیجه را ببینید.

موفق باشید




:: برچسب‌ها: arcobject
ن : عباس بیگی
ت : پنجشنبه ۳ بهمن ۱۳۸٧
نظرات ()
 
تلگرام
امكانات جانبي
موضوعات
نویسندگان
آرشیو مطالب
طرح قالب از