API библиотека для Microsoft Excel

Скачать файл библиотеки: smsc_api_excel.bas

Исходный код библиотеки: Attribute VB_Name = "smsc_api"
' BILLING.SMSTRAF.RU API (www.billing.smstraf.ru) версия 1.0 (10.01.2011)

Public Const SMSC_DEBUG As Byte = 0         '
флаг отладки
Public Const SMSC_CHARSET As String = "utf-8"    ' кодировка сообщения (utf-8 или koi8-r), по умолчанию используется windows-1251

Public SMSC_LOGIN As String                 '
логин клиента
Public SMSC_PASSWORD As String              ' пароль клиента или MD5-хеш пароля в нижнем регистре
Public SMSC_HTTPS As Byte                   '
использовать HTTPS протокол

Public Const SMTP_SERVER As String = "smtp.mail.ru"        ' адрес SMTP сервера
Public Const SMTP_USERNAME As String = "<smtp_user_name>"  '
логин на SMTP сервере
Public Const SMTP_PASSWORD As String = "<smtp_password>"   ' пароль на SMTP сервере
Public Const SMTP_FROM As String = "smtp_user_name@mail.ru" '
e-mail адрес отправителя

Public CONNECT_MODE As Byte         ' режим соединения с интернетом: 0 - прямое, 1 - Proxy, 2 - настройки из Internet Exporer
Public PROXY_SERVER As String       '
адрес Proxy-сервера
Public PROXY_PORT As Integer        ' порт Proxy-сервера
Public PROXY_AUTORIZATION As Byte   '
флаг использования авторизации на Proxy-сервере
Public PROXY_USERNAME As String     ' логин на Proxy-сервере
Public PROXY_PASSWORD As String     '
пароль на Proxy-сервере

Public Connection As Object

' Пауза в приложении
'
' Параметры:
'   
PauseTime - время паузы в секундах
'
Private Sub Sleep(PauseTime As Integer)

    Start = Timer
    Do While Timer < Start + PauseTime
        DoEvents
    Loop
   
End Sub


Public Function URLEncode(ByVal Str As String) As String

    Dim Ret

    Ret = ""
    CharStr = " !""@№#;%:?*().,/$^&\+"
   
    Str = Trim(Str)
    For i = 1 To Len(Str)
       
        S = Mid(Str, i, 1)
        SymCode = Asc(S)
       
        '
Перевод из UNICODE в ASCII
       
If ((SymCode > 1039) And (SymCode < 1104)) Then
            SymCode
= SymCode - 848
       
ElseIf SymCode = 8470 Then
            SymCode
= 185
       
ElseIf SymCode = 1105 Then
            SymCode
= 184
       
ElseIf SymCode = 1025 Then
            SymCode
= 168
        End
If
   
       
fl_replace = 0
       
If InStr(1, CharStr, S, vbBinaryCompare) > 0 Then
            Ret
= Ret & "%" & Hex(Int(SymCode / 16)) & Hex(Int(SymCode Mod 16))
           
fl_replace = 1
        End
If

        If (
SymCode <= 127) And (fl_replace = 0) Then
            Ret
= Ret & S
       
ElseIf fl_replace = 0 Then
            Ret
= Ret + "%" + Hex(Int(SymCode / 16)) & Hex(Int(SymCode Mod 16))
       
End If
   
   
Next i

    URLEncode
= Ret

End
Function

' Функция чтения URL.
'
Private Function SMSC_Read_URL(URL As String, Params As String) As String

    Dim Ret
As String
   
    On Error
GoTo 0
    Connection
.Open "POST", Trim(URL), 0
    Connection
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
Connection.Send Trim(Params)
   
Ret = Connection.ResponseText()
    If
Err.Number <> 0 Then
        MsgBox
"Не удалось получить данные с сервера!", , "Ошибка"
       
SMSC_Read_URL = ""
       
Exit Function
   
End If
   
   
SMSC_Read_URL = Ret

End
Function

' Функция вызова запроса. Формирует URL и делает 3 попытки чтения.
'
Private Function SMSC_Send_Cmd(Cmd As String, Optional Arg As String = "")
   
   
Dim URL As String, Params As String, Ret As String
       
    URL
= IIf(SMSC_HTTPS, "https", "http") & "://billing.smstraf.ru/sys/" & Cmd & ".php"
   
Params = "login=" & SMSC_LOGIN & "&psw=" & SMSC_PASSWORD & "&fmt=1" _
           
& IIf(SMSC_CHARSET = "", "", "&charset=" + SMSC_CHARSET) & "&" & Arg
   
    i
= 0
   
Do
        If
i Then Sleep (2)
        If
i = 2 Then URL = Replace(URL, "://billing.smstraf.ru/", "://www2.billing.smstraf.ru/")
       
Ret = SMSC_Read_URL(URL, Params)
       
i = i + 1
    Loop
While (IsEmpty(Ret) And i < 3)

    If
IsEmpty(Ret) Then
       
If SMSC_DEBUG Then MsgBox "Ошибка чтения адреса: " & URL, , "Ошибка"
       
Ret = ","  ' фиктивный ответ
    End If

    SMSC_Send_Cmd = Split(Ret, ",", -1, vbTextCompare)

End Function

'
Функция получения баланса
'
'
без параметров
'
'
возвращает баланс в виде строки или CVErr(N_Ошибки) в случае ошибки
'
Public Function Get_Balance()

    Dim m
   
    m = SMSC_Send_Cmd("balance")  '
(balance) или (0, -error)

    If
UBound(m) = 0 Then
        Get_Balance
