modutilities.bas

来自「FloodEvaluation-程序是gis方面的程序」· BAS 代码 · 共 1,015 行 · 第 1/3 页

    End With
    
    ' add oid field (access and sde) - must come before geometry field
    Set pFldEdt = New esriCore.Field
    With pFldEdt
      .name = "OID"
      .Type = esriFieldTypeOID
    End With
    pFldsEdt.AddField pFldEdt
    
    'add Geometry field
    Set pFldEdt = New esriCore.Field
    With pFldEdt
      .name = "Shape"
      .IsNullable = True
      .Type = esriFieldTypeGeometry
      Set .GeometryDef = pGeoDef
    End With
    pFldsEdt.AddField pFldEdt
    
    'add Name field
'    Set pFldEdt = New esriCore.Field
'    With pFldEdt
'      .Name = "地区"
'      .IsNullable = True
'      .Type = esriFieldTypeString
'    '    Set .GeometryDef = pGeoDef
'    End With
'    pFldsEdt.AddField pFldEdt
    
    'add Flood Loss field
'    Set pFldEdt = New esriCore.Field
'    With pFldEdt
'      .Name = sFieldName
'      .IsNullable = True
'      .Type = esriFieldTypeDouble
'    '    Set .GeometryDef = pGeoDef
'    End With
'    pFldsEdt.AddField pFldEdt
    
    Set CreateFeatureFields = pFldsEdt
    Exit Function
    
ERH:
    MsgBox "创建字段失败" & Chr(13) & ERR.Description, vbInformation + vbOKOnly, "提示信息"
  
End Function

'************************************************************************************************'''
''''AppendField，在原有表字段基础上，添加指定字段
'************************************************************************************************'''
Public Sub AppendField(pFields As IFields, strFieldName As String, pFldType As esriFieldType, pIsNullable As Boolean)
On Error GoTo ERH

    Dim lIndex As Long
    Dim pField As IField
    
    lIndex = pFields.FindField(strFieldName)
    If lIndex <> -1 Then
        MsgBox "欲加入的字段已存在", vbInformation + vbOKOnly, "提示信息"
        Exit Sub
    End If
    
    Dim pFieldsEdit As IFieldsEdit
    Set pFieldsEdit = pFields
    Dim pFieldEdit As IFieldEdit
    Set pFieldEdit = New esriCore.Field
    With pFieldEdit
      .name = strFieldName
      .IsNullable = pIsNullable
      .Type = pFldType
    '    Set .GeometryDef = pGeoDef
    End With
    pFieldsEdit.AddField pFieldEdit
    
    Exit Sub
ERH:
    MsgBox "添加字段失败", vbInformation + vbOKOnly, "提示信息"
End Sub

'************************************************************************************************'''
''''用多边形图层切割多边形或者线图层，结果存为所给名称
'************************************************************************************************'''
Public Function Intersect(resultFileName As String, resultPathName As String, polyLyr As IFeatureLayer, inputLyr As IFeatureLayer) As IFeatureClass
  ' Get the input layer and feature class

On Error GoTo ERR:
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    Dim pInputTable As ITable
    Set pInputTable = inputLyr
    
    ' Get the input feature class.
    ' The Input feature class properties, such as shape type,
    ' will be needed for the output
    Dim pInputFeatClass As IFeatureClass
    Set pInputFeatClass = inputLyr.FeatureClass
      
    ' Get the overlay layer
    ' Use the Itable interface from the Layer (not from the FeatureClass)
    '  Set pLayer = pMxDoc.FocusMap.Layer(1)
    Dim pOverlayTable As ITable
    Set pOverlayTable = polyLyr
    
    ' Error checking
    If pInputTable Is Nothing Then
        MsgBox "Table QI failed", vbInformation + vbOKOnly, "提示信息"
        Exit Function
    End If
      
    If pOverlayTable Is Nothing Then
        MsgBox "Table QI failed", vbInformation + vbOKOnly, "提示信息"
        Exit Function
    End If
    
    ' Define the output feature class name and shape type (taken from the
    ' properties of the input feature class)
    Dim pFeatClassName As IFeatureClassName
    Set pFeatClassName = New FeatureClassName
    With pFeatClassName
        .FeatureType = esriFTSimple
        .ShapeFieldName = "Shape"
        .shapeType = pInputFeatClass.shapeType
    End With
    
    ' Set output location and feature class name
    Dim pNewWSName As IWorkspaceName
    Set pNewWSName = New WorkspaceName
    pNewWSName.WorkspaceFactoryProgID = "esriCore.ShapeFileWorkspaceFactory.1"
    pNewWSName.pathName = resultPathName
    
    Dim pDatasetName As IDatasetName
    Set pDatasetName = pFeatClassName
    pDatasetName.name = Left(resultFileName, Len(resultFileName) - 4)
    
    Set pDatasetName.WorkspaceName = pNewWSName
      
    ' Set the tolerance.  Passing 0.0 causes the default tolerance to be used.
    ' The default tolerance is 1/10,000 of the extent of the data frame's spatial domain
    Dim tol As Double
    tol = 0#
      
    ' Perform the intersect
    Dim pBGP As IBasicGeoprocessor
    Set pBGP = New BasicGeoprocessor
    Dim pOutputFeatClass As IFeatureClass
    Set pOutputFeatClass = pBGP.Intersect(pInputTable, False, pOverlayTable, False, tol, pFeatClassName)
    
    ' Add the output layer to the map
    Set Intersect = pOutputFeatClass
    Exit Function
    
