clscreatestripmap.cls

使用VB和ArcObject结合的程序

590:     Screen.MousePointer = vbDefault
591:     pMx.ActiveView.Refresh
    Exit Sub
    
594:     Resume
eh:
596:     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)
606:     Set pPntColl = pGridPolygon
607:     For lLoop = 0 To pPntColl.PointCount - 2
608:         Perm_DrawLineFromPoints pPntColl.Point(lLoop), pPntColl.Point(lLoop + 1), pApp
609:     Next
610:     Perm_DrawLineFromPoints pPntColl.Point(0), pPntColl.Point(pPntColl.PointCount - 1), pApp
611:     Set pArea = pGridPolygon
612:     Set pCentroid = pArea.Centroid
613:     Perm_DrawTextFromPoint pCentroid, CStr(lIndex), pApp, , , , , 8
614:     pCentroid.Y = pCentroid.Y - (m_GridWidth / 3)
615:     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
    
629:     CompareDist = 0
    'Find the distance along curve
631:     Set pOutPt = New esrigeometry.Point
632:     pArc.QueryPointAndDistance esriNoExtension, pPoint, True, pOutPt, _
                        pDistAlong, pDist, pRightSide
    
635:     ReturnPercentageAlong = (pDistAlong * 100)
    Exit Function
ErrorHandler:
638:     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
653:     Set pLine = New esrigeometry.Line
654:     pLine.FromPoint = p1
655:     pLine.ToPoint = p2
656:     dAngleInRadians = pLine.Angle
657:     If dAngleInRadians = 0 Then
658:       ReturnedAngleRadians = 0
659:     ElseIf dAngleInRadians > 0 Then
660:       ReturnedAngleRadians = 360 - ((dAngleInRadians / cPI) * 180)
661:     Else
662:       ReturnedAngleRadians = Abs((dAngleInRadians / cPI) * 180)
663:     End If
664:     Set ReturnedGrid = New Polygon
665:     Set pPointColl = ReturnedGrid
    ' POINT 1 -------------------------------------------
667:     Set pPoint = New esrigeometry.Point
668:     pPoint.PutCoords p1.X + (Sin(dAngleInRadians) * (m_GridHeight / 2)), _
                     p1.Y - (Cos(dAngleInRadians) * (m_GridHeight / 2))
670:     pPointColl.AddPoint pPoint
671:     Set pPointStart = pPoint
    ' POINT 2 -------------------------------------------
673:     Set pPoint = New esrigeometry.Point
674:     pPoint.PutCoords p1.X - (Sin(dAngleInRadians) * (m_GridHeight / 2)), _
                     p1.Y + (Cos(dAngleInRadians) * (m_GridHeight / 2))
676:     pPointColl.AddPoint pPoint
    ' POINT 3 -------------------------------------------
678:     Set pPoint = New esrigeometry.Point
679:     pPoint.PutCoords p2.X - Sin(dAngleInRadians) * m_GridHeight / 2, _
                     p2.Y + Cos(dAngleInRadians) * m_GridHeight / 2
681:     pPointColl.AddPoint pPoint
    ' POINT 4 -------------------------------------------
683:     Set pPoint = New esrigeometry.Point
684:     pPoint.PutCoords p2.X + Sin(dAngleInRadians) * m_GridHeight / 2, _
                     p2.Y - Cos(dAngleInRadians) * m_GridHeight / 2
686:     pPointColl.AddPoint pPoint
    ' JOIN BACK TO FIRST (CLOSE POLYGON) ----------------
688:     pPointColl.AddPoint pPointStart
    
    Exit Sub
eh:
692:     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
711:     Set pMx = Application.Document
712:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
713:     Set pGCon = pGLayer
714:     Set pElement = New MarkerElement
715:     pElement.Geometry = pPoint
716:     Set pMarkerElement = pElement
    
    ' Set the symbol
719:     Set pColor = New RgbColor
720:     pColor.Red = dRed
721:     pColor.Green = dGreen
722:     pColor.Blue = dBlue
723:     Set pMarker = New SimpleMarkerSymbol
724:     With pMarker
725:         .Color = pColor
726:         .Size = dSize
727:     End With
728:     pMarkerElement.Symbol = pMarker
    
    ' Add the graphic
