modmakesymbols.bas

FloodEvaluation-程序是gis方面的程序

Attribute VB_Name = "modMakeSymbols"
Option Explicit

Private Const m_sPicFile As String = "C:\Program Files\ArcGIS\arcexe83\bin\icons\stop.bmp"
Public m_dSize As Double


'******************************************************************
'***********                    ***********************************
'*******       Marker Symbols        ******************************
'***********                    ***********************************
'******************************************************************
Public Function MakeNewSimpleMarkerSymbol() As ISymbol
  Dim pSimpSym As ISimpleMarkerSymbol
  Set pSimpSym = New SimpleMarkerSymbol
  With pSimpSym
    .Size = m_dSize
    .Style = esriSMSCircle
    .Color = RandomColor
    .Outline = True
    .OutlineSize = 0.1
    .OutlineColor = RandomColor
  End With
  
  Set MakeNewSimpleMarkerSymbol = pSimpSym
End Function

Public Function MakeNewArrowMarkerSymbol() As ISymbol
  Dim pArrSym As IArrowMarkerSymbol
  Set pArrSym = New ArrowMarkerSymbol
  With pArrSym
    .Color = RandomColor
    .Size = m_dSize
    .Style = esriAMSPlain
    .Angle = 45
  End With
  
  Set MakeNewArrowMarkerSymbol = pArrSym
End Function

Public Function MakeNewCharacterMarkerSymbol() As ISymbol
  Dim pCharSym As ICharacterMarkerSymbol
  Set pCharSym = New CharacterMarkerSymbol
  With pCharSym
    .Color = RandomColor
    .Size = m_dSize
    .CharacterIndex = 67
    .Font = MakeStdFont("ESRI Default Marker")
  End With
  
  Set MakeNewCharacterMarkerSymbol = pCharSym
End Function

Public Function MakeNewPictureMarkerSymbol() As ISymbol
  Dim pPicSym As IPictureMarkerSymbol
  Set pPicSym = New PictureMarkerSymbol
  With pPicSym
    .Size = m_dSize
    .CreateMarkerSymbolFromFile esriIPictureBitmap, m_sPicFile
  End With
  Set MakeNewPictureMarkerSymbol = pPicSym
End Function

Public Function MakeNewMultiLayerMarkerSymbol() As ISymbol
  Dim pMultiSym As IMultiLayerMarkerSymbol
  Set pMultiSym = New MultiLayerMarkerSymbol
  With pMultiSym
    .Size = m_dSize
    .AddLayer MakeNewPictureMarkerSymbol
    .AddLayer MakeNewCharacterMarkerSymbol
  End With
  
  Set MakeNewMultiLayerMarkerSymbol = pMultiSym
End Function

'******************************************************************
'***********                    ***********************************
'*******       Line Symbols        ******************************
'***********                    ***********************************
'******************************************************************
Public Function MakeNewSimpleLineSymbol() As ISymbol
  Dim pSimpSym As ISimpleLineSymbol
  Set pSimpSym = New SimpleLineSymbol
  With pSimpSym
    .Color = RandomColor
    .Width = m_dSize
    .Style = esriSLSDashDot
  End With
  
  Set MakeNewSimpleLineSymbol = pSimpSym
End Function

Public Function MakeNewMarkerLineSymbol() As ISymbol
  Dim pMarkSym As IMarkerLineSymbol
  Set pMarkSym = New MarkerLineSymbol
  With pMarkSym
    .Width = m_dSize
    Set .MarkerSymbol = MakeNewSimpleMarkerSymbol
  End With
  
  SetStdLineProperties pMarkSym, pMarkSym.MarkerSymbol.Size, pMarkSym.MarkerSymbol.Size * 2
  
  Set MakeNewMarkerLineSymbol = pMarkSym
End Function

Public Function MakeNewHashLineSymbol() As ISymbol
  Dim pHashSym As IHashLineSymbol
  Set pHashSym = New HashLineSymbol
  With pHashSym
    .Width = m_dSize
    Set .HashSymbol = MakeNewSimpleLineSymbol
  End With
  
  SetStdLineProperties pHashSym, pHashSym.HashSymbol.Width, pHashSym.HashSymbol.Width * 2
  
  Set MakeNewHashLineSymbol = pHashSym
End Function

Public Function MakeNewCartographicLineSymbol() As ISymbol
  Dim pCartSym As ICartographicLineSymbol
  Set pCartSym = New CartographicLineSymbol
  With pCartSym
    .Color = RandomColor
    .Width = m_dSize
    .Cap = esriLCSRound
    .Join = esriLJSMitre
  End With
  
  SetStdLineProperties pCartSym, pCartSym.Width, pCartSym.Width * 2
  
  Set MakeNewCartographicLineSymbol = pCartSym
End Function

Public Function MakeNewPictureLineSymbol() As ISymbol
  Dim pPicSym As IPictureLineSymbol
  Set pPicSym = New PictureLineSymbol
  With pPicSym
    .Width = m_dSize
    .CreateLineSymbolFromFile esriIPictureBitmap, m_sPicFile
  End With
  
  Set MakeNewPictureLineSymbol = pPicSym
