VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Class1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Public type_ As Integer
Public flag As Integer
'flag = 1


Private Declare Function PostThreadMessage Lib "user32" Alias "PostThreadMessageA" (ByVal idThread As Long, _
              ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As String) As Boolean
Private Declare Function GetCurrentThreadId Lib "Kernel32" () As Long
              
Sub DrawTxtDB()
  Dim bd As Long
  Dim r1 As Long
  Dim r2 As Long
  Dim r3 As Long
  Dim i As Integer
  i = 1
  Dim dr As Double
  Dim l As Double
  Dim f As Integer
  
  Dim data As Object
  Dim par As Object
  Dim item As Object
  Dim arr As Object
  Set data = kompasOb.DataBaseObject
  Set par = kompasOb.GetParamStruct(ko_UserParam)
  Set item = kompasOb.GetParamStruct(ko_LtVariant)
  Set arr = kompasOb.GetDynamicArray(LTVARIANT_ARR)
  If par Is Nothing Or item Is Nothing Or data Is Nothing Then
    Exit Sub
  End If
  par.Init
  par.SetUserArray arr
  item.Init
    item.doubleVal = 0
    arr.ksAddArrayItem -1, item
  item.Init
    item.doubleVal = 0
    arr.ksAddArrayItem -1, item
  item.Init
    item.intVal = 0
    arr.ksAddArrayItem -1, item

  Dim libName As String
  libName = kompasOb.ksChoiceFile("*.loa", "Базы данных(*.loa)|*.loa|Все файлы (*.*)|*.*|", 1)
  If Len(libName) <> 0 Then
    bd = data.ksCreateDB("TXT_DB") ' создать объект, обслуживающий базу данных
    If Not Not data.ksConnectDB(bd, libName) Then   ' связать объект базы с определенной базой данных( для текстового файла - имя файла )
      r1 = data.ksRelation(bd)     ' создать отношение - буфер для считывания информации из таблицы
        data.ksRDouble "dr"        ' имена даются ключевым колонкам,
        data.ksRDouble "L"         ' по ним в дальнейшем формируются условия выборки
        data.ksRInt ""
      data.ksEndRelation

      ' установить запрос - отношение связывается с базой( указываем какие колонки
      ' базы связать с переменными буфера )
      data.ksDoStatement bd, r1, "1 2 3"  ' колонка dr - 1, L - 2, оставшаяся колонка -3
      Do While (i <> 0)
        i = data.ksReadRecord(bd, r1, par)  ' считать очередную порцию информации и положть в структуру b
        If i <> 0 Then
          arr.ksGetArrayItem 0, item
          dr = item.doubleVal
          arr.ksGetArrayItem 1, item
          l = item.doubleVal
          arr.ksGetArrayItem 2, item
          f = item.intVal
          kompasOb.ksMessage "DR = " & dr & " L = " & l & " F = " & f
        End If
      Loop
      kompasOb.ksMessage "end"

      i = 1
      arr.ksClearArray
      item.Init
      item.strVal = ""
      arr.ksAddArrayItem -1, item
      r2 = data.ksRelation(bd)       ' создать отношение - буфер для считывания информации из таблицы
        data.ksRChar "", 255, 0
      data.ksEndRelation

      data.ksDoStatement bd, r2, "2" ' установить запрос - отношение связывается с базой( указываем какие колонки
      Do While (i <> 0)
        i = data.ksReadRecord(bd, r2, par)  ' считать очередную порцию информации и положть в структуру b
        If Not i = 0 Then
          arr.ksGetArrayItem 0, item
          kompasOb.ksMessage "L = " & item.strVal
        End If
      Loop
      kompasOb.ksMessage "end"

      Dim a As Double
      i = 1

      arr.ksClearArray
      item.Init
      item.doubleVal = 0
      arr.ksAddArrayItem -1, item
      item.Init
      item.doubleVal = 0
      arr.ksAddArrayItem -1, item
      r3 = data.ksRelation(bd)   ' создать отношение - буфер для считывания информации из таблицы
        data.ksRDouble ""
        data.ksRDouble "L"
      data.ksEndRelation

      data.ksDoStatement bd, r3, "1 2" ' установить запрос - отношение связывается с базой( указываем какие колонки
      data.ksCondition bd, r3, "L=100||L=150"
      Do While (i <> 0)
        i = data.ksReadRecord(bd, r3, par)  ' считать очередную порцию информации и положть в структуру b
        If i <> 0 Then
          arr.ksGetArrayItem 0, item
          a = item.doubleVal
          arr.ksGetArrayItem 1, item
          l = item.doubleVal
          kompasOb.ksMessage "dr = " & a & " L = " & l
        End If
      Loop
      kompasOb.ksMessage "end"
    End If
    data.ksDeleteDB bd  ' удалить обьект, обслуживающий базу данных
  End If
  Set data = Nothing
  Set par = Nothing
  Set item = Nothing
  Set arr = Nothing