731:     Set pElementProp = pElement
732:     pElementProp.Name = sElementName
733:     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
757:     Set pMx = Application.Document
758:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
759:     Set pGCon = pGLayer
760:     Set pElement = New LineElement
    
    ' Set the line symbol
763:     Set pLnSym = New SimpleLineSymbol
764:     Set myColor = New RgbColor
765:     myColor.Red = dRed
766:     myColor.Green = dGreen
767:     myColor.Blue = dBlue
768:     pLnSym.Color = myColor
769:     pLnSym.Width = dSize
    
    ' Create a standard polyline (via 2 points)
772:     Set pLine1 = New esrigeometry.Line
773:     pLine1.PutCoords pFromPoint, pToPoint
774:     Set pSeg1 = pLine1
775:     Set pPolyline = New Polyline
776:     pPolyline.AddSegment pSeg1
777:     pElement.Geometry = pPolyline
778:     Set pLineElement = pElement
779:     pLineElement.Symbol = pLnSym
    
    ' Add the graphic
782:     Set pElementProp = pElement
783:     pElementProp.Name = sElementName
784:     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
802:     Set pMx = Application.Document
803:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
804:     Set pGCon = pGLayer
805:     Set pElement = New TextElement
806:     pElement.Geometry = pPoint
807:     Set pTextElement = pElement
    
    ' Create the text symbol
810:     Set myTxtSym = New TextSymbol
811:     Set myColor = New RgbColor
812:     myColor.Red = dRed
813:     myColor.Green = dGreen
814:     myColor.Blue = dBlue
815:     myTxtSym.Color = myColor
816:     myTxtSym.Size = dSize
817:     myTxtSym.HorizontalAlignment = esriTHACenter
818:     pTextElement.Symbol = myTxtSym
819:     pTextElement.Text = sText
    
    ' Add the graphic
822:     Set pElementProp = pElement
823:     pElementProp.Name = sElementName
824:     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
840:     pMxDoc.DelayUpdateContents = True
841:     Set pGLayer = pMxDoc.FocusMap.BasicGraphicsLayer
842:     Set pGCon = pGLayer
843:     pGCon.Next
    
    ' Delete all the graphic elements that we created (identify by the name prefix)
846:     pGCon.Reset
847:     Set pElement = pGCon.Next
848:     While Not pElement Is Nothing
849:         If TypeOf pElement Is IElement Then
850:             Set pElementProp = pElement
851:             If (Left(pElementProp.Name, Len(sPrefix)) = sPrefix) Then
852:                 pGCon.DeleteElement pElement
853:             End If
854:         End If
855:         Set pElement = pGCon.Next
856:     Wend
    
    ' Switch ON the updating of the TOC, refresh
859:     pMxDoc.DelayUpdateContents = False
860:     pMxDoc.ActiveView.Refresh
    
    Exit Sub
ErrorHandler:
864:     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)
874:     Set pCurve = pPolyline
875:     Set pLine = New esrigeometry.Line
876:     pCurve.QueryTangent esriExtendTangentAtTo, 1, True, _
                        CDbl(m_GridWidth) * 1.1, pLine
    ' Convert ILine to an IPolyline
879:     Set pPLine = New Polyline
880:     pPLine.FromPoint = pLine.FromPoint
881:     pPLine.ToPoint = pLine.ToPoint
    ' Intersect the polyline with the circle
883:     Set pTopoOpt = pPLine
884:     Set pGeoCol = New GeometryBag
885:     Set pGeoCol = pTopoOpt.Intersect(pCirclePoly, esriGeometry0Dimension)
886:     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
    
893:   If pPolyline Is Nothing Then
894:     Set pPolyline = New Polyline
895:   End If
896:   Set pGCol = pPolyline
897:   Set pGeom = pPath
898:   pGCol.AddGeometry pGeom
899:   Set AddPathToPolyLine = pGCol

End Function