自助形标注-Auto Label

弹出对话框输入标注...

Public Sub PlaceTextElement()Sub PlaceTextElement(ByRef anchorpt As IPoint, ByRef textpt As IPoint, strText As String, ByRef pcolor As IColor)

    Dim ptextele As ITextElement
    Set ptextele = New TextElement
    
    Dim pele As IElement
    Set pele = ptextele
       
    pele.Geometry = textpt
    
    Dim pfts As IFormattedTextSymbol
    Set pfts = New TextSymbol
    
    
    Dim pLineCallout As ILineCallout
    Set pLineCallout = New LineCallout
    
    pLineCallout.AnchorPoint = anchorpt
   
    Dim parrsym As ILineSymbol
    Set parrsym = FindArrowSymbol("Arrow at Start")
    
    parrsym.Color = pcolor
    
        
    Set pLineCallout.LeaderLine = parrsym
    
    pLineCallout.Style = esriLCSThreePoint
    
    
    Set pLineCallout.AccentBar = Nothing
    Set pLineCallout.Border = Nothing
    
    
    Set pfts.Background = pLineCallout
    pfts.Color = pcolor
    
    Dim pFontDisp As stdole.IFontDisp
    Set pFontDisp = pfts.Font
    pFontDisp.Name = "Microsoft Sans Serif"
    pFontDisp.Bold = False
    
    If Not pFontDisp Is Nothing Then
        pfts.Font = pFontDisp
    End If
    
    pfts.Size = 10
    
    ptextele.Symbol = pfts
    ptextele.Text = strText
    
     
    Dim pgc As IGraphicsContainer
    
    
    If strText = " " Then
        
        Dim pSheet As IComPropertySheet
        Set pSheet = New esriFramework.ComPropertySheet
        Dim pPset As esriSystem.ISet
        Set pPset = New esriSystem.Set
        pPset.Add ptextele
             
        Dim page As IPropertyPage
        Set page = New TextElementPropertyPage
        
        pSheet.AddCategoryID New uid
        pSheet.AddPage page
        pSheet.EditProperties pPset, 0
       
    End If
    
    Set pgc = getmxd.activeView.GraphicsContainer
    pgc.AddElement ptextele, 0
    
    getmxd.activeView.PartialRefresh esriViewGraphics, Nothing, Nothing
    
End Sub

 

Private Function FindArrowSymbol()Function FindArrowSymbol(strSymbol As String) As ILineSymbol
    Dim pStylegallery As IStyleGallery
    Set pStylegallery = getmxd.StyleGallery
    
    Dim pEnumstyle As IEnumStyleGalleryItem
    Set pEnumstyle = pStylegallery.Items("Line Symbols", "ESRI.style", "ArrowEnd") 'change the name here
    
    Dim pStyleItem As IStyleGalleryItem
    Set pStyleItem = pEnumstyle.Next
    
    pEnumstyle.Reset
    
    
    Dim pMS As ILineSymbol
    Set pMS = Nothing
    Do Until pStyleItem Is Nothing
    
        If pStyleItem.Name = strSymbol Then
            Set pMS = pStyleItem.Item
            GoTo found
        End If
    
        Set pStyleItem = pEnumstyle.Next
    Loop
found:
    Set FindArrowSymbol = pMS
End Function