migrationanalysis/src/driver_docs/sources/CommonPreparation.bas

   1 Attribute VB_Name = "CommonPreparation"
   2 '/*************************************************************************
   3 ' *
   4 ' * DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   5 ' *
   6 ' * Copyright 2008 by Sun Microsystems, Inc.
   7 ' *
   8 ' * OpenOffice.org - a multi-platform office productivity suite
   9 ' *
  10 ' * $RCSfile: CommonPreparation.bas,v $
  11 ' *
  12 ' * This file is part of OpenOffice.org.
  13 ' *
  14 ' * OpenOffice.org is free software: you can redistribute it and/or modify
  15 ' * it under the terms of the GNU Lesser General Public License version 3
  16 ' * only, as published by the Free Software Foundation.
  17 ' *
  18 ' * OpenOffice.org is distributed in the hope that it will be useful,
  19 ' * but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ' * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ' * GNU Lesser General Public License version 3 for more details
  22 ' * (a copy is included in the LICENSE file that accompanied this code).
  23 ' *
  24 ' * You should have received a copy of the GNU Lesser General Public License
  25 ' * version 3 along with OpenOffice.org.  If not, see
  26 ' * <http://www.openoffice.org/license.html>
  27 ' * for a copy of the LGPLv3 License.
  28 ' *
  29 ' ************************************************************************/
  30
  31 Option Explicit
  32 Private Declare Function CryptAcquireContext Lib "advapi32.dll" _
  33    Alias "CryptAcquireContextA" (ByRef phProv As Long, _
  34    ByVal pszContainer As String, ByVal pszProvider As String, _
  35    ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
  36
  37 Private Declare Function CryptReleaseContext Lib "advapi32.dll" ( _
  38    ByVal hProv As Long, ByVal dwFlags As Long) As Long
  39
  40 Private Declare Function CryptCreateHash Lib "advapi32.dll" ( _
  41    ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, _
  42    ByVal dwFlags As Long, ByRef phHash As Long) As Long
  43
  44 Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
  45
  46 Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, _
  47     pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
  48
  49 Private Declare Function CryptGetHashParam Lib "advapi32.dll" ( _
  50    ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, _
  51    pdwDataLen As Long, ByVal dwFlags As Long) As Long
  52
  53 Private Const ALG_CLASS_ANY     As Long = 0
  54 Private Const ALG_TYPE_ANY      As Long = 0
  55 Private Const ALG_CLASS_HASH    As Long = 32768
  56 Private Const ALG_SID_MD5       As Long = 3
  57 ' Hash algorithms
  58 Private Const MD5_ALGORITHM As Long = ALG_CLASS_HASH Or ALG_TYPE_ANY Or ALG_SID_MD5
  59 ' CryptSetProvParam
  60 Private Const PROV_RSA_FULL        As Long = 1
  61 ' used when acquiring the provider
  62 Private Const CRYPT_VERIFYCONTEXT  As Long = &HF0000000
  63 ' Microsoft provider data
  64 Private Const MS_DEFAULT_PROVIDER  As String = _
  65               "Microsoft Base Cryptographic Provider v1.0"
  66
  67 Function DoPreparation(docAnalysis As DocumentAnalysis, myIssue As IssueInfo, preparationNote As String, _
  68                        var As Variant, currDoc As Object) As Boolean
  69     On Error GoTo HandleErrors
  70     Dim currentFunctionName As String
  71     currentFunctionName = "DoPreparation"
  72
  73     DoPreparation = False
  74
  75     'Log as Preparable
  76     AddIssueDetailsNote myIssue, 0, preparationNote, RID_STR_COMMON_PREPARATION_NOTE
  77     myIssue.Preparable = True
  78     docAnalysis.PreparableIssuesCount = docAnalysis.PreparableIssuesCount + 1
  79
  80     If Not CheckDoPrepare Then Exit Function
  81
  82     'Do Prepare
  83
  84     If myIssue.IssueTypeXML = CSTR_ISSUE_OBJECTS_GRAPHICS_AND_FRAMES And _
  85         myIssue.SubTypeXML = CSTR_SUBISSUE_OBJECT_IN_HEADER_FOOTER Then
  86         DoPreparation = Prepare_HeaderFooter_GraphicFrames(docAnalysis, myIssue, var, currDoc)
  87
  88     ElseIf myIssue.IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES And _
  89         myIssue.SubTypeXML = CSTR_SUBISSUE_OLD_WORKBOOK_VERSION Then
  90         DoPreparation = Prepare_WorkbookVersion()
  91
  92     End If
  93
  94 FinalExit:
  95     Exit Function
  96
  97 HandleErrors:
  98     WriteDebug currentFunctionName & _
  99     " : path " & docAnalysis.name & ": " & _
 100     " : myIssue " & myIssue.IssueTypeXML & "_" & myIssue.SubTypeXML & ": " & _
 101     Err.Number & " " & Err.Description & " " & Err.Source
 102     Resume FinalExit
 103 End Function
 104
 105 Function InDocPreparation() As Boolean
 106     InDocPreparation = True
 107 End Function
 108
 109 Function Prepare_DocumentCustomProperties(docAnalysis As DocumentAnalysis, myIssue As IssueInfo, _
 110                                           var As Variant, currDoc As Object) As Boolean
 111     On Error GoTo HandleErrors
 112     Dim currentFunctionName As String
 113     currentFunctionName = "Prepare_DocumentCustomProperties"
 114
 115     Dim aProp As DocumentProperty
 116     Dim myCustomDocumentProperties As DocumentProperties
 117     Dim commentProp As DocumentProperty
 118     Prepare_DocumentCustomProperties = False
 119
 120     Set myCustomDocumentProperties = getAppSpecificCustomDocProperties(currDoc)
 121     Set commentProp = getAppSpecificCommentBuiltInDocProperty(currDoc)
 122     Set aProp = var 'Safe as we know that a DocumentProperty is being passed in
 123
 124     If commentProp.value <> "" Then commentProp.value = commentProp.value & vbLf
 125
 126     commentProp.value = commentProp.value & _
 127                 RID_STR_COMMON_SUBISSUE_DOCUMENT_CUSTOM_PROPERTY & ": " & vbLf
 128
 129     commentProp.value = commentProp.value & _
 130         RID_STR_COMMON_ATTRIBUTE_NAME & " - " & aProp.name & ", " & _
 131         RID_STR_COMMON_ATTRIBUTE_TYPE & " - " & getCustomDocPropTypeAsString(aProp.Type) & ", " & _
 132         RID_STR_COMMON_ATTRIBUTE_VALUE & " - " & aProp.value
 133
 134     myCustomDocumentProperties.item(aProp.name).Delete
 135
 136     Prepare_DocumentCustomProperties = True
 137
 138 FinalExit:
 139     Exit Function
 140
 141 HandleErrors:
 142     WriteDebug currentFunctionName & " : " & docAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source
 143     Resume FinalExit
 144 End Function
 145
 146 Private Function GetProvider(hCtx As Long) As Boolean
 147     Const NTE_BAD_KEYSET = &H80090016
 148     Const NTE_EXISTS = &H8009000F
 149     Const NTE_KEYSET_NOT_DEF = &H80090019
 150     Dim currentFunctionName As String
 151     currentFunctionName = "GetProvider"
 152
 153     Dim strTemp       As String
 154     Dim strProvider  As String
 155     Dim strErrorMsg   As String
 156     Dim errStr As String
 157
 158     GetProvider = False
 159
 160     On Error Resume Next
 161     strTemp = vbNullChar
 162     strProvider = MS_DEFAULT_PROVIDER & vbNullChar
 163     If CBool(CryptAcquireContext(hCtx, ByVal strTemp, _
 164              ByVal strProvider, PROV_RSA_FULL, CRYPT_VERIFYCONTEXT)) Then
 165         GetProvider = True
 166         Exit Function
 167     End If
 168
 169     Select Case Err.LastDllError
 170         Case NTE_BAD_KEYSET
 171             errStr = "Key container does not exist or You do not have access to the key container."
 172         Case NTE_EXISTS
 173             errStr = "The key container already exists, but you are attempting to create it"
 174         Case NTE_KEYSET_NOT_DEF
 175             errStr = "The Crypto Service Provider (CSP) may not be set up correctly"
 176     End Select
 177     WriteDebug currentFunctionName & "Problems acquiring Crypto Provider: " & MS_DEFAULT_PROVIDER & ": " & errStr
 178 End Function
 179
 180
 181
 182 Function MD5HashString(ByVal Str As String) As String
 183     Const HP_HASHVAL = 2
 184     Const HP_HASHSIZE = 4
 185     On Error GoTo HandleErrors
 186     Dim currentFunctionName As String
 187     currentFunctionName = "MD5HashString"
 188
 189     Dim hCtx As Long
 190     Dim hHash As Long
 191     Dim ret As Long
 192     Dim lLen As Long
 193     Dim lIdx As Long
 194     Dim abData() As Byte
 195
 196     If Not GetProvider(hCtx) Then Err.Raise Err.LastDllError
 197
 198     ret = CryptCreateHash(hCtx, MD5_ALGORITHM, 0, 0, hHash)
 199     If ret = 0 Then Err.Raise Err.LastDllError
 200
 201     ret = CryptHashData(hHash, ByVal Str, Len(Str), 0)
 202     If ret = 0 Then Err.Raise Err.LastDllError
 203
 204     ret = CryptGetHashParam(hHash, HP_HASHSIZE, lLen, 4, 0)
 205     If ret = 0 Then Err.Raise Err.LastDllError
 206
 207
 208     ReDim abData(0 To lLen - 1)
 209     ret = CryptGetHashParam(hHash, HP_HASHVAL, abData(0), lLen, 0)
 210     If ret = 0 Then Err.Raise Err.LastDllError
 211
 212     For lIdx = 0 To UBound(abData)
 213         MD5HashString = MD5HashString & Right$("0" & Hex$(abData(lIdx)), 2)
 214     Next
 215     CryptDestroyHash hHash
 216
 217     CryptReleaseContext hCtx, 0
 218
 219 FinalExit:
 220     Exit Function
 221
 222 HandleErrors:
 223     MD5HashString = ""
 224     WriteDebug currentFunctionName & _
 225     Err.Number & " " & Err.Description & " " & Err.Source
 226     Resume FinalExit
 227 End Function
 228