Option Compare Database
Option Explicit

Public OUR_CERTIFICATE_Name

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
Const CAPICOM_AUTHENTICATED_ATTRIBUTE_DOCUMENT_DESCRIPTION = 2

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

     LoadFileAsBinaryString FileName, BinaryString
     Signfile BinaryString, SignedData
     If IsEmpty(SignedData) Then Exit Sub
     SaveFile FileName & ".sig", SignedData
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

'-- Сохраняет buffer в файл
Sub SaveFile(FileName, Buffer)
Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")
    Dim ts
    Set ts = fso.OpenTextFile(FileName, 2, True)
    ts.Write Buffer
End Sub

'-- Подписывает.
Sub Signfile(Content, Message)
Dim Store
Dim Certificates
Dim Certificate
Dim StoreName
Dim Signer
Dim StoreLocation
Dim SignedData
Dim t As String
Dim Attribut

On Error GoTo Err_Handler

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

'Чтение серитфикатов из хранилища.
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

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

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

Dim CAPIUtil
Set CAPIUtil = CreateObject("CAPICOM.Utilities")

AddAttribute Signer, CAPICOM_AUTHENTICATED_ATTRIBUTE_SIGNING_TIME, CAPIUtil.LocalTimeToUTCTime(Now)

AddAttribute Signer, CAPICOM_AUTHENTICATED_ATTRIBUTE_DOCUMENT_NAME, "Test"

' Создание объекта SignedData.
Set SignedData = CreateObject("CAPICOM.SignedData")
SignedData.Content = Content

Message = SignedData.Sign(Signer, True) 'Если нужна не отцепленная подпись, то False

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