clscreatestripmap.cls

来自「一个不错的插件」· CLS 代码 · 共 929 行 · 第 1/3 页

608:     MsgBox "Error in GenerateStripMap:" & vbCrLf & Err.Description
End Sub

Private Sub CreateGridFeaturesAsGraphics(pGridPolygon As IPolygon, lIndex As Long, dAngle As Double, pApp As IApplication)
    Dim pPntColl As IPointCollection
    Dim pArea As IArea
    Dim pCentroid As IPoint
    Dim lLoop As Long
    
    ' Create graphics (TEST PHASE)
618:     Set pPntColl = pGridPolygon
619:     For lLoop = 0 To pPntColl.PointCount - 2
620:         Perm_DrawLineFromPoints pPntColl.Point(lLoop), pPntColl.Point(lLoop + 1), pApp
621:     Next
622:     Perm_DrawLineFromPoints pPntColl.Point(0), pPntColl.Point(pPntColl.PointCount - 1), pApp
623:     Set pArea = pGridPolygon
624:     Set pCentroid = pArea.Centroid
625:     Perm_DrawTextFromPoint pCentroid, CStr(lIndex), pApp, , , , , 8
626:     pCentroid.Y = pCentroid.Y - (m_GridWidth / 3)
627:     Perm_DrawTextFromPoint pCentroid, Format(dAngle / cPI * 180, "(#0.0)"), pApp, , , , , 8

End Sub

Private Function ReturnPercentageAlong(ByVal pArc As ICurve, ByVal pPoint As IPoint) As Double
    Dim GeoCount As Long
    Dim pDistAlong As Double
    Dim pDist As Double
    Dim pRightSide As Boolean
    Dim pOutPt As IPoint
    Dim CompareDist As Double
    
    On Error GoTo ErrorHandler
    
641:     CompareDist = 0
    'Find the distance along curve
643:     Set pOutPt = New esrigeometry.Point
644:     pArc.QueryPointAndDistance esriNoExtension, pPoint, True, pOutPt, _
                        pDistAlong, pDist, pRightSide
    
647:     ReturnPercentageAlong = (pDistAlong * 100)
    Exit Function
ErrorHandler:
650:     Err.Raise Err.Number, "ReturnPercentageAlong", "Error in ReturnPercentageAlong." _
        & vbCrLf & "Err " & Err.Number & ": " & Err.Description
End Function

Private Sub CreateAngledGridPolygon(ByVal p1 As IPoint, ByVal p2 As IPoint, _
            ByRef ReturnedGrid As IPolygon, ByRef ReturnedAngleRadians As Double)
    Dim pPointColl As IPointCollection
    Dim pPointStart As IPoint
    Dim pPoint As IPoint
    Dim dAngleInRadians As Double
    Dim pLine As ILine
    
    On Error GoTo eh
    
    ' Init
665:     Set pLine = New esrigeometry.Line
666:     pLine.FromPoint = p1
667:     pLine.ToPoint = p2
668:     dAngleInRadians = pLine.Angle
669:     If dAngleInRadians = 0 Then
670:       ReturnedAngleRadians = 0
671:     ElseIf dAngleInRadians > 0 Then
672:       ReturnedAngleRadians = 360 - ((dAngleInRadians / cPI) * 180)
673:     Else
674:       ReturnedAngleRadians = Abs((dAngleInRadians / cPI) * 180)
675:     End If
676:     Set ReturnedGrid = New Polygon
677:     Set pPointColl = ReturnedGrid
    ' POINT 1 -------------------------------------------
679:     Set pPoint = New esrigeometry.Point
680:     pPoint.PutCoords p1.X + (Sin(dAngleInRadians) * (m_GridHeight / 2)), _
                     p1.Y - (Cos(dAngleInRadians) * (m_GridHeight / 2))
682:     pPointColl.AddPoint pPoint
683:     Set pPointStart = pPoint
    ' POINT 2 -------------------------------------------
685:     Set pPoint = New esrigeometry.Point
686:     pPoint.PutCoords p1.X - (Sin(dAngleInRadians) * (m_GridHeight / 2)), _
                     p1.Y + (Cos(dAngleInRadians) * (m_GridHeight / 2))
688:     pPointColl.AddPoint pPoint
    ' POINT 3 -------------------------------------------
690:     Set pPoint = New esrigeometry.Point
691:     pPoint.PutCoords p2.X - Sin(dAngleInRadians) * m_GridHeight / 2, _
                     p2.Y + Cos(dAngleInRadians) * m_GridHeight / 2
