(изменено: Курочкин Андрей, 9 февраля 2009 11:55:38)

Тема: Полезные примеры работы

В данной теме будут помещаться примеры подпрограмм и функций, которые можно и даже нужно использовать для программирования:
  2 - функции округления и преобразования
       Округлить в большую сторону
       Округлить с точностью, настроенной в TechnologiCS
       Перевести число в строку
  3 - функции получения справочных данных
       Получение наименования класса по ID
       Получение ID справочника по ID номенклатуры
       Получение полного наименования номенклатуры по ID номенклатуры
       Получение ID единицы измерения по наименованию
       Применяемость номенклатуры как конструктоский материал
       Функция выдает ID ветки дерева по её полному наименованию
       Полное наименование цеха\участка
       Остаток номенклатурной позиции по партии
  4 - работа с внешними объектами
       Открытие файла MS Excel
       Подключение к БД Access
       Открытие текстового файла
       Подключение к СУБД SQL
       Подключение к СУБД Oracle
       Открытие файла из окна диалога
       Создание документа MS Word (*.doc) по шаблону документа (*.dot) с   использованием Word Basic
  5 - работа с массивами
       Заполнение массива
       Количество строк
  6 - сортировка и фильтрация данных
       Тип сортировки
  7 - сервисные процедуры и функции
       Отметить выделенные сообщения как прочитанные
       Отобразить ProgressBar
       Функция привязки документа
       Функция привязки документа к версии спецификации, технологии
       Функция добавления параметров
  8 - добавление данных
       Процедура добавления документа с присвоением номера
       Процедура добавления документа
  9 - редактирование данных
10 - удаление данных

Re: Полезные примеры работы

Функции округления

Округлить в большую сторону
Function RoundUp( dblValue )
    RoundUp = Int( dblValue * -1 ) * -1
End Function

Округлить с точностью, настроенной в TechnologiCS
Function RoundAsTCS( dblValue )
    RoundAsTCS = Round( dblValue, TCSApp.DisplayPrecision )
End Function

Перевести число в строку
Function toStr( dblValue )
    toStr = Replace( CStr( dblValue ), ",", "." )
End Function

Re: Полезные примеры работы

Функции получения справочных данных

Получение наименования класса по ID
Function GetNmkClassNAME( NmkClassID )
    Dim NmkClasses
    Set NmkClasses = TCSApp.NmkClasses
    If Not ( NmkClasses Is Nothing ) Then
        NmkClasses.UserModuleName = NmkClasses.UniqueUserModuleName
        If NmkClasses.Locate( "ID", NmkClassID, 0 ) Then
            GetNmkClassNAME = NmkClasses.Properties( "NAME" ).DisplayText
        Else
            GetNmkClassNAME = ""
        End If
        Call TCSapp.DeleteModuleByUserModuleName( NmkClasses.UserModuleName )
    Else
        GetNmkClassNAME = ""
    End If
End Function

Получение ID справочника по ID номенклатуры
Function GetNmkClassId( NmkID )
    Dim Result : Result = -1
    Dim ISingleNmk : Set ISingleNmk = TCSApp.SingleNmkFromId( NmkID )
    If Not ISingleNmk Is Nothing Then
        ISingleNmk.UserModuleName = ISingleNmk.UniqueUserModuleName
        Result = ISingleNmk.Properties( "NMK_CLASSIF_TYPE_REF" ).AsSafeInteger
        Call TCSapp.DeleteModuleByUserModuleName( ISingleNmk.UserModuleName )
    End if
    GetNmkClassId = Result
End Function

Получение полного наименования номенклатуры по ID номенклатуры
Function GetNmkFullName( NmkID )
    Dim Result : Result = ""
    Dim ISingleNmk
    Set ISingleNmk = TCSApp.SingleNmkFromId( NmkID )
    If Not ISingleNmk Is Nothing Then
        ISingleNmk.UserModuleName = ISingleNmk.UniqueUserModuleName
        Result = Trim(ISingleNmk.Properties( "NOTE" ).DisplayText & " " & ISingleNmk.Properties( "NAME" ).DisplayText & Replace(" (" & ISingleNmk.Properties( "NMK_CODE" ).DisplayText & ")", "()", "" ))
        Call TCSapp.DeleteModuleByUserModuleName( ISingleNmk.UserModuleName )
    End if
    GetNmkFullName = Result
