Le portail francophone de la géomatique

Dim myTxtSym As IFormattedTextSymbol

Private Sub NewAnnoClass()
  ' get a reference to the linked feature class
  Dim pWS As IWorkspace
  Dim pWSF As IWorkspaceFactory
  
  Set pWSF = New AccessWorkspaceFactory
  Set pWS = pWSF.OpenFromFile("D:\data\acsa_new.mdb", 0)
  
  Dim PFWSAnno As IFeatureWorkspaceAnno
  Set PFWSAnno = pWS
    
  Dim pFWS As IFeatureWorkspace
  Set pFWS = pWS
  
  Dim pFDataset As IFeatureDataset
  Set pFDataset = pFWS.OpenFeatureDataset("Sewer")
  
  Dim psrcFClass As IFeatureClass
  Set psrcFClass = pFWS.OpenFeatureClass("sew_str")
  
  ' set up reference scale
  Dim pGLS As IGraphicsLayerScale
  Set pGLS = New GraphicsLayerScale
  
  Dim pGeoDS As IGeoDataset
  Set pGeoDS = pFDataset
  
  pGLS.Units = esriFeet
  pGLS.ReferenceScale = 2000
  
  ' set up symbol collection
  Dim pSymbolColl As ISymbolCollection
  Set pSymbolColl = New SymbolCollection
  
  MakeText
  
  Set pSymbolColl.Symbol(0) = myTxtSym

  ' set up the annotation labeling properties including the expression
  Dim pAnnoProps As IAnnotateLayerProperties
  Set pAnnoProps = New LabelEngineLayerProperties

  
  pAnnoProps.FeatureLinked = False
  pAnnoProps.AddUnplacedToGraphicsContainer = False
  pAnnoProps.CreateUnplacedElements = True
  pAnnoProps.DisplayAnnotation = True
  pAnnoProps.UseOutput = True
  Dim aAnnoVBScriptEngine As IAnnotationExpressionEngine
  Set aAnnoVBScriptEngine = New AnnotationVBScriptEngine
  
  Dim pLELayerProps As ILabelEngineLayerProperties
  Set pLELayerProps = pAnnoProps
  Set pLELayerProps.ExpressionParser = aAnnoVBScriptEngine
  pLELayerProps.Expression = "[DESCRIPTION]"
  
  pLELayerProps.IsExpressionSimple = True
  pLELayerProps.Offset = 0
  pLELayerProps.SymbolID = 0
  Set pLELayerProps.Symbol = myTxtSym
  
  Dim pATP As IAnnotateLayerTransformationProperties
  Set pATP = pAnnoProps
  pATP.ReferenceScale = pGLS.ReferenceScale
  pATP.Units = esriFeet
  pATP.ScaleRatio = 1
  
  Dim pAnnoPropsColl As IAnnotateLayerPropertiesCollection
  Set pAnnoPropsColl = New AnnotateLayerPropertiesCollection
  pAnnoPropsColl.Add pAnnoProps

  ' use the AnnotationFeatureClassDescription co-class to get the list of required fields and the default name of the shape field
  Dim pOCDesc As IObjectClassDescription
  Set pOCDesc = New AnnotationFeatureClassDescription
  Dim pFDesc As IFeatureClassDescription
  Set pFDesc = pOCDesc

  ' create the new class
  Dim pNewClass As IFeatureClass
  Set pNewClass = PFWSAnno.CreateAnnotationClass("AnnoTest", pOCDesc.RequiredFields, pOCDesc.InstanceCLSID, pOCDesc.ClassExtensionCLSID, pFDesc.ShapeFieldName, "", pFDataset, psrcFClass, pAnnoPropsColl, pGLS, pSymbolColl, True)
  
  MsgBox "done" 
End Sub

Public Sub MakeText(
  ' helper function to create the text symbol
  Set myTxtSym = New TextSymbol
  '** Set the font for myTxtSym
  Dim myFont As IFontDisp
  Set myFont = New StdFont
  myFont.Name = "Courier New"
  myFont.Size = 9
  myTxtSym.Font = myFont
  '** Set the Color for myTxtSym to be Dark Red
  Dim myColor As IRgbColor
  Set myColor = New RgbColor
  myColor.Red = 150
  myColor.Green = 0
  myColor.Blue = 0
  myTxtSym.Color = myColor
  '** Set other properties for myTxtSym
  myTxtSym.Angle = 0
  myTxtSym.RightToLeft = False
  myTxtSym.VerticalAlignment = esriTVABaseline
  myTxtSym.HorizontalAlignment = esriTHAFull
  myTxtSym.CharacterSpacing = 200
  myTxtSym.Case = esriTCNormal
End Sub