693:     pPointColl.AddPoint pPoint
    ' POINT 4 -------------------------------------------
695:     Set pPoint = New esrigeometry.Point
696:     pPoint.PutCoords p2.X + Sin(dAngleInRadians) * m_GridHeight / 2, _
                     p2.Y - Cos(dAngleInRadians) * m_GridHeight / 2
698:     pPointColl.AddPoint pPoint
    ' JOIN BACK TO FIRST (CLOSE POLYGON) ----------------
700:     pPointColl.AddPoint pPointStart
    
    Exit Sub
eh:
704:     Err.Raise Err.Number, Err.source, "Error in CreateAngledGridPolygon." _
        & "Err " & Err.Number & ": " & Err.Description
End Sub

Public Sub Perm_DrawPoint(ByVal pPoint As IPoint, Application As IApplication, _
            Optional sElementName As String = "DEMO_TEMPORARY", _
            Optional dRed As Double = 255, Optional dGreen As Double = 0, _
            Optional dBlue As Double = 0, Optional dSize As Double = 6)
' Add a permanent graphic dot on the display at the given point location
    Dim pColor As IRgbColor
    Dim pMarker As ISimpleMarkerSymbol
    Dim pGLayer As IGraphicsLayer
    Dim pGCon As IGraphicsContainer
    Dim pElement As IElement
    Dim pMarkerElement As IMarkerElement
    Dim pElementProp As IElementProperties
    Dim pMx As IMxDocument
    
    ' Init
723:     Set pMx = Application.Document
724:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
725:     Set pGCon = pGLayer
726:     Set pElement = New MarkerElement
727:     pElement.Geometry = pPoint
728:     Set pMarkerElement = pElement
    
    ' Set the symbol
731:     Set pColor = New RgbColor
732:     pColor.Red = dRed
733:     pColor.Green = dGreen
734:     pColor.Blue = dBlue
735:     Set pMarker = New SimpleMarkerSymbol
736:     With pMarker
737:         .Color = pColor
738:         .Size = dSize
739:     End With
740:     pMarkerElement.Symbol = pMarker
    
    ' Add the graphic
743:     Set pElementProp = pElement
744:     pElementProp.Name = sElementName
745:     pGCon.AddElement pElement, 0
End Sub

Public Sub Perm_DrawLineFromPoints(ByVal pFromPoint As IPoint, ByVal pToPoint As IPoint, _
            Application As IApplication, _
            Optional sElementName As String = "DEMO_TEMPORARY", _
            Optional dRed As Double = 0, Optional dGreen As Double = 0, _
            Optional dBlue As Double = 255, Optional dSize As Double = 1)
' Add a permanent graphic line on the display, using the From and To points supplied
    Dim pLnSym As ISimpleLineSymbol
    Dim pLine1 As ILine
    Dim pSeg1 As ISegment
    Dim pPolyline As ISegmentCollection
    Dim myColor As IRgbColor
    Dim pSym As ISymbol
    Dim pLineSym As ILineSymbol
    Dim pGLayer As IGraphicsLayer
    Dim pGCon As IGraphicsContainer
    Dim pElement As IElement
    Dim pLineElement As ILineElement
    Dim pElementProp As IElementProperties
    Dim pMx As IMxDocument
    
    ' Init
769:     Set pMx = Application.Document
770:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
771:     Set pGCon = pGLayer
772:     Set pElement = New LineElement
    
    ' Set the line symbol
775:     Set pLnSym = New SimpleLineSymbol
776:     Set myColor = New RgbColor
777:     myColor.Red = dRed
778:     myColor.Green = dGreen
779:     myColor.Blue = dBlue
780:     pLnSym.Color = myColor
781:     pLnSym.Width = dSize
    
    ' Create a standard polyline (via 2 points)
784:     Set pLine1 = New esrigeometry.Line
785:     pLine1.PutCoords pFromPoint, pToPoint
786:     Set pSeg1 = pLine1
787:     Set pPolyline = New Polyline
788:     pPolyline.AddSegment pSeg1
789:     pElement.Geometry = pPolyline
790:     Set pLineElement = pElement
791:     pLineElement.Symbol = pLnSym
    
    ' Add the graphic
794:     Set pElementProp = pElement
795:     pElementProp.Name = sElementName
796:     pGCon.AddElement pElement, 0
End Sub

Public Sub Perm_DrawTextFromPoint(pPoint As IPoint, sText As String, Application As IApplication, _
            Optional sElementName As String = "DEMO_TEMPORARY", _
            Optional dRed As Double = 50, Optional dGreen As Double = 50, _
            Optional dBlue As Double = 50, Optional dSize As Double = 10)