End Function

Public Function MakeNewMultiLayerLineSymbol() As ISymbol
  Dim pMultiSym As IMultiLayerLineSymbol
  Set pMultiSym = New MultiLayerLineSymbol
  With pMultiSym
    .Width = m_dSize
    m_dSize = m_dSize / 2
    .AddLayer MakeNewSimpleLineSymbol
    m_dSize = m_dSize * 2
    .AddLayer MakeNewMarkerLineSymbol
  End With
  
  Set MakeNewMultiLayerLineSymbol = pMultiSym
End Function

'******************************************************************
'***********                    ***********************************
'*******       Fill Symbols        ******************************
'***********                    ***********************************
'******************************************************************
Public Function MakeNewSimpleFillSymbol() As ISymbol
  Dim pSimpSym As ISimpleFillSymbol
  Set pSimpSym = New SimpleFillSymbol
  With pSimpSym
    .Color = RandomColor
    .Style = esriSFSSolid
    .Outline = MakeNewSimpleLineSymbol
  End With
  
  Set MakeNewSimpleFillSymbol = pSimpSym
End Function

Public Function MakeNewPictureFillSymbol() As ISymbol
  Dim pPicSym As IPictureFillSymbol
  Set pPicSym = New PictureFillSymbol
  With pPicSym
    .CreateFillSymbolFromFile esriIPictureBitmap, m_sPicFile
    .Angle = 30
  End With
  
  Set MakeNewPictureFillSymbol = pPicSym
End Function

Public Function MakeNewGradientFillSymbol(pLineSymbol As ISimpleLineSymbol) As ISymbol
  Dim pGradSym As IGradientFillSymbol
  Set pGradSym = New GradientFillSymbol
  With pGradSym
    .ColorRamp = MakeNewRamp
    .GradientAngle = 25
    .GradientPercentage = 1
    .IntervalCount = 100
    .Style = esriGFSLinear
    .Outline = pLineSymbol
  End With
  
  Set MakeNewGradientFillSymbol = pGradSym
End Function

Public Function MakeNewMarkerFillSymbol() As ISymbol
  Dim pMarkSym As IMarkerFillSymbol
  Set pMarkSym = New MarkerFillSymbol
  With pMarkSym
    Set .MarkerSymbol = MakeNewCharacterMarkerSymbol
    .GridAngle = 60
    .Style = esriMFSGrid
    '.Outline = MakeNewSimpleLineSymbol
  End With
  
  Set MakeNewMarkerFillSymbol = pMarkSym
End Function

Public Function MakeNewLineFillSymbol() As ISymbol
  Dim pLineSym As ILineFillSymbol
  Set pLineSym = New LineFillSymbol
  With pLineSym
    .Separation = m_dSize * 1.5
    Set .LineSymbol = MakeNewSimpleLineSymbol
  End With
  
  Set MakeNewLineFillSymbol = pLineSym
End Function

Public Function MakeNewMultiLayerFillSymbol() As ISymbol
  Dim pMultiSym As IMultiLayerFillSymbol
  Set pMultiSym = New MultiLayerFillSymbol
  With pMultiSym
    .AddLayer MakeNewSimpleFillSymbol
    .AddLayer MakeNewMarkerFillSymbol
    '.Outline = MakeNewSimpleLineSymbol
  End With
  
  Set MakeNewMultiLayerFillSymbol = pMultiSym
End Function

Public Function MakeNewDotDensityFillSymbol() As ISymbol
  Dim pDotSym As IDotDensityFillSymbol
  Set pDotSym = New DotDensityFillSymbol
  With pDotSym
    .Color = RandomColor
    SetSymArrayMarkers pDotSym
    .BackgroundColor = RandomColor
    .DotCount(0) = 100
    .DotCount(1) = 50
    .DotSize = 2
    .DotSpacing = 2
    .FixedPlacement = False
    .Outline = MakeNewSimpleLineSymbol
  End With
  
  Set MakeNewDotDensityFillSymbol = pDotSym
End Function

'******************************************************************
'***********                    ***********************************
'********       Chart Symbols       ******************************
'***********                    ***********************************
'******************************************************************
Public Function MakeNewPieChartSymbol() As ISymbol
  Dim pPieSym As IPieChartSymbol
  Set pPieSym = New PieChartSymbol
  With pPieSym
    .Clockwise = True
  End With
  
  SetSymArrayFills pPieSym
  
  Dim pChart As IChartSymbol
  Set pChart = pPieSym
  With pChart
    .MaxValue = 10
    .Value(0) = 3
    .Value(1) = 10
  End With
  
  Dim p3DChart As I3DChartSymbol
  Set p3DChart = pPieSym
  With p3DChart
    .Display3D = True
    .Thickness = 20
    .Tilt = 30
  End With
  
  Set MakeNewPieChartSymbol = pPieSym
End Function

