access2007功能区开发-自定义图像加载模块

时　间:2009-09-02 10:43:55
作　者:朱亦文   ID：61  城市：岳阳
摘　要:Access2007功能区开发-自定义图像加载模块
正　文:

模块名称: modOGL2007

Option Compare Database
Option Explicit
'***************************************
'* 用于功能区加载图片                  *
'***************************************
'***************************************
'* Office 2007 Graphics Library Module *
'* ? mossSOFT 04/2007                  *
'* Sascha Trowitzsch                   *
'***************************************
Public Const GUID_IPicture = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"   'IPicture
'User-defined types: ----------------------------------------------------------------------
Public Enum eEffects
    BlurEffect = 1
    SharpenEffect = 2
    ColorMatrixEffect = 3
    ColorLUTEffect = 4
    BrightnessContrastEffect = 5
    HueSaturationEffect = 6
    LevelEffect = 7
    TintEffect = 8
    ColorBalanceEffect = 9
    RedEyeCorrectionEffect = 10
    ColorCurveEffect = 11
End Enum
Public Enum PicFileType
    pictypeBMP = 1
    pictypeGIF = 2
    pictypePNG = 3
    pictypeJPG = 4
    pictypeTIF = 5
    pictypeICO = 6
    pictypeUnk = 7
End Enum
Private Type T_RGB
    Red As Byte
    Green As Byte
    Blue As Byte
End Type
Public Type T_HLS
    hue As Integer
    Luminance As Integer
    Saturation As Integer
End Type
Public Type GUID
    data1 As Long
    data2 As Integer
    data3 As Integer
    data4(7) As Byte
End Type
Public Type TSize
    x As Double
    y As Double
End Type
Public Type rect
    Bottom As Long
    Left As Long
    Right As Long
    Top As Long
End Type
Public Type RECTL
    Bottom As Long
    Left As Long
    Right As Long
    Top As Long
End Type
Private Type PICTDESC
    cbSizeOfStruct As Long
    PicType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
Public Enum GpStatus
    Ok = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
End Enum
Private Type GDIPStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    uuid As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type
Public Enum PixelFormat
    PixelFormat1bppIndexed = &H30101
    PixelFormat4bppIndexed = &H30402
    PixelFormat8bppIndexed = &H30803
    PixelFormat16bppGreyScale = &H101004
    PixelFormat16bppRGB555 = &H21005
    PixelFormat16bppRGB565 = &H21006
    PixelFormat16bppARGB1555 = &H61007
    PixelFormat24bppRGB = &H21808
    PixelFormat32bppRGB = &H22009
    PixelFormat32bppARGB = &H26200A
    PixelFormat32bppPARGB = &HE200B
    PixelFormat32bppCMYK = &H200F   '&H2200F ??
    PixelFormat48bppRGB = &H10300C
    PixelFormat64bppARGB = &H34400D
    PixelFormat64bppPARGB = &H1C400E
    PixelFormatMax = &H10
End Enum
Public Enum ColorAdjustType
    ColorAdjustTypeDefault = 0
    ColorAdjustTypeBitmap = 1
    ColorAdjustTypeBrush = 2
    ColorAdjustTypePen = 3
    ColorAdjustTypeText = 4
    ColorAdjustTypeCount = 5
    ColorAdjustTypeAny = 6
End Enum
Public Enum ColorMatrixFlags
    ColorMatrixFlagsDefault = 0
    ColorMatrixFlagsSkipGrays = 1
    ColorMatrixFlagsAltGray = 2
End Enum
Public Type ColorMatrix
    m(0 To 4, 0 To 4) As Single
End Type
Public Enum PaletteFlags
    PaletteFlagsHasAlpha = &H1
    PaletteFlagsGrayScale = &H2
    PaletteFlagsHalftone = &H4
End Enum
Public Type ColorPalette
    Flags As PaletteFlags
    count As Long
    Entries(0 To 255) As Long
End Type
Private Enum DitherType
    DitherTypeNone = 0
    DitherTypeSolid = 1
    DitherTypeOrdered4x4 = 2
    DitherTypeOrdered8x8 = 3
    DitherTypeOrdered16x16 = 4
    DitherTypeSpiral4x4 = 5
    DitherTypeSpiral8x8 = 6
    DitherTypeDualSpiral4x4 = 7
    DitherTypeDualSpiral8x8 = 8
    DitherTypeErrorDiffusion = 9
    DitherTypeMax = 10
End Enum
Public Enum PaletteType
    PaletteTypeCustom = 0
    PaletteTypeOptimal = 1
    PaletteTypeFixedBW = 2
    PaletteTypeFixedHalftone8 = 3
    PaletteTypeFixedHalftone27 = 4
    PaletteTypeFixedHalftone64 = 5
    PaletteTypeFixedHalftone125 = 6
    PaletteTypeFixedHalftone216 = 7
    PaletteTypeFixedHalftone252 = 8
    PaletteTypeFixedHalftone256 = 9
End Enum
Public Enum GpUnit
    UnitWorld = 0       ' World coordinate (non-physical unit)
    UnitDisplay = 1     ' Variable -- for PageTransform only
    UnitPixel = 2       ' Each unit is one device pixel.
    UnitPoint = 3       ' Each unit is a printer's point, or 1/72 inch.
    UnitInch = 4        ' Each unit is 1 inch.
    UnitDocument = 5    ' Each unit is 1/300 inch.
    UnitMillimeter = 6  ' Each unit is 1 millimeter.
End Enum
Public Type RGBQUAD
    rgbBlue As Byte
    rgbGreen As Byte
    rgbRed As Byte
    rgbReserved As Byte
End Type
Public Type COLORBYTES
    BlueByte As Byte
    GreenByte As Byte
    RedByte As Byte
    AlphaByte As Byte
End Type
Public Type COLORLONG
    longval As Long
End Type
Public Type BitmapData
    Width As Long
    Height As Long
    stride As Long
    PixelFormat As Long
    scan0 As Long
    Reserved As Long
End Type
Public Enum ImageLockMode
    ImageLockModeRead = &H1
    ImageLockModeWrite = &H2
    ImageLockModeUserInputBuf = &H4
End Enum
Private Type SharpenParameters
    Radius As Single
    amount As Single
End Type
Private Type BlurParameters
    Radius As Single
    ExpandEdges As Long
End Type
Private Type BrightnessContrastParameters
    brightnessLevel As Long
    contrastLevel As Long
End Type
Private Type TintParams
    hue As Long
    amount As Long
End Type
Private Type HueSaturationLightnessParameters
    hueLevel As Long
    saturationLevel As Long
    lightnessLevel As Long
End Type
Private Type LevelsParameters
    highlight As Long
    midtone As Long
    shadow As Long
End Type
Private Type ColorBalanceParameters
    cyanRed As Long
    magentaGreen As Long
    yellowBlue As Long
End Type
Private Type ColorLUTParameters
    lutB(1 To 256) As Byte
    lutG(1 To 256) As Byte
    lutR(1 To 256) As Byte
    lutA(1 To 256) As Byte
End Type
Private Enum CurveAdjustments
    AdjustExposure
    AdjustDensity
    AdjustContrast
    AdjustHighlight
    AdjustShadow
    AdjustMidtone
    AdjustWhiteSaturation
    AdjustBlackSaturation
