| For Microsoft Excel
Download the library file:
smsc_api_excel.bas
Library source code:
Attribute VB_Name = "smsc_api"
' SMSCENTRE.COM API (www.smscentre.com) версия 1.2 (03.07.2019)
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 ' пароль клиента
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 и делает 5 попыток чтения.
'
Private Function SMSC_Send_Cmd(Cmd As String, Optional Arg As String = "")
Dim URL As String, Params As String, Ret As String
URL_orig = IIf(SMSC_HTTPS, "https", "http") & "://smscentre.com/sys/" & Cmd & ".php"
URL = URL_orig
Params = "login=" & SMSC_LOGIN & "&psw=" & SMSC_PASSWORD & "&fmt=1" _
& IIf(SMSC_CHARSET = "", "", "&charset=" + SMSC_CHARSET) & "&" & Arg
i = 1
Do
If i > 1 Then
URL = URL_orig
URL = Replace(URL, "://smscentre.com/", "://www" & i & ".smscentre.com/")
End If
Ret = SMSC_Read_URL(URL, Params)
i = i + 1
Loop While (Ret = "" And i < 6)
If (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, 7 - mms, 8 - mail, 9 - call, 10 - viber, 11 - soc)
' 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", "mms=1", "mail=1", "call=1", "viber=1", "soc=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
Full-featured add-in for sending SMS messages based on the library.
Instructions for installing the add-in:
1) While in the main Excel window, open the File menu, nextParameters.
2) Open the tabAdd-ons and clickGo over.
3) In the window that appears, clickBrowse and select the file with the add-in.
4) After the add-in appears in the windowAvailable add-ons, select it and click OK.
5) In the main window, in the add-ons tab, a button will appearSend SMS.
6) To send an SMS to multiple numbers select the column with the numbers and clickSend SMS.
7) To send individual messages, place the phone numbers in the first column and the message texts in the second column, select them and clickSend SMS.
In some cases, due to a Windows security update, all files received from the Internet/mail are blocked when uploaded to Excel. This is done without any warning messages.
If the "Send SMS" button or the "Add-ons" tab does not appear during the installation of our add-in, then you can remove the lock as follows:
1. Close all Excel windows.
2. In File Explorer, right-click on the add-in file.
3. Select " Properties".
4. On the "General" tab, set the "Unblock" flag.".
5. Click the "Apply" - "OK" or just " OK".
|
For Microsoft Excel
