main/migrationanalysis/src/driver_docs/sources/CommonPreparation.bas

Attribute VB_Name = "CommonPreparation"
'*************************************************************************
'
'  Licensed to the Apache Software Foundation (ASF) under one
'  or more contributor license agreements.  See the NOTICE file
'  distributed with this work for additional information
'  regarding copyright ownership.  The ASF licenses this file
'  to you under the Apache License, Version 2.0 (the
'  "License"); you may not use this file except in compliance
'  with the License.  You may obtain a copy of the License at
'
'    http://www.apache.org/licenses/LICENSE-2.0
'
'  Unless required by applicable law or agreed to in writing,
'  software distributed under the License is distributed on an
'  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
'  KIND, either express or implied.  See the License for the
'  specific language governing permissions and limitations
'  under the License.
'
'*************************************************************************
Option Explicit
Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
   Alias "CryptAcquireContextA" (ByRef phProv As Long, _
   ByVal pszContainer As String, ByVal pszProvider As String, _
   ByVal dwProvType As Long, ByVal dwFlags As Long) As Long

Private Declare Function CryptReleaseContext Lib "advapi32.dll" ( _
   ByVal hProv As Long, ByVal dwFlags As Long) As Long

Private Declare Function CryptCreateHash Lib "advapi32.dll" ( _
   ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, _
   ByVal dwFlags As Long, ByRef phHash As Long) As Long

Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long

Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, _
    pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long

Private Declare Function CryptGetHashParam Lib "advapi32.dll" ( _
   ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, _
   pdwDataLen As Long, ByVal dwFlags As Long) As Long

Private Const ALG_CLASS_ANY     As Long = 0
Private Const ALG_TYPE_ANY      As Long = 0
Private Const ALG_CLASS_HASH    As Long = 32768
Private Const ALG_SID_MD5       As Long = 3
' Hash algorithms
Private Const MD5_ALGORITHM As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5
' CryptSetProvParam
Private Const PROV_RSA_FULL        As Long = 1
' used when acquiring the provider
Private Const CRYPT_VERIFYCONTEXT  As Long = &HF0000000
' Microsoft provider data
Private Const MS_DEFAULT_PROVIDER  As String = _
              "Microsoft Base Cryptographic Provider v1.0"

Function DoPreparation(docAnalysis As DocumentAnalysis, myIssue As IssueInfo, preparationNote As String, _
                       var As Variant, currDoc As Object) As Boolean
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "DoPreparation"

    DoPreparation = False

    'Log as Preparable
    AddIssueDetailsNote myIssue, 0, preparationNote, RID_STR_COMMON_PREPARATION_NOTE
    myIssue.Preparable = True
    docAnalysis.PreparableIssuesCount = docAnalysis.PreparableIssuesCount + 1

    If Not CheckDoPrepare Then Exit Function

    'Do Prepare

    If myIssue.IssueTypeXML = CSTR_ISSUE_OBJECTS_GRAPHICS_AND_FRAMES And _
        myIssue.SubTypeXML = CSTR_SUBISSUE_OBJECT_IN_HEADER_FOOTER Then
        DoPreparation = Prepare_HeaderFooter_GraphicFrames(docAnalysis, myIssue, var, currDoc)

    ElseIf myIssue.IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES And _
        myIssue.SubTypeXML = CSTR_SUBISSUE_OLD_WORKBOOK_VERSION Then
        DoPreparation = Prepare_WorkbookVersion()

    End If

FinalExit:
    Exit Function

HandleErrors:
    WriteDebug currentFunctionName & _
    " : path " & docAnalysis.name & ": " & _
    " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _
    Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function

Function InDocPreparation() As Boolean
    InDocPreparation = True
End Function

