Option Compare Database
 
Option Explicit
 
Dim Command_out As String
Dim Command_in As String
 
'-------------------------------------------------------------
'Процедура для совершения звонка
'Данную процедуру необходимо использовать на событиях нажатия кнопки "Позвонить" на Ваших формах
Public Sub Call_number(number As String)
 
If Trim(number) & "" = "" Then Exit Sub
 
Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, "CALL^" & number & "^") 'команда"Позвонить"

End Sub
'------------------------------------------------------------
'Процедура для отправки смс по одному из шаблонов Телефума
Public Sub SMS_shabl_number(number As String)
If Trim(number) & "" = "" Then Exit Sub
 
Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, "SENDSMSSHABL^" & number & "^") 'команда "Отправить СМС по шаблону"
End Sub
'------------------------------------------------------------
'Процедура для отправки смс c заданным текстом
Public Sub SMS_number(number As String, textSms As String)
If Trim(number) & "" = "" Then Exit Sub
Dim phone As String
phone = "1" 'Порядковый номер подключенного телефона (1-4 телефоны, 5- через интернет)

Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, "SENDSMS^" & number & "^" & textSms & "^" & phone & "^") 'команда "Отправить СМС"
End Sub
'------------------------------------------------------------
'Процедура для отправки емейл по одному из шаблонов Телефума
Public Sub Email_shabl(email As String)
If Trim(email) & "" = "" Then Exit Sub
'If InStr(email, "@") = 0 Then Exit Sub

Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, "SENDEMAILSHABL^" & email & "^") 'команда "Отправить емейл по шаблону"
End Sub
'------------------------------------------------------------
'Процедура для отправки смс по одному из шаблонов Телефума
Public Sub History_number(number As String)
If Trim(number) & "" = "" Then Exit Sub
 
Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, "SHOWHISTNUMBER^" & number & "^") 'команда "Показать историю звонков по номеру"
End Sub
Public Sub TelefUM_Timer() 'Процедура для получения входящих команд со стороны программы TelefUM
Dim msg_command As String
 
If Command_out & "" = "" Then
Command_out = read_Value("TelefUM", "files", "Dir1c", Environ("AppData") & "\TelefUM\out") & "\Command_out.txt"
End If
If Command_in & "" = "" Then
Command_in = read_Value("TelefUM", "files", "Dir1c", Environ("AppData") & "\TelefUM\out") & "\Command_in.txt"
End If
 
msg_command = read_ValueTXT(Command_out)
 
If Trim(msg_command) & "" = "" Then Exit Sub
 
Call TelefUM_Sub(msg_command)
Call ClearFile(Command_out) 'Очистка значений в файле

End Sub
 
'-------------------------------------------------------------
'Процедура для выполнения входящих команд со стороны программы TelefUM

Private Sub TelefUM_Sub(Msg As String)
 
Dim fields() As String, Nfields As Integer
fields = Split(Msg, "^")
Nfields = UBound(fields)
 
If Nfields <= 0 Then Exit Sub
    Select Case Trim(fields(1))
    Case "TEST" 'Открытие карточки контакта

        If Nfields > 1 Then
        'Вместо "Форма" необходимо вписать имя формы, в которой у Вас будет отображаться карточка контакта
        MsgBox fields(2)
        End If
    Case "CARD" 'Открытие карточки контакта
        If Nfields > 2 Then
        'Вместо "Форма" необходимо вписать имя формы, в которой у Вас будет отображаться карточка контакта
        DoCmd.OpenForm "Сведения о контактах", acNormal, , "ИД=" & Val(fields(2)), acFormEdit, acWindowNormal, ""
        End If
    Case "CREATECARD" 'Создание новой карточки контакта
        If Nfields > 2 Then
        'Здесь необходимо вписать процедуру, которая будет выполнять создание нового контакта.
        'В качестве Номера телефона здесь фигурирует Number = fields(2)
        DoCmd.OpenForm "Сведения о контактах", acNormal, , "ИД=0", acFormEdit, acWindowNormal, ""
        Forms![Сведения о контактах]![Рабочий телефон] = fields(2)
        End If
    Case "CONTACT?" 'Запрос контактных данных
        If Nfields > 3 Then
        Call TelefUM_contactInfo(fields(2), fields(3), fields(4))
        End If
    End Select
