Visualiser un fichier word contenu dans un champ OLE ACCESS


Commenter

Contenu du snippet 

Private Type  PT
    Width       As Integer
    Height      As Integer
End Type
Private Type OBJECTHEADER
    Signature   As Integer
    HeaderSize  As Integer
    ObjectType  As Long
    NameLen     As Integer
    ClassLen    As Integer
    NameOffset  As Integer
    ObjectSize  As PT
    OleInfo     As String * 256
End Type
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As  Long
'
'    adaptation depuis  http://www.tech-archive.net/Archive/VB/microsoft.public.vb.general.discussion/2005-10/msg01640.html
Function GetOLEWordDoc2File(ByRef vLookUpResult As Variant) As String
'   nécessite les 3 fonctions suivantes
'   GetTempDirectory :  http://www.codyx.org/snippet_recuperer-chemin-temp_772.aspx#2291
'   CreateFileFromBytes :  http://www.codyx.org/snippet_enregistrer-tableau-bytes-dans-fichier_5.aspx#1367
'   StartProcess :  http://www.codyx.org/snippet_ouvrir-document-lancer-executable_25.aspx#1548
    Dim abArr()          As Byte
    Dim sDest            As String
    Dim ObjHeader        As OBJECTHEADER
    Dim ObjectOffset     As Long
    Dim Buffer           As String
    Dim i                As Long
    Dim FileOffset       As Long
    Dim FileHeaderOffset As Integer
    Dim FileStream()     As Byte
    
    
'   tableau  de bytes
    On Local Error GoTo Err_Handler
    abArr = vLookUpResult
    On Error GoTo 0
'   chemin  d'extraction
    sDest = GetTempDirectory & "ExtractionOLE_" & Format$(Now, "MMDDHHNNSS") & ".doc"
    'Copy the first 19  bytes into a variable of the defined type OBJECTHEADER
'   copie le header du champ
    CopyMemory ObjHeader, abArr(0), 19
    'Determine where the  header ends
'   position de la fin du  header
    ObjectOffset = ObjHeader.HeaderSize +  1
    'Grab enough  bytes after the OLE header to get file header
'    récupère le header string du fichier sans le header du ole
    Buffer = ""
    For i = ObjectOffset To ObjectOffset + 512
        Buffer = Buffer & Chr$(abArr(i))
    Next i
    
    'Make sure the class  of the object is Word Document
'   le header  informe bien d'un doc word?
    If Mid$(Buffer, 12, 13) = "Word.Document" Then
'       récupère la  position de la fin de la première partie du header
        FileHeaderOffset = InStr(Buffer, "ÐÏ")
        If FileHeaderOffset > 0 Then
            'Calculate the  beginning of the document
'           fin du  header => début du document
            FileOffset = ObjectOffset + FileHeaderOffset - 1
            
            'Move  document into its own array
'           2e tableau sans le header parasite
            ReDim FileStream(UBound(abArr) -  FileOffset)
            CopyMemory FileStream(0), abArr(FileOffset), UBound(abArr) - FileOffset +  1
            'Document file path
'           enregistrement du tableau dans le doc  temp
            Call CreateFileFromBytes(sDest,  FileStream)
            
'            retour
            GetOLEWordDoc2File = sDest
        End If
    End If
Err_Handler:
    Erase FileStream
    Erase abArr
End Function

Compatibilité : VBA

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (PCPT)