Public Function MakeNewBarChartSymbol() As ISymbol
  Dim pBarSym As IBarChartSymbol
  Set pBarSym = New BarChartSymbol
  With pBarSym
    .ShowAxes = True
    .Spacing = 2
    .VerticalBars = True
    .Width = 20
  End With
  
  SetSymArrayFills pBarSym
  
  Dim pChart As IChartSymbol
  Set pChart = pBarSym
  With pChart
    .MaxValue = 10
    .Value(0) = 3
    .Value(1) = 10
  End With
  
  Dim p3DChart As I3DChartSymbol
  Set p3DChart = pBarSym
  With p3DChart
    .Display3D = True
    .Thickness = 20
    '.Tilt = 30
  End With
  
  Set MakeNewBarChartSymbol = pBarSym
End Function

Public Function MakeNewStackedChartSymbol() As ISymbol
  Dim pStackSym As IStackedChartSymbol
  Set pStackSym = New StackedChartSymbol
  With pStackSym
    .Fixed = False
    .UseOutline = True
    .VerticalBar = False
    .Width = 30
  End With
  
  SetSymArrayFills pStackSym
  
  Dim pChart As IChartSymbol
  Set pChart = pStackSym
  With pChart
    .MaxValue = 10
    .Value(0) = 3
    .Value(1) = 10
  End With
  
  Dim p3DChart As I3DChartSymbol
  Set p3DChart = pStackSym
  With p3DChart
    .Display3D = True
    .Thickness = 20
    '.Tilt = 30
  End With
  
  Set MakeNewStackedChartSymbol = pStackSym
End Function

'******************************************************************
'***********                    ***********************************
'********       Misc Symbols       ******************************
'***********                    ***********************************
'******************************************************************
Public Function MakeNewTextSymbol() As ISymbol
  Dim pTxtSym As ITextSymbol
  Set pTxtSym = New TextSymbol
  With pTxtSym
    .Color = RandomColor
    .Font = MakeStdFont("Helvetica")
    .Size = m_dSize
    .Text = Format(Now, "HH:MM:SS")
    .VerticalAlignment = esriTVACenter
  End With
  
  Set MakeNewTextSymbol = pTxtSym
End Function

Public Function MakeNewColorSymbol() As ISymbol
  Dim pColSym As IColorSymbol
  Set pColSym = New ColorSymbol
  With pColSym
    .Color = RandomColor
  End With
  
  Set MakeNewColorSymbol = pColSym
End Function

Public Function MakeNewColorRampSymbol() As ISymbol
  Dim pColSym As IColorRampSymbol
  Set pColSym = New ColorRampSymbol
  With pColSym
    .ColorRamp = MakeNewRamp
    .Invert = False
  End With
  
  Set MakeNewColorRampSymbol = pColSym
End Function

'******************************************************************
'***********                        ***********************************
'********       Utility functions       ******************************
'***********                        ***********************************
'******************************************************************

Public Function MakeNewTemplate(Optional dMark As Double = 10, Optional dGap As Double = 20) As ITemplate
  Set MakeNewTemplate = New Template
  MakeNewTemplate.AddPatternElement m_dSize, m_dSize * 2
  MakeNewTemplate.Interval = 1 'm_dSize * 3
End Function

Public Sub SetStdLineProperties(ByRef pLineProps As ILineProperties, ByVal dMark As Double, ByVal dGap As Double)
  If Not pLineProps Is Nothing Then
    With pLineProps
      Set .Template = MakeNewTemplate(dMark, dGap)
    End With
  End If
End Sub

Public Function MakeStdFont(Optional ByVal sName As String = "ESRI Default Marker") As StdFont
  Set MakeStdFont = New stdole.StdFont
  MakeStdFont.name = sName
End Function

Public Sub SetSymArrayMarkers(ByRef pArray As ISymbolArray)
  Dim pMarker As ISimpleMarkerSymbol
  Set pMarker = New SimpleMarkerSymbol
  pMarker.Color = RandomColor
  pMarker.Style = esriSMSCircle
  pArray.AddSymbol pMarker
  Set pMarker = New SimpleMarkerSymbol
  pMarker.Color = RandomColor
  pMarker.Style = esriSMSCross
  pArray.AddSymbol pMarker
    
End Sub

Public Sub SetSymArrayFills(ByRef pArray As ISymbolArray)
  Dim pFill As ISimpleFillSymbol
  Set pFill = New SimpleFillSymbol
  pFill.Color = RandomColor
  pFill.Style = esriSFSSolid
  pArray.AddSymbol pFill
  Set pFill = New SimpleFillSymbol
  pFill.Color = RandomColor
  pFill.Style = esriSFSSolid
  pArray.AddSymbol pFill
    
End Sub

Public Function RandomColor() As IColor
  Randomize

  Set RandomColor = New RgbColor
  RandomColor.RGB = CLng((16777214) * Rnd + 1)
End Function

Public Function MakeNewRamp() As IColorRamp
  Dim pRamp As IAlgorithmicColorRamp, pColor As IColor
  Set pRamp = New AlgorithmicColorRamp
  pRamp.FromColor = RandomColor
  pRamp.ToColor = RandomColor
  pRamp.Algorithm = esriLabLChAlgorithm
  
  Set MakeNewRamp = pRamp
End Function