Option Compare Database
Option Explicit

Public Certificate
Public Store
Public Signer
Public SignedData

Const CAPICOM_MY_STORE = "MY"
Const CAPICOM_CURRENT_USER_STORE = 2
Const CAPICOM_CERTIFICATE_FIND_EXTENDED_PROPERTY = 6
Const CAPICOM_CERTIFICATE_FIND_TIME_VALID = 9
Const CAPICOM_PROPID_KEY_PROV_INFO = 2
Const CAPICOM_ENCODE_BINARY = 1
Const CAPICOM_ENCODE_BASE64 = 0

'--Основная функция
Sub main(FileName)
Dim BinaryString
Dim Message
Dim Stream

LoadFileAsBinaryString FileName, BinaryString
Signfile BinaryString, Message
If IsEmpty(Message) Then Exit Sub
SaveBinFile FileName & ".sig", Message

'-- Выбираем серификат
Public Sub SignerCertificate()

Dim Certificates
Dim StoreName
Dim StoreLocation
Dim OUR_CERTIFICATE_Name
Dim CAPIUtil

OUR_CERTIFICATE_Name = ”Иванов Иван Иванович”

On Error GoTo Err_Handler

'Объявление Объектов
Set Store = CreateObject("CAPICOM.Store")
Set Signer = CreateObject("CAPICOM.Signer")

'Чтение серитфикатов из хранилища.
StoreLocation = CAPICOM_CURRENT_USER_STORE
StoreName = CAPICOM_MY_STORE
Store.Open StoreLocation, StoreName

Set Certificates = Store.Certificates
' Из них не рассматриваются сертификаты, в которых отсутствует закрытый ключ.
If Certificates.Count > 0 Then
Set Certificates = Certificates.Find(CAPICOM_CERTIFICATE_FIND_EXTENDED_PROPERTY, CAPICOM_PROPID_KEY_PROV_INFO)
End If

' Из них выбираются только сертификаты, действительные в настоящее время.
If Certificates.Count > 0 Then
Set Certificates = Certificates.Find(CAPICOM_CERTIFICATE_FIND_TIME_VALID, DateSerial(Year(Now), Month(Now), Day(Now)))
End If

' По имени владельца определим наш сертификат.
For Each Certificate In Certificates
If Certificate.GetInfo(CAPICOM_CERT_INFO_SUBJECT_DNS_NAME) = OUR_CERTIFICATE_Name Then
Exit For
End If
Next

If IsEmpty(Certificate) Then
Debug.Print "ERROR: Our Certificate not found!"
Set Certificates = Nothing
Set Store = Nothing
Exit Sub
End If

'--Заполняем объект Signer
Signer.Certificate = Certificate
Signer.Options = CAPICOM_CERTIFICATE_INCLUDE_END_ENTITY_ONLY

Set CAPIUtil = CreateObject("CAPICOM.Utilities")

AddAttribute Signer, CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME, CAPIUtil.LocalTimeToUTCTime(Now)

Set SignedData = CreateObject("CAPICOM.SignedData")

'Освобождакм объекты
Set Certificates = Nothing
Set Store = Nothing

End Sub

'-- Читаем файл в бинарную строку.
Sub LoadFileAsBinaryString(FileName, BinaryString)
Dim Stream
Dim CAPIUtil
Dim B, b2
Const adTypeBinary = 1

Set Stream = CreateObject("ADODB.Stream")
Set CAPIUtil = CreateObject("CAPICOM.Utilities")

Stream.Open
Stream.Type = adTypeBinary
Stream.LoadFromFile (FileName)
B = Stream.Read
BinaryString = CAPIUtil.ByteArrayToBinaryString(B)
Stream.Close

b2 = CAPIUtil.BinaryStringToByteArray(BinaryString)
End Sub

'-- Save binary array to FileName.
Sub SaveBinFile(FileName, Message)
Dim Stream
Dim Binarray() As Byte

Const adSaveCreateOverWrite = 2
Const adTypeBinary = 1
Const adModeReadWrite = 3

Binarray = Message
'Debug.Print VarType(Binarray2)
Set Stream = CreateObject("ADODB.Stream")
Stream.Type = adTypeBinary
Stream.Mode = adModeReadWrite
Stream.Open
Stream.Write Binarray
Stream.SaveToFile FileName, adSaveCreateOverWrite
Stream.Close
Set Stream = Nothing
End Sub

'-- Подписываем
Sub Signfile(Content, Message)

On Error GoTo Err_Handler

SignedData.Content = Content
Message = SignedData.Sign(Signer, True, CAPICOM_ENCODE_BINARY)
Exit Sub

Err_Handler:
MsgBox "Вставьте нужный ключ"
Err.Clear
Signfile Content, Message
End Sub

'-- Установить Аттрибут Signer
Sub AddAttribute(Signer, AttrName, AttrVal)
Dim Attribut
Set Attribut = CreateObject("CAPICOM.Attribute")

Attribut.Name = AttrName
Attribut.Value = AttrVal
Signer.AuthenticatedAttributes.Add Attribut
Set Attribut = Nothing
End Sub

Message = SignedData.Sign(Signer, True, CAPICOM_ENCODE_BINARY)