const VARIANT_TRUE = 1
const VARIANT_FALSE = 0
'Криптопровайдер
const PROV_GOST_2001_DH = 75
const PROV_INFOTECS = 2
'Distinguished Name
const XCN_CERT_NAME_STR_ENABLE_UTF8_UNICODE_FLAG = &H40000
'Закрытый ключ
const AT_KEYEXCHANGE = 1
const AT_SIGNATURE = 2
const PRIVATE_KEY_LENGTH = 1024
const XCN_NCRYPT_ALLOW_ALL_USAGES = &HFFFFFF
const XCN_NCRYPT_ALLOW_EXPORT_NONE = 0
const XCN_NCRYPT_ALLOW_EXPORT_FLAG = 1
const CRYPT_EXPORTABLE = 1
'Использование ключа
const XCN_CERT_DIGITAL_SIGNATURE_KEY_USAGE = &H80
const XCN_CERT_NON_REPUDIATION_KEY_USAGE = &H40
const XCN_CERT_KEY_ENCIPHERMENT_KEY_USAGE = &H20
const XCN_CERT_DATA_ENCIPHERMENT_KEY_USAGE = &H10
'Запрос сертификата
const XECR_PKCS10_V2_0 = 1
const XECR_PKCS7 = 2
const XECR_CMC = 3
const XECR_PKCS10_V1_5 = 4
const CONTEXT_USER = 1
'Регистрация запроса сертификата
const XCN_CRYPT_STRING_BASE64HEADER = 0
const XCN_CRYPT_STRING_BASE64 = 1
const XCN_CRYPT_STRING_ANY = 7
const ALLOW_UNTRUSTED_ROOT = 4
'Алгоритм подписи
const GOST_R_3411 = 32798
'Ошибки
const ERR_BAD_PARAMETER = 5

Function CreateCertRequestWithCertEnroll( dn_str, eku_arr_str, policy_str, extensions_map, exportable )
On Error Resume Next
'Инициализируем криптопровайдер
Set prov_alg_oid = CreateObject( "X509Enrollment.CObjectId" )
prov_alg_oid.InitializeFromValue( OID_CP_GOST_28147 )
Set provider_info = CreateObject( "X509Enrollment.CCspInformation" )
'Пытаемся инициализировать криптопровайдер с типом PROV_GOST_2001_DH
'В случае ошибки (ERR_BAD_PARAMETER - Недопустимый вызов или аргумент процедуры) пытаемся инициализировать криптопровайдер с типом PROV_INFOTECS
provider_info.InitializeFromType PROV_GOST_2001_DH, prov_alg_oid, VARIANT_FALSE
If Err.Number = ERR_BAD_PARAMETER Then
Err.Number = 0
provider_info.InitializeFromType PROV_INFOTECS, prov_alg_oid, VARIANT_FALSE
End If

'Начинаем формировать запрос сертификата
Set request = CreateObject( "X509Enrollment.CX509CertificateRequestPkcs10" )

'Указываем параметры секретного ключа
Set private_key = CreateObject( "X509Enrollment.CX509PrivateKey" )
private_key.CspInformations = CreateObject( "X509Enrollment.CCspInformations" )
private_key.CspInformations.Add( provider_info )
private_key.ProviderType = provider_info.Type
private_key.ProviderName = provider_info.Name
private_key.KeySpec = AT_KEYEXCHANGE
private_key.Length = PRIVATE_KEY_LENGTH
private_key.KeyUsage = XCN_NCRYPT_ALLOW_ALL_USAGES
private_key.MachineContext = VARIANT_FALSE
If( exportable = True ) Then
private_key.ExportPolicy = XCN_NCRYPT_ALLOW_EXPORT_FLAG
Else
private_key.ExportPolicy = XCN_NCRYPT_ALLOW_EXPORT_NONE
End If
request.InitializeFromPrivateKey CONTEXT_USER, private_key, ""

'Указываем реквизиты субъекта сертификата
Set dn = CreateObject( "X509Enrollment.CX500DistinguishedName" )
dn.Encode dn_str, XCN_CERT_NAME_STR_ENABLE_UTF8_UNICODE_FLAG
request.Subject = dn