' Add permanent graphic text on the display at the given point location
    Dim myTxtSym As ITextSymbol
    Dim myColor As IRgbColor
    Dim pGLayer As IGraphicsLayer
    Dim pGCon As IGraphicsContainer
    Dim pElement As IElement
    Dim pTextElement As ITextElement
    Dim pElementProp As IElementProperties
    Dim pMx As IMxDocument
    
    ' Init
814:     Set pMx = Application.Document
815:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
816:     Set pGCon = pGLayer
817:     Set pElement = New TextElement
818:     pElement.Geometry = pPoint
819:     Set pTextElement = pElement
    
    ' Create the text symbol
822:     Set myTxtSym = New TextSymbol
823:     Set myColor = New RgbColor
824:     myColor.Red = dRed
825:     myColor.Green = dGreen
826:     myColor.Blue = dBlue
827:     myTxtSym.Color = myColor
828:     myTxtSym.Size = dSize
829:     myTxtSym.HorizontalAlignment = esriTHACenter
830:     pTextElement.Symbol = myTxtSym
831:     pTextElement.Text = sText
    
    ' Add the graphic
834:     Set pElementProp = pElement
835:     pElementProp.Name = sElementName
836:     pGCon.AddElement pElement, 0
End Sub

Public Sub RemoveGraphicsByName(pMxDoc As IMxDocument, _
            Optional sPrefix As String = "DEMO_TEMPORARY")
' Delete all graphics with our prefix from ArcScene
    Dim pElement As IElement
    Dim pElementProp As IElementProperties
    Dim sLocalPrefix As String
    Dim pGLayer As IGraphicsLayer
    Dim pGCon As IGraphicsContainer
    Dim lCount As Long
    
    On Error GoTo ErrorHandler
    
    ' Init and switch OFF the updating of the TOC
852:     pMxDoc.DelayUpdateContents = True
853:     Set pGLayer = pMxDoc.FocusMap.BasicGraphicsLayer
854:     Set pGCon = pGLayer
855:     pGCon.Next
    
    ' Delete all the graphic elements that we created (identify by the name prefix)
858:     pGCon.Reset
859:     Set pElement = pGCon.Next
860:     While Not pElement Is Nothing
861:         If TypeOf pElement Is IElement Then
862:             Set pElementProp = pElement
863:             If (Left(pElementProp.Name, Len(sPrefix)) = sPrefix) Then
864:                 pGCon.DeleteElement pElement
865:             End If
866:         End If
867:         Set pElement = pGCon.Next
868:     Wend
    
    ' Switch ON the updating of the TOC, refresh
871:     pMxDoc.DelayUpdateContents = False
872:     pMxDoc.ActiveView.Refresh
    
    Exit Sub
ErrorHandler:
876:     MsgBox "Error in RemoveGraphicsByName: " & Err.Description, , "RemoveGraphicsByName"
End Sub

Private Function IntersectPointExtendedTo(pPolyline As IPolyline, pCirclePoly As IPolygon) As IPoint
    Dim pCurve As ICurve
    Dim pLine As ILine
    Dim pPLine As IPolyline
    Dim pTopoOpt As ITopologicalOperator
    Dim pGeoCol As IGeometryCollection
    ' Need to extend the end (creates an ILine object)
886:     Set pCurve = pPolyline
887:     Set pLine = New esrigeometry.Line
888:     pCurve.QueryTangent esriExtendTangentAtTo, 1, True, _
                        CDbl(m_GridWidth) * 1.1, pLine
    ' Convert ILine to an IPolyline
891:     Set pPLine = New Polyline
892:     pPLine.FromPoint = pLine.FromPoint
893:     pPLine.ToPoint = pLine.ToPoint
    ' Intersect the polyline with the circle
895:     Set pTopoOpt = pPLine
896:     Set pGeoCol = New GeometryBag
897:     Set pGeoCol = pTopoOpt.Intersect(pCirclePoly, esriGeometry0Dimension)
898:     Set IntersectPointExtendedTo = pGeoCol.Geometry(0)
End Function

Private Function AddPathToPolyLine(pPolyline As IPolyline, pPath As IPath) As IPolyline
  Dim pGCol As IGeometryCollection
  Dim pGeom As IGeometry
    
905:   If pPolyline Is Nothing Then
906:     Set pPolyline = New Polyline
907:   End If
908:   Set pGCol = pPolyline
909:   Set pGeom = pPath
910:   pGCol.AddGeometry pGeom
911:   Set AddPathToPolyLine = pGCol

End Function