'Attribute VB_Name = "Module1"
'Sub tttt()
'  Set s = ActiveProject.VBComponent.Collection.Item(1).
'  
'End Sub
'Sub rrr()
'  If ActiveMapContainer.EditedFeature Is Nothing Then
'    MsgBox "Необходимо выделить одну фигуру!"
'    Exit Sub
'  End If
'  Dim s As Double
'  Dim w As Integer
'  w = ActiveMapContainer.DistanceModelToDevice(ActiveMapContainer.EditedFeature.Bounds.Width)
'  s = 500 / w
'  i = MapSelectionColor
'  MapSelectionColor = ActiveMap.BackColor
'  Call ActiveMapContainer.MakeImage(ImageMetafile, "d:\1.emf", ActiveMapContainer.EditedFeature.Bounds, s, , 500, 500 * ActiveMapContainer.EditedFeature.Bounds.Height / ActiveMapContainer.EditedFeature.Bounds.Width, True, False, True)
'  MapSelectionColor = i
'End Sub
Sub Создание_Условных_Знаков_по_таблице_Excel()
  Const FileN = "\\INDORSOFT-DC\Документы\Переговоры 2010\Энерком,СУЭК\2010-07-09-список условных обозначений.xls"
  Const Cpath = "D:\Temp\Новая папка"
  Dim path As String
  path = InputBox("Путь к папке", "", Cpath)
  If path = "" Then Exit Sub
  Dim E As Excel.Application
  Set E = GetObject("", "Excel.Application")
  If E.ActiveSheet Is Nothing Then
    E.Workbooks.Open FileN
  End If
  E.ActiveWorkbook.SaveAs path + "\Symbols.txt", xlText, , , , , , True
  Dim r As Range
  Set r = E.Selection
  Dim Row As Long
  Row = 1
  If r Is Nothing Then
    Set r = E.ActiveSheet.UsedRange
    Row = 2
  Else
    If r.Columns.Count < 2 Then
      Set r = E.ActiveSheet.UsedRange
      Row = 2
    End If
  End If
  Dim g As GraphicLayer
  Dim p As Project
  Dim Container As MapContainer
  Set p = CreateProject
  Set Container = p.CreateMap.OpenEditor.MapContainer
  Set g = Container.Map.AddNewLayer("GraphicLayer", Container.Map.Layers)
  Container.RefreshLegends
  Dim it As ExSymbolItem
  Dim f As String
  Set it = g.PlaceItem(0)
  For i = 2 To r.Rows.Count
    it.ExFontName = r.Cells(i, 4).Value
    it.ExDrawRecord.ItemCode = r.Cells(i, 5).Value - 1
    it.ExDrawRecord.State = r.Cells(i, 6).Value - 1
    it.Position.X = 0
    it.Position.Y = 0
    it.ExDrawRecord.Size = 10
    it.UpdateBounds
    If Trim(r.Cells(i, 1).Text) = "" Then f = "0" Else f = Trim(r.Cells(i, 1).Text)
    If Trim(r.Cells(i, 2).Text) = "" Then f = f + "_0" Else f = f + "_" + Trim(r.Cells(i, 2).Text)
    w = Container.DistanceModelToDevice(it.Bounds.Width)
    s = 500 / w
    Call Container.MakeImage(ImageMetafile, path + "\" + f + ".emf", it.Bounds, s, , 500, 500 * it.Bounds.Height / it.Bounds.Width, True, False, False)
    Next i
  g.Modified = False
  p.Modified = False
  p.Close
  Set E = Nothing
End Sub