End Function

Получение ID единицы измерения по наименованию
Function GetMesurID( MesurNote )
    Dim ResultFunction : ResultFunction = Null   
    Dim IMesuriments
    TCSApp.ShowOneTreeNodeData = False
    Set IMesuriments = TCSApp.Mesuriments
    If Not IMesuriments Is Nothing Then
        IMesuriments.UserModuleName = IMesuriments.UniqueUserModuleName
        If IMesuriments.Locate( "NOTE", MesurNote, 0 ) Then
            ResultFunction = IMesuriments.Properties( "ID" ).AsSafeInteger
        End If
        Call TCSapp.DeleteModuleByUserModuleName( IMesuriments.UserModuleName )
    End if
    GetMesurID = ResultFunction
End Function

Применяемость номенклатуры как конструктоский материал
Sub FormMacro_Nmk_VH_Par(TCSActiveModule)   
Set Par = TCSApp.Parameters
If Par.Locate("PAR_CODE","KM00000001",0) Then
     Set Par_Vh = Par.ChildModules.ModuleByName("WhereUsed_parametres").AsIDispatch
     Set Par_Vh_NMK = Par_Vh.ChildModules.ModuleByName("WhereUsed_parametres_in_nomenklature").AsIDispatch
    Call Par_Vh_NMK.Filter.ClearFilter
    Call Par_Vh_NMK.Filter.NewFilterItem( Par_Vh_NMK.Properties( "NMK_ID_1" ), CSDN_Const.fkEQ, TCSActiveModule.Properties("ID").Value)
    Call Par_Vh_NMK.Filter.ApplyFilter
Id = Par_Vh_NMK.ShowModal("Входимость как конструкторский материал -  " +   TCSActiveModule.Properties("NOTE").DisplayText + " " + TCSActiveModule.Properties("NAME").DisplayText)
End If
End Sub

Функция выдает ID ветки дерева по её полному наименованию (используется в дереве архива)
Function ID_BY_NODE(DTree, Node)
' DTree - дерево, в котором надо искать
' Node - полное наименование ветки - строка
    Dim Node_Id_Master
    Node_Id_Master = 0
    For i = 0 To DTree.RootNodes.Count-1
        Call FullReadNode1(DTree.RootNodes.Item(i),Node,Node_Id_Master)
        ID_BY_NODE = Node_Id_Master
    Next
End Function

Процедура чтения дерева
Sub FullReadNode1 (DNode, Node, Node_Id)
  If Not (Node_Id = 0) Then
      Exit Sub
  Elseif DNode.FullPath("\\") = Node Then
      Node_Id = DNode.NodeId
      Exit Sub
  Else
      Node_Id = 0
      For i = 0 To DNode.Count-1
          If Not (Node_Id = 0) Then
              Exit For
          End If
          Call FullReadNode1(DNode.Item(i),Node,Node_Id)
      Next
  End If
End Sub

Полное наименование цеха\участка
Function GetPlantDepartmentsFullName( PlantDepartmentsID )
    Dim Result : Result = ""
    Dim IPlantDepartments
    Set IPlantDepartments = TCSApp.PlantDepartments
    IPlantDepartments.UserModuleName = IPlantDepartments.UniqueUserModuleName
    If IPlantDepartments.Locate( "ID", PlantDepartmentsID, 0 ) Then
        Result = IPlantDepartments.Properties( "CEHA_NUMBER" ).DisplayText & "/" & _
                 IPlantDepartments.Properties( "CEHA_SECTOR" ).DisplayText & " " & _
                 IPlantDepartments.Properties( "NAME" ).DisplayText
    End If
    Call TCSapp.DeleteModuleByUserModuleName( IPlantDepartments.UserModuleName )
    GetPlantDepartmentsFullName = Result
End Function

