Форум программистов, компьютерный форум, киберфорум
Наши страницы
Замабувараев
Войти
Регистрация
Восстановить пароль
Оценить эту запись

Получение ответа от вебсервера через XmlHttpRequest на FreeBASIC

Запись от Замабувараев размещена 09.04.2018 в 21:25

Эта статья посвящена интерфейсу IXmlHttpRequest и его использованию на фрибейсике.

Предупреждение: так как на этом форуме до сих пор отсутствует подсветка кода для FreeBASIC, то приходится размечать код как QBASIC, но в этом случае форум преобразует все ключевые слова в верхний регистр.

Как всем известно, XmlHttpRequest применяется для отправки запроса и получения ответа от вебсервера. Попробуем создать такой объект и мы.

Само определение интерфейса вместе с его таблицей виртуальных функций находится в файле «win\msxml.bi» примерно на строке 2221.

Для начала подключаем заголовочные файлы:

QBasic/QuickBASIC
1
2
3
4
5
6
#ifndef unicode
#define unicode
#endif
 
#include once "windows.bi"
#include once "win\objbase.bi"
Объявляем константы:

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
' Имя объекта из реестра
CONST ProgID_XmlHttpRequest = "Microsoft.XmlHttp"
' Имя сайта, с которого нужно получить ответ
CONST HttpUrl = "http://www.cyberforum.ru/"
' Метод доступа к сайту
CONST HttpMethod = "GET"
' Пустая строка
CONST EmptyWString = ""
Инициализируем переменные:

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
DIM varFalse AS VARIANT = ANY
With varFalse
    .vt = VT_BOOL
    .boolVal = VARIANT_FALSE
END With
 
DIM varEmptyBSTR AS VARIANT = ANY
With varEmptyBSTR
    .vt = VT_BSTR
    .bstrVal = SysAllocString(@EmptyWString)
END With
 
DIM bstrMethod AS BSTR = SysAllocString(@HttpMethod)
DIM bstrUrl AS BSTR = SysAllocString(@HttpUrl)
Инициализируем среду COM:

QBasic/QuickBASIC
1
2
3
4
IF CoInitialize(0) <> S_OK THEN
    PRINT "Не могу инициализировать COM"
    END(0)
END IF
Получаем CLSID по имени объекта:

QBasic/QuickBASIC
1
2
3
4
5
6
7
DIM idclsidXmlHttpRequest AS CLSID
DIM hr AS HRESULT = CLSIDFromProgID(@ProgID_XmlHttpRequest, @idclsidXmlHttpRequest)
 
IF FAILED(hr) THEN
    PRINT "Не могу разрешить CLSID по ProgID", Hex(hr)
    END(1)
END IF
Получаем фабрику класссов для создания объекта XmlHttpRequest:

QBasic/QuickBASIC
1
2
3
4
5
6
7
DIM pClassFactory AS IClassFactory Ptr = NULL
hr = CoGetClassObject(@idclsidXmlHttpRequest, CLSCTX_INPROC, NULL, @IID_IClassFactory, @pClassFactory)
 
IF FAILED(hr) THEN
    PRINT "Ошибка в CoGetClassObject", Hex(hr)
    END(1)
END IF
Теперь можно создавать объект и делать запросы к сайту:

QBasic/QuickBASIC
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
' Наш указатель на интерфейс
DIM pRequest AS IXMLHttpRequest Ptr = NULL
 
hr = pClassFactory->lpVtbl->CreateInstance(pClassFactory, NULL, @IID_IXmlHttpRequest, @pRequest)
IF FAILED(hr) THEN
    PRINT "Не могу создать XmlHttpRequest", Hex(hr)
ELSE
    
    Scope
        ' Метод Open подготавливает соединение с сайтом
        hr = pRequest->lpVtbl->OPEN(pRequest, bstrMethod, bstrUrl, varFalse, varEmptyBSTR, varEmptyBSTR)
        IF FAILED(hr) THEN
            PRINT "Не могу запустить метод Open из XmlHttpRequest", Hex(hr)
        END IF
        
        ' Метод Send отправляет запрос на сервер
        hr = pRequest->lpVtbl->Send(pRequest, varSendFileDataBSTR)
        IF FAILED(hr) THEN
            PRINT "Не могу запустить метод Send из XmlHttpRequest", Hex(hr)
        END IF
    END Scope
    
    Scope
        ' Получаем код ответа от сервера
        DIM StatusCode AS LONG
        hr = pRequest->lpVtbl->get_status(pRequest, @StatusCode)
        IF FAILED(hr) THEN
            PRINT "Не могу получить get_status из XmlHttpRequest", Hex(hr)
        ELSE
            PRINT "Код состояния", StatusCode
        END IF
    END Scope
    
    Scope
        ' Показываем все заголовки ответа
        DIM bstrHeaders AS BSTR
        hr = pRequest->lpVtbl->getAllResponseHeaders(pRequest, @bstrHeaders)
        IF FAILED(hr) THEN
            PRINT "Не могу получить getAllResponseHeaders из XmlHttpRequest", Hex(hr)
        ELSE
            IF bstrHeaders <> 0 THEN
                DIM HeadersValue AS WString Ptr = @bstrHeaders[0]
                PRINT "Заголовки ответа"
                PRINT *HeadersValue
                SysFreeString(bstrHeaders)
            END IF
        END IF
    END Scope
    
    Scope
        ' Показываем весь текст ответа
        DIM bstrResponseText AS BSTR
        hr = pRequest->lpVtbl->get_responseText(pRequest, @bstrResponseText)
        IF FAILED(hr) THEN
            PRINT "Не могу получить get_responseText из XmlHttpRequest", Hex(hr)
        ELSE
            IF bstrResponseText <> 0 THEN
                DIM ResponseText AS WString Ptr = @bstrResponseText[0]
                PRINT "Текст ответа"
                PRINT *ResponseText
                SysFreeString(bstrResponseText)
            END IF
        END IF
    END Scope
    
    ' Уничтожение объекта, он больше не нужен
    pRequest->lpVtbl->Release(pRequest)
END IF
 
' Уничтожение фабрики классов, она больше не нужна
pClassFactory->lpVtbl->Release(pClassFactory)
 
' Очистка среды COM
CoUninitialize()
Очистка:

QBasic/QuickBASIC
1
2
3
4
VariantClear(@varEmptyBSTR)
VariantClear(@varFalse)
SysFreeString(bstrUrl)
SysFreeString(bstrMethod)
Примечание: исходный код нужно сохранять в какой‐нибудь юникодной кодировке: UTF-8 или UTF-16.
Размещено в Без категории
Просмотров 445 Комментарии 2
Всего комментариев 2
Комментарии
  1. Старый комментарий

    Можно вместо CoGetClassObject также вызывать сразу CoCreateInstance (без фабрики классов) если не требуется создавать множество объектов XmlHttp.
    Запись от The trick размещена 30.04.2018 в 15:15 The trick вне форума
  2. Старый комментарий
    Аватар для Замабувараев
    Цитата:
    Сообщение от The trick Просмотреть комментарий

    Можно вместо CoGetClassObject также вызывать сразу CoCreateInstance (без фабрики классов) если не требуется создавать множество объектов XmlHttp.
    Да, так получается короче.
    Запись от Замабувараев размещена 01.05.2018 в 21:47 Замабувараев вне форума
 
КиберФорум - форум программистов, компьютерный форум, программирование
Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2018, vBulletin Solutions, Inc.
Рейтинг@Mail.ru