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