End Sub

Sub WriteSlideStep()
  ' выберем файл для записи
  Dim name As String
  name = kompasOb.ksSaveFile("*.rc", "", "", False)
  If Len(name) <> 0 Then
    Dim info As Object
    Set info = kompasOb.GetParamStruct(ko_RequestInfo)
    If Not info Is Nothing Then
      info.Init
      info.commandsString = "Укажите точку привязки слайда"
      ' точка привязки слайда - верхний левый угол габаритного прямоугольника слайда
      Dim X As Double
      Dim Y As Double
      If docActive.ksCursor(info, X, Y, Nothing) <> 0 Then
        Dim slideID As Long
        If kompasOb.ksReadInt("Введите идентификатор слайда", 100, 0, 32000, slideID) <> 0 Then
          If kompasOb.ksWriteSlide(name, slideID, X, Y) = 0 Then
            kompasOb.ksError "Группа селектирования пуста"
          End If
          docActive.ksClearGroup 0, True
        End If
      End If
      Set info = Nothing
    End If
  End If
End Sub

' Работа с относительными путями файлов
Sub WorkRelativePath()
  Dim mainName As String
  Dim fileName As String
  ' имя задающего файла
  mainName = kompasOb.ksChoiceFile("*.*", "Все файлы (*.*)|*.*|", True)
  fileName = kompasOb.ksChoiceFile("*.*", "Все файлы (*.*)|*.*|", True)
  If Len(mainName) <> 0 And Len(fileName) <> 0 Then
    ' относительный путь
    Dim relName As String
    relName = kompasOb.ksGetRelativePathFromFullPath(mainName, fileName)

    Dim mess As String
    mess = "Задающий файл : "
    mess = mess & mainName
    mess = mess & " \n"
    mess = mess & "Полный путь : "
    mess = mess & fileName
    mess = mess & " \n"
    mess = mess & "Относительный путь : "
    mess = mess & relName
    kompasOb.ksMessage mess

    ' полный путь
    Dim fullName As String
    fullName = kompasOb.ksGetFullPathFromRelativePath(mainName, relName)
    mess = "Задающий файл : "
    mess = mess & mainName
    mess = mess & " /n"
    mess = mess & "Относительный путь : "
    mess = mess & relName
    mess = mess & " /n"
    mess = mess & "Полный путь : "
    mess = mess & fullName
    mess = mess & " /n"
    kompasOb.ksMessage mess
  End If
End Sub

' Работа с системными каталогами
Sub WorkSystemPath()
  Dim catalogName(5) As String
  catalogName(0) = "каталог системных файлов"
  catalogName(1) = "каталог библиотек"
  catalogName(2) = "каталог временных файлов"
  catalogName(3) = "каталог конфигурации"
  catalogName(4) = "INI-файл"
  ' сформировать  полный путь к заданному файлу
  Dim info As Object
  Set info = kompasOb.GetParamStruct(ko_RequestInfo)
  If Not info Is Nothing Then
    info.Init
    info.Title = "Каталоги файлов системы"
    info.commandsString = "!Системные !Библиотеки !Временные !Конфигурация !INI-файл "
    info.prompt = "Выберите нужный каталог"
    Dim j As Integer
    ' static char* buf = "user.ttt";
    Dim fileName As String
    Dim typeCatalog As Integer
    Do
      j = docActive.ksCommandWindow(info)
      If j > 0 Then
        Select Case j
          Case 1
            typeCatalog = sptSYSTEM_FILES ' Относительно каталога системных файлов
          Case 2
            typeCatalog = sptLIBS_FILES   ' Относительно каталога файлов библиотек
          Case 3
            typeCatalog = sptTEMP_FILES   ' Относительно каталога сохранения временных файлов
          Case 4
            typeCatalog = sptCONFIG_FILES ' Относительно каталога сохранения конфигурации системы
          Case 5
            typeCatalog = sptINI_FILE     ' Относительно полного имени INI-файла системы
        End Select
        ' полный путь
        fileName = kompasOb.ksGetFullPathFromSystemPath("user.ttt", typeCatalog)
        Dim mess As String
        mess = "Полный путь к файлу user.ttt \n"
        mess = mess & catalogName(j - 1)
        mess = mess & " :\n"
        mess = mess & fileName
        kompasOb.ksMessage mess

        ' относительный путь
        Dim relName As String
        relName = kompasOb.ksGetRelativePathFromSystemPath(fileName, typeCatalog)
        mess = "Относительный путь к файлу \n"
        mess = mess & fileName
        mess = mess & "\n"
        mess = mess & catalogName(j - 1)
        mess = mess & " :\n"
        mess = mess & relName
        kompasOb.ksMessage mess
         
      End If
    Loop While (j > 0)
    Set info = Nothing
  End If