'Указываем параметры использования ключа
Set key_usage_ext = CreateObject( "X509Enrollment.CX509ExtensionKeyUsage" )
key_usage_flags = ( XCN_CERT_DIGITAL_SIGNATURE_KEY_USAGE OR XCN_CERT_NON_REPUDIATION_KEY_USAGE OR XCN_CERT_KEY_ENCIPHERMENT_KEY_USAGE OR XCN_CERT_DATA_ENCIPHERMENT_KEY_USAGE )
key_usage_ext.InitializeEncode( key_usage_flags )
request.X509Extensions.Add( key_usage_ext )

'Задаём расширения сертификата, из заявки
For Each oid In extensions_map
Set cur_extension = CreateObject( "X509Enrollment.CX509Extension" )
Set cur_extension_oid = CreateObject( "X509Enrollment.CObjectId" )
cur_extension_oid.InitializeFromValue( oid )
cur_value = Base64Encode( extensions_map( oid ) )
cur_extension.Initialize cur_extension_oid, XCN_CRYPT_STRING_BASE64, cur_value
request.X509Extensions.Add( cur_extension )
Next

'Указываем параметры улучшенного использования ключа
Set eku_oids = CreateObject( "X509Enrollment.CObjectIds" )
'Парсим строку с OID'ами, извлекая их по очереди, и помещаем каждый OID в отдельный объект
While Len( eku_arr_str ) > 0
right_comma_pos = InStrRev( eku_arr_str, "," )
If( right_comma_pos = 0 ) Then
cur_eku_str = eku_arr_str
eku_arr_str = ""
Else
cur_eku_str = Mid( eku_arr_str, right_comma_pos + 1, Len( eku_arr_str ) - rigth_comma_pos - 1 )
eku_arr_str = Left( eku_arr_str, right_comma_pos - 1 )
End If
Set eku_oid = CreateObject( "X509Enrollment.CObjectId" )
eku_oid.InitializeFromValue( cur_eku_str )
eku_oids.Add( eku_oid )
Wend
Set eku_ext = CreateObject( "X509Enrollment.CX509ExtensionEnhancedKeyUsage" )
eku_ext.InitializeEncode( eku_oids )
request.X509Extensions.Add( eku_ext )

'Задаём политики сертификата, если они есть
Set policies = CreateObject( "X509Enrollment.CCertificatePolicies" )
While Len( policy_str ) > 0
right_comma_pos = InStrRev( policy_str, "," )
If( right_comma_pos = 0 ) Then
cur_policy_str = policy_str
policy_str = ""
Else
cur_policy_str = Mid( policy_str, right_comma_pos + 1, Len( policy_str ) - rigth_comma_pos - 1 )
policy_str = Left( policy_str, right_comma_pos - 1 )
End If
Set policy_oid = CreateObject( "X509Enrollment.CObjectId" )
policy_oid.InitializeFromValue( cur_policy_str )
Set policy = CreateObject( "X509Enrollment.CCertificatePolicy" )
policy.Initialize( policy_oid )
policies.Add( policy )
Wend
Set policies_ext = CreateObject( "X509Enrollment.CX509ExtensionCertificatePolicies" )
policies_ext.InitializeEncode( policies )
request.X509Extensions.Add( policies_ext )

'Задаём возможности SMIME
request.SmimeCapabilities = VARIANT_TRUE

'Создаём ключи и запрос сертификата
Set enrollment = CreateObject( "X509Enrollment.CX509Enrollment" )
enrollment.InitializeFromRequest( request )
Dim request_strm
request_strm = enrollment.CreateRequest( XCN_CRYPT_STRING_BASE64 )

'Обрабатываем возможные ошибки и возвращаем результат
If Err.Number = 0 Then
CreateCertRequestWithCertEnroll = request_strm
Else
MsgBox( "Ошибка 0x" & Hex( Err.Number ) & ": " & Err.Description )
CreateCertRequestWithCertEnroll = ""
End If
End Function