'/// Скрипт бесплатной отправки SMS сообщений на номера Beeline

'К сожалению как и всего бесплатного так и у этого скрипта есть ограничения
'1) Отправлять СМС можно только на номера Beeline
'2) Количество отправляемых сообщений с одного IP ограничено
'3) Плюс часто приходит ответ о том, что система перегружена. В этом случае повторите отправку ещё раз.

Dim Operators(8)

Operators(0) = "777 - K-Mobile (Казахстан)"
Operators(1) = "095 - Beeline Damps (Россия)"
Operators(2) = "901 - Beeline Damps (Россия)"
Operators(3) = "903 - Beeline GSM (Россия)"
Operators(4) = "905 - Beeline GSM (Россия)"

Operators(5) = "906 - Beeline GSM (Россия)"
Operators(6) = "909 - Beeline GSM (Россия)"
Operators(7) = "960 - Beeline GSM (Россия)"
Operators(8) = "961 - Beeline GSM (Россия)"

Dim phone,message

phone = InputBox("Введите номер на который хотите произвести отправку сообщения." & vbCrlf & vbCrlf & "Доступные операторы:" & vbCrlf & vbCrlf & Join(Operators,vbCrlf),"Отправка смс сообщения на номера Beeline","890")
message = InputBox("Введите текст сообщения.","Отправка смс сообщения на номера Beeline","Сообщение")

Dim Status

Status = SendBeelineSMS(phone,message,1)

If Err.Number = 0 Then
    Msgbox Status,vbInformation
Else
    MsgBox Err.Number & " " & Err.Description,vbCritical
End if

Function SendBeelineSMS(phone,Message,translit)
    On Error Resume Next
    Dim operator, VarBody, XMLHTTP

    If Len(phone) <> 11 Then
        Err.Number = vbObjectError + 1
        Err.Description = "Недопустимая длина номера. Номер должен быть формата 890XXXXXXXX"
        Exit Function
    End If

    operator = Mid(phone, 2, 3)

    Dim AvailableOperators
    AvailableOperators = "777,095,901,903,905,906,909,960,961"
    if Instr(1,AvailableOperators,operator) = 0 Then
        Err.Number = vbObjectError + 2
        Err.Description = "Недопустимый (" & operator & ") оператор."
        Exit Function
    End if

    phone = Mid(phone, 5)
    if translit <> "" then translit="1"
    VarBody = "number_sms=number_sms_send&adv_year=&termtype=G&translit=" & translit & "&y=4&x=5&prf=7" & operator & "&phone=" & phone & "&message=" & EncodeURIcomponent(message) & "&submit=" & EncodeURIcomponent("Отправить")
    Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
    XMLHTTP.open "POST", "http://217.118.84.204/servlet/send/sms/", False
    XMLHTTP.SetRequestHeader "Content-type", "application/x-www-form-urlencoded"
    XMLHTTP.Send VarBody
    Select Case XMLHTTP.Status
    Case 200
        SendBeelineSMS = XMLHTTP.responsetext
    Case Else
        Err.Number = vbObjectError + 3
        Err.Description = "Ошибка при отправке запроса: " & XMLHTTP.Status & " " & XMLHTTP.StatusText & vbCrLf
        Exit Function
    End Select
End Function

Function EncodeURIcomponent(SourceString)
    Dim I, C, Out
    For I = 1 To Len(SourceString)
      C = Asc(Mid(SourceString, I, 1))
      If C = 32 Then
        EncodeURIcomponent = EncodeURIcomponent + "+"
      ElseIf (C < 48 Or C > 126) Or (C > 56 And C <= 64) Then
        EncodeURIcomponent = EncodeURIcomponent + "%" + Hex(C)
      Else
        EncodeURIcomponent = EncodeURIcomponent + Chr(C)
      End If
    Next
End Function