Function Prepare_DocumentCustomProperties(docAnalysis As DocumentAnalysis, myIssue As IssueInfo, _
                                          var As Variant, currDoc As Object) As Boolean
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "Prepare_DocumentCustomProperties"

    Dim aProp As DocumentProperty
    Dim myCustomDocumentProperties As DocumentProperties
    Dim commentProp As DocumentProperty
    Prepare_DocumentCustomProperties = False

    Set myCustomDocumentProperties = getAppSpecificCustomDocProperties(currDoc)
    Set commentProp = getAppSpecificCommentBuiltInDocProperty(currDoc)
    Set aProp = var 'Safe as we know that a DocumentProperty is being passed in

    If commentProp.value <> "" Then commentProp.value = commentProp.value & vbLf

    commentProp.value = commentProp.value & _
                RID_STR_COMMON_SUBISSUE_DOCUMENT_CUSTOM_PROPERTY & ": " & vbLf

    commentProp.value = commentProp.value & _
        RID_STR_COMMON_ATTRIBUTE_NAME & " - " & aProp.name & ", " & _
        RID_STR_COMMON_ATTRIBUTE_TYPE & " - " & getCustomDocPropTypeAsString(aProp.Type) & ", " & _
        RID_STR_COMMON_ATTRIBUTE_VALUE & " - " & aProp.value

    myCustomDocumentProperties.item(aProp.name).Delete

    Prepare_DocumentCustomProperties = True

FinalExit:
    Exit Function

HandleErrors:
    WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function

Private Function GetProvider(hCtx As Long) As Boolean
    Const NTE_BAD_KEYSET = &H80090016
    Const NTE_EXISTS = &H8009000F
    Const NTE_KEYSET_NOT_DEF = &H80090019
    Dim currentFunctionName As String
    currentFunctionName = "GetProvider"

    Dim strTemp       As String
    Dim strProvider  As String
    Dim strErrorMsg   As String
    Dim errStr As String

    GetProvider = False

    On Error Resume Next
    strTemp = vbNullChar
    strProvider = MS_DEFAULT_PROVIDER & vbNullChar
    If CBool(CryptAcquireContext(hCtx, ByVal strTemp, _
             ByVal strProvider, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)) Then
        GetProvider = True
        Exit Function
    End If

    Select Case Err.LastDllError
        Case NTE_BAD_KEYSET
            errStr = "Key container does not exist or You do not have access to the key container."
        Case NTE_EXISTS
            errStr = "The key container already exists, but you are attempting to create it"
        Case NTE_KEYSET_NOT_DEF
            errStr = "The Crypto Service Provider (CSP) may not be set up correctly"
    End Select
    WriteDebug currentFunctionName & "Problems acquiring Crypto Provider: " & MS_DEFAULT_PROVIDER & ": " & errStr
End Function



Function MD5HashString(ByVal Str As String) As String
    Const HP_HASHVAL = 2
    Const HP_HASHSIZE = 4
    On Error GoTo HandleErrors
    Dim currentFunctionName As String
    currentFunctionName = "MD5HashString"

    Dim hCtx As Long
    Dim hHash As Long
    Dim ret As Long
    Dim lLen As Long
    Dim lIdx As Long
    Dim abData() As Byte

    If Not GetProvider(hCtx) Then Err.Raise Err.LastDllError

    ret = CryptCreateHash(hCtx, MD5_ALGORITHM, 0, 0, hHash)
    If ret = 0 Then Err.Raise Err.LastDllError

    ret = CryptHashData(hHash, ByVal Str, Len(Str), 0)
    If ret = 0 Then Err.Raise Err.LastDllError

    ret = CryptGetHashParam(hHash, HP_HASHSIZE, lLen, 4, 0)
    If ret = 0 Then Err.Raise Err.LastDllError


    ReDim abData(0 To lLen - 1)
    ret = CryptGetHashParam(hHash, HP_HASHVAL, abData(0), lLen, 0)
    If ret = 0 Then Err.Raise Err.LastDllError

    For lIdx = 0 To UBound(abData)
        MD5HashString = MD5HashString & Right$("0" & Hex$(abData(lIdx)), 2)
    Next
    CryptDestroyHash hHash

    CryptReleaseContext hCtx, 0

FinalExit:
    Exit Function

HandleErrors:
    MD5HashString = ""
    WriteDebug currentFunctionName & _
    Err.Number & " " & Err.Description & " " & Err.Source
    Resume FinalExit
End Function