ERR:
    MsgBox "图层叠加操作失败！", vbInformation + vbOKOnly, "提示信息"
  End Function
  
'************************************************************************************************'''
''''设置线显示属性
'************************************************************************************************'''
Public Sub setLineSymbol(pFeatLyr As IFeatureLayer, nWidth As Integer, pColor As IRgbColor)
    
    Dim bFound As Boolean  ' find a polyline feature layer?
    
    Dim pLSym As ILineSymbol
    Set pLSym = New SimpleLineSymbol  'CustomLineSymbol.MyLineSymbol
    pLSym.Width = nWidth  '2
    
    pLSym.Color = pColor
    
    If pFeatLyr.FeatureClass.shapeType <> esriGeometryPolyline Then
       MsgBox "只对线状图层显示属性进行设置", vbInformation + vbOKOnly, "提示信息" 'bFound = True
       Exit Sub
    End If
      
    Dim pRen As ISimpleRenderer
    Dim pGeoFeatLyr As IGeoFeatureLayer
    Set pGeoFeatLyr = pFeatLyr
    Set pRen = pGeoFeatLyr.Renderer
    Set pRen.Symbol = pLSym

End Sub
    
'************************************************************************************************'''
''''设置点、线、面显示属性
'************************************************************************************************'''
Public Sub setFeatureLayerRenderer(pFeatLyr As IFeatureLayer, _
                                   Optional longVbColor As Long = vbRed)
    
On Error GoTo ERH
     
    If Not TypeOf pFeatLyr Is IFeatureLayer Then
        MsgBox "只能设置矢量图层属性", vbInformation + vbOKOnly, "提示信息"
        Exit Sub
    End If
    
    ' --------------------------------------------------
    '     if point features, use a marker symbol for rendering
    '     else, if line features, then use a line symbol
    '     else, if polygon features, then use a fill symbol
    '     else, do not assign renderer to layer
    Dim pMarkerSym As ISimpleMarkerSymbol
    Dim pLineSymbol As ISimpleLineSymbol
    Dim pFillSymbol As ISimpleFillSymbol
      
    Dim pColor As IRgbColor
    Set pColor = New RgbColor
'    pColor.RGB = vbRed
    
    Set pMarkerSym = New SimpleMarkerSymbol
    With pMarkerSym
        .Size = 12
'        .Color = pColor
        .Style = esriSMSX
    End With
    
    Set pLineSymbol = New SimpleLineSymbol
    With pLineSymbol
        .Width = 1.8
'        .Color = pColor
        .Style = esriSLSSolid  'esriSLSDashDotDot
    End With
    
    Set pFillSymbol = New SimpleFillSymbol
    With pFillSymbol
        .Color = pColor
        .Style = esriSFSNull 'esriSFSBackwardDiagonal
'        .Outline = pLineSymbol
    End With
      
    ' based on feature type, make proper symbol, then assign to pSym
    Dim pSym As ISymbol
    Select Case pFeatLyr.FeatureClass.shapeType
      
      Case esriGeometryPoint     ' set up a marker symbol
          pColor.RGB = longVbColor 'vbYellow
          pMarkerSym.Color = pColor
          Set pSym = pMarkerSym
    
      Case esriGeometryPolyline    ' set up a line symbol
          pColor.RGB = longVbColor 'vbRed
          pLineSymbol.Color = pColor
          Set pSym = pLineSymbol
    
      Case esriGeometryPolygon    ' setup a fill symbol
