frmsmapsettings.frm

一个不错的插件

646:     End If
End Sub

Public Sub Tickle()
650:     Call Form_Load
End Sub

Private Sub SetVisibleControls(iStep As Integer)
    ' Hide all
655:     fraAttributes.Visible = False
656:     fraDataFrameSize.Visible = False
657:     fraDestinationFeatureClass.Visible = False
658:     fraScaleStart.Visible = False
    ' Show applicable frame, set top/left
    Select Case iStep
        Case 0:
662:             fraDestinationFeatureClass.Visible = True
663:             fraDestinationFeatureClass.Top = 0
664:             fraDestinationFeatureClass.Left = 0
        Case 1:
666:             fraAttributes.Visible = True
667:             fraAttributes.Top = 0
668:             fraAttributes.Left = 0
        Case 2:
670:             fraScaleStart.Visible = True
671:             fraScaleStart.Top = 0
672:             fraScaleStart.Left = 0
        Case 3:
674:             fraDataFrameSize.Visible = True
675:             fraDataFrameSize.Top = 0
676:             fraDataFrameSize.Left = 0
        Case Else:
678:             MsgBox "Invalid Step Value : " & iStep
679:     End Select
End Sub

Private Sub CheckOutputFile()
    'Check the output option
684:     If txtNewGridLayer.Text <> "" Then
685:         If DoesShapeFileExist(txtNewGridLayer.Text) Then
686:             MsgBox "Shape file name already being used!!!"
687:             txtNewGridLayer.Text = ""
688:         End If
689:     End If
End Sub

Private Function CreateTheFields() As IFields
    Dim newField As IField
    Dim newFieldEdit As IFieldEdit
    Dim pNewFields As IFields
    Dim pFieldsEdit As IFieldsEdit
    Dim pGeomDef As IGeometryDef
    Dim pGeomDefEdit As IGeometryDefEdit
    Dim pMx As IMxDocument
    
    ' Init
702:     Set pNewFields = New Fields
703:     Set pFieldsEdit = pNewFields
704:     Set pMx = m_Application.Document
    ' Field: OID  -------------------------
706:     Set newField = New Field
707:     Set newFieldEdit = newField
708:     With newFieldEdit
709:         .Name = "OID"
710:         .Type = esriFieldTypeOID
711:         .AliasName = "Object ID"
712:         .IsNullable = False
713:     End With
714:     pFieldsEdit.AddField newField
    ' Field: STRIP MAP NAME -------------------------
716:     Set newField = New Field
717:     Set newFieldEdit = newField
718:     With newFieldEdit
719:       .Name = c_DefaultFld_StripMapName
720:       .AliasName = "StripMapName"
721:       .Type = esriFieldTypeString
722:       .IsNullable = True
723:       .length = 50
724:     End With
725:     pFieldsEdit.AddField newField
    ' Field: MAP ANGLE -------------------------
727:     Set newField = New Field
728:     Set newFieldEdit = newField
729:     With newFieldEdit
730:       .Name = c_DefaultFld_MapAngle
731:       .AliasName = "Map Angle"
732:       .Type = esriFieldTypeInteger
733:       .IsNullable = True
734:     End With
735:     pFieldsEdit.AddField newField
    ' Field: GRID NUMBER -------------------------
737:     Set newField = New Field
738:     Set newFieldEdit = newField
739:     With newFieldEdit
740:       .Name = c_DefaultFld_SeriesNum
741:       .AliasName = "Number In Series"
742:       .Type = esriFieldTypeInteger
743:       .IsNullable = True
744:     End With
745:     pFieldsEdit.AddField newField
    ' Field: SCALE -------------------------
747:     Set newField = New Field
748:     Set newFieldEdit = newField
749:     With newFieldEdit
750:       .Name = c_DefaultFld_MapScale
751:       .AliasName = "Plot Scale"
752:       .Type = esriFieldTypeDouble
753:       .IsNullable = True
754:       .Precision = 18
755:       .Scale = 11
756:     End With
757:     pFieldsEdit.AddField newField
    ' Return
759:     Set CreateTheFields = pFieldsEdit
End Function

Private Function CalculatePageToMapRatio(pApp As IApplication) As Double
    Dim pMx As IMxDocument
    Dim pPage As IPage
    Dim pPageUnits As esriUnits
    Dim pSR As ISpatialReference
    Dim pSRI As ISpatialReferenceInfo
    Dim pPCS As IProjectedCoordinateSystem
    Dim dMetersPerUnit As Double
    
    On Error GoTo eh
    
    ' Init
