frmsmapsettings.frm

使用VB和ArcObject结合的程序

630:     ElseIf KeyAscii = Asc(".") Then
631:         If InStr(txtManualMapScale.Text, ".") > 0 Then
632:             KeyAscii = 0
633:         End If
634:     End If
End Sub

Public Sub Tickle()
638:     Call Form_Load
End Sub

Private Sub SetVisibleControls(iStep As Integer)
    ' Hide all
643:     fraAttributes.Visible = False
644:     fraDataFrameSize.Visible = False
645:     fraDestinationFeatureClass.Visible = False
646:     fraScaleStart.Visible = False
    ' Show applicable frame, set top/left
    Select Case iStep
        Case 0:
650:             fraDestinationFeatureClass.Visible = True
651:             fraDestinationFeatureClass.Top = 0
652:             fraDestinationFeatureClass.Left = 0
        Case 1:
654:             fraAttributes.Visible = True
655:             fraAttributes.Top = 0
656:             fraAttributes.Left = 0
        Case 2:
658:             fraScaleStart.Visible = True
659:             fraScaleStart.Top = 0
660:             fraScaleStart.Left = 0
        Case 3:
662:             fraDataFrameSize.Visible = True
663:             fraDataFrameSize.Top = 0
664:             fraDataFrameSize.Left = 0
        Case Else:
666:             MsgBox "Invalid Step Value : " & iStep
667:     End Select
End Sub

Private Sub CheckOutputFile()
    'Check the output option
672:     If txtNewGridLayer.Text <> "" Then
673:         If DoesShapeFileExist(txtNewGridLayer.Text) Then
674:             MsgBox "Shape file name already being used!!!"
675:             txtNewGridLayer.Text = ""
676:         End If
677:     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
690:     Set pNewFields = New Fields
691:     Set pFieldsEdit = pNewFields
692:     Set pMx = m_Application.Document
    ' Field: OID  -------------------------
694:     Set newField = New Field
695:     Set newFieldEdit = newField
696:     With newFieldEdit
697:         .Name = "OID"
698:         .Type = esriFieldTypeOID
699:         .AliasName = "Object ID"
700:         .IsNullable = False
701:     End With
702:     pFieldsEdit.AddField newField
    ' Field: STRIP MAP NAME -------------------------
704:     Set newField = New Field
705:     Set newFieldEdit = newField
706:     With newFieldEdit
707:       .Name = c_DefaultFld_StripMapName
708:       .AliasName = "StripMapName"
709:       .Type = esriFieldTypeString
710:       .IsNullable = True
711:       .Length = 50
712:     End With
713:     pFieldsEdit.AddField newField
    ' Field: MAP ANGLE -------------------------
715:     Set newField = New Field
716:     Set newFieldEdit = newField
717:     With newFieldEdit
718:       .Name = c_DefaultFld_MapAngle
719:       .AliasName = "Map Angle"
720:       .Type = esriFieldTypeInteger
721:       .IsNullable = True
722:     End With
723:     pFieldsEdit.AddField newField
    ' Field: GRID NUMBER -------------------------
725:     Set newField = New Field
726:     Set newFieldEdit = newField
727:     With newFieldEdit
728:       .Name = c_DefaultFld_SeriesNum
729:       .AliasName = "Number In Series"
730:       .Type = esriFieldTypeInteger
731:       .IsNullable = True
732:     End With
733:     pFieldsEdit.AddField newField
    ' Field: SCALE -------------------------
735:     Set newField = New Field
736:     Set newFieldEdit = newField
737:     With newFieldEdit
738:       .Name = c_DefaultFld_MapScale
739:       .AliasName = "Plot Scale"
740:       .Type = esriFieldTypeDouble
741:       .IsNullable = True
742:       .Precision = 18
743:       .Scale = 11
744:     End With
745:     pFieldsEdit.AddField newField
    ' Return
747:     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
762:     Set pMx = pApp.Document
763:     Set pSR = pMx.FocusMap.SpatialReference
764:     If TypeOf pSR Is IProjectedCoordinateSystem Then
765:         Set pPCS = pSR
766:         dMetersPerUnit = pPCS.CoordinateUnit.MetersPerUnit
767:     Else
768:         dMetersPerUnit = 1
769:     End If
770:     Set pPage = pMx.PageLayout.Page
771:     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:
778:             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..."
781:             CalculatePageToMapRatio = dMetersPerUnit / (1 / 12 * 0.304800609601219)
782:     End Select
    Exit Function
eh:
785:     CalculatePageToMapRatio = 1
786:     MsgBox "Error in CalculatePageToMapRatio" & vbCrLf & Err.Description
End Function

Private Function ReturnMax(dDouble1 As Double, dDouble2 As Double) As Double
790:     If dDouble1 >= dDouble2 Then
791:         ReturnMax = dDouble1
792:     Else
793:         ReturnMax = dDouble2
794:     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
811:     Set pMx = m_Application.Document
812:     Set pFC = pMx.FocusMap.FeatureSelection
813:     Set pF = pFC.Next
814:     If pF Is Nothing Then
815:         CreateStripMapPolyline = "Requires selected polyline features/s."
        Exit Function
817:     End If
    ' Make polyline