Остаток номенклатурной позиции по партии
Function GetBalanceNmk( NmkID, BatchID )
    Dim Result : Result = 0
    Dim NmkClassId : NmkClassId = GetNmkClassId( NmkID )
    If NmkClassId > 0 Then
        Dim INomenclaturesBalance : Set INomenclaturesBalance = TCSApp.Inventory.NomenclaturesBalance( NmkClassId )
        If Not INomenclaturesBalance Is Nothing Then
            INomenclaturesBalance.UserModuleName = INomenclaturesBalance.UniqueUserModuleName
            If INomenclaturesBalance.Locate( "ID", NmkID, 0 ) Then
                Dim gmNomenclatureBatch : Set gmNomenclatureBatch = INomenclaturesBalance.Properties("NomenclatureBatch").AsIDispatch
                If Not gmNomenclatureBatch Is Nothing Then
                    If gmNomenclatureBatch.Locate( "ID", BatchID, 0 ) Then
                        Result = Result + gmNomenclatureBatch.Properties( "QUAN" ).AsSafeFloat
                    End If
                    Set gmNomenclatureBatch = Nothing
                End If
            End If
            Call TCSapp.DeleteModuleByUserModuleName( INomenclaturesBalance.UserModuleName )
        End If
    End If
    GetBalanceNmk = Result
End Function

Re: Полезные примеры работы

Работа с внешними объектами

Открытие файла MS Excel
If isEmpty(XLS) Then Set XLS = CreateObject("Excel.Application")
XLS.Visible = False
FileName = XLS.GetOpenFilename("Ms Excel (*.xls), *.xls", 1, "Выберите файл MS Excel")
If FileName <> False Then
        XLS.Visible = True
        Set WBK = XLS.Workbooks.Open(FileName)
        ....................................................................
Set WBK = Nothing
End If
Set XLS = Nothing

Подключение к БД Access
' FullPathMDB    - полный путь к БД с именем файла ("C:\Temp\mydb.mdb")
Set DatConct = CreateObject("ADODB.Connection")
DatConct.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + FullPathMDB

Открытие текстового файла
FileName= Имя файла 
Set fso = CreateObject("Scripting.FileSystemObject")
Set File = fso.OpenTextFile(FileName,1,True,-2)

Подключение к СУБД SQL
DatConct_SQL.Open "Provider=SQLOLEDB.1;Password=<Пароль>;
Persist Security Info=True;User ID=<Пользователь>;Initial Catalog=<Имя БД>;
Data Source=<Сервер>"

Подключение к СУБД Oracle
DatConct_Oracle.Open "Provider=OraOLEDB.Oracle.1; Data Source=<Имя БД>;
User ID=<Пользователь>; Password=<Пароль>"


Открытие файла из окна диалога
Set MSComDlg = CreateObject("MSComDlg.CommonDialog")
    With MSComDlg
       .Filter = "Basic Files (*.bas)|*.bas"
       .DialogTitle = "OpenFile:"
       .InitDir = "\\"
       .Flags = 0
       .MaxFileSize = 1000
       .filename = ""
       .ShowOpen()
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With

Создание документа MS Word (*.doc) по шаблону документа (*.dot) с использованием Word Basic.

Set FT = TCSApp.FileTypes
        FT.UserModuleName = FT.UniqueUserModuleName
Set Files_DOC = Single_Doc.Properties("FILES").AsIDispatch
           Files_DOC.UserModuleName = Files_DOC.UniqueUserModuleName
        If  Not Files_DOC Is Nothing Then
         If Files_Doc.IsEmpty Then
         If FT.Locate("EXT",".dot",0) Then
          Set FTT = FT.Properties("TEMPLATES").AsIDispatch
              FTT.UserModuleName = FTT.UniqueUserModuleName
          If FTT.Locate("NAME","БланкИИ.dot",0) Then
            Call Files_DOC.AddTemplate("",FTT.Properties("ID").AsInteger,3)
          End If
          Call TCSApp.DeleteModuleByUserModuleName(FTT.UserModuleName)
          Set FTT = Nothing
         End If
         End If