End Sub

' Функция обратной связи, вызываемая из Cursor
Public Function CALLBACKPROCCURSOR(comm As Integer, X As Double, Y As Double, info As Object, _
                               phan As Object, dynamic As Integer) As Integer
  If Not info Is Nothing And Not phan Is Nothing Then
    Dim t1 As Object
    Set t1 = phan.GetPhantomParam
    If Not t1 Is Nothing Then
      Select Case comm
        Case 1
          type_ = comm
        Case 2
          type_ = comm
        Case -1
          ' поставить в модель
          docActive.ksMoveObj t1.gr, X, Y
          If t1.angle > 0.001 Then
            docActive.ksRotateObj t1.gr, X, Y, t1.angle
          End If
          docActive.ksStoreTmpGroup t1.gr
          docActive.ksClearGroup t1.gr, True
      End Select
  ' группа для фантома должна быть временная и обновляться при изменении вида отрисовки
      If t1.gr <> 0 Then
        docActive.ksDeleteObj t1.gr
      End If
      t1.gr = docActive.ksNewGroup(1)   ' временная группа
  
      If (flag = 1 And comm = 1) Or (flag = 2 And comm = 2) Then
        type_ = 3
      End If
  
  ' обновляется не только изображение но и меню для запроса
      Select Case type_
        Case 1
          docActive.ksCircle 0, 0, 20, 1
          info.commandsString = "!Квадрат !Треугольник "
          flag = 1
        Case 2
          docActive.ksLineSeg -10, 0, 10, 0, 1
          docActive.ksLineSeg 10, 0, 0, 20, 1
          docActive.ksLineSeg 0, 20, -10, 0, 1
          info.commandsString = "!Окружность !Квадрат "
          flag = 2
        Case 3:
          docActive.ksLineSeg -10, 0, 10, 0, 1
          docActive.ksLineSeg 10, 0, 10, 20, 1
          docActive.ksLineSeg 10, 20, -10, 20, 1
          docActive.ksLineSeg -10, 20, -10, 0, 1
          info.commandsString = "!Окружность !Треугольник "
          flag = 0
      End Select
  
      docActive.ksEndGroup
      Set t1 = Nothing
    End If
  End If
  CALLBACKPROCCURSOR = 1
End Function

' Функция обратной связи, вызываемая из Placement
Public Function CALLBACKPROCPLACEMENT(comm As Integer, X As Double, Y As Double, ang As Double, _
                                       info As Object, phan As Object, dynamic As Integer) As Integer

  If Not info Is Nothing And Not phan Is Nothing Then
    Dim t1 As Object
    Set t1 = phan.GetPhantomParam
    If Not t1 Is Nothing Then
      Select Case comm
        Case 1
          type_ = comm
        Case 2
          type_ = comm
        Case -1                  ' поставить в модель
          docActive.ksMoveObj t1.gr, X, Y
  ' отлтчте от Cursor угол приходит в виде параметра функции
          If ang > 0.001 Then
            docActive.ksRotateObj t1.gr, X, Y, ang
          End If
          docActive.ksStoreTmpGroup t1.gr    ' поставить временную группу в вид
          docActive.ksClearGroup t1.gr, True
      End Select
  
  ' группа для фантома должна быть временная и обновляться при изменении вида отрисовки
      If t1.gr <> 0 Then
        docActive.ksDeleteObj t1.gr
      End If
      t1.gr = docActive.ksNewGroup(1)   ' временная группа
  
  ' обновляется не только изображение но и меню для запроса
      If (flag = 1 And comm = 1) Or (flag = 2 And comm = 2) Then
        type_ = 3
      End If
  
      Select Case type_
        Case 1
          docActive.ksCircle 0, 0, 20, 1
          info.commandsString = "!Квадрат !Треугольник "
          flag = 1
        Case 2
          docActive.ksLineSeg -10, 0, 10, 0, 1
          docActive.ksLineSeg 10, 0, 0, 20, 1
          docActive.ksLineSeg 0, 20, -10, 0, 1
          info.commandsString = "!Окружность !Квадрат "
          flag = 2
        Case 3
          docActive.ksLineSeg -10, 0, 10, 0, 1
          docActive.ksLineSeg 10, 0, 10, 20, 1
          docActive.ksLineSeg 10, 20, -10, 20, 1
          docActive.ksLineSeg -10, 20, -10, 0, 1
          info.commandsString = "!Окружность !Треугольник "
          flag = 0
      End Select
  
      docActive.ksEndGroup
      Set t1 = Nothing
    End If
  End If

  CALLBACKPROCPLACEMENT = 1
