· 6 years ago · Jun 27, 2019, 05:30 AM
1Option Compare Database
2Option Explicit
3
4
5'DEVELOPED AND TESTED UNDER MICROSOFT ACCESS 97 through A2003
6'
7'Copyright: Stephen Lebans - Lebans Holdings 1999 Ltd.
8
9
10'Distribution:
11
12' Plain and simple you are free to use this source within your own
13' applications, whether private or commercial, without cost or obligation, other that keeping
14' the copyright notices intact. No public notice of copyright is required.
15' You may not resell this source code by itself or as part of a collection.
16' You may not post this code or any portion of this code in electronic format.
17' The source may only be downloaded from:
18' www.lebans.com
19'
20'Name: GetContentsStream
21'
22'Version: 2.89
23'
24'Purpose:
25'
26' 1) Export data inserted into OLE object field.
27' The original application that served as an OLE Server to insert
28' the object is NOT required.
29'
30' 2) Perform an inventory of OLE field within an external table.
31' Returns inventory information including Linked path/filename if applicable.
32'
33'
34'
35'Author: Stephen Lebans
36'
37'Email: Stephen@lebans.com
38'
39'Web Site: www.lebans.com
40'
41'Date: Nov 17, 2007, 12:34:56 PM
42'
43'Dependencies: StrStorage.dll(Standard Windows DLL - DOES NOT require Registration.
44' modGetContents Stream
45' modListTables
46' clsCommonDialog
47' cDIBSection
48'
49'Inputs: See inline Comments for explanation
50
51'Output: See inline Comments for explanation
52'
53'Credits: Anyone who wants some!
54'
55'BUGS: Please report any bugs to my email address.
56'
57'What's Missing:
58' Enhanced Error Handling
59'
60'How it Works:
61' Keep reading!
62
63' Ver Jan 16 - 2008
64' Working on fixing Bug for embedded OT_STATIC MetafilePict
65' Added support for FoxitReader.Document embedded objects(PDF)
66
67' Ver Nov 17, 2007
68' Added support for WordPad documents.
69
70' Ver June 7, 2007
71' Added support for Kodak Imaging TIFF documents.
72
73
74' Ver March 20
75' Added support for PaperPort MAX documents and
76' HP DeskScan embedded images(Bitmaps).
77
78' This module exposes two functions.
79'Public Function fGetContentsStream(ByRef arrayOLE() As Byte, _
80'FileExtension As String, _
81'Optional FileNamePackage As String = "") As Boolean
82
83' The first parameter, arrayOLE, is an array of Byte values that contain the entire
84' contents of an OLE object field. We pass the the first element of the
85' array be Reference, arrayOLE(0), which really means we are passing
86' the address of the start of the array.
87
88' The second parameter, FileExtension, is a empty string variable you pass that will
89' be filled in with the file extension of the extracted object.
90
91' The third parameter, FileNamePackage, is a empty string variable you pass that will
92' be filled in with the original file name of the extracted object when the object
93' was embedded as a Package.
94
95
96
97'Public Function fInventory(ByRef arrayOLE() As Byte, _
98'ClassName As String, _
99'ObjectName As String, _
100'LinkedFileName As String, _
101'FileNamePackage As String, _
102'ObjectType As Long) As Boolean
103
104' The first parameter, arrayOLE, is an array of Byte values that contain the entire
105' contents of an OLE object field. We pass the the first element of the
106' array be Reference, arrayOLE(0), which really means we are passing
107' the address of the start of the array.
108
109' ClassName, ObjectName, LinkedFileName and FileNamePackage
110' are all empty strings you pass to this function that upon
111' Return will be filled in.
112' ObjectType is an empty Long variable that upon Return
113' will be filled in with the OLE object type, Linked, Embedded or Static
114
115
116
117'The StrStorage DLL exposes two functions.
118
119'Public Declare Function GetContentsStream Lib "C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll" _
120'(FirstElement As Byte, _
121' ByVal lElements As Long, _
122' ByVal sStreamName As String) As Long
123'
124' Public Declare Function ExtractOfficeDocument Lib "C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll" _
125'(FirstElement As Byte, _
126' ByVal lElements As Long, _
127' ByVal sStreamName As String) As Long
128
129' We call these 2 functions in VBA like this:
130'
131' lLen = ExtractOfficeDocument(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
132'
133' lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
134'
135'
136' The first parameter, arrayOLE is an array of Byte values that contain the entire
137' contents of an OLE object field. We pass the the first element of the
138' array be Reference, arrayOLE(0), which really means we are passing
139' the address of the start of the array.
140
141' The second parameter, Ubound(arrayOLE), is the length of the array.
142
143' The third parameter, is the name of the Structured Storage stream we
144' want to extract.
145
146'
147'
148'Have Fun!
149'
150'
151'
152' ******************************************************
153
154
155Private Type RECT
156 Left As Long
157 top As Long
158 right As Long
159 Bottom As Long
160End Type
161
162Private Type SIZEL
163 cx As Long
164 cy As Long
165End Type
166
167
168Private Type RGBQUAD
169 rgbBlue As Byte
170 rgbGreen As Byte
171 rgbRed As Byte
172 rgblReserved As Byte
173End Type
174
175Private Type BITMAPINFOHEADER '40 bytes
176 biSize As Long
177 biWidth As Long
178 biHeight As Long
179 biPlanes As Integer
180 biBitCount As Integer
181 biCompression As Long 'ERGBCompression
182 biSizeImage As Long
183 biXPelsPerMeter As Long
184 biYPelsPerMeter As Long
185 biClrUsed As Long
186 biClrImportant As Long
187End Type
188
189
190Private Type BITMAPINFO
191 bmiHeader As BITMAPINFOHEADER
192 bmiColors As RGBQUAD
193End Type
194
195
196Private Type BITMAP
197 bmType As Long
198 bmWidth As Long
199 bmHeight As Long
200 bmWidthBytes As Long
201 bmPlanes As Integer
202 bmBitsPixel As Integer
203 bmBits As Long
204End Type
205
206Private Type DIBSECTION
207 dsBm As BITMAP
208 dsBmih As BITMAPINFOHEADER
209 dsBitfields(2) As Long
210 dshSection As Long
211 dsOffset As Long
212End Type
213
214
215' Here is the header for the Bitmap file
216' as it resides in a disk file
217Private Type BITMAPFILEHEADER '14 bytes
218 bfType As Integer
219 bfSize As Long
220 bfReserved1 As Integer
221 bfReserved2 As Integer
222 bfOffBits As Long
223End Type
224
225Private Type METAFILEPICT
226 mm As Long
227 xExt As Long
228 yExt As Long
229 hMF As Long
230End Type
231
232
233Private Const CON_CHUNK_SIZE As Long = 32768
234Private Const OBJECT_SIGNATURE = &H1C15
235Private Const OBJECT_HEADER_SIZE = 20
236Private Const CHECKSUM_SIGNATURE = &HFE05AD00
237Private Const CHECKSUM_STRING_SIZE = 4
238Private Const SIG_BMP = &H4D42
239
240
241Private Type PT
242 width As Integer
243 Height As Integer
244End Type
245'
246'
247' OBJECTHEADER : Contains relevant information about object.
248'
249Private Type OBJECTHEADER
250 Signature As Integer ' Type signature (0x1c15).
251 HeaderSize As Integer ' Size of header (sizeof(struct
252 ' OBJECTHEADER) + cchName +
253 ' cchClass).
254 ObjectType As Long ' OLE Object type code (OT_STATIC,
255 ' OT_LINKED, OT_EMBEDDED).
256 NameLen As Integer ' Count of characters in object
257 ' name (CchSz(szName) + 1).
258 ClassLen As Integer ' Count of characters in class
259 ' name (CchSz(szClass) + 1).
260 NameOffset As Integer ' Offset of object name in
261 ' structure (sizeof(OBJECTHEADER)).
262 ClassOffset As Integer ' Offset of class name in
263 ' structure (ibName + cchName).
264 ObjectSize As PT ' Original size of object (see
265 ' code below for value).
266' OleInfo(256) As Byte
267End Type
268
269'/* Object types */
270Public Const OT_LINK As Long = 1&
271Public Const OT_EMBEDDED = 2&
272Public Const OT_STATIC = 3&
273
274
275
276Private Type MSPHOTOEDITOR_CONTENTS_HEADER
277 bmBitDepth As Integer
278 bmWidth As Integer
279 bmHeight As Integer
280End Type
281
282' Pass first element of Byte array - ex. a(0)
283' Pass size of array in bytes
284' Return length of valid data in the passed array of bytes
285' Array will contain complete CONTENTS Stream of Structured Storage
286Public Declare Function GetContentsStream Lib "SSGetContents.dll" _
287(FirstElement As Byte, _
288 ByVal lElements As Long, _
289 ByVal sStreamName As String _
290 ) As Long
291
292
293
294 ' Pass first element of Byte array - ex. a(0)
295' Pass size of array in bytes
296' Return length of valid data in the passed array of bytes
297' Array will contain complete embedded Ole10Native Stream of Structured Storage
298Public Declare Function GetContentsStreamChild Lib "SSGetContents.dll" _
299(FirstElement As Byte, _
300 ByVal lElements As Long, _
301 ByVal sStreamName As String _
302 ) As Long
303
304
305
306 Public Declare Function ExtractOfficeDocument Lib "SSGetContents.dll" _
307(FirstElement As Byte, _
308 ByVal lElements As Long, _
309 ByVal sStreamName As String) As Long
310
311' For debugging with Visual C++
312'Lib "C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll"
313
314Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
315(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
316
317Private Declare Function ShellExecuteA Lib "shell32.dll" _
318(ByVal hwnd As Long, ByVal lpOperation As String, _
319ByVal lpFile As String, ByVal lpParameters As String, _
320ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
321
322Private Declare Function LoadLibrary Lib "kernel32" _
323Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
324
325Private Declare Function FreeLibrary Lib "kernel32" _
326(ByVal hLibModule As Long) As Long
327
328Private Declare Function GetTempPath Lib "kernel32" _
329Alias "GetTempPathA" (ByVal nBufferLength As Long, _
330ByVal lpBuffer As String) As Long
331
332Private Declare Function GetTempFileName _
333Lib "kernel32" Alias "GetTempFileNameA" _
334(ByVal lpszPath As String, _
335ByVal lpPrefixString As String, _
336ByVal wUnique As Long, _
337ByVal lpTempFileName As String) As Long
338
339Private Declare Function GetLongPathName Lib "kernel32.dll" Alias _
340"GetLongPathNameA" (ByVal lpszShortPath As String, _
341 ByVal lpszLongPath As String, _
342 ByVal cchBuffer As Long) As Long
343
344Public Declare Function GetFullPathName Lib "kernel32" _
345 Alias "GetFullPathNameA" _
346 (ByVal lpFileName As String, _
347 ByVal nBufferLength As Long, _
348 ByVal lpBuffer As String, _
349 ByVal lpFilePart As String) As Long
350
351
352
353
354Private Const Pathlen = 256
355Private Const MaxPath = 256
356
357' Structured Storage Signature = 'D0CF11E0
358Private Const SSsig As Long = &HE011CFD0
359
360' Allow user to set FileName instead
361' of using API Temp Filename or
362' popping File Dialog Window
363Private mSaveFileName As String
364
365' Instance returned from LoadLibrary call
366Private hLibStrStorage As Long
367
368' * Move this into a class so we can init/destroy properly
369Private ds As cDIBSection
370
371
372Public Function fGetContentsStream(ByRef arrayOLE() As Byte, _
373FileExtension As String, _
374Optional FileNamePackage As String = "") As Boolean
375' arrayOLE must contain the entire contents of the OLE field.
376' Returns arrayOLE resized to fit and contain the
377' CONTENTS Stream of the OLE Structured Storage passed to this function.
378' Exceptions are for the "Package" type and Bitmap's embedded with MS Paint.
379
380' Hold working copy of arrayOLE
381Dim arrayB() As Byte
382
383' Size of "Package"
384Dim lPackSize As Long
385
386' File Extension of Package
387Dim FileNamePackageExt As String
388' Original File Name and Path of Package
389Dim FileNameandPathPackage As String
390
391' Current position in arrayOLE
392Dim lPos As Long
393
394' Temp vars
395Dim bCurValue As Byte
396Dim iOffset As Integer
397Dim i As Integer
398Dim x As Long
399Dim s As String
400Dim blRet As Boolean
401Dim lngRet As Long
402Dim y As Long
403
404' Length of array returned from functions in Structured Storage DLL.
405Dim lLen As Long
406
407' Access OLE Wrapper
408Dim objHeader As OBJECTHEADER
409
410' Offset to start of structured storage file
411Dim lOffSet As Long
412
413' Class name of embedded OLE object
414Dim arrayClassName(0 To 1023) As Byte
415
416' OLE object temp vars
417Dim sClassName As String
418Dim sStreamName As String
419Dim sBuf As String
420Dim sExt As String
421
422Dim mfp As METAFILEPICT
423Dim bm As BITMAPINFOHEADER
424
425
426On Error GoTo ERR_fGetContentsStream
427
428' Get Offset to start of Structured Storage
429CopyMemory objHeader, arrayOLE(0), OBJECT_HEADER_SIZE
430lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
431
432' If Linked object then exit
433If objHeader.ObjectType = OT_LINK Then
434 fGetContentsStream = False
435 Exit Function
436End If
437
438' Let's see if the StrStorage.DLL is available.
439'blRet = LoadLib()
440'If blRet = False Then
441' ' Cannot find StrStorage.dll file
442' fGetContentsStream = False
443' Exit Function
444'End If
445
446' If OLE object was draged and dropped then
447' the ClassLen member with be a NULL string
448'If objHeader.ClassLen > 1 Then
449 ' Convert byte Ascii data to VB string
450 sClassName = ""
451 For i = 0 To objHeader.ClassLen - 2
452 sClassName = sClassName & Chr(arrayOLE(objHeader.ClassOffset + i))
453 Next i
454'Else
455
456' Add support for ClassLen = 0 - Drag and Dropped OLE object
457'End If
458
459' Call seperate function if object is of type STATIC
460If objHeader.ObjectType = OT_STATIC Then
461sClassName = "OT_STATIC"
462End If
463
464' Logic tree based on ClassName of embedded object
465Select Case Left(sClassName, 7)
466
467Case "OT_STAT"
468' Two possibilities.
469' Static MetafilePict or Static DIB
470' Standard OLE wrapper but it is always the same size
471' because the Class name is blank and Object name is always "Picture".
472' 29 Bytes Access OLE Header wrapper.
473
474' The following 12 Bytes are private header data
475' This brings us to offset 41.
476' The next 3 bytes will either be = "DIB or "MET"
477' DIB
478' After "DIB" + terminating NULL char we jump over next
479' 8 bytes of private data.
480
481' The next 4 bytes are the size of the Bitmap.
482'
483' The next 40 Bytes are the BITMAPINFOHEADER structure
484' The next 4 bytes are always the value 40 - SIZEOF BITMAPINFOHEADER
485
486' The next X bytes are the BITMAPINFOHEADER
487
488' So once we get to the LONG SIZEOF bitmap data we can build
489' the disk basked BMP file.
490' The next X bytes are the actual Bitmap Data
491'
492'
493
494' Start of Package header
495' Jan - 2008 Offset out by 1 - was 41
496lPos = 40
497'' Skip nexy 4 bytes - Package size including padding
498'lPos = lPos + 4
499' Skip next 2 bytes - Embedded constant - 2 ?
500'lPos = lPos + 2
501
502' Checking for 0 so must initialize to any value but 0.
503bCurValue = 1
504
505Dim lSize As Long
506Dim FileHeaderBM As BITMAPFILEHEADER
507
508Dim sType As String
509' DIB or METAFILEPICT
510Do While bCurValue <> 0
511 bCurValue = arrayOLE(lPos)
512 sType = sType & Chr(bCurValue)
513 lPos = lPos + 1
514Loop
515
516' Jump over next 8 bytes of private data
517lPos = lPos + 8
518
519If sType = "DIB" Then
520 ' Get size of Bitmap Data
521 CopyMemory lSize, arrayOLE(lPos), 4
522 ' Make sure is less than arrayOLE
523 If lSize > UBound(arrayOLE) Then
524 ' Error
525 fGetContentsStream = False
526 Exit Function
527 End If
528 ' 14 is the size of the Bitmap disk File Header
529 ReDim arrayB(0 To lSize + 14 - 1)
530
531 ' Jump over 4 bytes of lSize
532 lPos = lPos + 4
533
534 ' Copy starting at end of BMP File Header(+14)
535 CopyMemory arrayB(14), arrayOLE(lPos), lSize
536
537 ' Are we 8 bits or less with a ColorTable
538 CopyMemory bm, arrayB(14), Len(bm)
539
540 Select Case bm.biBitCount
541
542 Case 24, 16
543 iOffset = 0
544
545 Case 8
546 ' Some apps mistakenly write &HFF here instead of 256(&H0100)
547 ' Further they only actually use 255 colors instead of 256
548 If bm.biClrUsed = 255 Then
549 iOffset = 255 * 4
550 Else
551 iOffset = 256 * 4
552 End If
553
554 Case 4
555 iOffset = 16
556
557 Case Else
558 iOffset = 0
559
560 End Select
561
562 ' Build BMP File Header
563 ' Signature
564 With FileHeaderBM
565 ' Signature
566 .bfType = &H4D42
567 ' Size of entire Bitmap disk file.
568 ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
569 .bfSize = Len(FileHeaderBM) + lSize
570 ' Offset from start of file to start of Bitmap data
571 .bfOffBits = Len(FileHeaderBM) + Len(bm) + iOffset
572 End With
573
574 ' Signature
575 CopyMemory arrayB(0), FileHeaderBM.bfType, 2
576 ' Size of Bitmap file
577 CopyMemory arrayB(2), FileHeaderBM.bfSize, 4
578 'CopyMemory arrayOLE(6), ByVal 0&, 4
579 ' Next 4 bytes Reserved
580 arrayB(6) = 0
581 arrayB(7) = 0
582 arrayB(8) = 0
583 arrayB(9) = 0
584 ' Offset to start of Bitmap data
585 ' Always File Header len(14) + BITMAPINFOHEADER len(40)
586 CopyMemory arrayB(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
587
588 ' Size our main array
589 ReDim arrayOLE(0 To UBound(arrayB))
590 ' Copy temp array to our main array
591 arrayOLE = arrayB
592 FileExtension = "bmp"
593 sExt = "bmp"
594
595
596Else
597 ' METAFILEPICT
598 ' Get size of Bitmap Data
599 CopyMemory lSize, arrayOLE(lPos), 4
600 ' Make sure is less than arrayOLE
601 If lSize > UBound(arrayOLE) Then
602 ' Error
603 fGetContentsStream = False
604 Exit Function
605 End If
606 ' 8 is the length of the METAFILEPICT structure
607 ' because this OLE format only uses WORD(2 bytes)
608 ' for each structure element
609 ReDim arrayB(0 To (lSize - 8) - 1)
610
611 ' Jump over 4 bytes of lSize
612 lPos = lPos + 4
613
614 ' Fill in our public METAFILEPICT structure
615 CopyMemory mfp.mm, arrayOLE(lPos), 2
616 CopyMemory mfp.xExt, arrayOLE(lPos + 2), 2
617 CopyMemory mfp.yExt, arrayOLE(lPos + 4), 2
618
619 ' Jump over 8 bytes of METAFILEPICT structure
620 lPos = lPos + 8
621
622 ' Copy starting at end of BMP File Header(+14)
623 CopyMemory arrayB(0), arrayOLE(lPos), lSize - 8
624
625 ' Convert WMF to DIB
626 blRet = ds.WMFtoBMP(arrayB(), mfp.mm, mfp.xExt, mfp.yExt)
627 If blRet = False Then
628 fGetContentsStream = False
629 Exit Function
630 End If
631
632 ' ArrayB now contains the Byte data for the DIB
633 ' Create the disk Based Bitmap file
634
635 ' 40 is the size of the BITMAPINFOHEADER
636 ' 14 is the size of the Bitmap disk File Header
637 ReDim arrayOLE(0 To UBound(arrayB()) + 40 + 14)
638
639 ' Jump over 4 bytes of lSize
640 'lPos = lPos + 4
641
642 ' Copy starting at end of BMP File Header(+14) plus BITMAPINFOHEADER(+40)
643 CopyMemory arrayOLE(14 + 40), arrayB(0), UBound(arrayB()) + 1
644
645 ' Build BITMAPINFOHEADER
646 With bm
647 .biBitCount = 24
648 .biClrImportant = 0
649 .biClrUsed = 0
650 .biCompression = 0
651 .biHeight = ds.dib_height
652 .biPlanes = 1
653 .biSize = 40
654 .biSizeImage = UBound(arrayB()) + 1 '(ds.dib_width * ds.BytesPerScanLine) * ds.dib_height
655 .biWidth = ds.dib_width
656 .biXPelsPerMeter = 0
657 .biYPelsPerMeter = 0
658
659 End With
660
661 ' Copy BITMAPINFOHEADER
662 CopyMemory arrayOLE(14), ByVal bm, Len(bm) ' always 40 for this project
663
664 ' Build BMP File Header
665 ' Fill in our Bitmap FileHeader.
666With FileHeaderBM
667 ' Signature
668 .bfType = &H4D42
669 ' Size of entire Bitmap disk file.
670 ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
671 .bfSize = Len(FileHeaderBM) + Len(bm) + bm.biSizeImage
672 ' Offset from start of file to start of Bitmap data
673 .bfOffBits = Len(FileHeaderBM) + Len(bm)
674End With
675 ' Signature
676 CopyMemory arrayOLE(0), FileHeaderBM.bfType, 2
677 ' Size of Bitmap file
678 CopyMemory arrayOLE(2), FileHeaderBM.bfSize, 4
679 'CopyMemory arrayOLE(6), ByVal 0&, 4
680 ' Next 4 bytes Reserved
681 arrayOLE(6) = 0
682 arrayOLE(7) = 0
683 arrayOLE(8) = 0
684 arrayOLE(9) = 0
685 ' Offset to start of Bitmap data
686 ' Always File Header len(14) + BITMAPINFOHEADER len(40)
687 CopyMemory arrayOLE(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
688
689
690 FileExtension = "bmp"
691 sExt = "bmp"
692End If
693
694fGetContentsStream = True
695
696Exit Function
697''''''''''''''''''''''''''''''''''''''''''
698''''''''''''''''''''''''''''''''''''''''''
699
700
701Case "Package"
702' Copy of original file exists.
703' Please note all string values are terminated with the NULL char(0).
704' Standard OLE wrapper but it is always the same size
705' because the Class name and Object name are always "Package".
706' 36 Bytes Access OLE Header wrapper.
707
708' The following 28 Bytes are private header data
709' This brings us to offset 64.
710' Here is another part of the header info. The first 4 bytes
711' are the size of the package, including padding.
712
713' The next two bytes are always the integer value of 2.
714' I'll guess this is a constant value for embedded Packages.
715
716' The next X bytes are a copy of the original file name, including
717' teminating NULL character.
718
719' The next X bytes are a copy of the original file name including
720' path and teminating NULL character.
721'
722'
723' The next 4 bytes are unknown values. This Long value always seems to be 3.
724
725' The next 2 bytes, an Integer, contain the length of string
726' immediately to follow, which is a copy of the path string above.
727
728' The next X bytes are a copy of the original file name including
729' path and teminating NULL character.
730
731
732' The next 4 bytes, a Long, contain the actual file size of the original
733' embedded file.
734
735' The next x bytes contain the file that was originally embedded. This is an exact
736' copy of the original file.
737
738
739' Start of Package header
740lPos = 64
741' Skip nexy 4 bytes - Package size including padding
742lPos = lPos + 4
743' Skip next 2 bytes - Embedded constant - 2 ?
744lPos = lPos + 2
745
746' Checking for 0 so must initialize to any value but 0.
747bCurValue = 1
748
749' Package original File Name
750Do While bCurValue <> 0
751 bCurValue = arrayOLE(lPos)
752 FileNamePackage = FileNamePackage & Chr(bCurValue)
753 lPos = lPos + 1
754Loop
755
756bCurValue = 1
757' Package original full path and File Name
758Do While bCurValue <> 0
759 bCurValue = arrayOLE(lPos)
760 FileNameandPathPackage = FileNameandPathPackage & Chr(bCurValue)
761 lPos = lPos + 1
762Loop
763
764' Unknown 4 bytes
765lPos = lPos + 4
766
767' Integer - number of bytes of following string
768' which contains fill path and filename
769CopyMemory iOffset, arrayOLE(lPos), 2
770
771' Jump over our iOffset
772lPos = lPos + 2
773
774' Jump over 2 bytes - Unknown
775lPos = lPos + 2
776
777' Jump over string
778lPos = lPos + iOffset
779
780' Grab complete size of embedded file
781CopyMemory lPackSize, arrayOLE(lPos), 4
782
783' Jump over lPacksize Offset
784lPos = lPos + 4
785
786' Resize to fit embedded file
787' Error check
788If lPackSize >= UBound(arrayOLE) Then
789 fGetContentsStream = False
790 Exit Function
791End If
792
793ReDim arrayB(0 To lPackSize - 1)
794
795' I just have never trusted overlapping memory locations
796CopyMemory arrayB(0), arrayOLE(lPos), lPackSize
797ReDim arrayOLE(0 To lPackSize - 1)
798arrayOLE = arrayB
799FileExtension = "pak"
800sExt = "pak"
801fGetContentsStream = True
802
803Exit Function
804''''''''''''''''''''''''''''''''''''''''''
805''''''''''''''''''''''''''''''''''''''''''
806
807Case "AcroExc"
808' PDf AcroExhange.Document inserted by Adobe Acrobat Reader
809sExt = "pdf"
810sStreamName = "CONTENTS"
811FileExtension = "pdf"
812''''''''''''''''''''''''''''''''''''''''''
813''''''''''''''''''''''''''''''''''''''''''
814
815Case "FoxitRe"
816' PDf AcroExhange.Document inserted by Adobe Acrobat Reader
817sExt = "pdf"
818sStreamName = "CONTENTS"
819FileExtension = "pdf"
820''''''''''''''''''''''''''''''''''''''''''
821''''''''''''''''''''''''''''''''''''''''''
822
823
824Case "Snapsho"
825' SNP Microsoft Access Snapshot format
826sExt = "snp"
827sStreamName = "CONTENTS"
828FileExtension = "snp"
829''''''''''''''''''''''''''''''''''''''''''
830''''''''''''''''''''''''''''''''''''''''''
831
832Case "PSP7.Im"
833' Paint Shop Pro
834sExt = "psp"
835sStreamName = "CONTENTS"
836''''''''''''''''''''''''''''''''''''''''''
837''''''''''''''''''''''''''''''''''''''''''
838
839Case "Imaging" '"Imaging.Document"
840' Kodak Imaging TIFF ONLY!
841sExt = "tiff"
842sStreamName = "CONTENTS"
843FileExtension = "tiff"
844''''''''''''''''''''''''''''''''''''''''''
845''''''''''''''''''''''''''''''''''''''''''
846
847
848Case "Paper.d"
849' PaperPort Document
850sExt = "max"
851sStreamName = "CONTENTS"
852FileExtension = "max"
853''''''''''''''''''''''''''''''''''''''''''
854''''''''''''''''''''''''''''''''''''''''''
855
856Case "HP.Desk"
857' Scan HP DeskScan.2
858sExt = "hpd"
859sStreamName = "Ole10Native"
860FileExtension = "bmp"
861''''''''''''''''''''''''''''''''''''''''''
862''''''''''''''''''''''''''''''''''''''''''
863
864
865Case "Excel.S"
866' Excel - need to diff between worksheet, graph etc.
867sExt = "xls"
868FileExtension = "xls"
869sStreamName = "WorkBook"
870' MS Office files need all of the Streams, except the Ole specific Streams, saved
871' to a new Structured Storage disk based file.
872' Enumerate through all of the Streams, copying desired Streams
873' to newly created storage.
874''''''''''''''''''''''''''''''''''''''''''
875''''''''''''''''''''''''''''''''''''''''''
876
877Case "Word.Do"
878' MS Word document
879sExt = "doc"
880sStreamName = "WordDocument"
881FileExtension = "doc"
882''''''''''''''''''''''''''''''''''''''''''
883''''''''''''''''''''''''''''''''''''''''''
884
885Case "Word.Pi"
886' MS Word Picture
887sExt = "doc"
888sStreamName = "WordDocument"
889FileExtension = "doc"
890''''''''''''''''''''''''''''''''''''''''''
891''''''''''''''''''''''''''''''''''''''''''
892
893' *** Apr 11-2007 - Why is there is a space in the sStreamName var here?
894Case "PowerPo"
895' MS Word document
896sExt = "ppt"
897sStreamName = "PowerPoint Document"
898FileExtension = "ppt"
899''''''''''''''''''''''''''''''''''''''''''
900''''''''''''''''''''''''''''''''''''''''''
901
902Case "Visio.D"
903' MS Word document
904sExt = "vsd"
905sStreamName = "VisioDocument"
906FileExtension = "vsd"
907''''''''''''''''''''''''''''''''''''''''''
908''''''''''''''''''''''''''''''''''''''''''
909
910Case "Wordpad"
911sExt = "rtf"
912sStreamName = "CONTENTS" '"Wordpad Document"
913FileExtension = "rtf"
914
915
916
917
918Case "MSPhoto"
919' MSPhotoEditor
920sExt = "bmp"
921sStreamName = "CONTENTS"
922FileExtension = "bmp"
923''''''''''''''''''''''''''''''''''''''''''
924''''''''''''''''''''''''''''''''''''''''''
925
926Case "Paint.P" 'Paint.Picture
927sExt = "bmp"
928FileExtension = "bmp"
929
930sStreamName = ""
931' Save off Bitmap file so we can simply exit
932' and return the original data minus the
933' Access OLE header and the 12 byte Checksum.
934
935' Delete Access OLE wrapper
936y = objHeader.HeaderSize + 31
937'copy back minus header and checksum
938For x = 0 To UBound(arrayOLE) - (objHeader.HeaderSize + 31)
939 arrayOLE(x) = arrayOLE(y)
940 y = y + 1
941Next x
942
943' Get Total Size.
944' For PaintBrushBitmap files it is an actual Disk based Bitmap file
945' not the MS Photo Editor private Bitmap or the PSP entire file.
946' It is the 3rd through 6th bytes that form the LONG value representing the
947' complete file size for the Bitmap.
948
949CopyMemory x, arrayOLE(2), 4
950
951ReDim Preserve arrayOLE(0 To x - 1) As Byte
952
953' Success!
954fGetContentsStream = True
955sExt = "bmp"
956Exit Function
957''''''''''''''''''''''''''''''''''''''''''
958''''''''''''''''''''''''''''''''''''''''''
959
960' Need more work on error logic
961Case Else
962' Not supported yet
963Err.Raise vbObjectError + 566, "modGetContentsStream.fGetContentsStream", _
964 "Sorry...this OLE object contains an unsupported format" & vbCrLf & _
965 "Please select a different Record to Export"
966''''''''''''''''''''''''''''''''''''''''''
967''''''''''''''''''''''''''''''''''''''''''
968'fGetContentsStream = False
969'sExt = ""
970'Exit Function
971
972End Select
973
974' For any objects that we need to use the Structured Storage DLL's
975' to retrieve the contents of the OLE object then we need to
976' delete Access OLE wrapper of size objHeader.Size
977' lOffSet var is previously filled in:
978'lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
979' MSPhotoEdScan.3 for some reason needs 4 bytes removed from
980' its offset to start of Structured Storage SIG.
981' I'll look in to it later and hardwire a fix for now.
982
983If sClassName = "MSPhotoEdScan.3" Then lOffSet = lOffSet - 4
984y = 0
985For x = lOffSet To UBound(arrayOLE) - lOffSet
986 arrayOLE(y) = arrayOLE(x)
987 y = y + 1
988Next x
989
990
991Select Case sStreamName
992
993Case "CONTENTS"
994' Contents stream in Root Storage
995' Call our function in the StrStorage DLL
996 lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
997
998Case "Ole10Native"
999' "Ole10Native" stream in sub storage named "Embedding 1" Of Root Storage
1000' Call our function in the StrStorage DLL
1001 lLen = GetContentsStreamChild(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
1002
1003Case Else
1004' Need to fix this to allow for other stream names other than Office Docs.
1005' Extract Office doc
1006 lLen = ExtractOfficeDocument(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
1007
1008
1009End Select
1010
1011'If sStreamName <> "CONTENTS" Then
1012' ' Extract Office doc
1013' lLen = ExtractOfficeDocument(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
1014'Else
1015'' Call our function in the StrStorage DLL
1016' lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
1017'End If
1018
1019
1020' Need to log errors so that a Dialog is not popping up
1021' for every record that errors
1022If lLen = 0 Then
1023Err.Raise vbObjectError + 526, "modGetContentsStream.fGetContentsStream", _
1024 "Sorry...this OLE object does not have a CONTENTS Stream" & vbCrLf & _
1025 "Please select a different Record to Export"
1026 Exit Function
1027End If
1028
1029' Resize our returned memory
1030ReDim Preserve arrayOLE(0 To lLen - 1) As Byte
1031
1032
1033' ***************************************************
1034' DEBUG
1035
1036'fGetContentsStream = True
1037'Exit Function
1038
1039
1040' ***************************************************
1041
1042
1043' Further processing is required for certain objects
1044Select Case sExt
1045
1046' Add Visio etc.
1047Case "doc", "xls", "ppt", "vsd", "rtf"
1048' Do nothings as File Extension is already set.
1049' Also arrayOLE is ready to be saved to disk
1050''''''''''''''''''''''''''''''''''''''''''
1051''''''''''''''''''''''''''''''''''''''''''
1052
1053
1054' PDF
1055Case "pdf", "snp"
1056' Do nothings as File Extension is already set.
1057' Also arrayOLE is ready to be saved to disk
1058''''''''''''''''''''''''''''''''''''''''''
1059''''''''''''''''''''''''''''''''''''''''''
1060
1061' PDF
1062Case "tiff"
1063' Remove header of 234 bytes
1064' Remaining data ' is the complete TIFF file.
1065' lLen is length of CONTENTS stream returned in GetContentsStream
1066ReDim arrayB(0 To lLen - (234 + 1)) As Byte
1067
1068CopyMemory arrayB(0), arrayOLE(234), lLen - (234 + 1)
1069ReDim arrayOLE(0 To lLen - (1 + 234)) As Byte
1070CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 234)
1071
1072''''''''''''''''''''''''''''''''''''''''''
1073''''''''''''''''''''''''''''''''''''''''''
1074
1075
1076
1077' PaperPort Document
1078' 64 ByteHeader needs to be removed
1079Case "max"
1080' Remove header of 64 bytes
1081' Remaining data ' is the complete Bitmap file.
1082' lLen is length of CONTENTS stream returned in GetContentsStream
1083
1084' April 18/2008
1085' In some instances there is NO HEADER TO REMOVE
1086' Examine first 3 bytes. If equal to MAX FILE SIGNATURE then DO NOT remove header!!!
1087
1088If arrayOLE(0) = 86 And arrayOLE(1) = 105 And arrayOLE(2) = 71 Then
1089' do nothing - DO NOT REMOVE HEADER
1090
1091Else
1092
1093 ReDim arrayB(0 To lLen - (64 + 1)) As Byte
1094
1095 CopyMemory arrayB(0), arrayOLE(64), lLen - (64 + 1)
1096 ReDim arrayOLE(0 To lLen - (1 + 64)) As Byte
1097 CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 64)
1098
1099
1100End If
1101''''''''''''''''''''''''''''''''''''''''''
1102''''''''''''''''''''''''''''''''''''''''''
1103
1104''''''''''''''''''''''''''''''''''''''''''
1105''''''''''''''''''''''''''''''''''''''''''
1106
1107
1108
1109' HP DeskScan stored as Bitmap
1110' Header needs to be removed
1111Case "hpd"
1112' Remove header of 4 bytes
1113' Remaining data ' is the complete Bitmap file.
1114' lLen is length of CONTENTS stream returned in GetContentsStream
1115ReDim arrayB(0 To lLen - (4 + 1)) As Byte
1116
1117CopyMemory arrayB(0), arrayOLE(4), lLen - (4 + 1)
1118ReDim arrayOLE(0 To lLen - (1 + 4)) As Byte
1119CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 4)
1120
1121
1122''''''''''''''''''''''''''''''''''''''''''
1123''''''''''''''''''''''''''''''''''''''''''
1124
1125Case "psp"
1126' Paint Shop Pro
1127' CONTENTS stream is the complete PSP file
1128' plus an Header we
1129FileExtension = "psp"
1130' Need to remove 36 Byte OLE/PSP header. Remaining data
1131' is the complete original PSP file.
1132' lLen is length of CONTENTS stream returned in GetContentsStream
1133ReDim arrayB(0 To lLen - 1) As Byte
1134
1135CopyMemory arrayB(0), arrayOLE(36), lLen - 36
1136ReDim arrayOLE(0 To lLen - 1) As Byte
1137CopyMemory arrayOLE(0), arrayB(0), lLen - 1
1138'arrayOLE = arrayB
1139
1140' Added functionality to remove padding at end of file.
1141' To calculate real PSP file size would involve basically
1142' having to build a PP reader to parse all of the
1143' blocks and their headers.
1144' We'll cheat instead. The extra padding is at the
1145' end of the fill and consists of all 0's.
1146 x = UBound(arrayOLE)
1147
1148Do While arrayOLE(x) = 0
1149 x = x - 1
1150Loop
1151
1152' Bug
1153' I canot remove all 0's at end of file
1154' because last byte could legally be 0.
1155' Let's leave the last 4 zero bytes
1156ReDim Preserve arrayOLE(0 To x + 4) As Byte
1157''''''''''''''''''''''''''''''''''''''''''
1158''''''''''''''''''''''''''''''''''''''''''
1159
1160
1161Case "bmp" ' I need to build a disk based BMP file
1162' from the packed DIB contained in the array.
1163'MS Photo Editor
1164' CONTENTS stream returns a packed DIB. A Header specifies Bitmap Height and Width and
1165' Bits per pixel. At offset &h336 Dec822 BEGINS the Bitmap data. This offset is
1166' calculated as follows:
1167' 14 bytes FILEHEADER
1168' 40 bytes BITMAPINFOHEADER
1169' 768 bytes Color Table( 3 byte RGB triplet * 256)
1170
1171' So above looks exactly like a standard disk based Bitmap file.
1172' Unfortuntately, it is not. First while the space is allocated
1173' for the FILEHEADER and BITMAPINFOHEADER structures, they do
1174' not contain valid data. For our purposes, only 3 values exist.
1175' Get MS Photo Editor CONTENTS Stream header - 18 Bytes
1176' The header contains the Image BitsperPixel, Width, Height
1177' I have only seen 2 values in the the BitsperPixel byte.
1178' 2 = 8 bits per pixel
1179' 1 = 24 bits per pixel(I think greyscale
1180' Jan/2006 Now I'm seeing a 3
1181' Perhaps this means 24 Bits but not DWORD aligned
1182'
1183' I need to test images of different BitsperPixel values.
1184
1185Dim ph As MSPHOTOEDITOR_CONTENTS_HEADER
1186' Fill our header
1187CopyMemory ph, arrayOLE(0), Len(ph)
1188
1189
1190' Standard GDI Bitmap related structures
1191Dim MyBitmapInfoHeader As BITMAPINFOHEADER
1192Dim FileHeader As BITMAPFILEHEADER
1193
1194
1195' Length of physical ColorTable
1196' which is the number of RGBQUADS
1197' required to hold the required number of colors.
1198' Only used for Bit Depths less than 16 bits.
1199' Note: The MS Photo Editor CONTENTS stream packs the
1200' Color Table using 3 byte RGB triplets instead of the
1201' 4 byte RGBQUADs specified for a disk based Bitmap file.
1202Dim lngLenColorTable As Long
1203
1204' Init to 0
1205lngLenColorTable = 0
1206
1207' Number of bytes for each complete row of the bitmap
1208Dim BytesPerScanLine As Long
1209
1210' Start filling in our Bitmap related structures
1211Debug.Print ph.bmBitDepth
1212With MyBitmapInfoHeader
1213If ph.bmBitDepth = 1 Then .biBitCount = 8
1214If ph.bmBitDepth = 2 Then .biBitCount = 8
1215If ph.bmBitDepth = 3 Then .biBitCount = 24
1216
1217.biClrImportant = 0
1218.biClrUsed = 0
1219.biCompression = 0 'BI_RGB ' no compression
1220.biHeight = ph.bmHeight
1221.biWidth = ph.bmWidth
1222.biPlanes = 1
1223.biSize = Len(MyBitmapInfoHeader)
1224
1225' Each pixel is comprised of 3 bytes, Red, Green & Blue(RGB).
1226' Each row of pixels must end on a memory address evenly divided by 4.
1227' This is commonly refered to as DWORD aligned.
1228BytesPerScanLine = (MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8) + 3) And &HFFFFFFFC
1229
1230' Size of the Bitmap data only.
1231.biSizeImage = (BytesPerScanLine * Abs(MyBitmapInfoHeader.biHeight)) ' 0 ' 0 OK for BI_RGB(uncompressed)
1232
1233' Most applications do not use these values
1234.biXPelsPerMeter = 0
1235.biYPelsPerMeter = 0
1236End With
1237
1238' Calc color table size
1239If MyBitmapInfoHeader.biBitCount = 8 Then lngLenColorTable = 256 * 4
1240' It's residing as RGB triplets not Quads in arrayOLE. We must translate this to
1241' RGBQUAD to reside on disk.
1242
1243
1244' Fill in our Bitmap FileHeader.
1245With FileHeader
1246 ' Signature
1247 .bfType = &H4D42
1248 ' Size of entire Bitmap disk file.
1249 ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
1250 .bfSize = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable) + MyBitmapInfoHeader.biSizeImage
1251 ' Offset from start of file to start of Bitmap data
1252 .bfOffBits = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable)
1253End With
1254
1255
1256' ********************************************************
1257' Trouble with structure alignment padding
1258' Copy our structures to our output array.
1259' Because of VB structure alignment pading
1260' we have to be careful and fill the structure
1261' members individually.
1262' Signature
1263CopyMemory arrayOLE(0), FileHeader.bfType, 2
1264' Size of Bitmap file
1265CopyMemory arrayOLE(2), FileHeader.bfSize, 4
1266'CopyMemory arrayOLE(6), ByVal 0, 4
1267' Next 4 bytes Reserved
1268arrayOLE(6) = 0
1269arrayOLE(7) = 0
1270arrayOLE(8) = 0
1271arrayOLE(9) = 0
1272' Offset to start of Bitmap data
1273CopyMemory arrayOLE(10), FileHeader.bfOffBits, 4
1274
1275' Must use second Byte array. Copying the Color Table is overwriting
1276' the start of the Bitmap data. The amount overwritten is equal to
1277' Len(FileHeader) + Len(MyBitmapInfoHeader)-18
1278' 18 bytes is the size of the private MS Photo Editor Header
1279' found at the very start of the CONTENTS Stream.
1280' Since the BM FileHeader = 14 Bytes and the BitmapInfoHeader
1281' = 40 bytes in length we need to move the Color Table and Bitmap data
1282' 54 - 18 = 36 bytes
1283' backwards in the current array. So we need to resize the array
1284' increasing by 36 bytes.
1285
1286
1287' Before we creating or Bitmap file we have an issue to resolve.
1288' MS Photo Editor stores the DIB as a Bottom UP DIB while most
1289' applications use Top Down and some apps will not even load Bottom Up format.
1290' Let's copy and mirror both the ColorTable and Bitmap data.
1291
1292
1293'*** BUG ***
1294' I have run into a file where the size of the
1295' CONTENTS stream did not equal a packed DIB layout
1296' FILEHEADER + BitmapInfoHeader + ColorTable + Bitmap data
1297' To get around this let's try resizing arrayOLE
1298' based on the BitmapInfoHeader.
1299'ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte
1300
1301If lngLenColorTable > 0 Then
1302 CopyMemory arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), arrayOLE(18), 768 ' RGB TripletlngLenColorTable
1303End If
1304
1305
1306' Now move the existing data back starting at the ColorTable
1307' if any and the Bitmap data.
1308' We can use CopyMemory as it is masquerading as RtlMoveMemory
1309' Copy ColorTable(if any)and move Bitmap data back 256 bytes to
1310' allow for the Bitmap file spec of 4 bytes per pixel(RGBQUAD)
1311' for each entry in the ColorTable.
1312
1313' * DWORD alignment issue. Bitmap data must be DWORD aligned. This simply
1314' means that each row of the Bitmap data must end on an address
1315' evenly divisable by 4. If it is not then you simply pad the row
1316' until it is. Since this is the MS published spec I just figured
1317' that MS Photo Editor would follow the spec. It does not.
1318' To get around this I will have to copy the data one row
1319' at a time from the OLE byte array.
1320
1321Dim BPSLineNotAligned As Long
1322BPSLineNotAligned = MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8)
1323
1324
1325' Temp storage for copy of Bitmap data
1326ReDim arrayB(0 To (MyBitmapInfoHeader.biHeight * BPSLineNotAligned) - 1)
1327
1328CopyMemory arrayB(0), arrayOLE(822), (MyBitmapInfoHeader.biHeight * BPSLineNotAligned)
1329
1330' The offset to the start of the Byte RGB data from the start of the file.
1331lOffSet = FileHeader.bfOffBits
1332
1333' Jan 5/2005 7:05 pm don't redim until after I copied arrayOLE to arrayB ********
1334ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte
1335
1336' For every row of Bitmap
1337For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
1338 CopyMemory arrayOLE(lOffSet + (x * BytesPerScanLine)), _
1339 arrayB(UBound(arrayB) - ((x * BPSLineNotAligned) + BPSLineNotAligned - 1)), BPSLineNotAligned
1340Next x
1341
1342
1343' Is there a Color Table?
1344If lngLenColorTable <> 0 Then
1345
1346 Dim r As Byte
1347 Dim b As Byte
1348 Dim g As Byte
1349
1350 ' Need to fix RGB to BGR issue on RGB Triplet ColorTable data
1351 ReDim arrayB(0 To lngLenColorTable - 1)
1352 CopyMemory arrayB(0), arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), 768
1353
1354 y = 0
1355 lOffSet = Len(FileHeader) + Len(MyBitmapInfoHeader)
1356
1357
1358 ' 2 Possiblities
1359 ' If ph.bmBitDepth = 2 then it's a normal Colortable
1360 ' If ph.bmBitDepth = 1 then it's a Greyscale Colortable
1361 ' which needs to be created
1362 If ph.bmBitDepth = 2 Then
1363
1364 For x = 0 To 768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
1365 r = arrayB(x)
1366 g = arrayB(x + 1)
1367 b = arrayB(x + 2)
1368 arrayOLE(lOffSet + (y * 4)) = b
1369 arrayOLE(lOffSet + (y * 4) + 1) = g
1370 arrayOLE(lOffSet + (y * 4) + 2) = r
1371 arrayOLE(lOffSet + (y * 4) + 3) = 0
1372 y = y + 1
1373 Next x
1374
1375 Else
1376 For x = 0 To 255 Step 1 '768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
1377 r = y 'arrayB(x)
1378 g = y 'arrayB(x + 1)
1379 b = y 'arrayB(x + 2)
1380 arrayOLE(lOffSet + (y * 4)) = b
1381 arrayOLE(lOffSet + (y * 4) + 1) = g
1382 arrayOLE(lOffSet + (y * 4) + 2) = r
1383 arrayOLE(lOffSet + (y * 4) + 3) = 0
1384 y = y + 1
1385 Next x
1386
1387
1388 End If
1389
1390
1391End If
1392
1393
1394' Copy BitmapInfoHeader
1395CopyMemory arrayOLE(Len(FileHeader)), MyBitmapInfoHeader, Len(MyBitmapInfoHeader)
1396
1397' Sat 6:17pm
1398' Change RGB triplet data to Quad RGB.
1399' put backin to see if we can handle both 8 bit and 24 bit
1400If MyBitmapInfoHeader.biBitCount = 24 Then
1401
1402 Dim rquad As RGBQUAD
1403
1404 ' The Byte RGB data needs to be reversed to BGR
1405 lOffSet = FileHeader.bfOffBits
1406
1407 ' For every row of Bitmap
1408 For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
1409 ' For each pixel(triplet of RGB values)
1410 For y = 0 To MyBitmapInfoHeader.biWidth - 1
1411 With rquad
1412 .rgbBlue = arrayOLE(lOffSet + (y * 3))
1413 .rgbRed = arrayOLE((y * 3) + 2 + lOffSet)
1414
1415 ' Reverse B and R
1416 arrayOLE((y * 3) + lOffSet) = .rgbRed
1417 arrayOLE((y * 3) + 2 + lOffSet) = .rgbBlue
1418 End With
1419
1420 ' increment 3 bytes per pixel is built into the above logic
1421 Next y
1422
1423 ' increment bytes per row (3 bytes per pixel + padding to end up on DWORD alignment
1424 lOffSet = lOffSet + BytesPerScanLine
1425 Next x
1426
1427End If
1428''''''''''''''''''''''''''''''''''''''''''
1429''''''''''''''''''''''''''''''''''''''''''
1430
1431Case Else
1432' Unsupported Format
1433
1434''''''''''''''''''''''''''''''''''''''''''
1435''''''''''''''''''''''''''''''''''''''''''
1436
1437End Select
1438
1439' Success
1440fGetContentsStream = True
1441
1442
1443EXIT_fGetContentsStream:
1444
1445' Add error handling
1446
1447Exit Function
1448
1449ERR_fGetContentsStream:
1450MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
1451fGetContentsStream = False
1452Resume EXIT_fGetContentsStream
1453
1454End Function
1455
1456
1457
1458Public Function LoadLib() As Boolean
1459Dim s As String
1460Dim blRet As Boolean
1461
1462On Error Resume Next
1463
1464LoadLib = False
1465
1466' Our error string
1467s = "Sorry...cannot find the SSGetContents.dll file" & vbCrLf
1468s = s & "Please copy the SSGetContents.dll file to your Windows System32 folder or into the same folder as this Access MDB."
1469
1470' ** Commented out for Debugging only - Must be active
1471' ***************************************************************************
1472'"C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll")
1473' OK Try to load the DLL assuming it is in the Window System folder
1474hLibStrStorage = LoadLibrary(CurrentDBDir() & "SSGetContents.dll")
1475If hLibStrStorage = 0 Then
1476 ' See if the DLL is in the same folder as this MDB
1477 ' CurrentDB works with both A97 and A2K or higher
1478 hLibStrStorage = LoadLibrary("SSGetContents.dll")
1479
1480 If hLibStrStorage = 0 Then
1481 MsgBox s, vbOKOnly, "MISSING StrStorage.dll FILE"
1482 Exit Function
1483 End If
1484End If
1485
1486
1487' RETURN SUCCESS
1488LoadLib = True
1489End Function
1490
1491
1492Public Function UnLoadLib() As Boolean
1493
1494
1495Dim s As String
1496Dim blRet As Boolean
1497
1498On Error Resume Next
1499
1500' If we aready loaded then free the library
1501If hLibStrStorage <> 0 Then
1502 hLibStrStorage = FreeLibrary(hLibStrStorage)
1503End If
1504
1505End Function
1506
1507
1508
1509'******************** Code Begin ****************
1510'Code courtesy of
1511'Terry Kreft & Ken Getz
1512'
1513Private Function CurrentDBDir() As String
1514Dim strDBPath As String
1515Dim strDBFile As String
1516 strDBPath = CurrentDb.Name
1517 strDBFile = Dir(strDBPath)
1518 CurrentDBDir = Left$(strDBPath, Len(strDBPath) - Len(strDBFile))
1519End Function
1520'******************** Code End ****************
1521
1522
1523
1524Private Function GetUniqueFilename(Optional path As String = "", _
1525Optional Prefix As String = "", _
1526Optional UseExtension As String = "") _
1527As String
1528
1529' originally Posted by Terry Kreft
1530' to: comp.Databases.ms -Access
1531' Subject: Re: Creating Unique filename ??? (Dev code)
1532' Date: 01/15/2000
1533' Author: Terry Kreft <terry.kreft@mps.co.uk>
1534
1535' SL Note: Input strings must be NULL terminated.
1536' Here it is done by the calling function.
1537
1538 Dim wUnique As Long
1539 Dim lpTempFileName As String
1540 Dim lngRet As Long
1541
1542 wUnique = 0
1543 If path = "" Then path = CurDir
1544 lpTempFileName = String(MaxPath, 0)
1545 lngRet = GetTempFileName(path, Prefix, _
1546 wUnique, lpTempFileName)
1547
1548 lpTempFileName = Left(lpTempFileName, _
1549 InStr(lpTempFileName, Chr(0)) - 1)
1550 Call Kill(lpTempFileName)
1551 If Len(UseExtension) > 0 Then
1552 lpTempFileName = Left(lpTempFileName, Len(lpTempFileName) - 3) & UseExtension
1553 End If
1554 GetUniqueFilename = lpTempFileName
1555End Function
1556
1557Public Function fInventory(ByRef arrayOLE() As Byte, _
1558ClassName As String, _
1559ObjectName As String, _
1560LinkedFileName As String, _
1561FileNamePackage As String, _
1562ObjectType As Long) As Boolean
1563
1564' The arrayOLE must contain the entire contents of the OLE field.
1565' For LINKED objects, returns arrayOLE resized to fit and contain the
1566' "|Ole" Moniker Stream of the OLE Structured Storage passed to this function.
1567'
1568' Exceptions are for the "Package" type and Bitmap's embedded with MS Paint.
1569
1570On Error GoTo ERR_fInventory
1571
1572' Hold working copy of arrayOLE
1573Dim arrayB() As Byte
1574
1575' Size of "Package"
1576Dim lPackSize As Long
1577
1578' File Extension of Package
1579Dim FileNamePackageExt As String
1580' Original File Name and Path of Package
1581Dim FileNameandPathPackage As String
1582
1583' Current position in arrayOLE
1584Dim lPos As Long
1585
1586' Temp vars
1587Dim bCurValue As Byte
1588Dim iOffset As Integer
1589Dim i As Integer
1590Dim x As Long
1591Dim s As String
1592Dim blRet As Boolean
1593Dim lngRet As Long
1594Dim y As Long
1595
1596' Length of array returned from functions in Structured Storage DLL.
1597Dim lLen As Long
1598
1599' Access OLE Wrapper
1600Dim objHeader As OBJECTHEADER
1601
1602' Offset to start of structured storage file
1603Dim lOffSet As Long
1604
1605' Class name of embedded OLE object
1606Dim arrayClassName(0 To 1023) As Byte
1607
1608' OLE object temp vars
1609'Dim sClassName As String
1610Dim sStreamName As String
1611Dim sBuf As String
1612Dim sExt As String
1613
1614On Error GoTo ERR_fInventory
1615
1616' Get Offset to start of Structured Storage
1617CopyMemory objHeader, arrayOLE(0), OBJECT_HEADER_SIZE
1618lOffSet = objHeader.HeaderSize + 40 '+ objHeader.ClassLen
1619
1620' Convert byte Ascii data to VB string
1621ClassName = ""
1622For i = 0 To objHeader.ClassLen - 1
1623 ClassName = ClassName & Chr(arrayOLE(objHeader.ClassOffset + i))
1624Next i
1625
1626
1627ObjectName = ""
1628For i = 0 To objHeader.NameLen - 1
1629 ObjectName = ObjectName & Chr(arrayOLE(objHeader.NameOffset + i))
1630Next i
1631
1632
1633' There are 3 Types of OLE objects.
1634' Linked OT_LINKED = 1
1635' Embedded OT_EMBEDDED =2
1636' Static OT_STATIC = 3
1637
1638ObjectType = objHeader.ObjectType
1639
1640' If the OLE Object Type is Embedded or Static
1641' then we simply return from this function
1642' at this point as all relevant params of this
1643' function have been been filled in.
1644' The exception is for the Package object.
1645
1646If ObjectType = OT_STATIC Then ClassName = "OT_STATIC"
1647
1648If (ClassName <> "Package") And ((ObjectType = OT_EMBEDDED) Or (ObjectType = OT_STATIC)) Then
1649 fInventory = False
1650 Exit Function
1651End If
1652
1653
1654' Logic tree based on ClassName of embedded object
1655Select Case Left(ClassName, 7)
1656
1657Case "Package"
1658' Copy of original file exists.
1659' Please note all string values are terminated with the NULL char(0).
1660' Standard OLE wrapper but it is always the same size
1661' because the Class name and Object name are always "Package".
1662' 36 Bytes Access OLE Header wrapper.
1663
1664' The following 28 Bytes are private header data
1665' This brings us to offset 64.
1666' Here is another part of the header info. The first 4 bytes
1667' are the size of the package, including padding.
1668
1669' The next two bytes are always the integer value of 2.
1670' I'll guess this is a constant value for embedded Packages.
1671
1672' The next X bytes are a copy of the original file name, including
1673' teminating NULL character.
1674
1675' The next X bytes are a copy of the original file name including
1676' path and teminating NULL character.
1677'
1678' The next 4 bytes are unknown values. This Long value always seems to be 3.
1679
1680' The next 2 bytes, an Integer, contain the length of string
1681' immediately to follow, which is a copy of the path string above.
1682
1683' The next X bytes are a copy of the original file name including
1684' path and teminating NULL character.
1685
1686' The next 4 bytes, a Long, contain the actual file size of the original
1687' embedded file.
1688
1689' The next x bytes contain the file that was originally embedded. This is an exact
1690' copy of the original file.
1691
1692' Start of Package header
1693lPos = 64
1694' Skip nexy 4 bytes - Package size including padding
1695lPos = lPos + 4
1696' Skip next 2 bytes - Embedded constant - 2 ?
1697lPos = lPos + 2
1698
1699' Checking for 0 so must initialize to any value but 0.
1700bCurValue = 1
1701
1702' Package original File Name
1703Do While bCurValue <> 0
1704 bCurValue = arrayOLE(lPos)
1705 FileNamePackage = FileNamePackage & Chr(bCurValue)
1706 lPos = lPos + 1
1707Loop
1708
1709bCurValue = 1
1710' Package original full path and File Name
1711Do While bCurValue <> 0
1712 bCurValue = arrayOLE(lPos)
1713 FileNameandPathPackage = FileNameandPathPackage & Chr(bCurValue)
1714 lPos = lPos + 1
1715Loop
1716
1717' Unknown 4 bytes
1718lPos = lPos + 4
1719
1720' Integer - number of bytes of following string
1721' which contains fill path and filename
1722CopyMemory iOffset, arrayOLE(lPos), 2
1723
1724' Jump over our iOffset
1725lPos = lPos + 2
1726
1727' Jump over 2 bytes - Unknown
1728lPos = lPos + 2
1729
1730' Jump over string
1731lPos = lPos + iOffset
1732
1733' Grab complete size of embedded file
1734CopyMemory lPackSize, arrayOLE(lPos), 4
1735'
1736fInventory = True
1737
1738Exit Function
1739''''''''''''''''''''''''''''''''''''''''''
1740''''''''''''''''''''''''''''''''''''''''''
1741
1742Case "Paint.P" 'Paint.Picture
1743sExt = "bmp"
1744'FileExtension = "bmp"
1745
1746sStreamName = Chr(1) & "Ole"
1747
1748
1749Case Else
1750' If we get to here then
1751' we have a Linked object.
1752' We need to get the contents of the |Ole stream
1753' which contains the file Moniker for this object.
1754sStreamName = Chr(1) & "Ole"
1755
1756
1757' Not supported yet
1758'Err.Raise vbObjectError + 566, "modGetContentsStream.fInventory", _
1759' "Sorry...this OLE object contains an unsupported format" & vbCrLf & _
1760' "Please select a different Record to Inventory"
1761''''''''''''''''''''''''''''''''''''''''''
1762''''''''''''''''''''''''''''''''''''''''''
1763
1764
1765End Select
1766
1767' For any objects that we need to use the Structured Storage DLL's
1768' to retrieve the contents of the OLE object then we need to
1769' delete Access OLE wrapper of size objHeader.Size
1770' lOffSet var is previously filled in:
1771'lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
1772
1773y = 0
1774For x = lOffSet To UBound(arrayOLE) - lOffSet
1775 arrayOLE(y) = arrayOLE(x)
1776 y = y + 1
1777Next x
1778
1779' Call our function in the StrStorage DLL
1780 lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
1781
1782If lLen = 0 Then
1783Err.Raise vbObjectError + 526, "modGetContentsStream.fInventory", _
1784 "Sorry...this OLE object class is not supported" & vbCrLf & _
1785 "Please select a different Record to Inventory"
1786End If
1787
1788' Resize our returned memory
1789ReDim Preserve arrayOLE(0 To lLen - 1) As Byte
1790
1791' There is no published spec for this Stream
1792' as it is up to the OLE Server to decide what and
1793' where to write the necessary Linking information.
1794' Most OLE Server apps seem to roughly follow the
1795' same format.
1796
1797
1798' ***************************************************
1799' DEBUG
1800
1801' Let's get the Linking info
1802Dim lPosString As Long
1803Dim iStringLen As Integer
1804
1805'Note Binary representation are HEX - 2 characters per Byte
1806' 00 to FF
1807' Finally, Intel Byte ordering.
1808
1809lPos = 0
1810' The first 16 Bytes are always the same
1811lPos = 16
1812
1813' Skip nexy 4 bytes - always Zero
1814lPos = lPos + 4
1815
1816' Now the next 2 bytes are either the offset to be added
1817' to offset &H20 to point to the start
1818' of the signature for the DOS Short path and filename
1819' or they are ZERO. If ZERO then we have to search
1820' for the signature(&HC000 0000 0000 0046) which in limited testing
1821' is always at Offset 36
1822CopyMemory lPosString, arrayOLE(lPos), 4
1823If lPosString = 0 Then
1824 lPos = 36
1825Else
1826 lPos = 32 + lPosString
1827End If
1828
1829' So we should now be at the start of the string Signature
1830' Verify this
1831CopyMemory lPosString, arrayOLE(lPos), 4
1832 If lPosString <> 192 Then '&HC0 00 00 00
1833fInventory = True
1834Exit Function
1835End If
1836
1837' Skip over 4 byte string Signature
1838lPos = lPos + 4
1839
1840' Skip over next 2 bytes - Always ZERO
1841lPos = lPos + 2
1842
1843' Skip over next 2 bytes - Always &H0046
1844lPos = lPos + 2
1845
1846' Skip over next 2 bytes - Always ZERO
1847lPos = lPos + 2
1848
1849' Next 2 bytes are length of path/filename
1850CopyMemory iStringLen, arrayOLE(lPos), 2
1851' Error check
1852If iStringLen > 1024 Then
1853 fInventory = False
1854 Exit Function
1855End If
1856
1857' Skip over String Length
1858lPos = lPos + 2
1859
1860' Skip over next 2 bytes - Always ZERO
1861lPos = lPos + 2
1862
1863
1864' Dec. 15/2005
1865' Not happy with SHORT path/filename.
1866' There seems to be a specific arrangement of bytes following the SHORT
1867' path/filename up to the UNICODE full/long path/filename.
1868' SHORT path/filename ends with NULL char
1869' Next 2 bytes always &HFFFF followed by &HADDE
1870' or &HADDE followed by &H0000
1871' Since it is not always the same let's skip directly to
1872' the 2 bytes(WORD) describing the length of the UNICODE string
1873' that is the full/long path/filename
1874lPos = lPos + iStringLen
1875
1876' Jump to length of UNICODE string
1877lPos = lPos + 28
1878
1879' Next 2 bytes are length of path/filename
1880CopyMemory iStringLen, arrayOLE(lPos), 2
1881' Error check
1882If iStringLen > 1024 Then
1883 fInventory = False
1884 Exit Function
1885End If
1886
1887' Skip over String Length
1888lPos = lPos + 2
1889
1890' Skip over next 2 bytes - Always ZERO
1891lPos = lPos + 2
1892
1893' Skip over next 2 bytes - Always &H0300
1894lPos = lPos + 2
1895
1896LinkedFileName = ""
1897' We are now at the start of the Unicode String
1898For i = 0 To iStringLen - 1 Step 2
1899 LinkedFileName = LinkedFileName & Chr(arrayOLE(lPos + i))
1900Next i
1901
1902fInventory = True
1903
1904
1905EXIT_fInventory:
1906' Add error handling
1907
1908Exit Function
1909
1910ERR_fInventory:
1911MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
1912fInventory = False
1913Resume EXIT_fInventory
1914
1915End Function
1916
1917
1918Public Function CreateDS()
1919Set ds = New cDIBSection
1920End Function
1921
1922
1923Public Function FreeDS()
1924Set ds = Nothing
1925End Function