'          Set pLineSymbol = New SimpleLineSymbol
'          With pLineSymbol
'              .Width = 1.5
'              .Color = pColor
'              .Style = esriSLSSolid  'esriSLSDashDotDot
'          End With
'          Set pSym = MakeNewGradientFillSymbol(pLineSymbol)  'pFillSymbol
          
          pColor.RGB = longVbColor  'vbBlue
          pLineSymbol.Color = pColor
          pFillSymbol.Outline = pLineSymbol
          Set pSym = pFillSymbol
    
      Case Else
          MsgBox "只能设置矢量图层属性", vbInformation + vbOKOnly, "提示信息"
          Exit Sub
    
    End Select
    ' --------------------------------------------------
      
    ' create a new CustomSimpleRend
    Dim pRend As IFeatureRenderer
    Set pRend = New clsCustomSimpleRend
    
    ' set symbol.  we must use ISimpleRenderer interface
    Dim pSimpleRend As ISimpleRenderer
    Set pSimpleRend = pRend
    Set pSimpleRend.Symbol = pSym
    
    Dim pGeoFL As IGeoFeatureLayer
    Set pGeoFL = pFeatLyr
    
    ' finally, set the new renderer to the layer and refresh the map
    Set pGeoFL.Renderer = pRend
    
    Set pColor = Nothing
    Set pSym = Nothing
    Set pMarkerSym = Nothing
    Set pLineSymbol = Nothing
    Set pFillSymbol = Nothing
    Set pRend = Nothing
    Set pSimpleRend = Nothing
    Set pGeoFL = Nothing
      
    Exit Sub
    
ERH:

    MsgBox "设置图例失败" & ERR.Description, vbInformation + vbOKOnly, "提示信息"
    Exit Sub
End Sub
    
'Private Sub aboutListView()
'   Dim itmX As ListItem
'   Dim itmH As ColumnHeader
'  'Add three Column Headers to the control
''  ListView1.ColumnHeaders.Count = 3
''   Set itmH = ListView1.ColumnHeaders.Item(0).Text  .Add(Text:="Name")
'   ListView1.ColumnHeaders.Item(1).Text = "name" ' .Add(Text:="Name")
'   Set itmH = ListView1.ColumnHeaders.Add(Text:="Date")
'   Set itmH = ListView1.ColumnHeaders.Add(Text:="Value")
'  'Set the ListView to Report view
'   ListView1.View = lvwReport
'  'Add some data to the ListView control
'   Set itmX = ListView1.ListItems.Add(Text:="Joe")
'   itmX.SubItems(1) = "05/07/97"
'   itmX.SubItems(2) = "44"
'   Set itmX = ListView1.ListItems.Add(Text:="Sally")
'   itmX.SubItems(1) = "04/08/93"
'   itmX.SubItems(2) = "16"
'   Set itmX = ListView1.ListItems.Add(Text:="Bill")
'   itmX.SubItems(1) = "05/29/94"
'   itmX.SubItems(2) = "1"
'   Set itmX = ListView1.ListItems.Add(Text:="Fred")
'   itmX.SubItems(1) = "03/17/95"
'   itmX.SubItems(2) = "215"
'   Set itmX = ListView1.ListItems.Add(Text:="Anne")
'   itmX.SubItems(1) = "07/01/97"
'   itmX.SubItems(2) = "20"
'   Set itmX = ListView1.ListItems.Add(Text:="Bob")
'   itmX.SubItems(1) = "04/01/91"
'   itmX.SubItems(2) = "21"
'   Set itmX = ListView1.ListItems.Add(Text:="John")
'   itmX.SubItems(1) = "12/25/92"
'   itmX.SubItems(2) = "176"
'   Set itmX = ListView1.ListItems.Add(Text:="Paul")
'   itmX.SubItems(1) = "11/23/95"
'   itmX.SubItems(2) = "113"
'   Set itmX = ListView1.ListItems.Add(Text:="Maria")
'   itmX.SubItems(1) = "02/01/96"
'   itmX.SubItems(2) = "567"
'End Sub
'