End Sub
 
'-------------------------------------------------------------
'Функция для получения контактных данных по телефонному номеру, со стороны программы TelefUM

'*******Данную функцию нельзя использовать нигде!*******
'*******Это служебная TelefUM-функция!******************

Private Sub TelefUM_contactInfo(number As String, phone As String, line As String)
Dim ID As String, name As String, Company As String, about As String, Result As String
 
  'MsgBox number
'Определение имени контакта по базе данных
'Определение имени происходит по последним 10 цифрам телефонного номера

Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset("select ИД, Имя, Фамилия, Организация, Должность, Заметки " & _
"from Контакты where ((right([Рабочий телефон],10)=""" & Right(number, 10) & """" & ") OR (right([Домашний телефон],10)=""" & Right(number, 10) & """" & ")" & _
"OR (right([Мобильный телефон],10)=""" & Right(number, 10) & """" & ")" & _
"OR (right([Номер факса],10)=""" & Right(number, 10) & """" & ")" & _
")" _
, dbOpenForwardOnly)
 
If rs.EOF Then
ID = "0"
Else
 
ID = Trim(Str(rs!ИД))
name = Nz(rs![Имя], "") & " " & Nz(rs![Фамилия], "")
Company = Nz(rs!Организация, "") & " (" & Nz(rs![Должность], "") & ")"
about = Nz(rs!Заметки, "")
 
End If
 
    If ID = "" Or ID = "0" Then
    Result = "NOCONTACT^" _
    & number & "^" _
    & phone & "^" _
    & line & "^"
    Else
    Result = "CONTACT^" _
    & number & "^" _
    & phone & "^" _
    & line & "^" _
    & Trim(name) & "^" _
    & Trim(Company) & "^" _
    & Trim(about) & "^" _
    & ID & "^"
    End If
 
'Обновление_пути_к_управляющим_файлам
Command_out = read_Value("TelefUM", "files", "Dir1c", Environ("AppData") & "\TelefUM\out") & "\Command_out.txt"
Command_in = read_Value("TelefUM", "files", "Dir1c", Environ("AppData") & "\TelefUM\out") & "\Command_in.txt"
'Полученный результат записываем в файл Command_in.ini:

Call ClearFile(Command_in)
Call write_ValueTXT(Command_in, Result) 'Открытие поиска карточек контактов

End Sub
 
Private Function read_Value(Progr As String, Sect As String, Ky As String, Default As String) As String
'Функция чтения значения реестра (Запись производиться в "HKEY_CURRENT_USER\Software\VB and VBA Program Settings\")

Dim readValue As String
readValue = GetSetting _
(Progr, Sect, Ky, Default)
 
read_Value = Trim(readValue)
 
End Function
 
Private Sub ClearFile(FileName_str As String) 'Очистка файла
Dim F
If FileName_str & "" = "" Then Exit Sub
F = FreeFile
Open FileName_str For Output As #F
Close F
End Sub
Private Function read_ValueTXT(txtPath As String) As String
Open txtPath For Input As #1
    Dim s As String
    While Not EOF(1)
        Input #1, s
        read_ValueTXT = read_ValueTXT & vbNewLine & s
    Wend
Close #1
End Function
Private Sub write_ValueTXT(txtPath As String, DataFile As String)
'txtPath - путь к  файлу
'DataFile - текстовые данные, для записи в файл
On Error Resume Next
 
Const ForAppending = 8
Dim strFileName1, objFSO, objMyFile
 
Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  ' открываем файл для добавления;
  ' третий параметр (Boolean) указывает создавать ли файл если он не существует
Set objMyFile = objFSO.OpenTextFile(txtPath, ForAppending, True)
 
  ' чего-то пишем
  objMyFile.WriteLine DataFile
 
End Sub

Private Sub Form_Timer()
Call TelefUM_Timer
End Sub