Помоните с https

[Demonx]

Народ помогите скачать картинку через https. Использую MSXML.

[Konst_One]

Код: Выделить всё

Public Function POST( _
    ByVal URL As String, _
    ByVal SendQuery As String, _
    ByRef doc As MSXML2.DOMDocument, _
    Optional ByVal CertificateName As String = "") As Boolean
'<EhHeader>
On Error GoTo Err_debug
'</EhHeader>
Dim objSrvHTTP As MSXML2.ServerXMLHTTP40
Dim objXMLReceive As MSXML2.DOMDocument
Dim s As String
Dim b As String
Const lResolve As Long = 5 * 1000
Const lConnect As Long = 5 * 1000
Const lSend As Long = 15 * 1000
Const lReceive As Long = 15 * 1000

    POST = False
    mMain.LogInfo "POST: " & URL & " Message length: " & Len(SendQuery)
    Set objSrvHTTP = New MSXML2.ServerXMLHTTP40
    objSrvHTTP.setTimeouts lResolve, lConnect, lSend, lReceive
    objSrvHTTP.Open "POST", URL, False
    objSrvHTTP.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    If VBA.Len(CertificateName) > 0 Then
        Call objSrvHTTP.setOption(SXH_OPTION_SELECT_CLIENT_SSL_CERT, CertificateName)
    End If
    objSrvHTTP.send SendQuery
    If GetHTTPStatus(objSrvHTTP.Status) = httpOK Then
        s = objSrvHTTP.getResponseHeader("Content-Type")
        Set objXMLReceive = New MSXML2.DOMDocument
        objXMLReceive.async = False
        b = objXMLReceive.loadXML(objSrvHTTP.responseText)
        objXMLReceive.setProperty "SelectionLanguage", "XPath"
        If objXMLReceive.parseError.errorCode <> 0 Then
            With objXMLReceive.parseError
            #If KP_DEBUG Then
            Debug.Print "Error: " & .errorCode & " on line " & .Line & " position " & .linepos
            Debug.Print .reason
            Debug.Print .srcText
            #End If
            mMain.LogInfo "POST: Parse Error = " & .errorCode & " on line " & .Line & " position " & .linepos
            mMain.LogInfo "POST: Parse Error = " & .srcText
            End With
        Else
            #If KP_DEBUG Then
            Debug.Print objXMLReceive.xml
            #End If
            mMain.LogInfo "POST: XML = " & objXMLReceive.xml
            Set doc = objXMLReceive
            POST = True
        End If
    Else
        mMain.LogInfo "POST: Site Error = " & objSrvHTTP.Status & " " & objSrvHTTP.statusText
        mMain.LogInfo "POST: Site Error HTML = " & objSrvHTTP.responseText
    End If
   
'<EhFooter>
lb_out:
    Set objSrvHTTP = Nothing
    Set objXMLReceive = Nothing
    Exit Function

Err_debug:
    mMain.LogError "POST"
    Resume lb_out
'</EhFooter>
End Function

CertificateName - имя сертификата