774:     Set pMx = pApp.Document
775:     Set pSR = pMx.FocusMap.SpatialReference
776:     If TypeOf pSR Is IProjectedCoordinateSystem Then
777:         Set pPCS = pSR
778:         dMetersPerUnit = pPCS.CoordinateUnit.MetersPerUnit
779:     Else
780:         dMetersPerUnit = 1
781:     End If
782:     Set pPage = pMx.PageLayout.Page
783:     pPageUnits = pPage.Units
    Select Case pPageUnits
        Case esriInches: CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
        Case esriFeet: CalculatePageToMapRatio = dMetersPerUnit / (0.304800609601219)
        Case esriCentimeters: CalculatePageToMapRatio = dMetersPerUnit / (1 / 100)
        Case esriMeters: CalculatePageToMapRatio = dMetersPerUnit / (1)
        Case Else:
790:             MsgBox "Warning: Only the following Page (Layout) Units are supported by this tool:" _
                & vbCrLf & " - Inches, Feet, Centimeters, Meters" _
                & vbCrLf & vbCrLf & "Calculating as though Page Units are in Inches..."
793:             CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
794:     End Select
    Exit Function
eh:
797:     CalculatePageToMapRatio = 1
798:     MsgBox "Error in CalculatePageToMapRatio" & vbCrLf & Err.Description
End Function

Private Function ReturnMax(dDouble1 As Double, dDouble2 As Double) As Double
802:     If dDouble1 >= dDouble2 Then
803:         ReturnMax = dDouble1
804:     Else
805:         ReturnMax = dDouble2
806:     End If
End Function

Private Function CreateStripMapPolyline() As String
    Dim pMx As IMxDocument
    Dim pFL As IFeatureLayer
    Dim pFC As IEnumFeature
    Dim pF As IFeature
    Dim pPolyline As IPolyline
    Dim pTmpPolyline As IPolyline
    Dim pTopoSimplify As ITopologicalOperator
    Dim pTopoUnion As ITopologicalOperator
    Dim pGeoColl As IGeometryCollection
    
    On Error GoTo eh
    
    ' Init
823:     Set pMx = m_Application.Document
824:     Set pFC = pMx.FocusMap.FeatureSelection
825:     Set pF = pFC.Next
826:     If pF Is Nothing Then
827:         CreateStripMapPolyline = "Requires selected polyline features/s."
        Exit Function
829:     End If
    ' Make polyline
831:     Set pPolyline = New Polyline
832:     While Not pF Is Nothing
833:         If pF.Shape.GeometryType = esriGeometryPolyline Then
834:             Set pTmpPolyline = pF.ShapeCopy
835:             Set pTopoSimplify = pTmpPolyline
836:             pTopoSimplify.Simplify
837:             Set pTopoUnion = pPolyline
838:             Set pPolyline = pTopoUnion.Union(pTopoSimplify)
839:             Set pTopoSimplify = pPolyline
840:             pTopoSimplify.Simplify
841:         End If
842:         Set pF = pFC.Next
843:     Wend
    ' Check polyline for beinga single, connected polyline (Path)
845:     Set pGeoColl = pPolyline
846:     If pGeoColl.GeometryCount = 0 Then
847:         CreateStripMapPolyline = "Requires selected polyline features/s."
        Exit Function
849:     ElseIf pGeoColl.GeometryCount > 1 Then
850:         CreateStripMapPolyline = "Cannot process the StripMap - multi-part polyline created." _
            & vbCrLf & "Check for non-connected segments, overlaps or loops."
        Exit Function
853:     End If
    ' Give option to flip
855:     Perm_DrawPoint pPolyline.FromPoint, , 0, 255, 0, 20
856:     Perm_DrawTextFromPoint pPolyline.FromPoint, "START", , , , , 20
857:     Perm_DrawPoint pPolyline.ToPoint, , 255, 0, 0, 20
858:     Perm_DrawTextFromPoint pPolyline.ToPoint, "END", , , , , 20
859:     pMx.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
    
861:     Set m_Polyline = pPolyline
    
863:     CreateStripMapPolyline = ""
    
    Exit Function
