Sub Example_TrueColorImages()
    'Этот пример читает и изменяет значение параметра, которое определяет, показаны ли 
    'растровые и тонированные изображения в TrueColor или пакетированном цвете.
    'Когда закончено, этот пример сбрасывает значение параметра.
    '
    'Этот пример использует "watch.jpg" найденный в типовом каталоге. 
    'Если Вы не имеете этого изображения или оно расположено в другом каталоге, 
    'вставьте допустимый путь и имя файла для переменной imageName ниже.
    
    Dim ACADPref As AcadPreferencesDisplay
    Dim originalValue As Variant, newValue As Variant
    Dim insertionPoint(0 To 2) As Double
    Dim scalefactor As Double, rotationAngle As Double
    Dim imageName As String
    Dim rasterObj As AcadRasterImage
    
    imageName = "c:\program files\autocad\sample\watch.jpg"
    
    'Определите объект Raster
    insertionPoint(0) = 5: insertionPoint(1) = 5: insertionPoint(2) = 0
    scalefactor = 5#: rotationAngle = 0
    
    On Error GoTo ERRORTRAP
    
    'Загружает растровое изображение в пространство модели
    Set rasterObj = ThisDrawing.ModelSpace.AddRaster(imageName, insertionPoint, scalefactor, rotationAngle)
    ThisDrawing.Application.ZoomAll
    
    'Получите объект параметров отображения
    Set ACADPref = ThisDrawing.Application.preferences.DISPLAY
    
    'Читайте и показывайте оригинальное значение
    originalValue = ACADPref.TrueColorImages
    MsgBox "Параметр TrueColorImages: " & originalValue

    'Измените параметр TrueColorImages, переключая значение
    ACADPref.TrueColorImages = Not (originalValue)
    newValue = ACADPref.TrueColorImages
    ThisDrawing.Regen acAllViewports
    
    MsgBox "Параметр TrueColorImages теперь: " & newValue

    'Сбросьте параметр
    '
    '* Примечание: Прокомментируйте этот последний раздел, чтобы оставить
    ' изменение этому параметру
    ACADPref.TrueColorImages = originalValue
    ThisDrawing.Regen acAllViewports
    
    MsgBox "Параметр TrueColorImages был сброшен назад к: " & originalValue

    Exit Sub
    
    'Если Вы получили ошибку (наиболее вероятно проблема с путем к файлу), 
    ' покажите сообщение об ошибках
ERRORTRAP:
    If Err.Description <> "" Then
        MsgBox Err.Description
    End If
End Sub

Сайт управляется системой uCoz