End Function

Sub DrawRectCallBack()
  type_ = 1
  flag = 1
  Dim phan As Object
  Set phan = kompasOb.GetParamStruct(ko_Phantom)
  If Not phan Is Nothing Then
    phan.Init
    phan.phantom = 1
    Dim t1 As Object
    Set t1 = phan.GetPhantomParam
    If Not t1 Is Nothing Then
      t1.Init
      t1.scale_ = 1
      t1.gr = docActive.ksNewGroup(1)   ' временная группа
        docActive.ksCircle 0, 0, 20, 1
      docActive.ksEndGroup

      Dim X As Double
      Dim Y As Double
      Dim ang As Double
      Dim info As Object
      Set info = kompasOb.GetParamStruct(ko_RequestInfo)
      If Not info Is Nothing Then
        info.Init
        info.commandsString = "!Квадрат !Треугольник"
        ' указываем адрес обратной функции для Placement
        info.SetCallBackP "CALLBACKPROCPLACEMENT", 0, Me
        docActive.ksPlacement info, X, Y, ang, phan

        t1.gr = docActive.ksNewGroup(1)   ' временная группа
          docActive.ksCircle 0, 0, 20, 1
        docActive.ksEndGroup

        ' указываем адрес обратной функции для Cursor
        info.SetCallBackC "CALLBACKPROCCURSOR", 0, Me
        docActive.ksCursor info, X, Y, phan
        Set info = Nothing
      End If
      Set t1 = Nothing
    End If
    Set phan = Nothing
  End If
End Sub

Sub DrawRectNULL()
  Dim type1 As Integer
  Dim flag1 As Integer
  Dim j As Integer
  type1 = 1
  flag = 1
  j = 1
  Dim phan As Object
  Set phan = kompasOb.GetParamStruct(ko_Phantom)
  If Not phan Is Nothing Then
    phan.Init
    phan.phantom = 1
    Dim t1 As Object
    Set t1 = phan.GetPhantomParam
    If Not t1 Is Nothing Then
      t1.Init
      t1.scale_ = 1
      t1.gr = 0   ' временная группа

      Dim X As Double
      Dim Y As Double
      Dim ang As Double
      Dim info As Object
      Set info = kompasOb.GetParamStruct(ko_RequestInfo)
      If Not info Is Nothing Then
        info.Init
        Do While (j <> 0)

          If t1.gr <> 0 Then
            docActive.ksDeleteObj t1.gr
          End If

          t1.gr = docActive.ksNewGroup(1) ' временная группа
          If (flag1 = 1 And j = 1) Or (flag1 = 2 And j = 2) Then
            type1 = 3
          End If

          Select Case type1
            Case 1
              docActive.ksCircle 0, 0, 20, 1
              info.commandsString = "!Квадрат !Треугольник "
              flag1 = 1
            Case 2
              docActive.ksLineSeg -10, 0, 10, 0, 1
              docActive.ksLineSeg 10, 0, 0, 20, 1
              docActive.ksLineSeg 0, 20, -10, 0, 1
              info.commandsString = "!Окружность !Квадрат "
              flag1 = 2
            Case 3
              docActive.ksLineSeg -10, 0, 10, 0, 1
              docActive.ksLineSeg 10, 0, 10, 20, 1
              docActive.ksLineSeg 10, 20, -10, 20, 1
              docActive.ksLineSeg -10, 20, -10, 0, 1
              info.commandsString = "!Окружность !Треугольник "
              flag1 = 0
          End Select

          docActive.ksEndGroup

          j = docActive.ksPlacement(info, X, Y, ang, phan)