End Enum
Private Enum CurveChannel
    CurveChannelAll
    CurveChannelRed
    CurveChannelGreen
    CurveChannelBlue
End Enum
Private Type ColorCurveParameters
    adjustment As CurveAdjustments
    Channel As CurveChannel
    adjustValue As Long
End Type
Private Type RedEyeCorrectionParameters
    numberOfAreas As Long
    areas() As rect
End Type
'API-Declarations: ----------------------------------------------------------------------------
'Load DLL
Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
'Release DLL
Private Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
'Retrieve Address of a named function of a DLL :
Private Declare Function GetProcAddress Lib "kernel32.dll" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetModuleHandle Lib "kernel32.dll" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetModuleFileName Lib "kernel32.dll" Alias "GetModuleFileNameA" (ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
'Convert a windows bitmap to OLE-Picture :
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
'Retrieve GUID-Type from string :
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pCLSID As GUID) As Long
'Memory functions:
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal Destination As Long, ByRef Source As Byte, ByVal Length As Long)
'OLE-Stream functions :
Private Declare Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any) As Long
Private Declare Function GetHGlobalFromStream Lib "OLE32.dll" (ByVal pstm As Any, ByRef phglobal As Long) As Long
'Standard-GDI functions:
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As rect) As Long
'Create to screen compatible DeviceContext :
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Create an empty windows bitmap :
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
'Copy GDI object to DeviceContext:
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
'Create Background color/Handle :
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
'Delete GDI object:
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Delete DeviceContext:
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'Retrieve a property of a DeviceContext :
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
'Copy a bitmap pattern in DeviceContext :
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal dwRop As Long) As Long
Private Declare Sub ColorRGBToHLS Lib "shlwapi.dll" (ByVal clrRGB As Long, ByRef pwHue As Integer, ByRef pwLuminance As Integer, ByRef pwSaturation As Integer)
Private Declare Function ColorHLSToRGB Lib "shlwapi.dll" (ByVal wHue As Integer, ByVal wLuminance As Integer, ByVal wSaturation As Integer) As Long
'Retrieve Shell-Icon for a file type:
Private Declare Function ExtractAssociatedIcon Lib "Shell32.dll" Alias "ExtractAssociatedIconA" (ByVal hInst As Long, ByVal lpIconPath As String, lpiIcon As Long) As Long
'Avoid repaint of a window:
Public Declare Function LockWindowUpdate Lib "user32.dll" (ByVal hwndLock As Long) As Long
'Office 2007 Graphics Library:
'GDIPlus-API Declarations:
'Initialization GDIP:
Private Declare Function GdiplusStartup Lib "ogl" (token As Long, inputbuf As GDIPStartupInput, Optional ByVal outputbuf As Long = 0) As Long
'Tear down GDIP:
Private Declare Function GdiplusShutdown Lib "ogl" (ByVal token As Long) As Long
'Load GDIP-Image from file :
Private Declare Function GdipCreateBitmapFromFile Lib "ogl" (ByVal FileName As Long, bitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "ogl" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
'Create GDIP- graphical area from Windows-DeviceContext:
Private Declare Function GdipCreateFromHDC Lib "ogl" (ByVal hdc As Long, GpGraphics As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "ogl" (ByVal image As Long, graphics As Long) As Long
'Delete GDIP graphical area :
Private Declare Function GdipDeleteGraphics Lib "ogl" (ByVal graphics As Long) As Long
'Copy GDIP-Image to graphical area:
Private Declare Function GdipDrawImageRect Lib "ogl" (ByVal graphics As Long, ByVal image As Long, ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single) As Long
Private Declare Function GdipGraphicsClear Lib "ogl" (ByVal graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipSetCompositingQuality Lib "ogl" (ByVal graphics As Long, ByVal CompositingQlty As Long) As Long
Private Declare Function GdipCreateImageAttributes Lib "ogl" (imageattr As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "ogl" (ByVal graphics As Long, ByVal image As Long, ByVal dstx As Long, ByVal dsty As Long, ByVal dstwidth As Long, ByVal dstheight As Long, ByVal srcx As Long, ByVal srcy As Long, ByVal srcwidth As Long, ByVal srcheight As Long, ByVal srcUnit As GpUnit, Optional ByVal imageAttributes As Long = 0, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipDisposeImageAttributes Lib "ogl" (ByVal imageattr As Long) As Long
Private Declare Function GdipSetImageAttributesColorKeys Lib "ogl" (ByVal imageattr As Long, ByVal ClrAdjType As ColorAdjustType, ByVal enableFlag As Long, ByVal colorLow As Long, ByVal colorHigh As Long) As Long
Private Declare Function GdipCloneImageAttributes Lib "ogl" (ByVal imageattr As Long, cloneImageattr As Long) As Long
Private Declare Function GdipResetImageAttributes Lib "ogl" (ByVal imageattr As Long, ByVal ClrAdjType As ColorAdjustType) As Long
Private Declare Function GdipSetImageAttributesColorMatrix Lib "ogl" (ByVal imageattr As Long, ByVal ClrAdjType As ColorAdjustType, ByVal enableFlag As Long, colourMatrix As ColorMatrix, grayMatrix As Any, ByVal Flags As ColorMatrixFlags) As Long
Private Declare Function GdipSetImageAttributesGamma Lib "ogl" (ByVal imageattr As Long, ByVal ClrAdjType As ColorAdjustType, ByVal enableFlag As Long, ByVal gamma As Single) As Long
Private Declare Function GdipGetImageAttributesAdjustedPalette Lib "ogl" (ByVal imageattr As Long, colorPal As ColorPalette, ByVal ClrAdjType As ColorAdjustType) As Long
Private Declare Function GdipGetImagePixelFormat Lib "ogl" (ByVal image As Long, PixelFormat As Long) As Long
Private Declare Function GdipGetImagePalette Lib "ogl" (ByVal image As Long, palette As ColorPalette, ByVal size As Long) As Long
Private Declare Function GdipSetImagePalette Lib "ogl" (ByVal image As Long, palette As ColorPalette) As Long
Private Declare Function GdipGetImagePaletteSize Lib "ogl" (ByVal image As Long, size As Long) As Long
Private Declare Function GdipBitmapGetPixel Lib "ogl" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As Long
Private Declare Function GdipBitmapLockBits Lib "ogl" (ByVal bitmap As Long, rect As RECTL, ByVal Flags As ImageLockMode, ByVal PixelFormat As Long, lockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "ogl" (ByVal bitmap As Long, lockedBitmapData As BitmapData) As Long
'Clear allocated bitmap memory from GDIP :
Private Declare Function GdipDisposeImage Lib "ogl" (ByVal image As Long) As Long
'Retrieve windows bitmap handle from GDIP-Image:
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "ogl" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
'Retrieve Windows-Icon-Handle from GDIP-Image:
Private Declare Function GdipCreateHICONFromBitmap Lib "ogl" (ByVal bitmap As Long, hbmReturn As Long) As Long
'Scaling GDIP-Image size:
Private Declare Function GdipGetImageThumbnail Lib "ogl" (ByVal image As Long, ByVal thumbWidth As Long, ByVal thumbHeight As Long, thumbImage As Long, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
'Retrieve GDIP-Image from Windows-Bitmap-Handle:
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "ogl" (ByVal hbm As Long, ByVal hpal As Long, bitmap As Long) As Long
'Retrieve GDIP-Image from Windows-Icon-Handle:
Private Declare Function GdipCreateBitmapFromHICON Lib "ogl" (ByVal hIcon As Long, bitmap As Long) As Long
'Retrieve width of a GDIP-Image (Pixel):
Private Declare Function GdipGetImageWidth Lib "ogl" (ByVal image As Long, Width As Long) As Long
'Retrieve height of a GDIP-Image (Pixel):
Private Declare Function GdipGetImageHeight Lib "ogl" (ByVal image As Long, Height As Long) As Long
'Save GDIP-Image to file in seletable format:
Private Declare Function GdipSaveImageToFile Lib "ogl" (ByVal image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
'Save GDIP-Image in OLE-Stream with seletable format:
Private Declare Function GdipSaveImageToStream Lib "ogl" (ByVal image As Long, ByVal stream As IUnknown, clsidEncoder As GUID, encoderParams As Any) As Long
'Retrieve GDIP-Image from OLE-Stream-Object:
Private Declare Function GdipLoadImageFromStream Lib "ogl" (ByVal stream As IUnknown, image As Long) As Long
'Only GDI+1.1 !!!:
'Create an Effect object (used here for Sharpen-Object ):
Private Declare Function GdipCreateEffect Lib "ogl" (ByVal cid1 As Long, ByVal cid2 As Long, ByVal cid3 As Long, ByVal cid4 As Long, Effect As Long) As Long
'Set parameter for Effect object :
Private Declare Function GdipSetEffectParameters Lib "ogl" (ByVal Effect As Long, params As Any, ByVal size As Long) As Long
'Apply Effect on a GDIP-Image :
Private Declare Function GdipBitmapApplyEffect Lib "ogl" (ByVal image As Long, ByVal Effect As Long, ByVal roi As Long, ByVal useAuxData As Long, ByVal auxData As Long, ByVal auxDataSize As Long) As Long
'Clear Effect object:
Private Declare Function GdipDeleteEffect Lib "ogl" (ByVal Effect As Long) As Long
Private Declare Function GdipInitializePalette Lib "ogl" (ByVal palette As Long, ByVal APaletteType As PaletteType, ByVal optimalColors As Long, ByVal useTransparentColor As Long, ByVal bitmap As Long) As Long
Private Declare Function GdipBitmapConvertFormat Lib "ogl" (ByVal image As Long, ByVal format As PixelFormat, ByVal ADitherType As DitherType, ByVal APaletteType As PaletteType, ByRef palette As ColorPalette, ByVal alphaThresholdPercent As Single) As Long

Private lGDIP As Long
Private hMod As Long

'Check, whether ogl.dll is installed on the system and Initialize GDI+:
Sub InitGDIP()
    Dim TGDP As GDIPStartupInput
    Dim sSharedFolder As String
    If hMod = 0 Then
        sSharedFolder = GetSpecFolder(43) & "\Microsoft Shared\Office12"
        hMod = LoadLibrary(sSharedFolder & "\ogl.dll")
    End If
    If hMod = 0 Then
        MsgBox "Office Graphics Library 没有安装。", vbCritical, "modOGL2007"
        Exit Sub
    End If
    If lGDIP <> 0 Then ShutDownGDIP
    TGDP.GdiplusVersion = 1
    GdiplusStartup lGDIP, TGDP
End Sub
'Clear GDI+:
Sub ShutDownGDIP()
    If lGDIP <> 0 Then
        GdiplusShutdown lGDIP
        lGDIP = 0
    End If
    If hMod <> 0 Then
        FreeLibrary hMod
        hMod = 0
    End If
End Sub
'Load image file with GDIP
'It's equivalent to the method LoadPicture() in OLE-Automation library (stdole2.tlb)
'Allowed format: bmp, gif, jp(e)g, tif, png, wmf, emf, ico
Function LoadPictureGDIP(sFilename As String) As StdPicture
    Dim hBmp As Long
    Dim hPic As Long
    Dim ret As Long
    If Dir(sFilename) = "" Then
        '在程序中采用安静模式
        'Err.Raise 53, "modOGL2007", "文件 " & sFilename & " 不存在。"
       
        Exit Function
    End If
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    ret = GdipCreateBitmapFromFile(StrPtr(sFilename), hPic)
    If ret = 0 Then
        ret = GdipCreateHBITMAPFromBitmap(hPic, hBmp, 0&)
        If hBmp <> 0 Then
            Set LoadPictureGDIP = BitmapToPicture(hBmp)
            GdipDisposeImage hPic
        Else
            Err.Raise vbObjectError + 303, "modOGL2007", VerboseGDIPLusError(ret)
        End If
    Else
        Err.Raise vbObjectError + 301, "modOGL2007", VerboseGDIPLusError(ret)
    End If
End Function
'Scale picture with GDIP
'A StdPicture is commited, also the return value
'Width and Height of generatrix pictures in Width, Height
'bSharpen: TRUE=Thumb is additional sharpend (only if GDI+ 1.1 is installed!)
Function ResampleImage(ByVal image As Picture, ByVal Width As Long, ByVal Height As Long, _
                       Optional bSharpen As Boolean = True) As StdPicture
    Dim ret As Long
    Dim lBitmap As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If image.type = 1 Then
        ret = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
    Else
        ret = GdipCreateBitmapFromHICON(image.Handle, lBitmap)
    End If
    If ret = 0 Then
        Dim lThumb As Long
        Dim hBitmap As Long
        ret = GdipGetImageThumbnail(lBitmap, Width, Height, lThumb, 0, 0)
        If ret = 0 Then
            If bSharpen Then
                Dim iEffect As Long
                iEffect = CreateEffect(SharpenEffect)
                If iEffect <> 0 Then
                    ret = SetSharpenParameters(iEffect, 1, 90)
                    If ret = 0 Then GdipBitmapApplyEffect lThumb, iEffect, 0, 0, 0, 0
                    ret = GdipDeleteEffect(iEffect)
                End If
            End If
            If image.type = 3 Then  'Image-Type 3 is named : Icon!
                'Convert with these GDI+ method :
                ret = GdipCreateHICONFromBitmap(lThumb, hBitmap)
                Set ResampleImage = BitmapToPicture(hBitmap, True)
            Else
                ret = GdipCreateHBITMAPFromBitmap(lThumb, hBitmap, 0)
                Set ResampleImage = BitmapToPicture(hBitmap)
            End If
            GdipDisposeImage lThumb
        Else
            Err.Raise vbObjectError + 305, "mdOGL2007", VerboseGDIPLusError(ret)
        End If
        GdipDisposeImage lBitmap
    End If
End Function
'Create thumbnail from image with GDIP
'Width and Height are Width and Height of the thumbnails
'Backcolor (Optional) is the Backcolor for the border,
'which arise, cause size of thumbnail and size of image
'do not match.
Function MakeThumb(ByVal image As Picture, Width As Long, Height As Long, Optional BackColor As Long = 8421504) As StdPicture
    Dim ret As Long
    Dim lBitmap As Long
    Dim lGraph As Long
    Dim hdc As Long
    Dim hBmp As Long
    Dim hBrush As Long
    Dim x As Long, y As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    'Create GDIP-Image from Windows-Bitmap-Handle:
    ret = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
    If ret = 0 Then
        'Retrieve image dimensions:
        GdipGetImageWidth lBitmap, x
        GdipGetImageHeight lBitmap, y
        'Create new and empty DeviceContext:
        hdc = CreateCompatibleDC(0)
        'Create empty bitmap within there with requested size for thumbnail:
        hBmp = CreateBitmap(Width, Width, GetDeviceCaps(hdc, 14), GetDeviceCaps(hdc, 12), ByVal 0&)
        hBmp = SelectObject(hdc, hBmp)
        'Create Backcolor :
        hBrush = CreateSolidBrush(BackColor)
        'Copy backcolor to DeviceContext:
        hBrush = SelectObject(hdc, hBrush)
        'Dummy function, to apply backcolor and size for thumbnail:
        PatBlt hdc, 0, 0, Width, Height, &HF00021   'Modus PATCOPY
        DeleteObject SelectObject(hdc, hBrush)
        'Create GDIP graphical area from DeviceContext:
        ret = GdipCreateFromHDC(hdc, lGraph)
        'Copy Thumbnail-Bitmap to the area :
        ret = GdipDrawImageRect(lGraph, lBitmap, (Width - x) / 2, (Height - y) / 2, x, y)
        'Return (modified) Windows-Bitmap :
        hBmp = SelectObject(hdc, hBmp)
        '...and convert to StdPicture :
        Set MakeThumb = BitmapToPicture(hBmp)
        'Clean :
        DeleteDC hdc
        GdipDisposeImage lBitmap
        GdipDeleteGraphics lGraph
    End If
End Function
'Zwei Bilder Image1 und Image 2 mischen
'delta:     überblendfaktor von 0...1. Umso h?her, desto st?rker tritt Image1 im Ergebnis auf.
'bMaxScreen:Falls True, dann hat Ergebnisbild die Gr??e des Bildschirms (eingepasst).
'           Ansonsten sind Breite und H?he des Ergebnisses die jeweils maximale
'           Ausdehnung von Image1 oder Image2
Function MergeImages(ByVal Image1 As Picture, ByVal Image2 As Picture, _
                     Optional delta As Single = 0.5, _
                     Optional bMaxScreen As Boolean = True) As StdPicture
    Dim lBitmap As Long, lBitmap1 As Long, lBitmap2 As Long, lGraph As Long
    Dim h As Long, W As Long, H1 As Long, H2 As Long, W1 As Long, W2 As Long
    Dim imgAttr As Long, imgAttr2 As Long, hBmp As Long
    Dim arrCM As ColorMatrix
    Dim siz As TSize
    Dim ret As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    ret = GdipCreateBitmapFromHBITMAP(Image1.Handle, 0, lBitmap1)
    ret = GdipCreateBitmapFromHBITMAP(Image2.Handle, 0, lBitmap2)
    GdipGetImageHeight lBitmap1, H1
    GdipGetImageHeight lBitmap2, H2
    GdipGetImageWidth lBitmap1, W1
    GdipGetImageWidth lBitmap2, W2
    h = H1
    W = W1
    If H2 > h Then h = H2
    If W2 > W Then W = W2
    If bMaxScreen Then
        siz = GetScreenRes
        If siz.x < W Then h = h * siz.x / W: W = siz.x
        If siz.y < h Then W = W * siz.y / h: h = siz.y
    End If
    ret = GdipCreateBitmapFromScan0(CLng(W), CLng(h), 0, &H22009, ByVal 0&, lBitmap)
    ret = GdipGetImageGraphicsContext(lBitmap, lGraph)
    ret = GdipCreateImageAttributes(imgAttr)
    ret = GdipCreateImageAttributes(imgAttr2)
    With arrCM
        .m(0, 0) = 1
        .m(1, 1) = 1
        .m(2, 2) = 1
        .m(3, 3) = delta
        .m(4, 4) = 1
    End With
    ret = GdipSetImageAttributesColorMatrix(imgAttr, ColorAdjustTypeBitmap, 1, arrCM, 0&, ColorMatrixFlagsDefault)
    arrCM.m(3, 3) = 1 - delta
    ret = GdipSetImageAttributesColorMatrix(imgAttr2, ColorAdjustTypeBitmap, 1, arrCM, 0&, ColorMatrixFlagsDefault)

    ret = GdipDrawImageRectRectI(lGraph, lBitmap1, (W - W1) \ 2, (h - H1) \ 2, W1, H1, 0, 0, W1, H1, UnitPixel, imgAttr, 0, 0)
    ret = GdipDrawImageRectRectI(lGraph, lBitmap2, (W - W2) \ 2, (h - H2) \ 2, W2, H2, 0, 0, W2, H2, UnitPixel, imgAttr2, 0, 0)
    GdipCreateHBITMAPFromBitmap lBitmap, hBmp, 0&
    Set MergeImages = BitmapToPicture(hBmp)
    GdipDisposeImageAttributes imgAttr
    GdipDisposeImage lBitmap
    GdipDisposeImage lBitmap1
    GdipDisposeImage lBitmap2
    GdipDeleteGraphics lGraph
End Function
'Image mit Transparenz-Kanal aus einem ohne Transparenz erstellen
'(Erzeugen eines 32bit-Bildes)
'AlphaColor:    Farbe im Bild, die transparent werden soll.
'               Falls nicht angegeben, dann wird die Farbe in der linken oberen Ecke
'               als Transparenzfarbe ermittelt.
'NEU: Falls SavePNGFile angegeben, dann wird Bild als PNG-Datei abgespeichert
Function ImageMakeAlpha(image As StdPicture, _
                        Optional AlphaColor As Long = -1, _
                        Optional SavePNGFile As Variant) As StdPicture
    Dim lBitmap As Long, lBitmap2 As Long, lGraph As Long
    Dim h As Long, W As Long, alfa As Long
    Dim imgAttr As Long, hBmp As Long
    Dim ret As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If image Is Nothing Then Exit Function
    ret = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
    If AlphaColor = -1 Then
        ret = GdipBitmapGetPixel(lBitmap, 0, 0, alfa)
        AlphaColor = alfa
    End If
    GdipGetImageHeight lBitmap, h
    GdipGetImageWidth lBitmap, W
    ret = GdipCreateBitmapFromScan0(CLng(W), CLng(h), 0, PixelFormat32bppARGB, ByVal 0&, lBitmap2)
    ret = GdipGetImageGraphicsContext(lBitmap2, lGraph)
    ret = GdipGraphicsClear(lGraph, &H0)
    ret = GdipCreateImageAttributes(imgAttr)
    ret = GdipSetImageAttributesColorKeys(imgAttr, ColorAdjustTypeBitmap, 1&, ByVal AlphaColor, ByVal AlphaColor)
    ret = GdipDrawImageRectRectI(lGraph, lBitmap, 0, 0, W, h, 0, 0, W, h, UnitPixel, _
                                 imgAttr, 0, 0)

    If Not IsMissing(SavePNGFile) Then
        Dim TEncoder As GUID
        Dim TParams As EncoderParameters
        CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), TEncoder
        ret = GdipSaveImageToFile(lBitmap2, StrPtr(SavePNGFile), TEncoder, TParams)
        If ret <> 0 Then MsgBox VerboseGDIPLusError(ret), vbExclamation, _
           "Speichern von " & SavePNGFile & " schlug fehl:"
    End If
    GdipCreateHBITMAPFromBitmap lBitmap2, hBmp, 0&
    Set ImageMakeAlpha = BitmapToPicture(hBmp)
    GdipDisposeImageAttributes imgAttr
    GdipDisposeImage lBitmap
    GdipDisposeImage lBitmap2
    GdipDeleteGraphics lGraph
End Function
'Bild 2 mit Transparenz in Bild 1 einblenden
'ImageMain:     Hauptbild
'ImageOverlay:  Einzublendenes Bild; muss kleiner sein als Hauptbild! (Sonst wird Ergebnis=Nothing)
'alpha:         Grad der Transparenz von 0...1 (0=nicht transparent)
'AlphaColor:    Farbe in Bild 2, die tranparent werden soll. Falls angegeben, dann
'               wird Parameter alpha au?er Kraft gesetzt!
'x,y:           Position in Pixel, an der linke obere Ecke von Bild 2 in Bild1 eingeblendet wird
'Bsp.: SaveImage(OverlayImages(LoadPicture("e:\sascha2.bmp"),LoadPicture("e:\dev_email.bmp"),0.6,10,500,0&),"e:\overlay.jpg",pictypeJPG )
Function OverlayImages(ByVal ImageMain As Picture, ByVal ImageOverlay As Picture, _
                       ByVal alpha As Single, x As Long, y As Long, _
                       Optional AlphaColor As Long = -1) As StdPicture
    Dim lBitmap1 As Long, lBitmap2 As Long, lGraph As Long
    Dim H1 As Long, H2 As Long, W1 As Long, W2 As Long
    Dim imgAttr As Long, imgAttr2 As Long, hBmp As Long
    Dim arrCM As ColorMatrix
    Dim ret As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    ret = GdipCreateBitmapFromHBITMAP(ImageMain.Handle, 0, lBitmap1)
    ret = GdipCreateBitmapFromHBITMAP(ImageOverlay.Handle, 0, lBitmap2)
    GdipGetImageHeight lBitmap1, H1
    GdipGetImageHeight lBitmap2, H2
    GdipGetImageWidth lBitmap1, W1
    GdipGetImageWidth lBitmap2, W2
    If (W2 > W1) Or (H2 > H1) Then
        GdipDisposeImage lBitmap1
        GdipDisposeImage lBitmap2
        Exit Function
    End If
    ret = GdipGetImageGraphicsContext(lBitmap1, lGraph)
    ret = GdipCreateImageAttributes(imgAttr)
    With arrCM
        .m(0, 0) = 1
        .m(1, 1) = 1
        .m(2, 2) = 1
        .m(3, 3) = alpha
        .m(4, 4) = 1
    End With
    ret = GdipSetImageAttributesColorMatrix(imgAttr, ColorAdjustTypeBitmap, 1, arrCM, 0&, ColorMatrixFlagsDefault)
    If AlphaColor > -1 Then
        ret = GdipCreateImageAttributes(imgAttr2)
        ret = GdipSetImageAttributesColorKeys(imgAttr2, ColorAdjustTypeBitmap, 1&, ByVal AlphaColor, ByVal AlphaColor)
    End If
    '    ret = GdipSetCompositingQuality(lGraph, ByVal 3&)
    ret = GdipDrawImageRectRectI(lGraph, lBitmap2, x, y, W2, H2, 0, 0, W2, H2, UnitPixel, _
                                 IIf(AlphaColor > -1, imgAttr2, imgAttr), 0, 0)
    GdipCreateHBITMAPFromBitmap lBitmap1, hBmp, 0&
    Set OverlayImages = BitmapToPicture(hBmp)
    GdipDisposeImageAttributes imgAttr
    GdipDisposeImageAttributes imgAttr2
    GdipDisposeImage lBitmap1
    GdipDisposeImage lBitmap2
    GdipDeleteGraphics lGraph
End Function
'Retrieve Width and Height of a pictures in Pixel with GDIP
'Return value as user/defined type TSize (X/Y als Long)
Function GetImageSize(ByVal image As Picture) As TSize
    Dim ret As Long
    Dim lBitmap As Long
    Dim x As Long, y As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If image Is Nothing Then Exit Function
    ret = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
    If ret = 0 Then
        GdipGetImageHeight lBitmap, y
        GdipGetImageWidth lBitmap, x
        GetImageSize.x = CDbl(x)
        GetImageSize.y = CDbl(y)
        GdipDisposeImage lBitmap
    End If
End Function
'Save a bitmap as file (with format converting umwandlung!)
'hBMP = Windows-Handle (hBitmap)
'sFile = complete file path
'PicType = pictypeBMP, pictypeGIF, pictypePNG oder pictypeJPG
'Quality: 0...100; (works only with pictypeJPG!)
'Returns TRUE if successful
Function SaveImage(ByRef image As StdPicture, sFile As String, _
                   PicType As PicFileType, Optional Quality As Byte = 80) As Boolean
    Dim lBitmap As Long
    Dim TEncoder As GUID
    Dim ret As Long
    Dim TParams As EncoderParameters
    Dim sType As String
    If PicType = pictypeICO Then
        MsgBox "不支持 ICO 格式。", vbCritical, "modGDIPLUS/SaveImage"
        Exit Function
    End If
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
        Dim fpx As Long
        ret = GdipGetImagePixelFormat(lBitmap, fpx)
        Debug.Print Hex(fpx)
        Select Case PicType
        Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeTIF: sType = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        End Select
        CLSIDFromString StrPtr(sType), TEncoder
        TParams.count = 0
        Select Case PicType
        Case pictypeJPG
            TParams.count = 1
            With TParams.Parameter    ' Quality
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .uuid
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(CLng(Quality))
            End With
        Case pictypeGIF
            Dim TPalette As ColorPalette
            TParams.count = 1
            TPalette.count = 256
            TPalette.Flags = PaletteFlagsHasAlpha
            ret = GdipInitializePalette(ByVal VarPtr(TPalette), PaletteTypeOptimal, _
                                        256&, 0&, lBitmap)
            If ret = 0 Then
                ret = GdipBitmapConvertFormat(lBitmap, PixelFormat8bppIndexed, _
                                              DitherTypeErrorDiffusion, PaletteTypeOptimal, TPalette, 0)
            End If
        Case pictypeTIF
            TParams.count = 1
            With TParams.Parameter  'Kompression
                CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .uuid
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(2&)     'LZW-Kompression; Andere Werte: RLE=5; CCITT3=3; CCITT4=4
            End With
        End Select
        'Save GDIP-Image to file :
        ret = GdipSaveImageToFile(lBitmap, StrPtr(sFile), TEncoder, TParams)
        GdipDisposeImage lBitmap
        DoEvents
        'Function returns True, if generated file actually exists:
        SaveImage = (Dir(sFile) <> "")
    End If
End Function
'Kontrast und Helligkeit eines Bildes einstellen
'Brightness: Helligkeit von -1 bis +1; 0=unver?ndert
'Contrast:   Kontrast von -1 bis +1; 0 = unver?ndert
Function BrightnessContrast(image As StdPicture, Optional Brightness As Single, Optional contrast As Single) As StdPicture
    Dim lBitmap As Long
    Dim lbitmapRet As Long
    Dim hBitmap As Long
    Dim lGraph As Long
    Dim h As Long, W As Long
    Dim imgAttr As Long
    Dim arrCM As ColorMatrix
    Dim sDiff As Single
    Dim ret As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    ret = GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap)
    GdipGetImageHeight lBitmap, h
    GdipGetImageWidth lBitmap, W
    ret = GdipCreateBitmapFromScan0(CLng(W), CLng(h), 0, &H22009, ByVal 0&, lbitmapRet)
    ret = GdipGetImageGraphicsContext(lbitmapRet, lGraph)
    ret = GdipCreateImageAttributes(imgAttr)
    If Brightness < -1 Then Brightness = -1
    If Brightness > 1 Then Brightness = 1
    If contrast < -1 Then contrast = -1
    If contrast > 1 Then contrast = 1
    sDiff = (Brightness / 2) - (contrast / 2)
    With arrCM
        .m(0, 0) = 1 + contrast: .m(0, 4) = Brightness + sDiff
        .m(1, 1) = 1 + contrast: .m(1, 4) = Brightness + sDiff
        .m(2, 2) = 1 + contrast: .m(2, 4) = Brightness + sDiff
        .m(3, 3) = 1
        .m(4, 4) = 1
    End With
    ret = GdipSetImageAttributesColorMatrix(imgAttr, ColorAdjustTypeBitmap, 1, arrCM, 0&, ColorMatrixFlagsDefault)
    ret = GdipDrawImageRectRectI(lGraph, lBitmap, 0, 0, W, h, 0, 0, W, h, UnitPixel, imgAttr, 0, 0)
    GdipCreateHBITMAPFromBitmap lbitmapRet, hBitmap, 0&
    Set BrightnessContrast = BitmapToPicture(hBitmap)
    GdipDisposeImageAttributes imgAttr
    GdipDisposeImage lBitmap
    GdipDisposeImage lbitmapRet
    GdipDeleteGraphics lGraph
End Function
'Farbs?ttigung einstellen
'Image: Input-Bild
'Saturation: S?ttigungswert von 0...1; 0=schwarz-wei?
Function SetSaturation(image As StdPicture, Saturation As Single) As StdPicture
    Dim lBitmap As Long
    Dim hBitmap As Long
    Dim RCT As RECTL
    Dim BD As BitmapData
    Dim h As Long, W As Long
    Dim x As Long, y As Long
    Dim bytes() As Long
    Dim i As Long, j As Long
    Dim ret As Long
    Dim col1 As Long, r1 As Double, g1 As Double, b1 As Double, sgray As Double
    Dim ii As Long, jj As Long
    Dim lMask As Long

    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
        ret = GdipGetImageWidth(lBitmap, W)
        ret = GdipGetImageHeight(lBitmap, h)
        With RCT
            .Left = 0
            .Top = h
            .Right = W
            .Bottom = 0
        End With
        ReDim bytes(W, h)
        With BD
            .Width = W
            .Height = h
            .PixelFormat = PixelFormat32bppARGB
            .stride = 4 * CLng(.Width + 1)
            .scan0 = VarPtr(bytes(0, 0))
        End With
        ret = GdipBitmapLockBits(lBitmap, RCT, ImageLockModeRead Or ImageLockModeUserInputBuf Or ImageLockModeWrite, PixelFormat32bppARGB, BD)
        lMask = &HFF000000
        For x = 0 To W
            For y = 0 To h
                col1 = bytes(x, y) And Not lMask
                r1 = col1 \ 256 \ 256
                g1 = (col1 \ 256) And &HFF
                b1 = bytes(x, y) And &HFF
                sgray = (b1 + g1 + r1) / 3
                r1 = (sgray * (1 - Saturation) + r1 * Saturation)
                g1 = (sgray * (1 - Saturation) + g1 * Saturation)
                b1 = (sgray * (1 - Saturation) + b1 * Saturation)
                If r1 > 255 Then r1 = 255
                If r1 < 0 Then r1 = 0
                If g1 > 255 Then g1 = 255
                If g1 < 0 Then g1 = 0
                If b1 > 255 Then b1 = 255
                If b1 < 0 Then b1 = 0
                bytes(x, y) = RGB2ARGB(RGB(r1, g1, b1))
            Next y
        Next x
        ret = GdipBitmapUnlockBits(lBitmap, BD)
        ret = GdipCreateHBITMAPFromBitmap(lBitmap, hBitmap, 0)
        Set SetSaturation = BitmapToPicture(hBitmap)
        GdipDisposeImage lBitmap
    End If
    ShutDownGDIP
    Erase bytes()
End Function
'This procedure is similar to the above (see Parameter), the different is,
'that nothing is stored as a file, but a conversion is executed
'using a OLE-Stream-Object to an Byte-Array .
'! This code is novelty, cause no type library is used,
'  the stream is created by the hidden stdole.IUnknown
'  and only OLE-API-Functions are used !
Function ArrayFromPicture(ByVal image As Picture, PicType As PicFileType, Optional Quality As Byte = 80) As Byte()
    Dim lBitmap As Long
    Dim TEncoder As GUID
    Dim ret As Long
    Dim TParams As EncoderParameters
    Dim sType As String
    Dim IStm As stdole.IUnknown
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
    If GdipCreateBitmapFromHBITMAP(image.Handle, 0, lBitmap) = 0 Then
        Select Case PicType    'CLSID des GDIP-Format-Encoders w?hlen:
        Case pictypeBMP: sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeGIF: sType = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypePNG: sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeJPG: sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
        Case pictypeTIF: sType = "{557cf405-1a04-11d3-9a73-0000f81ef32e}"
        End Select
        CLSIDFromString StrPtr(sType), TEncoder
        TParams.count = 0
        Select Case PicType
        Case pictypeJPG     'If JPG, set additional parameter
            'to apply the quality level
            TParams.count = 1
            With TParams.Parameter  ' Quality
                CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .uuid
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(Quality)
            End With
        Case pictypeGIF
            Dim TPalette As ColorPalette
            TParams.count = 1
            TPalette.count = 256
            TPalette.Flags = PaletteFlagsHasAlpha
            ret = GdipInitializePalette(ByVal VarPtr(TPalette), PaletteTypeOptimal, _
                                        256&, 0&, lBitmap)
            If ret = 0 Then
                Call GdipBitmapConvertFormat(lBitmap, PixelFormat8bppIndexed, _
                                             DitherTypeErrorDiffusion, PaletteTypeOptimal, TPalette, 0)
            End If
        Case pictypeTIF
            TParams.count = 1
            With TParams.Parameter
                CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .uuid
                .NumberOfValues = 1
                .type = 4
                .Value = VarPtr(2&)
            End With
        End Select
        ret = CreateStreamOnHGlobal(0&, 1, IStm)    'Create stream
        'Save GDIP-Image to stream :
        ret = GdipSaveImageToStream(lBitmap, IStm, TEncoder, TParams)
        If ret = 0 Then
            Dim hMem As Long, lSize As Long, lpMem As Long
            Dim abData() As Byte
            ret = GetHGlobalFromStream(IStm, hMem)    'Get Memory-Handle from stream
            If ret = 0 Then
                lSize = GlobalSize(hMem)
                lpMem = GlobalLock(hMem)    'Get access to memory
                ReDim abData(lSize - 1)     'Arrays dimension
                'Commit memory stack from streams :
                CopyMemory abData(0), ByVal lpMem, lSize
                GlobalUnlock hMem   'Lock memory
                ArrayFromPicture = abData   'Result
            End If
            Set IStm = Nothing  'Clean
        End If
        GdipDisposeImage lBitmap    'Clear GDIP-Image-Memory
    End If
End Function
'Create an OLE-StdPicture from Byte-Array PicBin()
Public Function ArrayToPicture(ByRef PicBin() As Byte) As Picture
    Dim IStm As stdole.IUnknown
    Dim size As Long
    Dim lBitmap As Long
    Dim hBmp As Long
    Dim ret As Long
    If lGDIP = 0 Then InitGDIP: If lGDIP = 0 Then Exit Function
   
    If UBound(PicBin) > 0 Then
        ret = CreateStreamOnHGlobal(VarPtr(PicBin(0)), 1, IStm)   'Create stream from memory stack
        If ret = 0 Then 'OK, start GDIP :
            'Convert stream to GDIP-Image :
            ret = GdipLoadImageFromStream(IStm, lBitmap)
            If ret = 0 Then
                'Get Windows-Bitmap from GDIP-Image:
                GdipCreateHBITMAPFromBitmap lBitmap, hBmp, 0&
                If hBmp <> 0 Then
                    'Convert bitmap to StdPicture :
                    Set ArrayToPicture = BitmapToPicture(hBmp)
                End If
            End If
            'Clear memory ...
            GdipDisposeImage lBitmap
        End If
    End If
End Function
Private Function CreateEffect(lEffect As eEffects) As Long
    Dim sGUID As String
    Dim data1 As Long
    Dim data2 As Long
    Dim data3 As Long
    Dim data4 As Long
    Select Case lEffect
    Case eEffects.BlurEffect
        sGUID = "633C80A4-1843-482b-9EF2-BE2834C5FDD4"
    Case eEffects.BrightnessContrastEffect
        sGUID = "D3A1DBE1-8EC4-4c17-9F4C-EA97AD1C343D"
    Case eEffects.ColorBalanceEffect
        sGUID = "537E597D-251E-48da-9664-29CA496B70F8"
    Case eEffects.ColorCurveEffect
        sGUID = "DD6A0022-58E4-4a67-9D9B-D48EB881A53D"
    Case eEffects.ColorLUTEffect
        sGUID = "A7CE72A9-0F7F-40d7-B3CC-D0C02D5C3212"
    Case eEffects.ColorMatrixEffect
        sGUID = "718F2615-7933-40e3-A511-5F68FE14DD74"
    Case eEffects.HueSaturationEffect
        sGUID = "8B2DD6C3-EB07-4d87-A5F0-7108E26A9C5F"
    Case eEffects.LevelEffect
        sGUID = "99C354EC-2A31-4f3a-8C34-17A803B33A25"
    Case eEffects.RedEyeCorrectionEffect
        sGUID = "74D29D05-69A4-4266-9549-3CC52836B632"
    Case eEffects.SharpenEffect
        sGUID = "63CBF3EE-C526-402c-8F71-62C540BF5142"
    Case eEffects.TintEffect
        sGUID = "1077AF00-2848-4441-9489-44AD4C2D7A2C"
    Case Else
        Exit Function
    End Select
    sGUID = Replace(sGUID, "-", "")
    data1 = Val("&H" & Left(sGUID, 8))
    data2 = Val("&H" & Mid(sGUID, 9, 8))
    data3 = Val("&H" & Mid(sGUID, 17, 8))
    data4 = Val("&H" & Mid(sGUID, 25, 8))
    Call GdipCreateEffect(data1, data2, data3, data4, CreateEffect)
End Function
Private Function SetSharpenParameters(iEffect As Long, ByVal Radius As Single, ByVal amount As Single) As Long
    Dim ep As SharpenParameters
    ep.Radius = Radius    ' 0 bis 255
    ep.amount = amount    ' 0 bis 100
    SetSharpenParameters = GdipSetEffectParameters(iEffect, ep, Len(ep))
End Function
Private Function SetBlurParameters(iEffect As Long, ByVal Radius As Single) As Long
    Dim ep As BlurParameters
    ep.Radius = Radius    ' 0 bis 255
    ep.ExpandEdges = 1
    SetBlurParameters = GdipSetEffectParameters(iEffect, ep, Len(ep))
End Function
Private Function SetBrightnessContrastParameters(iEffect As Long, _
                                                 ByVal brightnessLevel As Long, contrastLevel As Long) As Long
    Dim ep As BrightnessContrastParameters
    ep.brightnessLevel = brightnessLevel    ' 0 bis 255
    ep.contrastLevel = contrastLevel
    SetBrightnessContrastParameters = GdipSetEffectParameters(iEffect, ep, Len(ep))
End Function
'Retrieve Shell-Icon (as shown in explorer) based on file name
Public Function GetIconPic(sFilename As String) As StdPicture
    Dim lIcon As Long
    lIcon = ExtractAssociatedIcon(0, sFilename, 1)
    If lIcon <> 0 Then Set GetIconPic = BitmapToPicture(lIcon, True)
End Function
'Retrieve screen resolution :
Public Function GetScreenRes() As TSize
    Dim r As rect
    Call GetClientRect(GetDesktopWindow, r)
    GetScreenRes.x = r.Right
    GetScreenRes.y = r.Top
End Function

'Help function to get a OLE-Picture from Windows-Bitmap-Handle
'If bIsIcon = TRUE, an Icon-Handle is commited
Function BitmapToPicture(ByVal hBmp As Long, Optional bIsIcon As Boolean = False) As Picture
    Dim TPicConv As PICTDESC, UID As GUID
    With TPicConv
        If bIsIcon Then
            .cbSizeOfStruct = 16
            .PicType = 3    'PicType Icon
        Else
            .cbSizeOfStruct = Len(TPicConv)
            .PicType = 1    'PicType Bitmap
        End If
        .hImage = hBmp
    End With
    CLSIDFromString StrPtr(GUID_IPicture), UID
    OleCreatePictureIndirect TPicConv, UID, True, BitmapToPicture
End Function

Private Function ColorSetAlpha(ByVal lColor As Long, ByVal alpha As Byte) As Long
    Dim bytestruct As COLORBYTES
    Dim result As COLORLONG
    result.longval = lColor
    LSet bytestruct = result
    bytestruct.AlphaByte = alpha
    LSet result = bytestruct
    ColorSetAlpha = result.longval
End Function
Private Function GetRGBFromGDIP(ByVal lColor As Long) As Long
    Dim argb As COLORBYTES
    CopyMemory argb, lColor, 4
    GetRGBFromGDIP = RGB(argb.RedByte, argb.GreenByte, argb.BlueByte)
End Function
Private Function RGB2ARGB(ByVal lColor As Long) As Long
    Dim rgbq As RGBQUAD
    Dim bytestruct As COLORBYTES
    CopyMemory rgbq, lColor, 4
    With bytestruct
        .AlphaByte = 255
        .BlueByte = rgbq.rgbRed
        .GreenByte = rgbq.rgbGreen
        .RedByte = rgbq.rgbBlue
    End With
    CopyMemory RGB2ARGB, bytestruct, 4
End Function
Public Function UnRGB(lRGB As Long) As T_RGB
    UnRGB.Red = (lRGB And 255)
    UnRGB.Green = (lRGB And 65280) \ 256
    UnRGB.Blue = lRGB \ 65536
End Function
Public Function RGBToHLS(lRGB As Long) As T_HLS
    Dim h As Integer, l As Integer, s As Integer
    Call ColorRGBToHLS(lRGB, h, l, s)
    With RGBToHLS
        .hue = h
        .Luminance = l
        .Saturation = s
    End With
End Function
Public Function HLSToRGB(h As Integer, l As Integer, s As Integer) As Long
    HLSToRGB = ColorHLSToRGB(h, l, s)
End Function
Public Function LightenColor(lRGB As Long, Factor As Double) As Long
    Dim TCol As T_HLS
    TCol = RGBToHLS(lRGB)
    TCol.Luminance = TCol.Luminance * Factor
    If TCol.Luminance > 240 Then TCol.Luminance = 240
    LightenColor = HLSToRGB(TCol.hue, TCol.Luminance, TCol.Saturation)
End Function

'--------------------------------------------------------------------------------------------------
'Hilfsfunktionen
Function GetSpecFolder(id As Long) As String
    Dim oShell As Object, oFld As Object
    On Error Resume Next
    Set oShell = CreateObject("Shell.Application.1")
    Set oFld = oShell.NameSpace(CLng(id))
    GetSpecFolder = oFld.Self.Path
    Set oFld = Nothing
    Set oShell = Nothing
End Function
Function GetFileExt(sFile As String) As String
    GetFileExt = Mid(sFile, InStrRev(sFile, ".") + 1)
End Function
Private Function VerboseGDIPLusError(ErrNo As Long) As String
    Dim sErr As String
    Select Case ErrNo
    Case GpStatus.Aborted: sErr = "Aufruf wurde abgebrochen"
    Case GpStatus.AccessDenied: sErr = "Zugriff auf Datei gesperrt"
    Case GpStatus.FileNotFound: sErr = "Datei nicht gefunden"
    Case GpStatus.FontFamilyNotFound: sErr = "Font-Familie nicht gefunden oder nicht installiert"
    Case GpStatus.FontStyleNotFound: sErr = "Font-Style für die Font-Familie nicht vorhanden"
    Case GpStatus.GdiplusNotInitialized: sErr = "GDIPlLus ist nicht initialisiert"
    Case GpStatus.GenericError: sErr = "Ungültiger Methodenaufruf"
    Case GpStatus.InsufficientBuffer: sErr = "Nicht ausreichend Speicher allozierbar"
    Case GpStatus.InvalidParameter: sErr = "Falscher Parameter"
    Case GpStatus.NotImplemented: sErr = "Unbekannte Methode"
    Case GpStatus.NotTrueTypeFont: sErr = "übergebener Font ist kein TrueType Font"
    Case GpStatus.ObjectBusy: sErr = "Objekt durch anderen Thread gesperrt (Objekt in Bearbeitung)"
    Case GpStatus.OutOfMemory: sErr = "Unzureichender Speicher für Operation"
    Case GpStatus.PropertyNotFound: sErr = "Angesprochene Eigenschaft nicht gefunden"
    Case GpStatus.PropertyNotSupported: sErr = "Nicht unterstützte Eigenschaft angesprochen"
    Case GpStatus.UnknownImageFormat: sErr = "Nicht unterstütztes Bildformat"
    Case GpStatus.UnsupportedGdiplusVersion: sErr = "Inkompatible Version von GDIPlus"
    Case GpStatus.ValueOverflow: sErr = "überlauf bei Operation"
    Case GpStatus.Win32Error: sErr = "Von Win32 weitergereichter Fehler"
    Case GpStatus.WrongState: sErr = "Status des aufgerufenen Objekts verbietet Operation"
    Case Else
        sErr = "Unbekannter Fehler"
    End Select
    VerboseGDIPLusError = sErr
End Function

为加热Access2007开发，特借贵宝地发布一些有关于Access2007开发的辅助模块。

调用方式：
LoadPictureGDIP(sFilename As String)

举例：

'----------------------------------------------------------
'过程 : LoadImages
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 加载功能区时加载控件的图片
'
'       作用于 :
'       <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" loadImage = "LoadImages">
'           加载
'           <button id="btnMessage" label="最新消息" size="large" image="message.png" onAction="onButtonClick" />
'           image 属性所指定的图片
'
'       strImage : image 属性值
'       Image    : StdPicture, 返回值
'----------------------------------------------------------
Public Sub LoadImages(strImage As String, ByRef image)
    '<button id="btnMessage" label="最新消息" size="large" image="message.png" onAction="onButtonClick" />
   
    If strImage <> "" Then
        If LCase(Left(strImage, 4)) = "mso." Then
            image = Mid(strImage, 5)
        Else
            Dim sImgPath As String
            If ImagePath = "" Then ImagePath = CurrentProject.Path & "\Pics"
            sImgPath = ImagePath & "\" & strImage
           
            Set image = LoadPictureGDIP(sImgPath)
        End If
    End If
   
End Sub

'----------------------------------------------------------
'过程 : GetImage
'日期 : 2009.05.02
'作者 : 朱亦文
'目的 : 设置功能区控件的图片
'
'       作用于 :
'       功能区getImage回调
'       <button id="btnMessage" size="large" getImage="Main_GetImage" tag="mso.HappyFace" />
'           其中tag指定控件的默认图片
'       modRibbonPrivate模块
'       Public Sub Main_GetImage(control As IRibbonControl, ByRef image)
'           Call GetImage("Main", control, image)
'       End Sub
'----------------------------------------------------------
Public Sub GetImage(ribbonName As String, control As IRibbonControl, ByRef image)
    On Error GoTo ErrGetImage
   
    Dim sImgName As String  ' 图片文件名或Office图片名称
   
    If Ribbons(ribbonName).Controls(control.id).image = "" Then
        sImgName = control.tag
    Else
        sImgName = Ribbons(ribbonName).Controls(control.id).image
    End If
   
    If sImgName <> "" Then
        If LCase(Left(sImgName, 4)) = "mso." Then
            image = Mid(sImgName, 5)
        Else
            Dim sImgPath As String
            If ImagePath = "" Then ImagePath = CurrentProject.Path & "\Pics"
            sImgPath = ImagePath & "\" & sImgName
           
            Set image = LoadPictureGDIP(sImgPath)
        End If
    End If
   
    On Error GoTo 0
    Exit Sub
ErrGetImage:
    Debug.Print Err.Number, Err.Description
    Resume Next
End Sub