Set W = CreateObject("Word.Basic")
       FileName = Files_DOC.Properties( "NAME" ).DisplayText
       FileName1 = Left(FileName,LEN(FileName)-1)&"c" 
     
       
      Path = Single_Doc.GetDefaultUnloadPath     ' Путь для выгрузки шаблона
     
       id = Single_Doc.OpenDocEx(-2,Path)        ' Выгружаем    .dot
       
       W.FileNew Path + "\" + FileName           ' Создаем файл (Документ1.doc)
       W.FileSaveAs(Path + "\" + FileName1)      ' Сохраняем с расширением .doc (FileName1)
       W.FileExit
         
         If Len(Single_Doc.Properties("LOCKUSR_NAME").DisplayText) > 0 Then
         
            Call TCSApp.ShowMessageBox("Внимаение!","Бланк извещения будет сохранен. Позднее, в него можно будет занести дополнительные данные.")

                        Call Single_Doc.CloseDocEx(True,Path)   ' Разблокируем и сохраняем изменения
                        'Удалим файл .dot
                         Files_DOC.Refresh
                         If Files_DOC.Locate("TYPE_EXT",".dot",0) Then
                         Files_DOC.DeleteRecord(False)
                         End If
                         If Files_DOC.Locate("TYPE_EXT",".doc",0) Then
                         Call Files_DOC.ActionList.ActionByName("SetActiveAction").Execute   ' делаем активным
                         End If
 
         Else
                    MsgBox "Документ не открыт!"
         End If

       
      Call TCSApp.DeleteModuleByUserModuleName(Files_DOC.UserModuleName)
      Set Files_DOC = Nothing
     End If 

     Call TCSApp.DeleteModuleByUserModuleName(FT.UserModuleName)
      Set FT = Nothing

Re: Полезные примеры работы

Работа с массивами

Заполнение массива
' Chr(9) - знак разделитель
FileName = Имя файла
Set fso = CreateObject("Scripting.FileSystemObject")
Set File = fso.OpenTextFile(FileName,1,True,-2)
Do While File.AtEndOfStream <> True
           sLine = File.ReadLine
          aLine = Split(sLine, Chr(9))
         If nColCount = 0 Then
            nColCount = UBound(aLine)
            Redim Array (nColCount, 0)
        End If
     Redim Preserve Array (nColCount, nRow)
     For ii = 0 To nColCount
        On Error Resume Next
            Array (ii, nRow) = aLine(ii)
        If Err <> 0 Then Array (ii, nRow) = ""
        Next 
nRow = nRow + 1
Loop

Количество строк
Function GetRowCount( Array )
    Dim Result : Result = 0
    On Error Resume Next
        Result = Ubound( Array, 2 )
    On Error GoTo 0
    GetRowCount = Result
End Function

Re: Полезные примеры работы

Cортировка и фильтрация данных

Тип сортировки
stNone - сортировка не задана
stDescending - сортировать по убыванию
stAscending - сортировать по возрастанию
stUnsupported - свойство не поддерживает сортировку

Re: Полезные примеры работы

Сервисные процедуры и функции

Отметить выделенные сообщения как прочитанные
Sub FormMacro_Pr_Soob(TCSActiveModule)
Dim pr_soob
LogObject.ScriptTimeOut = 0
    For cnt = 0 To TCSActiveModule.SelectedRowsCount - 1
        If TCSActiveModule.GotoSelectedRow(cnt) Then
                 If TCSActiveModule.Properties("IS_READ").DisplayText = "F" Then
                     Set pr_soob = TCSActiveModule.ActionList.ActionByName("MarkUnReadAction")
                                   If  Not pr_soob Is Nothing Then   pr_soob.Execute
                 End If   
         End If
    Next
TCSActiveModule.Refresh
TCSActiveModule.First
End Sub

Отобразить ProgressBar
Function ShowProgressBarNote( ProgressString, Caption )
    If ProgressString = "" Then
        ProgressString = "||||||||||||||||||||||||||||||||                                                                         "                                                                     
    End If   
    Call TCSApp.ShowProgressMessage( ProgressString, Caption )
    ShowProgressBarNote = Right( ProgressString, 1 ) + Left( ProgressString, Len( ProgressString ) - 1 )
End Function

Функция привязки документа
Sub Creat_Link(Doc, Link, Comment, Ver_iD_Doc)
Dim Link_doc
       Set Link_doc = Doc.Properties("LINKS").AsIDispatch
       Call Link_doc.CreateNew
          Link_doc.Properties("LINK_TYPE").Value = Link
          Link_doc.Properties("COMMENT").Value = Comment
          Link_doc.Properties("LINKED_VER_ID").Value = Ver_iD_Doc
       On Error Resume Next
       Call Link_doc.SaveChanges
       Call Link_doc.CancelChanges
End Sub

Функция привязки документа к версии спецификации, технологии
Sub Creat_LinkVer(ID_Spr, NMKs_ID, Ver_iD_SP)
Dim Link_Ver
            Set Link_Ver = New_Doc.Properties("BoundNomenclature").AsIDispatch
             If  Not Link_Ver Is Nothing Then
                Call Link_Ver.CreateNew
                Link_Ver.Properties("NMK_ATTACH_ID").Value = ID_Spr
                Link_Ver.Properties("NMK_ID").Value = NMKs_ID
                Link_Ver.Properties("VER_ID").Value = Ver_iD_SP
                On Error Resume Next
                Call Link_Ver.SaveChanges
                Call Link_Ver.CancelChanges 
           End If
End Sub

Функция добавления параметров
Function WriteParameter(Param,ParCode,ParValue,NmkID)
'NmkID - для параметров типа "ссылка на номенклатуру". в остальных случаях 0
    Dim FLAGPRAV, tmp_value
    FLAGPRAV = True
    If ParValue <> "" Then
           Set Param_G = TCSApp.Parameters
           Param_G.UserModuleName = Param_G.UniqueUserModuleName
           tmp_value = ""
           If Param_G.Locate("PAR_CODE",ParCode,0) Then
                 ' Проверка типа данных
                 If  Param_G.Properties("PAR_TYPE").AsString = "T" _
                 Or Param_G.Properties("PAR_TYPE").AsString = "S" _
                 Or Param_G.Properties("PAR_TYPE").AsString = "R" Then
                       tmp_value = CStr(ParValue)
                 Elseif  Param_G.Properties("PAR_TYPE").AsString = "I" Then 
                       tmp_value = CInt(ParValue)
                 Elseif  Param_G.Properties("PAR_TYPE").AsString = "D" Then 
                       tmp_value = CDbl(ParValue) 
                 Elseif Param_G.Properties("PAR_TYPE").AsString = "B" Then
                     If ParValue = False Then                                 
                       tmp_value = "F"
                     Else
                       tmp_value = "T" 
                     End If
                 End If                   
           End If
           If Not tmp_value = "" Then
               If Not Param.SetParameterValueByParCode(ParCode,tmp_value , NmkID, True) Then FLAGPRAV = False
           End If
          TCSApp.DeleteModuleByUserModuleName (Param_G.UserModuleName)
          Set Param_G = Nothing
     Else
         If Param.Locate("PAR_CODE",ParCode,0) Then
             Param.DeleteRecord(False)
             FLAGPRAV = False
         End If         
     End If
     WriteParameter = FLAGPRAV
End Function

Re: Полезные примеры работы

Добавление данных

Процедура добавления документа с присвоением номера

Sub Add_Doc_Arhiv(DocType, ArchiveTreeID, WORKFLOW, WorkGroupID)
  On Error Resume Next
  Set New_Doc = TCSApp.CreateDoc2( 1, "", "", DocType, ArchiveTreeID, _
                               WORKFLOW, WorkGroupID, " ", Null, Null ) 
  If  Not New_Doc Is Nothing Then                              
        New_Doc.Edit
        New_Doc.Properties("COMMENT").Value  = New_Doc.Properties("NAME").DisplayText +". " + New_Doc.Properties("TYPE_NOTE").DisplayText
        New_Doc.Properties("VER_NAME").Value = "изм. 00"
        New_Doc.SaveChanges
  End If
End Sub

Процедура добавления документа

Sub Creat_Doc(DocNote, DocName, DocTypeID, ArchiveTreeID, WorkFlowTypeID, WorkGroupID)
On Error Resume Next
Set New_Doc = TCSApp.CreateDoc(DocNote, DocName, CLng(DocTypeID), CLng(ArchiveTreeID), CLng(WorkFlowTypeID), CLng(WorkGroupID), Null, Null)
  If  Not New_Doc Is Nothing Then 
     New_Doc.Edit 
       New_Doc.Properties("COMMENT").Value  = New_Doc.Properties("NAME").DisplayText _
       & ". " & New_Doc.Properties("TYPE_NOTE").DisplayText                                      
     New_Doc.Properties("VER_NAME").Value = "изм. 00"
     New_Doc.SaveChanges

      Set Doc_Param = New_Doc.Properties("PARAMS_VALUES").AsIDispatch
          If  Not Doc_Param Is Nothing Then 
                   I = Doc_Param.ShowModal("Параметры документа " & New_Doc.Properties        ("TYPE_NOTE").DisplayText & "  "  & New_Doc.Properties("NOTE").DisplayText & " " & New_Doc.Properties("NAME").DisplayText)
        End If
End If

End Sub

Re: Полезные примеры работы

Курочкин Андрей пишет:

Подключение к БД Access
' FullPathMDB    - полный путь к БД с именем файла ("C:\Temp\mydb.mdb")
Set DatConct = CreateObject("ADODB.Connection")
DatConct.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + FullPathMDB

Для Office 2007
DatConct.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" + FullPathMDB + ";Persist Security Info=False;"

Re: Полезные примеры работы

Передача значений параметров SQL-запросу
Иногда текст SQL запросов формируют самостоятельно с подставленными значениями.
Это приводит к ошибкам, если значение будет null или будет содержать символы разметки (').


Set AccessCon = CreateObject("ADODB.Connection") 'Подключение к Access
AccessCon.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" + FullPathMDB

Set AccessCommand = CreateObject("ADODB.Command")

'текст SQL запроса
TextSQL_Access = "INSERT INTO Table1(a, b, c, d) " + _
                 "VALUES ( (:p1), (:p2), (:p3), (:p4) ) "
          
AccessCommand.ActiveConnection = AccessCon 'указывается соединение
AccessCommand.CommandText = TextSQL_Access  
AccessCommand.Parameters.Refresh


AccessCommand.Parameters(0) = TCSActiveModule.Properties("ID").Value
AccessCommand.Parameters(1) = TCSActiveModule.Properties("NOTE").Value
AccessCommand.Parameters(2) = TCSActiveModule.Properties("NAME").Value
AccessCommand.Parameters(3) = TCSActiveModule.Properties("CODE").Value

AccessCommand.Execute

Увеличение времени ожидания выполнения запроса
Иногда, при выполнении больших запросов, выводится сообщение о превышении времени ожидания:

    Set AccessCon = CreateObject("ADODB.Connection") 'Подключение к Access
    Set AccessRS = CreateObject("ADODB.Recordset")   'Набор данных для Access

    TextSQL_Access = "select * from Table1"
    AccessRS.Open TextSQL_Access, AccessCon
    'далее следует ожидание выполнения запроса, а потом и ошибка

Для этого я переписываю через команды:


    Set AccessCon = CreateObject("ADODB.Connection") 'Подключение к Access
    Set SQLCommand = CreateObject("ADODB.Command")

    ...

    TextSQL_Access = "select * from Table1"

        SQLCommand.CommandText = TextSQL_Access
        SQLCommand.CommandTimeout = 700 'таймаут
        
        Set AccessRS = SQLCommand.Execute() 
        'далее с AccessRS работать, как с обычным ADODB.Recordset

Подключение к БД DBF

' FullPathDBF    - полный путь к папке с DBF файоами ("C:\Temp\")
Set DatConct = CreateObject("ADODB.Connection")
DatConct.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="+FullPathDBF+";Extended Properties=dBase 5.0;Persist Security Info=False"

'в именах таблиц нужно писать .DBF
TextDBF = "select * from Table1.DBF"