access vba实现OLE对象保存到本地

参考oletodisk的实现方法，更新为在64位office上野可以运行，函数模块代码如下：

   1 Option Compare Database
   2 Option 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 '?) 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 'Have Fun!
  97 '
  98 '
  99 '
 100 ' ******************************************************
 101
 102
 103 Private Type RECT
 104     Left As Long
 105     top As Long
 106     right As Long
 107     Bottom As Long
 108 End Type
 109
 110 Private Type SIZEL
 111     cx As Long
 112     cy As Long
 113 End Type
 114
 115 Private Type RGBQUAD
 116   rgbBlue As Byte
 117   rgbGreen As Byte
 118   rgbRed As Byte
 119   rgblReserved As Byte
 120 End Type
 121
 122 Private Type BITMAPINFOHEADER '40 bytes
 123   biSize As Long
 124   biWidth As Long
 125   biHeight As Long
 126   biPlanes As Integer
 127   biBitCount As Integer
 128   biCompression As Long 'ERGBCompression
 129   biSizeImage As Long
 130   biXPelsPerMeter As Long
 131   biYPelsPerMeter As Long
 132   biClrUsed As Long
 133   biClrImportant As Long
 134 End Type
 135
 136
 137 Private Type BITMAPINFO
 138   bmiHeader As BITMAPINFOHEADER
 139   bmiColors As RGBQUAD
 140 End Type
 141
 142
 143 Private Type BITMAP
 144   bmType As Long
 145   bmWidth As Long
 146   bmHeight As Long
 147   bmWidthBytes As Long
 148   bmPlanes As Integer
 149   bmBitsPixel As Integer
 150   bmBits As Long
 151 End Type
 152
 153 Private Type DIBSECTION
 154     dsBm As BITMAP
 155     dsBmih As BITMAPINFOHEADER
 156     dsBitfields(2) As Long
 157     dshSection As Long
 158     dsOffset As Long
 159 End Type
 160
 161
 162 ' Here is the header for the Bitmap file
 163 ' as it resides in a disk file
 164 Private Type BITMAPFILEHEADER    '14 bytes
 165   bfType As Integer
 166   bfSize As Long
 167   bfReserved1 As Integer
 168   bfReserved2 As Integer
 169   bfOffBits As Long
 170 End Type
 171
 172 Private Type METAFILEPICT
 173  mm As Long
 174  xExt As Long
 175  yExt As Long
 176  hMF As Long
 177 End Type
 178
 179
 180 Private Const CON_CHUNK_SIZE As Long = 32768
 181 Private Const OBJECT_SIGNATURE = &H1C15
 182 Private Const OBJECT_HEADER_SIZE = 20
 183 Private Const CHECKSUM_SIGNATURE = &HFE05AD00
 184 Private Const CHECKSUM_STRING_SIZE = 4
 185 Private Const SIG_BMP = &H4D42
 186
 187
 188 Private Type PT
 189    width As Integer
 190    Height As Integer
 191 End Type
 192 '
 193 '
 194 ' OBJECTHEADER : Contains relevant information about object.
 195 '
 196 Private Type OBJECTHEADER
 197    Signature As Integer         ' Type signature (0x1c15).
 198    HeaderSize As Integer        ' Size of header (sizeof(struct
 199                                 ' OBJECTHEADER) + cchName +
 200                                 '  cchClass).
 201    ObjectType As Long           ' OLE Object type code (OT_STATIC,
 202                                 '  OT_LINKED, OT_EMBEDDED).
 203    NameLen As Integer           ' Count of characters in object
 204                                 '  name (CchSz(szName) + 1).
 205    ClassLen As Integer          ' Count of characters in class
 206                                 '  name (CchSz(szClass) + 1).
 207    NameOffset As Integer        ' Offset of object name in
 208                                 '  structure (sizeof(OBJECTHEADER)).
 209    ClassOffset As Integer       ' Offset of class name in
 210                                 '  structure (ibName + cchName).
 211    ObjectSize As PT             ' Original size of object (see
 212                                 '  code below for value).
 213 '   OleInfo(256) As Byte
 214 End Type
 215
 216 '/* Object types */
 217 Public Const OT_LINK As Long = 1&
 218 Public Const OT_EMBEDDED = 2&
 219 Public Const OT_STATIC = 3&
 220
 221
 222
 223 Private Type MSPHOTOEDITOR_CONTENTS_HEADER
 224     bmBitDepth As Integer
 225     bmWidth As Integer
 226     bmHeight As Integer
 227 End Type
 228
 229 ' Pass first element of Byte array - ex. a(0)
 230 ' Pass size of array in bytes
 231 ' Return length of valid data in the passed array of bytes
 232 ' Array will contain complete CONTENTS Stream of Structured Storage
 233
 234
 235 ' debugging with Visual C++
 236 'Lib "C:\VisualCsource\SLStrucStorageContents\Debug\SSGetContents.dll"
 237
 238 Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
 239 (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
 240
 241 Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" _
 242 (ByVal hwnd As Long, ByVal lpOperation As String, _
 243 ByVal lpFile As String, ByVal lpParameters As String, _
 244 ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 245
 246 Private Declare PtrSafe Function LoadLibrary Lib "kernel32" _
 247 Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
 248
 249 Private Declare PtrSafe Function FreeLibrary Lib "kernel32" _
 250 (ByVal hLibModule As Long) As Long
 251
 252 Private Declare PtrSafe Function GetTempPath Lib "kernel32" _
 253 Alias "GetTempPathA" (ByVal nBufferLength As Long, _
 254 ByVal lpBuffer As String) As Long
 255
 256 Private Declare PtrSafe Function GetTempFileName _
 257 Lib "kernel32" Alias "GetTempFileNameA" _
 258 (ByVal lpszPath As String, _
 259 ByVal lpPrefixString As String, _
 260 ByVal wUnique As Long, _
 261 ByVal lpTempFileName As String) As Long
 262
 263 Private Declare PtrSafe Function GetLongPathName Lib "kernel32.dll" Alias _
 264 "GetLongPathNameA" (ByVal lpszShortPath As String, _
 265       ByVal lpszLongPath As String, _
 266       ByVal cchBuffer As Long) As Long
 267
 268 Public Declare PtrSafe Function GetFullPathName Lib "kernel32" _
 269      Alias "GetFullPathNameA" _
 270      (ByVal lpFileName As String, _
 271       ByVal nBufferLength As Long, _
 272       ByVal lpBuffer As String, _
 273       ByVal lpFilePart As String) As Long
 274
 275
 276
 277
 278 Private Const Pathlen = 256
 279 Private Const MaxPath = 256
 280
 281 ' Structured Storage Signature = 'D0CF11E0
 282 Private Const SSsig As Long = &HE011CFD0
 283
 284 ' Allow user to set FileName instead
 285 ' of using API Temp Filename or
 286 ' popping File Dialog Window
 287 Private mSaveFileName As String
 288
 289 ' Instance returned from LoadLibrary call
 290 Private hLibStrStorage As Long
 291
 292 ' * Move this into a class so we can init/destroy properly
 293 Private ds As cDIBSection
 294
 295
 296 Public Function fGetContentsStream(ByRef arrayOLE() As Byte, _
 297 FileExtension As String, _
 298 Optional FileNamePackage As String = "") As Boolean
 299 ' arrayOLE must contain the entire contents of the OLE field.
 300 ' Returns arrayOLE resized to fit and contain the
 301 ' CONTENTS Stream of the OLE Structured Storage passed to this function.
 302 ' Exceptions are for the "Package" type and Bitmap's embedded with MS Paint.
 303
 304 ' Hold working copy of arrayOLE
 305 Dim arrayB() As Byte
 306
 307 ' Size of "Package"
 308 Dim lPackSize As Long
 309
 310 ' File Extension of Package
 311 Dim FileNamePackageExt As String
 312 ' Original File Name and Path of Package
 313 Dim FileNameandPathPackage As String
 314
 315 ' Current position in arrayOLE
 316 Dim lPos As Long
 317
 318 ' Temp vars
 319 Dim bCurValue As Byte
 320 Dim iOffset As Integer
 321 Dim i As Integer
 322 Dim x As Long
 323 Dim s As String
 324 Dim blRet As Boolean
 325 Dim lngRet As Long
 326 Dim y As Long
 327
 328 ' Length of array returned from functions in Structured Storage DLL.
 329 Dim lLen As Long
 330
 331 ' Access OLE Wrapper
 332 Dim objHeader As OBJECTHEADER
 333
 334 ' Offset to start of structured storage file
 335 Dim lOffSet As Long
 336
 337 ' Class name of embedded OLE object
 338 Dim arrayClassName(0 To 1023) As Byte
 339
 340 ' OLE object temp vars
 341 Dim sClassName As String
 342 Dim sStreamName As String
 343 Dim sBuf As String
 344 Dim sExt As String
 345
 346 Dim mfp As METAFILEPICT
 347 Dim bm As BITMAPINFOHEADER
 348
 349
 350 On Error GoTo ERR_fGetContentsStream
 351
 352 ' Get Offset to start of Structured Storage
 353 CopyMemory objHeader, arrayOLE(0), OBJECT_HEADER_SIZE
 354 lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
 355
 356 ' If Linked object then exit
 357 If objHeader.ObjectType = OT_LINK Then
 358     fGetContentsStream = False
 359     Exit Function
 360 End If
 361
 362 ' Let's see if the StrStorage.DLL is available.
 363 'blRet = LoadLib()
 364 'If blRet = False Then
 365 '    ' Cannot find StrStorage.dll file
 366 '    fGetContentsStream = False
 367 '    Exit Function
 368 'End If
 369
 370 ' If OLE object was draged and dropped then
 371 ' the ClassLen member with be a NULL string
 372 'If objHeader.ClassLen > 1 Then
 373     ' Convert byte Ascii data to VB string
 374     sClassName = ""
 375     For i = 0 To objHeader.ClassLen - 2
 376         sClassName = sClassName & Chr(arrayOLE(objHeader.ClassOffset + i))
 377     Next i
 378 'Else
 379
 380 ' Add support for ClassLen = 0 - Drag and Dropped OLE object
 381 'End If
 382
 383 ' Call seperate function if object is of type STATIC
 384 If objHeader.ObjectType = OT_STATIC Then
 385 sClassName = "OT_STATIC"
 386 End If
 387
 388 ' Logic tree based on ClassName of embedded object
 389 Select Case Left(sClassName, 7)
 390
 391 Case "OT_STAT"
 392 ' Two possibilities.
 393 ' Static MetafilePict or Static DIB
 394 ' Standard OLE wrapper but it is always the same size
 395 ' because the Class name is blank and Object name is always "Picture".
 396 ' 29 Bytes Access OLE Header wrapper.
 397
 398 ' The following 12 Bytes are private header data
 399 ' This brings us to offset 41.
 400 ' The next 3 bytes will either be = "DIB or "MET"
 401 ' DIB
 402 ' After "DIB" + terminating NULL char we jump over next
 403 ' 8 bytes of private data.
 404
 405 ' The next 4 bytes are the size of the Bitmap.
 406 '
 407 ' The next 40 Bytes are the BITMAPINFOHEADER structure
 408 ' The next 4 bytes are always the value 40 - SIZEOF BITMAPINFOHEADER
 409
 410 ' The next X bytes are the BITMAPINFOHEADER
 411
 412 ' So once we get to the LONG SIZEOF bitmap data we can build
 413 ' the disk basked BMP file.
 414 ' The next X bytes are the actual Bitmap Data
 415 '
 416 '
 417
 418 ' Start of Package header
 419 ' Jan - 2008 Offset out by 1 - was 41
 420 lPos = 38
 421 '' Skip nexy 4 bytes - Package size including padding
 422 'lPos = lPos + 4
 423 ' Skip next 2 bytes - Embedded constant - 2 ?
 424 'lPos = lPos + 2
 425
 426 ' Checking for 0 so must initialize to any value but 0.
 427 bCurValue = 1
 428
 429 Dim lSize As Long
 430 Dim FileHeaderBM As BITMAPFILEHEADER
 431
 432 Dim sType As String
 433 ' DIB or METAFILEPICT
 434 Do While bCurValue <> 0
 435     bCurValue = arrayOLE(lPos)
 436     sType = sType & Chr(bCurValue)
 437     lPos = lPos + 1
 438 Loop
 439
 440 ' Jump over next 8 bytes of private data
 441 lPos = lPos + 8
 442
 443 If sType = "DIB" Then
 444     ' Get size of Bitmap Data
 445     CopyMemory lSize, arrayOLE(lPos), 4
 446     ' Make sure is less than arrayOLE
 447     If lSize > UBound(arrayOLE) Then
 448         ' Error
 449         fGetContentsStream = False
 450         Exit Function
 451     End If
 452     ' 14 is the size of the Bitmap disk File Header
 453     ReDim arrayB(0 To lSize + 14 - 1)
 454
 455     ' Jump over 4 bytes of lSize
 456     lPos = lPos + 4
 457
 458     ' Copy starting at end of BMP File Header(+14)
 459     CopyMemory arrayB(14), arrayOLE(lPos), lSize
 460
 461     ' Are we 8 bits or less with a ColorTable
 462     CopyMemory bm, arrayB(14), Len(bm)
 463
 464     Select Case bm.biBitCount
 465
 466     Case 24, 16
 467     iOffset = 0
 468
 469     Case 8
 470     ' Some apps mistakenly write &HFF here instead of 256(&H0100)
 471     ' Further they only actually use 255 colors instead of 256
 472     If bm.biClrUsed = 255 Then
 473         iOffset = 255 * 4
 474     Else
 475         iOffset = 256 * 4
 476     End If
 477
 478     Case 4
 479     iOffset = 16
 480
 481     Case Else
 482     iOffset = 0
 483
 484     End Select
 485
 486     ' Build BMP File Header
 487     ' Signature
 488     With FileHeaderBM
 489         ' Signature
 490         .bfType = &H4D42
 491         ' Size of entire Bitmap disk file.
 492         ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
 493         .bfSize = Len(FileHeaderBM) + lSize
 494         ' Offset from start of file to start of Bitmap data
 495         .bfOffBits = Len(FileHeaderBM) + Len(bm) + iOffset
 496     End With
 497
 498     ' Signature
 499     CopyMemory arrayB(0), FileHeaderBM.bfType, 2
 500     ' Size of Bitmap file
 501     CopyMemory arrayB(2), FileHeaderBM.bfSize, 4
 502     'CopyMemory arrayOLE(6), ByVal 0&, 4
 503     ' Next 4 bytes Reserved
 504     arrayB(6) = 0
 505     arrayB(7) = 0
 506     arrayB(8) = 0
 507     arrayB(9) = 0
 508     ' Offset to start of Bitmap data
 509     ' Always File Header len(14) + BITMAPINFOHEADER len(40)
 510     CopyMemory arrayB(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
 511
 512     ' Size our main array
 513     ReDim arrayOLE(0 To UBound(arrayB))
 514     ' Copy temp array to our main array
 515     arrayOLE = arrayB
 516     FileExtension = "bmp"
 517     sExt = "bmp"
 518
 519
 520 Else
 521     ' METAFILEPICT
 522     ' Get size of Bitmap Data
 523         CopyMemory lSize, arrayOLE(lPos), 4
 524         ' Make sure is less than arrayOLE
 525         If lSize > UBound(arrayOLE) Then
 526             ' Error
 527             fGetContentsStream = False
 528             Exit Function
 529         End If
 530     ' 8 is the length of the METAFILEPICT structure
 531     ' because this OLE format only uses WORD(2 bytes)
 532     ' for each structure element
 533     ReDim arrayB(0 To (lSize - 8) - 1)
 534
 535     ' Jump over 4 bytes of lSize
 536     lPos = lPos + 4
 537
 538     ' Fill in our public METAFILEPICT structure
 539     CopyMemory mfp.mm, arrayOLE(lPos), 2
 540     CopyMemory mfp.xExt, arrayOLE(lPos + 2), 2
 541     CopyMemory mfp.yExt, arrayOLE(lPos + 4), 2
 542
 543     ' Jump over 8 bytes of METAFILEPICT structure
 544     lPos = lPos + 8
 545
 546     ' Copy starting at end of BMP File Header(+14)
 547     CopyMemory arrayB(0), arrayOLE(lPos), lSize - 8
 548
 549     ' Convert WMF to DIB
 550     blRet = ds.WMFtoBMP(arrayB(), mfp.mm, mfp.xExt, mfp.yExt)
 551     If blRet = False Then
 552         fGetContentsStream = False
 553         Exit Function
 554     End If
 555
 556     ' ArrayB now contains the Byte data for the DIB
 557     ' Create the disk Based Bitmap file
 558
 559     ' 40 is the size of the BITMAPINFOHEADER
 560     ' 14 is the size of the Bitmap disk File Header
 561     ReDim arrayOLE(0 To UBound(arrayB()) + 40 + 14)
 562
 563     ' Jump over 4 bytes of lSize
 564     'lPos = lPos + 4
 565
 566     ' Copy starting at end of BMP File Header(+14) plus BITMAPINFOHEADER(+40)
 567     CopyMemory arrayOLE(14 + 40), arrayB(0), UBound(arrayB()) + 1
 568
 569     ' Build BITMAPINFOHEADER
 570     With bm
 571         .biBitCount = 24
 572         .biClrImportant = 0
 573         .biClrUsed = 0
 574         .biCompression = 0
 575         .biHeight = ds.dib_height
 576         .biPlanes = 1
 577         .biSize = 40
 578         .biSizeImage = UBound(arrayB()) + 1 '(ds.dib_width * ds.BytesPerScanLine) * ds.dib_height
 579         .biWidth = ds.dib_width
 580         .biXPelsPerMeter = 0
 581         .biYPelsPerMeter = 0
 582
 583     End With
 584
 585     ' Copy BITMAPINFOHEADER
 586     CopyMemory arrayOLE(14), ByVal bm, Len(bm)  ' always 40 for this project
 587
 588     ' Build BMP File Header
 589     ' Fill in our Bitmap FileHeader.
 590 With FileHeaderBM
 591     ' Signature
 592     .bfType = &H4D42
 593     ' Size of entire Bitmap disk file.
 594     ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
 595     .bfSize = Len(FileHeaderBM) + Len(bm) + bm.biSizeImage
 596     ' Offset from start of file to start of Bitmap data
 597     .bfOffBits = Len(FileHeaderBM) + Len(bm)
 598 End With
 599     ' Signature
 600     CopyMemory arrayOLE(0), FileHeaderBM.bfType, 2
 601     ' Size of Bitmap file
 602     CopyMemory arrayOLE(2), FileHeaderBM.bfSize, 4
 603     'CopyMemory arrayOLE(6), ByVal 0&, 4
 604     ' Next 4 bytes Reserved
 605     arrayOLE(6) = 0
 606     arrayOLE(7) = 0
 607     arrayOLE(8) = 0
 608     arrayOLE(9) = 0
 609     ' Offset to start of Bitmap data
 610     ' Always File Header len(14) + BITMAPINFOHEADER len(40)
 611     CopyMemory arrayOLE(10), FileHeaderBM.bfOffBits, 4 ' Add BMP File Header
 612
 613
 614     FileExtension = "bmp"
 615     sExt = "bmp"
 616 End If
 617
 618 fGetContentsStream = True
 619
 620 Exit Function
 621 ''''''''''''''''''''''''''''''''''''''''''
 622 ''''''''''''''''''''''''''''''''''''''''''
 623
 624
 625 Case "Package"
 626 ' Copy of original file exists.
 627 ' Please note all string values are terminated with the NULL char(0).
 628 ' Standard OLE wrapper but it is always the same size
 629 ' because the Class name and Object name are always "Package".
 630 ' 36 Bytes Access OLE Header wrapper.
 631
 632 ' The following 28 Bytes are private header data
 633 ' This brings us to offset 64.
 634 ' Here is another part of the header info. The first 4 bytes
 635 ' are the size of the package, including padding.
 636
 637 ' The next two bytes are always the integer value of 2.
 638 ' I'll guess this is a constant value for embedded Packages.
 639
 640 ' The next X bytes are a copy of the original file name, including
 641 ' teminating NULL character.
 642
 643 ' The next X bytes are a copy of the original file name including
 644 ' path and teminating NULL character.
 645 '
 646 '
 647 ' The next 4 bytes are unknown values. This Long value always seems to be 3.
 648
 649 ' The next 2 bytes, an Integer, contain the length of string
 650 ' immediately to follow, which is a copy of the path string above.
 651
 652 ' The next X bytes are a copy of the original file name including
 653 ' path and teminating NULL character.
 654
 655
 656 ' The next 4 bytes, a Long, contain the actual file size of the original
 657 ' embedded file.
 658
 659 ' The next x bytes contain the file that was originally embedded. This is an exact
 660 ' copy of the original file.
 661
 662
 663 ' Start of Package header
 664 lPos = 64
 665 ' Skip nexy 4 bytes - Package size including padding
 666 lPos = lPos + 4
 667 ' Skip next 2 bytes - Embedded constant - 2 ?
 668 lPos = lPos + 11
 669
 670 ' Checking for 0 so must initialize to any value but 0.
 671 bCurValue = 1
 672
 673 ' Package original File Name
 674 Do While bCurValue <> 0
 675     bCurValue = arrayOLE(lPos)
 676     FileNamePackage = FileNamePackage & Chr(bCurValue)
 677     lPos = lPos + 1
 678 Loop
 679
 680 bCurValue = 1
 681 ' Package original full path and File Name
 682 Do While bCurValue <> 0
 683     bCurValue = arrayOLE(lPos)
 684     FileNameandPathPackage = FileNameandPathPackage & Chr(bCurValue)
 685     lPos = lPos + 1
 686 Loop
 687
 688 ' Unknown 4 bytes
 689 lPos = lPos + 4
 690
 691 ' Integer - number of bytes of following string
 692 ' which contains fill path and filename
 693 CopyMemory iOffset, arrayOLE(lPos), 2
 694
 695 ' Jump over our iOffset
 696 lPos = lPos + 2
 697
 698 ' Jump over 2 bytes - Unknown
 699 lPos = lPos + 2
 700
 701 ' Jump over string
 702 lPos = lPos + iOffset
 703
 704 ' Grab complete size of embedded file
 705 CopyMemory lPackSize, arrayOLE(lPos), 4
 706
 707 ' Jump over lPacksize Offset
 708 lPos = lPos + 4
 709
 710 ' Resize to fit embedded file
 711 ' Error check
 712 If lPackSize >= UBound(arrayOLE) Then
 713     fGetContentsStream = False
 714     Exit Function
 715 End If
 716
 717 ReDim arrayB(0 To lPackSize - 1)
 718
 719 ' I just have never trusted overlapping memory locations
 720 CopyMemory arrayB(0), arrayOLE(lPos), lPackSize
 721 ReDim arrayOLE(0 To lPackSize - 1)
 722 arrayOLE = arrayB
 723 FileExtension = "pak"
 724 sExt = "pak"
 725 fGetContentsStream = True
 726
 727 Exit Function
 728 ''''''''''''''''''''''''''''''''''''''''''
 729 ''''''''''''''''''''''''''''''''''''''''''
 730
 731
 732 Case "HP.Desk"
 733 ' Scan HP DeskScan.2
 734 sExt = "hpd"
 735 sStreamName = "Ole10Native"
 736 FileExtension = "bmp"
 737 ''''''''''''''''''''''''''''''''''''''''''
 738
 739
 740 Case "Visio.D"
 741 ' MS Word document
 742 sExt = "vsd"
 743 sStreamName = "VisioDocument"
 744 FileExtension = "vsd"
 745 ''''''''''''''''''''''''''''''''''''''''''
 746 ''''''''''''''''''''''''''''''''''''''''''
 747 '''''''''''''''''''''''''''''''''''
 748
 749 Case "Paint.P"   'Paint.Picture
 750 sExt = "bmp"
 751 FileExtension = "bmp"
 752
 753 sStreamName = ""
 754 ' Save off Bitmap file so we can simply exit
 755 ' and return the original data minus the
 756 ' Access OLE header and the 12 byte Checksum.
 757
 758 ' Delete Access OLE wrapper
 759 y = objHeader.HeaderSize + 31
 760 'copy back minus header and checksum
 761 For x = 0 To UBound(arrayOLE) - (objHeader.HeaderSize + 31)
 762     arrayOLE(x) = arrayOLE(y)
 763     y = y + 1
 764 Next x
 765
 766 ' Get Total Size.
 767 ' For PaintBrushBitmap files it is an actual Disk based Bitmap file
 768 ' not the MS Photo Editor private Bitmap or the PSP entire file.
 769 ' It is the 3rd through 6th bytes that form the LONG value representing the
 770 ' complete file size for the Bitmap.
 771
 772 CopyMemory x, arrayOLE(2), 4
 773
 774 ReDim Preserve arrayOLE(0 To x - 1) As Byte
 775
 776 ' Success!
 777 fGetContentsStream = True
 778 sExt = "bmp"
 779 Exit Function
 780 ''''''''''''''''''''''''''''''''''''''''''
 781 ''''''''''''''''''''''''''''''''''''''''''
 782
 783 ' Need more work on error logic
 784 Case Else
 785 ' Not supported yet
 786 Err.Raise vbObjectError + 566, "modGetContentsStream.fGetContentsStream", _
 787     "Sorry...this OLE object contains an unsupported format" & vbCrLf & _
 788     "Please select a different Record to Export"
 789 ''''''''''''''''''''''''''''''''''''''''''
 790 ''''''''''''''''''''''''''''''''''''''''''
 791 'fGetContentsStream = False
 792 'sExt = ""
 793 'Exit Function
 794
 795 End Select
 796
 797 ' For any objects that we need to use the Structured Storage DLL's
 798 ' to retrieve the contents of the OLE object then we need to
 799 ' delete Access OLE wrapper of size objHeader.Size
 800 ' lOffSet var is previously filled in:
 801 'lOffSet = objHeader.HeaderSize + 24 + objHeader.ClassLen
 802 ' MSPhotoEdScan.3 for some reason needs 4 bytes removed from
 803 ' its offset to start of Structured Storage SIG.
 804 ' I'll look in to it later and hardwire a fix for now.
 805
 806 If sClassName = "MSPhotoEdScan.3" Then lOffSet = lOffSet - 4
 807 y = 0
 808 For x = lOffSet To UBound(arrayOLE) - lOffSet
 809     arrayOLE(y) = arrayOLE(x)
 810     y = y + 1
 811 Next x
 812
 813
 814
 815 'If sStreamName <> "CONTENTS" Then
 816 '    ' Extract Office doc
 817 '    lLen = ExtractOfficeDocument(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
 818 'Else
 819 '' Call our function in the StrStorage DLL
 820 '    lLen = GetContentsStream(arrayOLE(0), UBound(arrayOLE) - lOffSet, sStreamName)
 821 'End If
 822
 823
 824 ' Need to log errors so that a Dialog is not popping up
 825 ' for every record that errors
 826 If lLen = 0 Then
 827 Err.Raise vbObjectError + 526, "modGetContentsStream.fGetContentsStream", _
 828     "Sorry...this OLE object does not have a CONTENTS Stream" & vbCrLf & _
 829     "Please select a different Record to Export"
 830     Exit Function
 831 End If
 832
 833 ' Resize our returned memory
 834 ReDim Preserve arrayOLE(0 To lLen - 1) As Byte
 835
 836
 837 ' ***************************************************
 838 '   DEBUG
 839
 840 'fGetContentsStream = True
 841 'Exit Function
 842
 843
 844 ' ***************************************************
 845
 846
 847 ' Further processing is required for certain objects
 848 Select Case sExt
 849
 850 ' Add Visio etc.
 851 Case "doc", "xls", "ppt", "vsd", "rtf"
 852 ' Do nothings as File Extension is already set.
 853 ' Also arrayOLE is ready to be saved to disk
 854 ''''''''''''''''''''''''''''''''''''''''''
 855 ''''''''''''''''''''''''''''''''''''''''''
 856
 857
 858 ' PDF
 859 Case "pdf", "snp"
 860 ' Do nothings as File Extension is already set.
 861 ' Also arrayOLE is ready to be saved to disk
 862 ''''''''''''''''''''''''''''''''''''''''''
 863 ''''''''''''''''''''''''''''''''''''''''''
 864
 865 ' PDF
 866 Case "tiff"
 867 ' Remove header of 234 bytes
 868 ' Remaining data ' is the complete TIFF file.
 869 ' lLen is length of CONTENTS stream returned in GetContentsStream
 870 ReDim arrayB(0 To lLen - (234 + 1)) As Byte
 871
 872 CopyMemory arrayB(0), arrayOLE(234), lLen - (234 + 1)
 873 ReDim arrayOLE(0 To lLen - (1 + 234)) As Byte
 874 CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 234)
 875
 876 ''''''''''''''''''''''''''''''''''''''''''
 877 ''''''''''''''''''''''''''''''''''''''''''
 878
 879
 880
 881 ' PaperPort Document
 882 ' 64 ByteHeader needs to be removed
 883 Case "max"
 884 ' Remove header of 64 bytes
 885 ' Remaining data ' is the complete Bitmap file.
 886 ' lLen is length of CONTENTS stream returned in GetContentsStream
 887
 888 ' April 18/2008
 889 ' In some instances there is NO HEADER TO REMOVE
 890 ' Examine first 3 bytes. If equal to MAX FILE SIGNATURE then DO NOT remove header!!!
 891
 892 If arrayOLE(0) = 86 And arrayOLE(1) = 105 And arrayOLE(2) = 71 Then
 893 ' do nothing - DO NOT REMOVE HEADER
 894
 895 Else
 896
 897     ReDim arrayB(0 To lLen - (64 + 1)) As Byte
 898
 899     CopyMemory arrayB(0), arrayOLE(64), lLen - (64 + 1)
 900     ReDim arrayOLE(0 To lLen - (1 + 64)) As Byte
 901     CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 64)
 902
 903
 904 End If
 905 ''''''''''''''''''''''''''''''''''''''''''
 906 ''''''''''''''''''''''''''''''''''''''''''
 907
 908 ''''''''''''''''''''''''''''''''''''''''''
 909 ''''''''''''''''''''''''''''''''''''''''''
 910
 911
 912
 913 ' HP DeskScan stored as Bitmap
 914 ' Header needs to be removed
 915 Case "hpd"
 916 ' Remove header of 4 bytes
 917 ' Remaining data ' is the complete Bitmap file.
 918 ' lLen is length of CONTENTS stream returned in GetContentsStream
 919 ReDim arrayB(0 To lLen - (4 + 1)) As Byte
 920
 921 CopyMemory arrayB(0), arrayOLE(4), lLen - (4 + 1)
 922 ReDim arrayOLE(0 To lLen - (1 + 4)) As Byte
 923 CopyMemory arrayOLE(0), arrayB(0), lLen - (1 + 4)
 924
 925
 926 ''''''''''''''''''''''''''''''''''''''''''
 927 ''''''''''''''''''''''''''''''''''''''''''
 928
 929 Case "psp"
 930 ' Paint Shop Pro
 931 ' CONTENTS stream is the complete PSP file
 932 ' plus an  Header we
 933 FileExtension = "psp"
 934 ' Need to remove 36 Byte OLE/PSP header. Remaining data
 935 ' is the complete original PSP file.
 936 ' lLen is length of CONTENTS stream returned in GetContentsStream
 937 ReDim arrayB(0 To lLen - 1) As Byte
 938
 939 CopyMemory arrayB(0), arrayOLE(36), lLen - 36
 940 ReDim arrayOLE(0 To lLen - 1) As Byte
 941 CopyMemory arrayOLE(0), arrayB(0), lLen - 1
 942 'arrayOLE = arrayB
 943
 944 ' Added functionality to remove padding at end of file.
 945 ' To calculate real PSP file size would involve basically
 946 ' having to build a PP reader to parse all of the
 947 ' blocks and their headers.
 948 ' We'll cheat instead. The extra padding is at the
 949 ' end of the fill and consists of all 0's.
 950   x = UBound(arrayOLE)
 951
 952 Do While arrayOLE(x) = 0
 953     x = x - 1
 954 Loop
 955
 956 ' Bug
 957 ' I canot remove all 0's at end of file
 958 ' because last byte could legally be 0.
 959 ' Let's leave the last 4 zero bytes
 960 ReDim Preserve arrayOLE(0 To x + 4) As Byte
 961 ''''''''''''''''''''''''''''''''''''''''''
 962 ''''''''''''''''''''''''''''''''''''''''''
 963
 964
 965 Case "bmp" ' I need to build a disk based BMP file
 966 ' from the packed DIB contained in the array.
 967 'MS Photo Editor
 968 ' CONTENTS stream returns a packed DIB. A Header specifies Bitmap Height and Width and
 969 ' Bits per pixel. At offset &h336 Dec822 BEGINS the Bitmap data. This offset is
 970 ' calculated as follows:
 971 ' 14 bytes FILEHEADER
 972 ' 40 bytes BITMAPINFOHEADER
 973 ' 768 bytes Color Table( 3 byte RGB triplet * 256)
 974
 975 ' So above looks exactly like a standard disk based Bitmap file.
 976 ' Unfortuntately, it is not. First while the space is allocated
 977 ' for the FILEHEADER and BITMAPINFOHEADER structures, they do
 978 ' not contain valid data. For our purposes, only 3 values exist.
 979 ' Get MS Photo Editor CONTENTS Stream header - 18 Bytes
 980 ' The header contains the Image BitsperPixel, Width, Height
 981 ' I have only seen 2 values in the the BitsperPixel byte.
 982 ' 2 = 8 bits per pixel
 983 ' 1 = 24 bits per pixel(I think greyscale
 984 ' Jan/2006 Now I'm seeing a 3
 985 ' Perhaps this means 24 Bits but not DWORD aligned
 986 '
 987 ' I need to test images of different BitsperPixel values.
 988
 989 Dim ph As MSPHOTOEDITOR_CONTENTS_HEADER
 990 ' Fill our header
 991 CopyMemory ph, arrayOLE(0), Len(ph)
 992
 993
 994 ' Standard GDI Bitmap related structures
 995 Dim MyBitmapInfoHeader As BITMAPINFOHEADER
 996 Dim FileHeader As BITMAPFILEHEADER
 997
 998
 999 ' Length of physical ColorTable
1000 ' which is the number of RGBQUADS
1001 ' required to hold the required number of colors.
1002 ' Only used for Bit Depths less than 16 bits.
1003 ' Note: The MS Photo Editor CONTENTS stream packs the
1004 ' Color Table using 3 byte RGB triplets instead of the
1005 ' 4 byte RGBQUADs specified for a disk based Bitmap file.
1006 Dim lngLenColorTable As Long
1007
1008 ' Init to 0
1009 lngLenColorTable = 0
1010
1011 ' Number of bytes for each complete row of the bitmap
1012 Dim BytesPerScanLine As Long
1013
1014 ' Start filling in our Bitmap related structures
1015 Debug.Print ph.bmBitDepth
1016 With MyBitmapInfoHeader
1017 If ph.bmBitDepth = 1 Then .biBitCount = 8
1018 If ph.bmBitDepth = 2 Then .biBitCount = 8
1019 If ph.bmBitDepth = 3 Then .biBitCount = 24
1020
1021 .biClrImportant = 0
1022 .biClrUsed = 0
1023 .biCompression = 0 'BI_RGB ' no compression
1024 .biHeight = ph.bmHeight
1025 .biWidth = ph.bmWidth
1026 .biPlanes = 1
1027 .biSize = Len(MyBitmapInfoHeader)
1028
1029 ' Each pixel is comprised of 3 bytes, Red, Green & Blue(RGB).
1030 ' Each row of pixels must end on a memory address evenly divided by 4.
1031 ' This is commonly refered to as DWORD aligned.
1032 BytesPerScanLine = (MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8) + 3) And &HFFFFFFFC
1033
1034 ' Size of the Bitmap data only.
1035 .biSizeImage = (BytesPerScanLine * Abs(MyBitmapInfoHeader.biHeight))   ' 0 ' 0 OK for BI_RGB(uncompressed)
1036
1037 ' Most applications do not use these values
1038 .biXPelsPerMeter = 0
1039 .biYPelsPerMeter = 0
1040 End With
1041
1042 ' Calc color table size
1043 If MyBitmapInfoHeader.biBitCount = 8 Then lngLenColorTable = 256 * 4
1044 ' It's residing as RGB triplets not Quads in arrayOLE. We must translate this to
1045 ' RGBQUAD to reside on disk.
1046
1047
1048 ' Fill in our Bitmap FileHeader.
1049 With FileHeader
1050     ' Signature
1051     .bfType = &H4D42
1052     ' Size of entire Bitmap disk file.
1053     ' FileHeader + BitmapInfoHeader + ColorTable(if any) + Bitmap data bytes
1054     .bfSize = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable) + MyBitmapInfoHeader.biSizeImage
1055     ' Offset from start of file to start of Bitmap data
1056     .bfOffBits = Len(FileHeader) + (Len(MyBitmapInfoHeader) + lngLenColorTable)
1057 End With
1058
1059
1060 ' ********************************************************
1061 ' Trouble with structure alignment padding
1062 ' Copy our structures to our output array.
1063 ' Because of VB structure alignment pading
1064 ' we have to be careful and fill the structure
1065 ' members individually.
1066 ' Signature
1067 CopyMemory arrayOLE(0), FileHeader.bfType, 2
1068 ' Size of Bitmap file
1069 CopyMemory arrayOLE(2), FileHeader.bfSize, 4
1070 'CopyMemory arrayOLE(6), ByVal 0, 4
1071 ' Next 4 bytes Reserved
1072 arrayOLE(6) = 0
1073 arrayOLE(7) = 0
1074 arrayOLE(8) = 0
1075 arrayOLE(9) = 0
1076 ' Offset to start of Bitmap data
1077 CopyMemory arrayOLE(10), FileHeader.bfOffBits, 4
1078
1079 ' Must use second Byte array. Copying the Color Table is overwriting
1080 ' the start of the Bitmap data. The amount overwritten is equal to
1081 ' Len(FileHeader) + Len(MyBitmapInfoHeader)-18
1082 ' 18 bytes is the size of the private MS Photo Editor Header
1083 ' found at the very start of the CONTENTS Stream.
1084 ' Since the BM FileHeader = 14 Bytes and the BitmapInfoHeader
1085 ' = 40 bytes in length we need to move the Color Table and Bitmap data
1086 ' 54 - 18 = 36 bytes
1087 ' backwards in the current array. So we need to resize the array
1088 ' increasing by 36 bytes.
1089
1090
1091 ' Before we creating or Bitmap file we have an issue to resolve.
1092 ' MS Photo Editor stores the DIB as a Bottom UP DIB while most
1093 ' applications use Top Down and some apps will not even load Bottom Up format.
1094 ' Let's copy and mirror both the ColorTable and Bitmap data.
1095
1096
1097 '***  BUG ***
1098 ' I have run into a file where the size of the
1099 ' CONTENTS stream did not equal a packed DIB layout
1100 ' FILEHEADER + BitmapInfoHeader + ColorTable + Bitmap data
1101 ' To get around this let's try resizing arrayOLE
1102 ' based on the BitmapInfoHeader.
1103 'ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte
1104
1105 If lngLenColorTable > 0 Then
1106     CopyMemory arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), arrayOLE(18), 768 ' RGB TripletlngLenColorTable
1107 End If
1108
1109
1110 ' Now move the existing data back starting at the ColorTable
1111 ' if any and the Bitmap data.
1112 ' We can use CopyMemory as it is masquerading as RtlMoveMemory
1113 ' Copy ColorTable(if any)and move Bitmap data back 256 bytes to
1114 ' allow for the Bitmap file spec of 4 bytes per pixel(RGBQUAD)
1115 ' for each entry in the ColorTable.
1116
1117 ' * DWORD alignment issue. Bitmap data must be DWORD aligned. This simply
1118 ' means that each row of the Bitmap data must end on an address
1119 ' evenly divisable by 4. If it is not then you simply pad the row
1120 ' until it is. Since this is the MS published spec I just figured
1121 ' that MS Photo Editor would follow the spec. It does not.
1122 ' To get around this I will have to copy the data one row
1123 ' at a time from the OLE byte array.
1124
1125 Dim BPSLineNotAligned As Long
1126 BPSLineNotAligned = MyBitmapInfoHeader.biWidth * (MyBitmapInfoHeader.biBitCount / 8)
1127
1128
1129 ' Temp storage for copy of Bitmap data
1130 ReDim arrayB(0 To (MyBitmapInfoHeader.biHeight * BPSLineNotAligned) - 1)
1131
1132 CopyMemory arrayB(0), arrayOLE(822), (MyBitmapInfoHeader.biHeight * BPSLineNotAligned)
1133
1134 ' The offset to the start of the Byte RGB data from the start of the file.
1135 lOffSet = FileHeader.bfOffBits
1136
1137 ' Jan 5/2005 7:05 pm don't redim until after I copied arrayOLE to arrayB ********
1138 ReDim Preserve arrayOLE(0 To FileHeader.bfSize - 1) As Byte
1139
1140 ' For every row of Bitmap
1141 For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
1142     CopyMemory arrayOLE(lOffSet + (x * BytesPerScanLine)), _
1143     arrayB(UBound(arrayB) - ((x * BPSLineNotAligned) + BPSLineNotAligned - 1)), BPSLineNotAligned
1144 Next x
1145
1146
1147 ' Is there a Color Table?
1148 If lngLenColorTable <> 0 Then
1149
1150     Dim r As Byte
1151     Dim b As Byte
1152     Dim g As Byte
1153
1154     ' Need to fix RGB to BGR issue on RGB Triplet ColorTable data
1155     ReDim arrayB(0 To lngLenColorTable - 1)
1156     CopyMemory arrayB(0), arrayOLE(Len(FileHeader) + Len(MyBitmapInfoHeader)), 768
1157
1158     y = 0
1159     lOffSet = Len(FileHeader) + Len(MyBitmapInfoHeader)
1160
1161
1162     ' 2 Possiblities
1163     ' If ph.bmBitDepth = 2 then it's a normal Colortable
1164     ' If ph.bmBitDepth = 1 then it's a Greyscale Colortable
1165     ' which needs to be created
1166     If ph.bmBitDepth = 2 Then
1167
1168         For x = 0 To 768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
1169             r = arrayB(x)
1170             g = arrayB(x + 1)
1171             b = arrayB(x + 2)
1172             arrayOLE(lOffSet + (y * 4)) = b
1173             arrayOLE(lOffSet + (y * 4) + 1) = g
1174             arrayOLE(lOffSet + (y * 4) + 2) = r
1175             arrayOLE(lOffSet + (y * 4) + 3) = 0
1176             y = y + 1
1177         Next x
1178
1179     Else
1180         For x = 0 To 255 Step 1 '768 - 4 Step 3 'Len(FileHeader) + Len(MyBitmapInfoHeader) To lngLenColorTable - 3 Step 3
1181             r = y 'arrayB(x)
1182             g = y 'arrayB(x + 1)
1183             b = y 'arrayB(x + 2)
1184             arrayOLE(lOffSet + (y * 4)) = b
1185             arrayOLE(lOffSet + (y * 4) + 1) = g
1186             arrayOLE(lOffSet + (y * 4) + 2) = r
1187             arrayOLE(lOffSet + (y * 4) + 3) = 0
1188             y = y + 1
1189         Next x
1190
1191
1192     End If
1193
1194
1195 End If
1196
1197
1198 ' Copy BitmapInfoHeader
1199 CopyMemory arrayOLE(Len(FileHeader)), MyBitmapInfoHeader, Len(MyBitmapInfoHeader)
1200
1201 ' Sat 6:17pm
1202 ' Change RGB triplet data to Quad RGB.
1203 ' put backin to see if we can handle both 8 bit and 24 bit
1204 If MyBitmapInfoHeader.biBitCount = 24 Then
1205
1206     Dim rquad As RGBQUAD
1207
1208     ' The Byte RGB data needs to be reversed to BGR
1209     lOffSet = FileHeader.bfOffBits
1210
1211     ' For every row of Bitmap
1212     For x = 0 To Abs(MyBitmapInfoHeader.biHeight) - 1
1213         ' For each pixel(triplet of RGB values)
1214         For y = 0 To MyBitmapInfoHeader.biWidth - 1
1215             With rquad
1216                 .rgbBlue = arrayOLE(lOffSet + (y * 3))
1217                 .rgbRed = arrayOLE((y * 3) + 2 + lOffSet)
1218
1219                 ' Reverse B and R
1220                 arrayOLE((y * 3) + lOffSet) = .rgbRed
1221                 arrayOLE((y * 3) + 2 + lOffSet) = .rgbBlue
1222             End With
1223
1224         ' increment 3 bytes per pixel is built into the above logic
1225         Next y
1226
1227     ' increment bytes per row (3 bytes per pixel + padding to end up on DWORD alignment
1228     lOffSet = lOffSet + BytesPerScanLine
1229     Next x
1230
1231 End If
1232 ''''''''''''''''''''''''''''''''''''''''''
1233 ''''''''''''''''''''''''''''''''''''''''''
1234
1235 Case Else
1236 ' Unsupported Format
1237
1238 ''''''''''''''''''''''''''''''''''''''''''
1239 ''''''''''''''''''''''''''''''''''''''''''
1240
1241 End Select
1242
1243 ' Success
1244 fGetContentsStream = True
1245
1246
1247 EXIT_fGetContentsStream:
1248
1249 ' Add error handling
1250
1251 Exit Function
1252
1253 ERR_fGetContentsStream:
1254 MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
1255 fGetContentsStream = False
1256 Resume EXIT_fGetContentsStream
1257
1258 End Function

窗体代码如下：

  1 Option Compare Database
  2 Option Explicit
  3
  4 Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" _
  5 (ByVal hwnd As Long, ByVal lpOperation As String, _
  6 ByVal lpFile As String, ByVal lpParameters As String, _
  7 ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
  8
  9 ' The following function will attempt to
 10 ' extract and save the current OLE object to disk.
 11 ' It will also launch whatever Application is currently
 12 ' registered for this file type on your system.
 13
 14 Private Sub cmdSave_Click()
 15 On Error GoTo Err_cmdSave_Click
 16
 17 Dim a() As Byte
 18 Dim b() As Byte
 19 Dim x As Long
 20 Dim lTemp As Long
 21 Dim sl As String
 22 Dim blRet As Boolean
 23 Dim sExt As String
 24 Dim sFileExist As String
 25
 26 ' This is an optional param we pass to fGetContentsStream.
 27 ' It will contain the original file name of the
 28 ' object when embedded as a Package.
 29 Dim PackageFileName As String
 30
 31 Dim iFileHandle As Integer
 32
 33 lTemp = LenB(Me.OLEPic.Value)
 34 ReDim a(0 To lTemp - 1)
 35 ReDim b(0 To lTemp - 1)
 36
 37 ' Copy the contents of the OLE field to our byte array
 38 a = Me.OLEPic.Value
 39
 40 ' Make a copy of the original data
 41 b = a
 42
 43 blRet = fGetContentsStream(a(), sExt, PackageFileName)
 44 If blRet = True Then
 45
 46     If sExt = "pak" Then
 47         ' If a file was dragged from the Explorer window
 48         ' it will have a Package object Filename of NULL
 49         ' inserted by Shell.DLL
 50         ' Catch and give a temp file name
 51         If Len(PackageFileName & vbNullString) < 3 Then
 52                     PackageFileName = "OLE-ExtractDraggedFromExplorer" & "." & "bmp"
 53         End If
 54
 55         iFileHandle = FreeFile
 56         sl = "H:\" & PackageFileName
 57         sFileExist = Dir(sl)
 58         If Len(sFileExist & vbNullString) > 0 Then
 59             Kill sl
 60         End If
 61
 62         Open sl For Binary Access Write As iFileHandle
 63         Put iFileHandle, , a
 64         Close iFileHandle
 65     Else
 66
 67         iFileHandle = FreeFile
 68         sl = "H:\" & sExt & UBound(a)
 69         '& "." & sExt
 70         sFileExist = Dir(sl)
 71         If Len(sFileExist & vbNullString) > 0 Then
 72          Kill sl
 73         End If
 74         Open sl For Binary Access Write As iFileHandle
 75         Put iFileHandle, , a
 76         Close iFileHandle
 77     End If
 78
 79
 80     Dim StartRegisteredApp As Boolean
 81
 82     'StartRegisteredApp = True
 83     ' Do we open the exported OLE object in the
 84     ' Application registered for this file type on this system?
 85     If StartRegisteredApp = True Then
 86     ' Some apps require vbNullString for the first parameter,
 87     ' other apps require "open" for the first parameter
 88      ShellExecuteA Application.hWndAccessApp, vbNullString, sl, vbNullString, vbNullString, 1
 89     End If '                                    "open"
 90 End If
 91
 92 ' Below is for debugging.
 93
 94 'iFileHandle = FreeFile
 95 'sl = "C:\OLE-field-ALL" & ".dat"
 96 'sFileExist = Dir(sl)
 97 'If Len(sFileExist & vbNullString) > 0 Then
 98 ' Kill sl
 99 'End If
100 '
101 'Open sl For Binary Access Write As iFileHandle
102 'Put iFileHandle, , b
103 'Close iFileHandle
104 '
105 'iFileHandle = FreeFile
106 'sl = "C:\OLE-field-CONTENTS" & ".dat"
107 'sFileExist = Dir(sl)
108 'If Len(sFileExist & vbNullString) > 0 Then
109 ' Kill sl
110 'End If
111 '
112 'Open sl For Binary Access Write As iFileHandle
113 'Put iFileHandle, , a
114 'Close iFileHandle
115
116 Exit_cmdSave_Click:
117 ' Release structured storage library
118     Exit Sub
119
120 Err_cmdSave_Click:
121     MsgBox Err.Description
122     Resume Exit_cmdSave_Click
123
124 End Sub

类模块代码如下：

  1 Option Compare Database
  2 Option Explicit
  3
  4
  5 Private Type RECT
  6     Left As Long
  7     top As Long
  8     right As Long
  9     Bottom As Long
 10 End Type
 11
 12 Private Type SIZEL
 13     cx As Long
 14     cy As Long
 15 End Type
 16
 17 Private Type ENHMETAHEADER
 18         iType As Long
 19         nSize As Long
 20         rclBounds As RECT
 21         rclFrame As RECT
 22         dSignature As Long
 23         nVersion As Long
 24         nBytes As Long
 25         nRecords As Long
 26         nHandles As Integer
 27         sReserved As Integer
 28         nDescription As Long
 29         offDescription As Long
 30         nPalEntries As Long
 31         szlDevice As SIZEL
 32         szlMillimeters As SIZEL
 33 End Type
 34
 35
 36 Private Type RGBQUAD
 37   rgbBlue As Byte
 38   rgbGreen As Byte
 39   rgbRed As Byte
 40   rgblReterved As Byte
 41 End Type
 42
 43
 44 'Private Enum ERGBCompression
 45  Private Const BI_RGB = 0&
 46   Private Const BI_RLE4 = 2&
 47   Private Const BI_RLE8 = 1&
 48   Private Const DIB_RGB_COLORS = 0 '  color table in RGBs
 49 'End Enum
 50
 51
 52 Private Type BITMAPINFOHEADER '40 bytes
 53   biSize As Long
 54   biWidth As Long
 55   biHeight As Long
 56   biPlanes As Integer
 57   biBitCount As Integer
 58   biCompression As Long 'ERGBCompression
 59   biSizeImage As Long
 60   biXPelsPerMeter As Long
 61   biYPelsPerMeter As Long
 62   biClrUsed As Long
 63   biClrImportant As Long
 64 End Type
 65
 66
 67 Private Type BITMAPINFO
 68   bmiHeader As BITMAPINFOHEADER
 69   bmiColors As RGBQUAD
 70 End Type
 71
 72
 73 Private Type BITMAP
 74   bmType As Long
 75   bmWidth As Long
 76   bmHeight As Long
 77   bmWidthBytes As Long
 78   bmPlanes As Integer
 79   bmBitsPixel As Integer
 80   bmBits As Long
 81 End Type
 82
 83 Private Type DIBSECTION
 84     dsBm As BITMAP
 85     dsBmih As BITMAPINFOHEADER
 86     dsBitfields(2) As Long
 87     dshSection As Long
 88     dsOffset As Long
 89 End Type
 90
 91 Private Type METAFILEPICT
 92  mm As Long
 93  xExt As Long
 94  yExt As Long
 95  hMF As Long
 96 End Type
 97
 98 ' From winuser.h
 99 Private Const IMAGE_BITMAP = 0
100 Private Const IMAGE_ICON = 1
101 Private Const IMAGE_CURSOR = 2
102 Private Const IMAGE_ENHMETAFILE = 3
103
104 Private Const LR_DEFAULTCOLOR = &H0
105 Private Const LR_MONOCHROME = &H1
106 Private Const LR_COLOR = &H2
107 Private Const LR_COPYRETURNORG = &H4
108 Private Const LR_COPYDELETEORG = &H8
109 Private Const LR_LOADFROMFILE = &H10
110 Private Const LR_LOADTRANSPARENT = &H20
111 Private Const LR_DEFAULTSIZE = &H40
112 Private Const LR_VGACOLOR = &H80
113 Private Const LR_LOADMAP3DCOLORS = &H1000
114 Private Const LR_CREATEDIBSECTION = &H2000
115 Private Const LR_COPYFROMRESOURCE = &H4000
116 Private Const LR_SHARED = &H8000
117
118 Private Const vbSrcCopy = &HCC0020
119 Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
120 Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE
121 Private Const BLACKNESS = &H42 ' (DWORD) dest = BLACK
122
123 ' Note - this is not the declare in the API viewer - modify lplpVoid to be
124 ' Byref so we get the pointer back:
125 Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
126 Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
127 Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
128 Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
129 Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
130 Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBmp As Long, ByVal uStartScan As Long, ByVal cScanLines As Long, ByVal lpvBits As Long, ByRef lpbi As BITMAPINFO, ByVal uUsage As Long) As Long
131 Private Declare PtrSafe Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInstance As Long, ByVal Name As Long, ByVal uType As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal fuLoad As Long) As Long
132 Private Declare PtrSafe Function apiGetObject Lib "gdi32" Alias "GetObjectA" _
133 (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
134 Private Declare PtrSafe Sub apiCopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
135 (Destination As Any, Source As Any, ByVal Length As Long)
136
137 Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
138
139 Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" _
140 Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
141
142 ' Create an Information Context
143 Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
144 (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
145 ByVal lpOutput As String, lpInitData As Any) As Long
146
147 Private Declare PtrSafe Function apiPlayEnhMetaFile Lib "gdi32" Alias "PlayEnhMetaFile" (ByVal hdc As Long, ByVal hEMF As Long, lpRect As RECT) As Long
148
149 'Private Declare PtrSafe Function SetWinMetaFileBits Lib "gdi32" _
150 '(ByVal cbBuffer As Long, lpbBuffer As Byte, _
151 'ByVal hdcRef As Long, lpmfp As METAFILEPICT) As Long
152
153 Private Declare PtrSafe Function SetWinMetaFileBits Lib "gdi32" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As LongPtr, lpmfp As METAFILEPICT) As LongPtr
154
155
156 Private Declare PtrSafe Function apiDeleteEnhMetaFile Lib "gdi32" Alias "DeleteEnhMetaFile" _
157 (ByVal hEMF As Long) As Long
158
159 Private Declare PtrSafe Function apiCloseEnhMetaFile Lib "gdi32" Alias "CloseEnhMetaFile" _
160 (ByVal hdc As Long) As Long
161
162 Private Declare PtrSafe Function GetEnhMetaFileHeader Lib "gdi32" _
163 (ByVal hEMF As Long, ByVal cbBuffer As Long, lpemh As ENHMETAHEADER) As Long
164
165 Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" _
166   Alias "DeleteDC" (ByVal hdc As Long) As Long
167
168 Private Declare PtrSafe Function apiCreateSolidBrush Lib "gdi32" Alias "CreateSolidBrush" _
169     (ByVal crColor As Long) As Long
170
171 Private Declare PtrSafe Function apiFillRect Lib "user32" Alias "FillRect" _
172 (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
173
174
175 ' Predefined Clipboard Formats
176 Private Const CF_TEXT = 1
177 Private Const CF_BITMAP = 2
178 Private Const CF_METAFILEPICT = 3
179 Private Const CF_SYLK = 4
180 Private Const CF_DIF = 5
181 Private Const CF_TIFF = 6
182 Private Const CF_OEMTEXT = 7
183 Private Const CF_DIB = 8
184 Private Const CF_PALETTE = 9
185 Private Const CF_PENDATA = 10
186 Private Const CF_RIFF = 11
187 Private Const CF_WAVE = 12
188 Private Const CF_UNICODETEXT = 13
189 Private Const CF_ENHMETAFILE = 14
190
191 '  Device Parameters for GetDeviceCaps()
192 Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
193 Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y
194
195 ' Handle to the current DIBSection:
196 Private m_hDib As Long
197 ' Handle to the old bitmap in the DC, for clear up:
198 Private m_hBmpOld As Long
199 ' Handle to the Device context holding the DIBSection:
200 Private m_hDC As Long
201 ' Address of memory pointing to the DIBSection's bits:
202 Private m_lPtr As Long
203 ' Type containing the Bitmap information:
204 Private m_bmi As BITMAPINFO
205 ' Holds current JPEG's FileName
206 Private m_CurrentJpegFileName As String
207 ' Array to hold original compressed Jpeg
208 ' to be used for BLOB storage in Table
209 Private bArray() As Byte
210
211 ' Temp var
212 Dim lngRet As Long
213
214
215
216 Public Function CreateDIB( _
217   ByVal lhdc As Long, _
218   ByVal lWidth As Long, _
219   ByVal lHeight As Long, _
220   ByVal lChannels As Long, _
221   ByRef hDib As Long _
222   ) As Boolean
223
224   With m_bmi.bmiHeader
225     .biSize = Len(m_bmi.bmiHeader)
226     .biWidth = lWidth
227     .biHeight = lHeight
228     .biPlanes = 1
229     If lChannels = 3 Then
230       .biBitCount = 24
231     Else
232       .biBitCount = 32
233     End If
234     .biCompression = BI_RGB
235     .biSizeImage = BytesPerScanLine * .biHeight
236   End With
237
238   'The m_lPtr is passed in byref.. so that it returns the the pointer to the bitmapinfo bits
239   'the m_lptr is then stored as a reference to the uncompressed image data
240   'the m_lptr is filled with image data when the ijlread method is invoked.
241   hDib = CreateDIBSection(lhdc, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
242
243   CreateDIB = (hDib <> 0)
244
245 End Function
246
247
248 Public Function Create(ByVal lWidth As Long, ByVal lHeight As Long, Optional ByVal lChannels As Long = 3) As Boolean
249
250   CleanUp
251
252   m_hDC = CreateCompatibleDC(0)
253
254   If (m_hDC <> 0) Then
255     If (CreateDIB(m_hDC, lWidth, lHeight, lChannels, m_hDib)) Then
256       m_hBmpOld = SelectObject(m_hDC, m_hDib)
257       Create = True
258     Else
259       Call DeleteObject(m_hDC)
260       m_hDC = 0
261     End If
262   End If
263
264 End Function
265
266
267 Public Function Load(ByVal Name As String) As Boolean
268   Dim hBmp As Long
269   Dim pName As Long
270   Dim aName As String
271
272   Load = False
273
274   CleanUp
275
276   m_hDC = CreateCompatibleDC(0)
277   If m_hDC = 0 Then
278     Exit Function
279   End If
280
281   aName = StrConv(Name, vbFromUnicode)
282   pName = StrPtr(aName)
283
284   hBmp = LoadImage(0, pName, IMAGE_BITMAP, 0, 0, (LR_CREATEDIBSECTION Or LR_LOADFROMFILE))
285   If hBmp = 0 Then
286     Call DeleteObject(m_hDC)
287     m_hDC = 0
288     MsgBox "Can't load BMP image"
289     Exit Function
290   End If
291
292   m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
293
294   ' get image sizes
295   Call GetDIBits(m_hDC, hBmp, 0, 0, 0, m_bmi, DIB_RGB_COLORS)
296
297   ' make 24 bpp dib section
298   m_bmi.bmiHeader.biBitCount = 24
299   m_bmi.bmiHeader.biCompression = BI_RGB
300   m_bmi.bmiHeader.biClrUsed = 0
301   m_bmi.bmiHeader.biClrImportant = 0
302
303   m_hDib = CreateDIBSection(m_hDC, m_bmi, DIB_RGB_COLORS, m_lPtr, 0, 0)
304   If m_hDib = 0 Then
305     Call DeleteObject(hBmp)
306     Call DeleteObject(m_hDC)
307     m_hDC = 0
308     Exit Function
309   End If
310
311   m_hBmpOld = SelectObject(m_hDC, m_hDib)
312
313   m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
314
315   ' get image data in 24 bpp format (convert if need)
316   Call GetDIBits(m_hDC, hBmp, 0, m_bmi.bmiHeader.biHeight, m_lPtr, m_bmi, DIB_RGB_COLORS)
317
318   Call DeleteObject(hBmp)
319
320   Load = True
321
322 End Function
323
324
325 Public Property Get BytesPerScanLine() As Long
326   ' Scans must align on dword boundaries:
327   BytesPerScanLine = (m_bmi.bmiHeader.biWidth * (m_bmi.bmiHeader.biBitCount / 8) + 3) And &HFFFFFFFC
328 End Property
329
330
331 Public Property Get dib_width() As Long
332   dib_width = m_bmi.bmiHeader.biWidth
333 End Property
334
335
336 Public Property Get dib_height() As Long
337   dib_height = m_bmi.bmiHeader.biHeight
338 End Property
339
340
341 Public Property Get dib_channels() As Long
342   dib_channels = m_bmi.bmiHeader.biBitCount / 8
343 End Property
344
345 Public Property Get CurrentJpegFileName() As String
346 CurrentJpegFileName = m_CurrentJpegFileName
347 End Property
348
349 Public Sub PaintPicture( _
350   ByVal lhdc As Long, _
351   Optional ByVal lDestLeft As Long = 0, _
352   Optional ByVal lDestTop As Long = 0, _
353   Optional ByVal lDestWidth As Long = -1, _
354   Optional ByVal lDestHeight As Long = -1, _
355   Optional ByVal lSrcLeft As Long = 0, _
356   Optional ByVal lSrcTop As Long = 0, _
357   Optional ByVal eRop As Long) ' = vbSrcCopy)
358
359   If (lDestWidth < 0) Then lDestWidth = m_bmi.bmiHeader.biWidth
360   If (lDestHeight < 0) Then lDestHeight = m_bmi.bmiHeader.biHeight
361 Dim lngRet As Long
362   lngRet = BitBlt(lhdc, lDestLeft, lDestTop, lDestWidth, lDestHeight, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)
363 'lngRet = BitBlt(lhDC, lDestLeft, lDestTop, 640, 480, m_hDC, lSrcLeft, lSrcTop, vbSrcCopy)
364
365 End Sub
366
367 Public Function LoadJpegFileIntoArray() As Boolean
368
369 On Error GoTo Err_CmdLoad_Click
370
371 Dim blRet As Boolean
372
373  ' jpg_scale = 1
374   Dim strfName As String
375   strfName = Me.CurrentJpegFileName  ' m_cDib.FileDialog 'c:\test2.jpg"
376   ' Read JPEG image
377
378 Dim lPtr As Long
379 Dim lSize As Long
380 Dim iFile As Integer
381 Dim sFile As String
382 'Dim bArray() As Byte
383
384    ' Copy the current Jpeg file data directly to the buffer
385    iFile = FreeFile
386    Open strfName For Binary Access Read Lock Write As #iFile
387    lSize = LOF(iFile)
388    ReDim bArray(0 To lSize - 1) As Byte
389    Get #iFile, , bArray()
390    Close #iFile
391
392
393     LoadJpegFileIntoArray = True
394 Exit_CmdLoad_Click:
395     Exit Function
396
397 Err_CmdLoad_Click:
398 LoadJpegFileIntoArray = False
399     MsgBox Err.Description
400     Resume Exit_CmdLoad_Click
401
402 End Function
403
404
405 Public Property Get JPegAsByteArray() As Variant
406 JPegAsByteArray = bArray
407
408 End Property
409
410 Public Property Get hdc() As Long
411   hdc = m_hDC
412 End Property
413
414
415 Public Property Get hDib() As Long
416   hDib = m_hDib
417 End Property
418
419
420 Public Property Get DIBSectionBitsPtr() As Long
421   DIBSectionBitsPtr = m_lPtr
422 End Property
423
424
425 Public Function DIBtoPictureData(ctl As Control)
426  Dim lngRet As Long
427  Dim ds As DIBSECTION
428
429      lngRet = apiGetObject(hDib, Len(ds), ds)
430
431     '.bfSize = Len(FileHeader) + Len(ds.dsBmih) + ds.dsBmih.biSizeImage
432
433     ' Update the Image Control display
434     ' We do this by simply copying the mBitmapAdd's contents to
435     ' the control's PictureData prop
436
437     Dim varTemp() As Byte
438     ReDim varTemp(ds.dsBmih.biSizeImage + 40)
439     apiCopyMemory varTemp(40), ByVal Me.DIBSectionBitsPtr, ds.dsBmih.biSizeImage
440     apiCopyMemory varTemp(0), ds.dsBmih, 40
441
442      ctl.PictureData = varTemp
443
444
445 End Function
446
447 Public Sub CleanUp()
448
449   If (m_hDC <> 0) Then
450     If (m_hDib <> 0) Then
451       Call SelectObject(m_hDC, m_hBmpOld)
452       Call DeleteObject(m_hDib)
453     End If
454     Call DeleteObject(m_hDC)
455   End If
456
457   m_hDC = 0
458   m_hDib = 0
459   m_hBmpOld = 0
460   m_lPtr = 0
461
462   m_bmi.bmiColors.rgbBlue = 0
463   m_bmi.bmiColors.rgbGreen = 0
464   m_bmi.bmiColors.rgbRed = 0
465   m_bmi.bmiColors.rgblReterved = 0
466   m_bmi.bmiHeader.biSize = Len(m_bmi.bmiHeader)
467   m_bmi.bmiHeader.biWidth = 0
468   m_bmi.bmiHeader.biHeight = 0
469   m_bmi.bmiHeader.biPlanes = 0
470   m_bmi.bmiHeader.biBitCount = 0
471   m_bmi.bmiHeader.biClrUsed = 0
472   m_bmi.bmiHeader.biClrImportant = 0
473   m_bmi.bmiHeader.biCompression = 0
474
475 End Sub
476
477
478 Private Sub Class_Terminate()
479   CleanUp
480 End Sub
481
482
483 Public Function FileDialog(LoadSave As Boolean) As String
484 ' Calls the API File Dialog Window
485 ' Returns full path to new File.
486 ' If LoadSave = TRUE then call File Load Dialog
487
488 On Error GoTo Err_fFileDialog
489
490 ' Call the File Common Dialog Window
491 Dim clsDialog As Object
492 Dim strTemp As String
493 Dim strfName As String
494
495 Set clsDialog = New clsCommonDialog
496
497 ' Fill in our structure
498 ' I'll leave in how to select Jpeg to
499 ' show you how to build the Filter
500 clsDialog.Filter = "JPEG (*.JPG)" & Chr$(0) & "*.JPG" & Chr$(0)
501 clsDialog.Filter = clsDialog.Filter & "Jpe (*.JPE)" & Chr$(0) & "*.JPE" & Chr$(0)
502 clsDialog.Filter = clsDialog.Filter & "Jpeg (*.JPEG)" & Chr$(0) & "*.JPEG" & Chr$(0)
503 clsDialog.Filter = clsDialog.Filter & "ALL (*.*)" & Chr$(0) & "*.*" & Chr$(0)
504
505 'clsDialog.Filter = clsDialog.Filter & "Gif (*.GIF)" & Chr$(0) & "*.GIF" & Chr$(0)
506
507
508 If LoadSave Then
509 ' Display the Open File Dialog
510 clsDialog.DialogTitle = "Please Select a JPEG File to Load"
511 clsDialog.ShowOpen
512 Else
513 clsDialog.DialogTitle = "Please Enter/Select a FileName to save the JPEG File"
514 clsDialog.ShowSave
515 End If
516
517 ' See if user clicked Cancel or even selected
518 ' the very same file already selected
519 strfName = clsDialog.FileName
520 If Len(strfName & vbNullString) = 0 Then
521 Set clsDialog = Nothing
522 Exit Function
523 '' Raise the exception
524  ' Err.Raise vbObjectError + 513, "clsPrintToFit.fFileDialog", _
525  ' "Please type in a Name for a New File"
526 End If
527
528 ' Return File Path and Name
529 FileDialog = strfName
530 ' Update our property
531 m_CurrentJpegFileName = strfName
532
533 Exit_fFileDialog:
534
535 Err.Clear
536 Set clsDialog = Nothing
537 Exit Function
538
539 Err_fFileDialog:
540 FileDialog = ""
541 m_CurrentJpegFileName = ""
542 MsgBox Err.Description, vbOKOnly, Err.Source & ":" & Err.Number
543 Resume Exit_fFileDialog
544
545 End Function
546
547
548
549 Public Function WMFtoBMP(bWMF() As Byte, mm As Long, xExt As Long, yExt As Long) As Boolean
550 Dim hEMF As LongPtr
551 Dim lngIC As Long
552
553 ' Instance of EMF Header structure
554  Dim mh As ENHMETAHEADER
555
556 ' Current Screen Resolution
557 Dim lngXdpi As Long
558 Dim lngYdpi As Long
559
560 ' Used to convert Metafile dimensions to pixels
561 Dim sngConvertX As Single
562 Dim sngConvertY As Single
563 Dim sngMetaResolutionX As Single
564 Dim sngMetaResolutionY As Single
565
566 Dim rc As RECT
567
568 Dim mfp As METAFILEPICT
569
570
571 ' Init our vars
572   CleanUp
573
574 ' Convert EMF byte array to memory EMF
575 With mfp
576     .hMF = 0
577     .mm = mm
578     .xExt = xExt
579     .yExt = yExt
580 End With
581
582 hEMF = SetWinMetaFileBits(UBound(bWMF) + 1, bWMF(0), 0&, mfp)
583 If hEMF = 0 Then
584     'Call DeleteObject(m_hDC)
585     'm_hDC = 0
586     WMFtoBMP = False
587     Exit Function
588 End If
589
590 ' Convert EMF size to pixels
591 '
592 lngRet = GetEnhMetaFileHeader(hEMF, Len(mh), mh)
593 If lngRet = 0 Then
594     WMFtoBMP = False
595     Exit Function
596 End If
597
598 With mh.rclFrame
599     ' The rclFrame member Specifies the dimensions,
600     ' in .01 millimeter units, of a rectangle that surrounds
601     ' the picture stored in the metafile.
602     ' I'll show this as seperate steps to aid in understanding
603     ' the conversion process.
604
605 ' Convert to MM
606 sngConvertX = (.right - .Left) * 0.01
607 sngConvertY = (.Bottom - .top) * 0.01
608  End With
609
610 ' Convert to CM
611 sngConvertX = sngConvertX * 0.1
612 sngConvertY = sngConvertY * 0.1
613 ' Convert to Inches
614 sngConvertX = sngConvertX / 2.54
615 sngConvertY = sngConvertY / 2.54
616
617
618 ' Get current Screen DPI
619 lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
620 'If the call to CreateIC didn't fail, then get the Screen X resolution.
621 If lngIC <> 0 Then
622     lngXdpi = apiGetDeviceCaps(lngIC, LOGPIXELSX)
623     lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
624     'Release the information context.
625     apiDeleteDC (lngIC)
626 Else
627     ' Something has gone wrong. Assume an average value.
628     lngXdpi = 120
629     lngYdpi = 120
630 End If
631
632 ' Convert the szlMillimeters to inches. This member
633 ' Specifies the resolution of the reference device, in millimeters.
634 ' Convert Inches to Pixels
635 'sngMetaResolutionX = (mh.szlMillimeters.cx * 0.01) / 2.54
636 sngMetaResolutionX = (mh.szlDevice.cx / ((mh.szlMillimeters.cx * 0.1) / 2.54))
637 sngMetaResolutionY = (mh.szlDevice.cy / ((mh.szlMillimeters.cy * 0.1) / 2.54))
638
639 Create CLng(sngConvertX * sngMetaResolutionX), CLng(sngConvertY * sngMetaResolutionY)
640
641 ' **********************
642 ' I have seen cases where the xExt and yExt values are not correct.
643 ' I may consider playing the MWF into an EMF DC so that
644 ' I could allow the GDI to determine the
645 ' actual extents of the Image. Next revision.
646
647
648 ' Case CF_ENHMETAFILE
649  ' If it is an Enhanced Metafile then we
650  ' Need to  "PLAY" the Metafile
651  ' back into the Device COntext instead
652  ' of using the SelectObject API
653
654 rc.top = 0
655 rc.Left = 0
656 rc.Bottom = m_bmi.bmiHeader.biHeight
657 rc.right = m_bmi.bmiHeader.biWidth
658 lngRet = apiPlayEnhMetaFile(m_hDC, hEMF, rc)
659
660 ' Delete the EMF
661 lngRet = apiDeleteEnhMetaFile(hEMF)
662
663 ' Resize array
664 GetDIBBytes bWMF()
665
666 '// Success
667 WMFtoBMP = True
668 End Function
669
670
671
672 Public Function GetDIBBytes(bBytes() As Byte)
673 Dim lngRet As Long
674 Dim lSize As Long
675
676
677 lSize = m_bmi.bmiHeader.biSizeImage - 1
678 ReDim bBytes(0 To lSize) As Byte
679
680 apiCopyMemory bBytes(0), ByVal m_lPtr, m_bmi.bmiHeader.biSizeImage
681
682 End Function

可实现的功能如下：

点击保存后，可以将粘贴在OLE对象框内的图像保存在本地