Сохранение растрового формата

[userascon2]

Кто программировал в VB6 следующую команду " ksDocument2D.ksSaveAsToRasterFormat ", сбросьте пожалуйста ее полный текст с параметрами (всю строку), использую как пример. А то по хэлпу завел какие-то значения параметров

ksDocument2D.ksSaveAsToRasterFormat "f:\11.jpg", 2, 8, 0, 0, 1, 0, 0, 0, 0

и выдается ошибка, а в чем ошибка состоит не выводится.

Заранее благодарю.

[olden]

держи:
Dim iDoc2D As Kompas6API5.Document2D
Set iDoc2D = iKompasObject.ActiveDocument2D
If iDoc2D Is Nothing Then Exit Sub
  Dim iRastFormatParam As Kompas6API5.RasterFormatParam
  Set iRastFormatParam = iDoc2D.RasterFormatParam
  If iRastFormatParam Is Nothing Then Exit Sub
    iRastFormatParam.init
    iRastFormatParam.Format = FORMAT_BMP
    iRastFormatParam.colorBPP = BPP_COLOR_08
    iRastFormatParam.greyScale = False
    iRastFormatParam.extResolution = 0
    iRastFormatParam.extScale = 1
    iRastFormatParam.colorType = COLORVIEW
    iRastFormatParam.onlyThinLine = False
    If iDoc2D.SaveAsToRasterFormat(App.path & "\1.bmp", iRastFormatParam) = False Then
      iKompasObject.ksMessage "Документ не сохранен"
    End If

[olden]

Если разберешся с этой командой полностью, то пришли исходник (с участием этой команды) как пример ее использования на топик "Исходники, описания, примеры". Не обязательно всю свою  библиотеку, а достаточно при каких условиях эта команда не работает, при каких условиях - работает и так далее и тому подобное. Пожалуйста. The Best Regards Olden.

[userascon2]

Текст получил, только чуть подправил шапочку :

Dim ksDocument2D As Object
Set ksDocument2D = Kompas.ActiveDocument2D
If ksDocument2D Is Nothing Then Exit Sub
  Dim iRastFormatParam As Kompas6API5.RasterFormatParam
  Set iRastFormatParam = ksDocument2D.RasterFormatParam
  If iRastFormatParam Is Nothing Then Exit Sub
    iRastFormatParam.Init
    iRastFormatParam.Format = FORMAT_BMP
    iRastFormatParam.colorBPP = BPP_COLOR_08
    iRastFormatParam.greyScale = False
    iRastFormatParam.extResolution = 0
    iRastFormatParam.extScale = 1
    iRastFormatParam.colorType = COLORVIEW
    iRastFormatParam.onlyThinLine = False
    If ksDocument2D.SaveAsToRasterFormat(App.Path & "\1.bmp", iRastFormatParam) = False Then
      ksDocument2D.ksMessage "Документ не сохранен"
    End If

и работает !! огромное СПАСИБО.

осталось параметры немного подстроить под свою задачу, готовую программку с описанием позднее вышлю, как только сделаю.

Au revoir.

[userascon2]

дело тормознулось, cdw файлы сохраняет нормально по вышеописанной схеме, а вот файлы спецификации не хочет обрабатывать, т.е. пока забросил это дело, потом вернусь к этому вопросу, и программку отлаженную представлю.
почему не хочет сохранять в растровом формате спецификации, не знаю, может кто подскажет параметры сохранения какие надо в команду включать ?
Au revoir.

[olden]

Для того чтоб сохранить документ "спецификация" надо указать, что сохранять мы будем спецификацию. Схема сохранения в растр остается таже (смотри выше), только с маленькими изменениями.

Dim ksDocument2D As Object
Set ksDocument2D = Kompas.SpcActiveDocument ' в этой строке указывается тип документа который надо сохранить
                                                                       ' будь-то чертеж, спецификация, текстовый или 3D документы
                                                                       ' смотри ksSaveAsToRasterFormat
If ksDocument2D Is Nothing Then Exit Sub
  Dim iRastFormatParam As Kompas6API5.RasterFormatParam
  Set iRastFormatParam = ksDocument2D.RasterFormatParam
  If iRastFormatParam Is Nothing Then Exit Sub
    iRastFormatParam.Init
    iRastFormatParam.Format = FORMAT_BMP
    iRastFormatParam.colorBPP = BPP_COLOR_08
    iRastFormatParam.greyScale = False
    iRastFormatParam.extResolution = 0
    iRastFormatParam.extScale = 1
    iRastFormatParam.colorType = COLORVIEW
    iRastFormatParam.onlyThinLine = False
    If ksDocument2D.SaveAsToRasterFormat(App.Path & "\1.bmp", iRastFormatParam) = False Then
      ksDocument2D.ksMessage "Документ не сохранен"
    End If

