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