819:     Set pPolyline = New Polyline
820:     While Not pF Is Nothing
821:         If pF.Shape.GeometryType = esriGeometryPolyline Then
822:             Set pTmpPolyline = pF.ShapeCopy
823:             Set pTopoSimplify = pTmpPolyline
824:             pTopoSimplify.Simplify
825:             Set pTopoUnion = pPolyline
826:             Set pPolyline = pTopoUnion.Union(pTopoSimplify)
827:             Set pTopoSimplify = pPolyline
828:             pTopoSimplify.Simplify
829:         End If
830:         Set pF = pFC.Next
831:     Wend
    ' Check polyline for beinga single, connected polyline (Path)
833:     Set pGeoColl = pPolyline
834:     If pGeoColl.GeometryCount = 0 Then
835:         CreateStripMapPolyline = "Requires selected polyline features/s."
        Exit Function
837:     ElseIf pGeoColl.GeometryCount > 1 Then
838:         CreateStripMapPolyline = "Cannot process the StripMap - multi-part polyline created." _
            & vbCrLf & "Check for non-connected segments, overlaps or loops."
        Exit Function
841:     End If
    ' Give option to flip
843:     Perm_DrawPoint pPolyline.FromPoint, , 0, 255, 0, 20
844:     Perm_DrawTextFromPoint pPolyline.FromPoint, "START", , , , , 20
845:     Perm_DrawPoint pPolyline.ToPoint, , 255, 0, 0, 20
846:     Perm_DrawTextFromPoint pPolyline.ToPoint, "END", , , , , 20
847:     pMx.ActiveView.PartialRefresh esriViewGraphics, Nothing, Nothing
    
849:     Set m_Polyline = pPolyline
    
851:     CreateStripMapPolyline = ""
    
    Exit Function
854:     Resume
eh:
856:     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
874:     Set pMx = m_Application.Document
875:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
876:     Set pGCon = pGLayer
877:     Set pElement = New MarkerElement
878:     pElement.Geometry = pPoint
879:     Set pMarkerElement = pElement
    
    ' Set the symbol
882:     Set pColor = New RgbColor
883:     pColor.Red = dRed
884:     pColor.Green = dGreen
885:     pColor.Blue = dBlue
886:     Set pMarker = New SimpleMarkerSymbol
887:     With pMarker
888:         .Color = pColor
889:         .Size = dSize
890:     End With
891:     pMarkerElement.Symbol = pMarker
    
    ' Add the graphic
894:     Set pElementProp = pElement
895:     pElementProp.Name = sElementName
896:     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
919:     Set pMx = m_Application.Document
920:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
921:     Set pGCon = pGLayer
922:     Set pElement = New LineElement
    
    ' Set the line symbol
925:     Set pLnSym = New SimpleLineSymbol
926:     Set myColor = New RgbColor
927:     myColor.Red = dRed
928:     myColor.Green = dGreen
929:     myColor.Blue = dBlue
930:     pLnSym.Color = myColor
931:     pLnSym.Width = dSize
    
    ' Create a standard polyline (via 2 points)
934:     Set pLine1 = New esrigeometry.Line
935:     pLine1.PutCoords pFromPoint, pToPoint
936:     Set pSeg1 = pLine1
937:     Set pPolyline = New Polyline
938:     pPolyline.AddSegment pSeg1
939:     pElement.Geometry = pPolyline
940:     Set pLineElement = pElement
941:     pLineElement.Symbol = pLnSym
    
    ' Add the graphic
944:     Set pElementProp = pElement
945:     pElementProp.Name = sElementName
946:     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
964:     Set pMx = m_Application.Document
965:     Set pGLayer = pMx.FocusMap.BasicGraphicsLayer
966:     Set pGCon = pGLayer
967:     Set pElement = New TextElement
968:     pElement.Geometry = pPoint
969:     Set pTextElement = pElement
    
    ' Create the text symbol
972:     Set myTxtSym = New TextSymbol
973:     Set myColor = New RgbColor
974:     myColor.Red = dRed
975:     myColor.Green = dGreen
976:     myColor.Blue = dBlue
977:     myTxtSym.Color = myColor
978:     myTxtSym.Size = dSize
979:     myTxtSym.HorizontalAlignment = esriTHACenter
980:     pTextElement.Symbol = myTxtSym
981:     pTextElement.Text = sText
    
    ' Add the graphic
984:     Set pElementProp = pElement
985:     pElementProp.Name = sElementName
986:     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
1002:     pMxDoc.DelayUpdateContents = True
1003:     Set pGLayer = pMxDoc.FocusMap.BasicGraphicsLayer
1004:     Set pGCon = pGLayer
1005:     pGCon.Next
    
    ' Delete all the graphic elements that we created (identify by the name prefix)
1008:     pGCon.Reset
1009:     Set pElement = pGCon.Next
1010:     While Not pElement Is Nothing
1011:         If TypeOf pElement Is IElement Then
1012:             Set pElementProp = pElement
1013:             If (Left(pElementProp.Name, Len(sPrefix)) = sPrefix) Then
1014:                 pGCon.DeleteElement pElement
1015:             End If
1016:         End If
1017:         Set pElement = pGCon.Next
1018:     Wend
    
    ' Switch ON the updating of the TOC, refresh
1021:     pMxDoc.DelayUpdateContents = False
1022:     pMxDoc.ActiveView.Refresh
    
    Exit Sub
ErrorHandler:
1026:     MsgBox "Error in RemoveGraphicsByName: " & Err.Description, , "RemoveGraphicsByName"
End Sub

Private Sub txtStripMapSeriesName_Change()
1030:     SetControlsState
End Sub