'          j = docActive.ksCursor( info, x, y, phan )
          Select Case j
            Case 1
              type1 = j
            Case 2
              type1 = j
            Case -1 ' поставить в модель
              docActive.ksMoveObj t1.gr, X, Y
              If t1.angle > 0.001 Then
                docActive.ksRotateObj t1.gr, X, Y, ang
              End If
              docActive.ksStoreTmpGroup t1.gr    ' поставить временную группу в вид
              docActive.ksClearGroup t1.gr, True
          End Select
        Loop
        Set info = Nothing
      End If
      Set t1 = Nothing
    End If
    Set phan = Nothing
  End If
End Sub

Public Function GetLibraryName() As String
  GetLibraryName = "приемы работы"
End Function

Public Sub ExternalRunCommand(ByVal command As Integer, ByVal mode As Integer, ByVal kompas_ As Object)
  Set kompasOb = kompas_
    
  ' получить интерфейс 2D документа
  Set docActive = kompasOb.ActiveDocument2D  ' интерфейс активного документа
  
  Select Case command
    
    Case 1
      DrawTxtDB            ' работа с БД
    Case 2                 ' процессы
      If kompasOb.ksYesNo("Вызывать функцию CallBack?") Then
        DrawRectCallBack
      Else
        DrawRectNULL
      End If
    Case 3                 ' ввод длинного целого
      Dim h1 As Long
      If kompasOb.ksReadInt("Ввести индекс", 10000, -100000, 100000, h1) Then
        kompasOb.ksMessage "h = " & h1
      Else
        kompasOb.ksMessage "отказ"
      End If
    Case 4                 ' выбор имени файла
      Dim name As String
      name = kompasOb.ksChoiceFile("*.cdw", "", True)
      If Len(name) <> 0 Then
        kompasOb.ksMessage name
      Else
        kompasOb.ksMessage "отказ"
      End If
    Case 5
      WriteSlideStep   ' пример отрисовки слайда
    Case 6
      TestDialog.TestShowDialog    ' отрисовать слайд ( описание в файле step4_3.cpp )
    Case 7
      kompasOb.ksEnableTaskAccess 0  ' запретили доступ к задаче
      Dim i As Integer
      For i = 0 To 10000
        docActive.ksLineSeg 10, 10 + i, 20, 10 + i, 1
        If (i Mod 100) = 0 Then
          ' посылаем необрабатываемое сообщение своему приложению
          ' для выполнения процесса в фоновом режиме
          Dim tr As Long
          tr = GetCurrentThreadId()
          PostThreadMessage tr, 0, 0, 0
          kompasOb.ksPumpWaitingMessages ' через каждые 100 отрезков обрабатываем очередь сообщений
                                         ' при этом Windows получает возможность выполнить свои
                                         ' действия, например переключиться на другую задачу
        End If
      Next
      kompasOb.ksEnableTaskAccess 1  ' разрешили доступ к задаче
    Case 8
      WorkRelativePath             ' Работа с относительными путями файлов
    Case 9
      WorkSystemPath               ' Работа с системными каталогами
  
  Set docActive = Nothing
  End Select
End Sub

Public Function ExternalMenuItem(ByVal number As Integer, itemType As Integer, command As Integer) As String
    itemType = 3 '"ENDMENU"'
    ExternalMenuItem = ""
    command = -1

    Select Case number
        Case 1
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "работа с БД"
            command = 1
        Case 2
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "Placement, Cursor"
            command = 2
        Case 3
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "ввод длинного целого"
            command = 3
        Case 4
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "выбор имени файла"
            command = 4
        Case 5
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "записать слайд"
            command = 5
        Case 6
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "отрисовать слайд"
            command = 6
        Case 7
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "пример с обработкой очереди сообщений"
            command = 7
        Case 8
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "относительный путь фала"
            command = 8
        Case 9
            itemType = 1 'MENUITEM'
            ExternalMenuItem = "работа с системными каталогами"
            command = 9
        Case 10
            itemType = 3 '"ENDMENU"'
            ExternalMenuItem = ""
            command = -1
    End Select
End Function