[userascon2]

Как оказалось просто, всего то изменить Set ksDocument2D = Kompas.ActiveDocument2D на Set ksDocument2D = Kompas.SpcActiveDocument, честно говоря я перебирал параметры, выдумывал новые. Сейчас все получилось (спецификации сохраняются в gif файлах), позднее дооформлю программку и скину в форум, как освобожусь от срочной работы.
Огромное СПАСИБО.
Au revoir.

[olden]

Удачи. И с нетерпение ждем программку. Если что обращайся. Чем смогу тем помогу. Или будем разбираться вместе.

The Best Regards Olden.

[userascon2]

Погоняли программу с контсрукторами, вроде все работает, сохраняет картинки. Они в восторге, не надо вручную это делать.
Здесь я сбросил, как обещал, полный текст программы файлов frm и bas.
mm - это менюшные функции, их как бы надо создать :
mm1- запустить процесс
mm21(0) - нормальный режим  (1) - полный режим  (2) - минимальный режим загрузки, октрытия, сохранения, выгрузки
mm0 - выход
mm31 и mm32 - параметры
и надо создать dir1, drive1, file1 (spw и cdw файлы), file2 (gif - файлы) элементы

если не получится, дайте email адрес, я туда вышлю оригиналы vbp, frm, bas файлов программы, а вы как надо распространите

savejpg.frm :

Option Explicit

' Общие переменные программы :
Dim Kompas As Object
Dim sff1 As String, sff2 As String, sff0 As String
Dim pff1 As String, pff2 As String
Dim ppff1 As Integer
Dim tff1 As Long

Private Sub cm1() 'сохраняет изменения документа компаса
 If Not Kompas Is Nothing Then
   Dim ksDocument2D As Object
   Set ksDocument2D = Kompas.ActiveDocument2D
   If Not ksDocument2D Is Nothing Then
     ksDocument2D.ksSaveDocument ""
   End If
 End If
End Sub

Private Sub cm2() 'Загрузка графики компаса и создание объекта
 If Kompas Is Nothing Then
   Set Kompas = CreateObject("KOMPAS.Application.5")
   If Not Kompas Is Nothing Then
     Kompas.Visible = True
   End If
   End If
End Sub

Private Sub cm3() 'Открытие графики компаса и объекта
If Kompas Is Nothing Then
   Set Kompas = GetObject(, "KOMPAS.Application.5")
   If Not Kompas Is Nothing Then
     Kompas.Visible = True
     Kompas.ActivateControllerAPI
   End If
 End If
End Sub

Private Sub cm5() 'закрывает документ компаса
If Not Kompas Is Nothing Then
   Dim ksDocument2D As Object
   Set ksDocument2D = Kompas.ActiveDocument2D
   If Not ksDocument2D Is Nothing Then
     ksDocument2D.ksCloseDocument
   End If
 End If
End Sub

Private Sub cm6() ' выгружает графику и объект компаса
If Not Kompas Is Nothing Then
 Kompas.Quit
 Set Kompas = Nothing
 End If
End Sub

Private Sub Form_DblClick()
MsgBox "Программа бесплатная и свободная для распространения / октябрь-декабрь 2006 / D K", vbExclamation, "Для тех, кто работает в компасе и сохраняет gif-файлы чертежей"
End Sub

Private Sub Form_Load()
pff1 = 1
pff2 = 150
savejpg.Caption = "Программа сохранения рисунка " & pff2 & " точек/дюйм, " & pff1 & " цвет"
End Sub

Private Sub mm0_Click()
Unload Me
Set savejpg = Nothing
End Sub

Private Sub mm1_Click()
tff1 = Timer()
sff0 = Dir1.Path
If mm21(1).Checked = False Then cm2
sff2 = Dir$(sff0 & "\*.cdw")
Do While Len(sff2) > 0
     If sff2 <> "" Then
     sff1 = sff0 & "\" & sff2
If mm21(1).Checked = True Then cm2
cm3
If Not Kompas Is Nothing Then
loadfile1
savejpg1
If mm21(0).Checked = True Then cm1
cm5
If mm21(1).Checked = True Then cm6
End If
End If
sff2 = Dir()
Loop
sff2 = Dir$(sff0 & "\*.spw")
Do While Len(sff2) > 0
     If sff2 <> "" Then
     sff1 = sff0 & "\" & sff2