866:     Resume
eh:
868:     CreateStripMapPolyline = "Error in CreateStripMapPolyline : " & Err.Description
End Function

Public Sub Perm_DrawPoint(ByVal pPoint As IPoint, _
            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
886:     Set pMx = m_Application.Document
887:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
888:     Set pGCon = pGLayer
889:     Set pElement = New MarkerElement
890:     pElement.Geometry = pPoint
891:     Set pMarkerElement = pElement
    
    ' Set the symbol
894:     Set pColor = New RgbColor
895:     pColor.Red = dRed
896:     pColor.Green = dGreen
897:     pColor.Blue = dBlue
898:     Set pMarker = New SimpleMarkerSymbol
899:     With pMarker
900:         .Color = pColor
901:         .Size = dSize
902:     End With
903:     pMarkerElement.Symbol = pMarker
    
    ' Add the graphic
906:     Set pElementProp = pElement
907:     pElementProp.Name = sElementName
908:     pGCon.AddElement pElement, 0
End Sub

Public Sub Perm_DrawLineFromPoints(ByVal pFromPoint As IPoint, ByVal pToPoint As IPoint, _
            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
931:     Set pMx = m_Application.Document
932:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
933:     Set pGCon = pGLayer
934:     Set pElement = New LineElement
    
    ' Set the line symbol
937:     Set pLnSym = New SimpleLineSymbol
938:     Set myColor = New RgbColor
939:     myColor.Red = dRed
940:     myColor.Green = dGreen
941:     myColor.Blue = dBlue
942:     pLnSym.Color = myColor
943:     pLnSym.Width = dSize
    
    ' Create a standard polyline (via 2 points)
946:     Set pLine1 = New esrigeometry.Line
947:     pLine1.PutCoords pFromPoint, pToPoint
948:     Set pSeg1 = pLine1
949:     Set pPolyline = New Polyline
950:     pPolyline.AddSegment pSeg1
951:     pElement.Geometry = pPolyline
952:     Set pLineElement = pElement
953:     pLineElement.Symbol = pLnSym
    
    ' Add the graphic
956:     Set pElementProp = pElement
957:     pElementProp.Name = sElementName
958:     pGCon.AddElement pElement, 0
End Sub

Public Sub Perm_DrawTextFromPoint(pPoint As IPoint, sText As String, _
            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
976:     Set pMx = m_Application.Document
977:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
978:     Set pGCon = pGLayer
979:     Set pElement = New TextElement
980:     pElement.Geometry = pPoint
981:     Set pTextElement = pElement
    
    ' Create the text symbol
984:     Set myTxtSym = New TextSymbol
985:     Set myColor = New RgbColor
986:     myColor.Red = dRed
987:     myColor.Green = dGreen
988:     myColor.Blue = dBlue
989:     myTxtSym.Color = myColor
990:     myTxtSym.Size = dSize
991:     myTxtSym.HorizontalAlignment = esriTHACenter
992:     pTextElement.Symbol = myTxtSym
993:     pTextElement.Text = sText
    
    ' Add the graphic
996:     Set pElementProp = pElement
997:     pElementProp.Name = sElementName
998:     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
1014:     pMxDoc.DelayUpdateContents = True
1015:     Set pGLayer = pMxDoc.FocusMap.BasicGraphicsLayer
1016:     Set pGCon = pGLayer
1017:     pGCon.Next
    
    ' Delete all the graphic elements that we created (identify by the name prefix)
1020:     pGCon.Reset
1021:     Set pElement = pGCon.Next
1022:     While Not pElement Is Nothing
1023:         If TypeOf pElement Is IElement Then
1024:             Set pElementProp = pElement
1025:             If (Left(pElementProp.Name, Len(sPrefix)) = sPrefix) Then
1026:                 pGCon.DeleteElement pElement
1027:             End If
1028:         End If
1029:         Set pElement = pGCon.Next
1030:     Wend
    
    ' Switch ON the updating of the TOC, refresh
1033:     pMxDoc.DelayUpdateContents = False
1034:     pMxDoc.ActiveView.Refresh
    
    Exit Sub
ErrorHandler:
1038:     MsgBox "Error in RemoveGraphicsByName: " & Err.Description, , "RemoveGraphicsByName"
End Sub

Private Sub txtStripMapSeriesName_Change()
1042:     SetControlsState
End Sub