= m(0)
    Else
       
Get_Balance = CVErr(-m(1))
   
End If

End Function

' Функция отправки SMS
'
' обязательные параметры:
'
' Phones - список телефонов через запятую или точку с запятой
'
Message - отправляемое сообщение
'
'
необязательные параметры:
'
'
Translit - переводить или нет в транслит (1 или 0)
' Time - необходимое время доставки в виде строки (DDMMYYhhmm, h1-h2, 0ts, +m)
'
Id - идентификатор сообщения
' Format - формат сообщения (0 - обычное sms, 1 - flash-sms, 2 - wap-push, 3 - hlr, 4 - bin, 5 - bin-hex, 6 - ping-sms)
'
Sender - имя отправителя (Sender ID)
' Query - дополнительные параметры
'
' возвращает массив (<id>, <количество sms>, <стоимость>, <баланс>) в случае успешной отправки
'
либо массив (<id>, -<код ошибки>) в случае ошибки
'
Public Function Send_SMS(Phones As String, Message As String, Optional Translit = 0, Optional Time = 0, Optional Id = 0, Optional Format = 0, Optional sender = "", Optional Query = "")
   
    Dim Formats As Variant
    Dim m
   
    Formats = Array("flash=1", "push=1", "hlr=1", "bin=1", "bin=2", "ping=1")
    FormatStr = ""
    If (Format > 0) Then
        FormatStr = Formats(Format - 1)
    End If
 
    m = SMSC_Send_Cmd("send", "cost=3&phones=" & URLEncode(Phones) & "&mes=" & Message _
                    & "&translit=" & Translit & "&id=" & Id & IIf(Format > 0, "&" & FormatStr, "") _
                    & IIf(sender = "", "", "&sender=" & URLEncode(sender)) _
                    & "&charset=" & SMSC_CHARSET & IIf(Time = "", "", "&time=" & URLEncode(Time)) _
                    & IIf(Query = "", "", "&" & Query))

    '
(id, cnt, cost, balance) или (id, -error)

   
Send_SMS = m
   
End
Function


' Функция получения стоимости SMS
'
' обязательные параметры:
'
' Phones - список телефонов через запятую или точку с запятой
'
Message - отправляемое сообщение
'
'
необязательные параметры:
'
'
Translit - переводить или нет в транслит (1 или 0)
' Sender - имя отправителя (Sender ID)
'
Query - дополнительные параметры
'
'
возвращает массив (<стоимость>, <количество sms>) либо массив (0, -<код ошибки>) в случае ошибки
'
Public Function Get_SMS_Cost(Phones As String, Message As String, Optional Translit = 0, Optional sender = "", Optional Query = "")

    Dim m
   
    m = SMSC_Send_Cmd("send", "cost=1&phones=" & URLEncode(Phones) & "&mes=" & Message & IIf(sender = "", "", "&sender=" & URLEncode(sender)) _
                    & "&translit=" & Translit & IIf(Query = "", "", "&" & Query))


    '
(cost, cnt) или (0, -error)

   
Get_SMS_Cost = m

End
Function

' Функция проверки статуса отправленного SMS
'
' Id - ID cообщения
'
Phone - номер телефона
'
'
возвращает массив
' для отправленного SMS (<статус>, <время изменения>, <код ошибки sms>)
'
для HLR-запроса (<статус>, <время изменения>, <код ошибки sms>, <код страны регистрации>, <код оператора абонента>,
' <название страны регистрации>, <название оператора абонента>, <название роуминговой страны>, <название роумингового оператора>,
'
<код IMSI SIM-карты>, <номер сервис-центра>)
' либо список (0, -<код ошибки>) в случае ошибки
'
Public Function Get_Status(Id, Phone)

   
Dim m

    m
= SMSC_Send_Cmd("status", "phone=" & URLEncode(Phone) & "&id=" & Id)

   
' (status, time, err) или (0, -error)

    Get_Status = m
   
End Function

'
Инициализация подключения
'
Public Function SMSC_Initialize()

    On Error GoTo 0
    Set Connection = CreateObject("WinHttp.WinHttpRequest.5.1")
    Connection.Option 9, 80
   
    If Err.Number = 440 Or Err.Number = 432 Then
       MsgBox "Не удалось создать объект ""WinHttp.WinHttpRequest.5.1""!" & Chr(13) & "Проверьте наличие системной библиотеки ""WinHttp.dll""", , "Ошибка"
       Err.Clear
    End If

End Function

Полнофункциональная надстройка для отправки SMS-сообщений на основе библиотеки.

Инструкция по установке надстройки:
1) Находясь в главном окне Excel, откройте меню Файл, далее Параметры.
2) Откройте вкладку Надстройки и нажмите кнопку Перейти.
3) В появившемся окне нажмите Обзор и выберите файл с надстройкой.
4) После того, как надстройка появится в окне Доступные надстройки, выделите ее и нажмите ОК.
5) В главном окне во вкладке надстройки появится кнопка Отправить SMS.
6) Чтобы отправить SMS на несколько номеров выделите столбец с номерами и нажмите Отправить SMS.
7) Для отправки индивидуальных сообщений в первом столбце расположите номера телефонов, а во втором тексты сообщений, выделите их и нажмите Отправить SMS.



Повышение тарифов на отправку SMS-сообщений для оператора МОТИВ
21.08.2017
С 1 сентября повышаются тарифы на отправку SMS-сообщений в сеть оператора МОТИВ (Россия). Повышение вызвано изменением тарифов со стороны оператора. Новые тарифы указаны на странице Тарифы.