VBA & HTTPS

http://www.sql.ru/forum/actualthread.aspx?tid=534523

130     Set objSrvHTTP = New MSXML2.ServerXMLHTTP40
 131     objSrvHTTP.setTimeouts lResolve, lConnect, lSend, lReceive
240     objSrvHTTP.Open "POST", CStr(URL), False
 250     objSrvHTTP.setRequestHeader "Content-Type", ContentType ' "application/x-www-form-urlencoded"
 'получаем подписанные выбранным сертификатом данные
270     Signature = mHTTP.GetSignature(SendQuery, ErrCode, ErrDesc)
'добавляем полученные данные в заголовок запроса
 280     objSrvHTTP.setRequestHeader "Your-Signature-name", Signature
290     objSrvHTTP.send SendQuery

Public Function GetSignature(ByRef Request As String, Optional ByRef ErrCode As Long, Optional ByRef ErrDesc As String) As String
 Dim s As String
Dim b As Boolean

        GetSignature = ""
         If Len(mMain.CertificateName) = 0 Then
            LogInfo "GetSignature: Не указан сертификат клиента."
             Exit Function
        End If
        b = mHTTP.SignData(mMain.CertificateName, Request, s)
        If b Then
             GetSignature = s
        End If
    
End Function

Public Function SelectCertificate(Optional ByVal CertName As String = "") As CAPICOM.ICertificate
 '<EhHeader>
On Error GoTo Err_debug
'</EhHeader>
Dim MyStore As CAPICOM.Store
 Dim i As Integer

    Set MyStore = New CAPICOM.Store
    MyStore.Open CAPICOM_CURRENT_USER_STORE, "My", CAPICOM_STORE_OPEN_READ_ONLY
     If CertName <> "" Then
        For i = 1 To MyStore.Certificates.Count
             If MyStore.Certificates.Item(i).GetInfo(CAPICOM_CERT_INFO_SUBJECT_SIMPLE_NAME) = CertName Then
                Set SelectCertificate = MyStore.Certificates.Item(i)
                 GoTo lb_out
            End If
        Next i
        LogInfo "SelectCertificate: Error - неверный сертификат=" & CertName
     Else
        Set SelectCertificate = MyStore.Certificates.Item(1)
    End If
     
'<EhFooter>
lb_out:
    Set MyStore = Nothing
    Exit Function
 
Err_debug:
    LogError "SelectCertificate"
    Resume lb_out
'</EhFooter>
End Function
 

Public Function SignData(ByVal CertificateName As String, ByVal InputData As String, ByRef sSignedData As String) As Boolean
 '<EhHeader>
On Error GoTo Err_debug
'</EhHeader>
Dim SignedData As CAPICOM.SignedData
 Dim Signer As CAPICOM.Signer
Dim TimeAttribute As CAPICOM.Attribute

    SignData = False

    Set SignedData = New CAPICOM.SignedData
     Set Signer = New CAPICOM.Signer
    Set TimeAttribute = New CAPICOM.Attribute
    

    ' Set the data that we want to sign
     SignedData.Content = InputData
    Signer.Certificate = SelectCertificate(CertificateName)
            
    'Set the time in which we are applying the signature
    TimeAttribute.Name = CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME
     TimeAttribute.Value = VBA.Date
        
    Signer.AuthenticatedAttributes.Add TimeAttribute
            
    'Do the Sign operation
    sSignedData = SignedData.Sign(Signer, True)
     
    
    SignData = True
    
'<EhFooter>
lb_out:
    Set SignedData = Nothing
    Set Signer = Nothing
     Set TimeAttribute = Nothing
    Exit Function

Err_debug:
    LogError "SignData"
     Resume lb_out
'</EhFooter>
End Function