If mm21(1).Checked = True Then cm2
cm3
If Not Kompas Is Nothing Then
loadfile1
savejpg2
If mm21(0).Checked = True Then cm1
cm5
If mm21(1).Checked = True Then cm6
End If
End If
sff2 = Dir()
Loop
If mm21(1).Checked = False Then cm6
File1.Refresh
File2.Refresh
cm6
MsgBox "Процесс создания gif файлов завершен", vbInformation, "Затрачено " & Round((Timer() - tff1), 0) & " сек"
End Sub

Public Sub savejpg1()
Dim sff3 As String
sff3 = Left(sff2, Len(sff2) - 3)
Dim ksDocument2D As Object
Set ksDocument2D = Kompas.ActiveDocument2D
If ksDocument2D Is Nothing Then Exit Sub
  Dim iRastFormatParam As Kompas6API5.RasterFormatParam
 Set iRastFormatParam = ksDocument2D.RasterFormatParam
 If iRastFormatParam Is Nothing Then Exit Sub
   iRastFormatParam.Init
   iRastFormatParam.Format = FORMAT_GIF
   iRastFormatParam.colorBPP = pff1  'BPP_COLOR_01 сколько цветов
   iRastFormatParam.greyScale = 0 '0 - цветное изображение
   iRastFormatParam.extResolution = pff2  '150 точек на дюйм
   iRastFormatParam.extScale = 1
   iRastFormatParam.colorType = COLOROBJECT
   iRastFormatParam.onlyThinLine = False
   If ksDocument2D.SaveAsToRasterFormat(sff0 & "\" & sff3 & "gif", iRastFormatParam) = False Then
     ksDocument2D.ksMessage "Документ не сохранен"
   End If
End Sub

Public Sub savejpg2()
Dim sff3 As String
sff3 = Left(sff2, Len(sff2) - 3)
Dim ksDocument2D As Object
Set ksDocument2D = Kompas.SpcActiveDocument
If ksDocument2D Is Nothing Then Exit Sub
  Dim iRastFormatParam As Kompas6API5.RasterFormatParam
 Set iRastFormatParam = ksDocument2D.RasterFormatParam
 If iRastFormatParam Is Nothing Then Exit Sub
   iRastFormatParam.Init
   iRastFormatParam.Format = FORMAT_GIF
   iRastFormatParam.colorBPP = pff1  'BPP_COLOR_01
   iRastFormatParam.greyScale = 0 '0 - цветное изображение
   iRastFormatParam.extResolution = pff2  '150
   iRastFormatParam.extScale = 1
   iRastFormatParam.colorType = COLOROBJECT
   iRastFormatParam.onlyThinLine = False
   iRastFormatParam.multiPageOutput = 0
   If ksDocument2D.SaveAsToRasterFormat(sff0 & "\" & sff3 & "gif", iRastFormatParam) = False Then
     ksDocument2D.ksMessage "Документ не сохранен"
   End If
End Sub

Public Sub loadfile1()
       Dim docType As Integer
       docType = Kompas.ksGetDocumentTypeByName(sff1)
       Select Case docType
         Case lt_DocPart3D, lt_DocAssemble3D
           Dim ksDocument3D As Object
           Set ksDocument3D = Kompas.Document3D
           ksDocument3D.Open sff1, 0
         Case lt_DocSheetStandart, lt_DocFragment
           Dim ksDocument2D As Object
           Set ksDocument2D = Kompas.Document2D
           ksDocument2D.ksOpenDocument sff1, False
         Case lt_DocSpc, lt_DocSpcUser
           Dim ksSpcDocument As Object
           Set ksSpcDocument = Kompas.SpcDocument
           ksSpcDocument.ksOpenDocument sff1, False
         Case lt_DocTxtStandart
           Dim ksDocumentTxt As Object
           ksDocumentTxt = Kompas.DocumentTxt
           ksDocumentTxt.ksOpenDocument sff1, False
       End Select
       Dim err As Integer
       err = Kompas.ksReturnResult
       If err Then
         Kompas.MassageBoxResult
         Kompas.ResultNULL
         End If
End Sub

Private Sub Dir1_Change()
sff0 = Dir1.Path
File1.Path = Dir1.Path
File2.Path = Dir1.Path
ChDir Dir1.Path
End Sub

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
ChDrive Drive1.Drive
End Sub

Private Sub mm21_Click(Index As Integer)
mm21(0).Checked = False
mm21(1).Checked = False
mm21(2).Checked = False
mm21(Index).Checked = True
End Sub

Private Sub mm31_Click()
pff1 = InputBox("1-(чб) или 2 (4цв.) или 4 (16цв.) или 8 (256цв.)", "Введите число цветов :", "1")
savejpg.Caption = "Программа сохранения рисунка " & pff2 & " точек/дюйм, " & pff1 & " цветов"
End Sub

Private Sub mm32_Click()
pff2 = InputBox("Введите число точек на дюйм : ", "", "150")
savejpg.Caption = "Программа сохранения рисунка " & pff2 & " точек/дюйм, " & pff1 & " цветов"
End Sub

savejpg.bas

Option Explicit

Public Const lt_DocSheetStandart = 1        ' тип документа 1- чертеж стандартный
Public Const lt_DocSheetUser = 2            '               2- чертеж нестандартный
Public Const lt_DocFragment = 3             '               3- фрагмент
Public Const lt_DocSpc = 4                  '               4- спецификация
Public Const lt_DocPart3D = 5               '               5- 3d-документ модель
Public Const lt_DocAssemble3D = 6           '               6- 3d-документ сборка
Public Const lt_DocTxtStandart = 7          '               7- текстовый документ стандартный
Public Const lt_DocTxtUser = 8              '               8- текстовый документ нестандартный
Public Const lt_DocSpcUser = 9  '                       9- спецификация нестандартный формат

Public Const FORMAT_BMP = 0
Public Const FORMAT_GIF = 1
Public Const FORMAT_JPG = 2
Public Const FORMAT_PNG = 3
Public Const FORMAT_TIF = 4
Public Const FORMAT_TGA = 5
Public Const FORMAT_PCX = 6

Public Const BPP_COLOR_01 = 1   ' "Черный"
Public Const BPP_COLOR_02 = 2   ' "4 цвета"
Public Const BPP_COLOR_04 = 4   ' "16 цветов"
Public Const BPP_COLOR_08 = 8   ' "256 цветов"
Public Const BPP_COLOR_16 = 16  ' "16 разрядов"
Public Const BPP_COLOR_24 = 24  ' "24 разряда"
Public Const BPP_COLOR_32 = 32  ' "32 разряда"

' определения для настройки цвета растрового формата
' ---
Public Const BLACKWHITE = 0    ' цвет черный
Public Const COLORVIEW = 1     ' цвет установленный для вида
Public Const COLORLAYER = 2    ' цвет установленный для слоя
Public Const COLOROBJECT = 3   ' цвет установленный для объекта

[olden]

В виде архива, если можно, выложи в тему "Исходники, описания, примеры". Чтоб не мучаться с email. Мой email: denoleg@yandex.ru

[userascon2]

Высылаю файлы проекта, необходимо только добавить в проект VB в меню Project-References элементы:
OLE-Automation
Kompas6API2D5COM
Kompas6API3D5COM
Kompas6API5
Kompas6Constants
Kompas6Constants3D

просто напротив них поставить галочки, и запускайте, должно работать.

Au revoir.

[GL]

сделали exe
хотелось бы, чтобы автор чуть чуть усовершенствовал программку.
предложения:
1. видеть чертежи во вложенных папках.
2. спецификацию к имени файла гиф дополнительно приписывать "сп" или "S". иначе затирает чертеж с таким же именем.
3. многолистовые чертежи делать одним файлом. или сделать выбор как именно нужно, одним листом или несколькими. (лично нам удобнее одним файлом)
4. имя файла гиф брать из чертежа с поля "обозначение документа".

[GL]

поправленная новая версия.

еще расскажите пожалста, как взять с документа обозначение чертежа (спецификации) для того, чтобы сохранить картинку с этим именем?

[Poltava]

Да

сделали exe
хотелось бы, чтобы автор чуть чуть усовершенствовал программку.
предложения:
1. видеть чертежи во вложенных папках.
2. спецификацию к имени файла гиф дополнительно приписывать "сп" или "S". иначе затирает чертеж с таким же именем.
3. многолистовые чертежи делать одним файлом. или сделать выбор как именно нужно, одним листом или несколькими. (лично нам удобнее одним файлом)
4. имя файла гиф брать из чертежа с поля "обозначение документа".

Да былобы не плохо добавить эти функции но скажем с возможностью самому формировать имя файла пипа шаблона к примеру %n - %o - %nf  номер чертежа обозначение чертижа исходное имя файла ну или что то на подобии того
и наверно не просто видеть чертежи но и сохранять структуру тоесть те подпапки в каких они находились
а так программа отличная автору респект и +

[GL]

К сожалению я не автор.  но автору передам.

[Galush]

Получилось ли реализовать вышеперечисленные пожелания?