[VB자료]PNG 출력,GDI 묘둘

Option Explicit Private Type GUID Data1 As Long Data2 As Integer Data3 As Integer Data4(7) As Byte End Type Private Type PICTDESC size As Long Type As Long hBmp As Long hPal As Long Reserved As Long End Type Private Type GdiplusStartupInput GdiplusVersion As Long DebugEventCallback As Long SuppressBackgroundThread As Long SuppressExternalCodecs As Long End Type Private Type PWMFRect16 Left As Integer Top As Integer Right As Integer Bottom As Integer End Type Private Type wmfPlaceableFileHeader Key As Long hMf As Integer BoundingBox As PWMFRect16 Inch As Integer Reserved As Long CheckSum As Integer End Type ' GDI Functions Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long 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 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 Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long ' GDI+ functions Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal FileName As Long, GpImage As Long) As Long Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (Token As Long, gdipInput As GdiplusStartupInput, GdiplusStartupOutput As Long) As Long Private Declare Function GdipCreateFromHDC Lib "GdiPlus.dll" (ByVal hdc As Long, GpGraphics As Long) As Long Private Declare Function GdipSetInterpolationMode Lib "GdiPlus.dll" (ByVal Graphics As Long, ByVal InterMode As Long) As Long Private Declare Function GdipDrawImageRectI Lib "GdiPlus.dll" (ByVal Graphics As Long, ByVal Img As Long, ByVal X As Long, ByVal Y As Long, ByVal Width As Long, ByVal Height As Long) As Long Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal Graphics As Long) As Long Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal Image As Long) As Long Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBmp As Long, ByVal hPal As Long, GpBitmap As Long) As Long Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal Image As Long, Width As Long) As Long Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal Image As Long, Height As Long) As Long Private Declare Function GdipCreateMetafileFromWmf Lib "GdiPlus.dll" (ByVal hWmf As Long, ByVal deleteWmf As Long, WmfHeader As wmfPlaceableFileHeader, Metafile As Long) As Long Private Declare Function GdipCreateMetafileFromEmf Lib "GdiPlus.dll" (ByVal hEmf As Long, ByVal deleteEmf As Long, Metafile As Long) As Long Private Declare Function GdipCreateBitmapFromHICON Lib "GdiPlus.dll" (ByVal hIcon As Long, GpBitmap As Long) As Long Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal Graphics As Long, ByVal GpImage 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 Long, ByVal imageAttributes As Long, ByVal callback As Long, ByVal callbackData As Long) As Long Private Declare Sub GdiplusShutdown Lib "GdiPlus.dll" (ByVal Token As Long) ' GDI and GDI+ constants Private Const PLANES = 14 ' Number of planes Private Const BITSPIXEL = 12 ' Number of bits per pixel Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern Private Const PICTYPE_BITMAP = 1 ' Bitmap type Private Const InterpolationModeHighQualityBicubic = 7 Private Const GDIP_WMF_PLACEABLEKEY = &H9AC6CDD7 Private Const UnitPixel = 2 ' Initialises GDI Plus Public Function InitGDIPlus() As Long Dim Token As Long Dim gdipInit As GdiplusStartupInput gdipInit.GdiplusVersion = 1 GdiplusStartup Token, gdipInit, ByVal 0& InitGDIPlus = Token End Function ' Frees GDI Plus Public Sub FreeGDIPlus(Token As Long) GdiplusShutdown Token End Sub ' Loads the picture (optionally resized) Public Function LoadPictureGDIPlus(PicFile As String, Optional Width As Long = -1, Optional Height As Long = -1, Optional ByVal BackColor As Long = vbWhite, Optional RetainRatio As Boolean = False) As IPicture Dim hdc As Long Dim hBitmap As Long Dim Img As Long ' Load the image If GdipLoadImageFromFile(StrPtr(PicFile), Img) <> 0 Then Err.Raise 999, "GDI+ Module", "Error loading picture " & PicFile Exit Function End If ' Calculate picture's width and height if not specified If Width = -1 Or Height = -1 Then GdipGetImageWidth Img, Width GdipGetImageHeight Img, Height End If ' Initialise the hDC InitDC hdc, hBitmap, BackColor, Width, Height ' Resize the picture gdipResize Img, hdc, Width, Height, RetainRatio GdipDisposeImage Img ' Get the bitmap back GetBitmap hdc, hBitmap ' Create the picture Set LoadPictureGDIPlus = CreatePicture(hBitmap) End Function ' Initialises the hDC to draw Private Sub InitDC(hdc As Long, hBitmap As Long, BackColor As Long, Width As Long, Height As Long) Dim hBrush As Long ' Create a memory DC and select a bitmap into it, fill it in with the backcolor hdc = CreateCompatibleDC(ByVal 0&) hBitmap = CreateBitmap(Width, Height, GetDeviceCaps(hdc, PLANES), GetDeviceCaps(hdc, BITSPIXEL), ByVal 0&) hBitmap = SelectObject(hdc, hBitmap) hBrush = CreateSolidBrush(BackColor) hBrush = SelectObject(hdc, hBrush) PatBlt hdc, 0, 0, Width, Height, PATCOPY DeleteObject SelectObject(hdc, hBrush) End Sub ' Resize the picture using GDI plus Private Sub gdipResize(Img As Long, hdc As Long, Width As Long, Height As Long, Optional RetainRatio As Boolean = False) Dim Graphics As Long ' Graphics Object Pointer Dim OrWidth As Long ' Original Image Width Dim OrHeight As Long ' Original Image Height Dim OrRatio As Double ' Original Image Ratio Dim DesRatio As Double ' Destination rect Ratio Dim DestX As Long ' Destination image X Dim DestY As Long ' Destination image Y Dim DestWidth As Long ' Destination image Width Dim DestHeight As Long ' Destination image Height GdipCreateFromHDC hdc, Graphics GdipSetInterpolationMode Graphics, InterpolationModeHighQualityBicubic If RetainRatio Then GdipGetImageWidth Img, OrWidth GdipGetImageHeight Img, OrHeight OrRatio = OrWidth ⁄ OrHeight DesRatio = Width ⁄ Height ' Calculate destination coordinates DestWidth = IIf(DesRatio < OrRatio, Width, Height * OrRatio) DestHeight = IIf(DesRatio < OrRatio, Width ⁄ OrRatio, Height) DestX = (Width - DestWidth) ⁄ 2 DestY = (Height - DestHeight) ⁄ 2 GdipDrawImageRectRectI Graphics, Img, DestX, DestY, DestWidth, DestHeight, 0, 0, OrWidth, OrHeight, UnitPixel, 0, 0, 0 Else GdipDrawImageRectI Graphics, Img, 0, 0, Width, Height End If GdipDeleteGraphics Graphics End Sub ' Replaces the old bitmap of the hDC, Returns the bitmap and Deletes the hDC Private Sub GetBitmap(hdc As Long, hBitmap As Long) hBitmap = SelectObject(hdc, hBitmap) DeleteDC hdc End Sub ' Creates a Picture Object from a handle to a bitmap Private Function CreatePicture(hBitmap As Long) As IPicture Dim IID_IDispatch As GUID Dim Pic As PICTDESC Dim IPic As IPicture ' Fill in OLE IDispatch Interface ID IID_IDispatch.Data1 = &H20400 IID_IDispatch.Data4(0) = &HC0 IID_IDispatch.Data4(7) = &H46 ' Fill Pic with necessary parts Pic.size = Len(Pic) ' Length of structure Pic.Type = PICTYPE_BITMAP ' Type of Picture (bitmap) Pic.hBmp = hBitmap ' Handle to bitmap ' Create the picture OleCreatePictureIndirect Pic, IID_IDispatch, True, IPic Set CreatePicture = IPic End Function ' Returns a resized version of the picture Public Function Resize(Handle As Long, PicType As PictureTypeConstants, Width As Long, Height As Long, Optional BackColor As Long = vbWhite, Optional RetainRatio As Boolean = False) As IPicture Dim Img As Long Dim hdc As Long Dim hBitmap As Long Dim WmfHeader As wmfPlaceableFileHeader ' Determine pictyre type Select Case PicType Case vbPicTypeBitmap GdipCreateBitmapFromHBITMAP Handle, ByVal 0&, Img Case vbPicTypeMetafile FillInWmfHeader WmfHeader, Width, Height GdipCreateMetafileFromWmf Handle, False, WmfHeader, Img Case vbPicTypeEMetafile GdipCreateMetafileFromEmf Handle, False, Img Case vbPicTypeIcon ' Does not return a valid Image object GdipCreateBitmapFromHICON Handle, Img End Select ' Continue with resizing only if we have a valid image object If Img Then InitDC hdc, hBitmap, BackColor, Width, Height gdipResize Img, hdc, Width, Height, RetainRatio GdipDisposeImage Img GetBitmap hdc, hBitmap Set Resize = CreatePicture(hBitmap) End If End Function ' Fills in the wmfPlacable header Private Sub FillInWmfHeader(WmfHeader As wmfPlaceableFileHeader, Width As Long, Height As Long) WmfHeader.BoundingBox.Right = Width WmfHeader.BoundingBox.Bottom = Height WmfHeader.Inch = 1440 WmfHeader.Key = GDIP_WMF_PLACEABLEKEY End Sub 'Load Png (Bubbelbilden) to Image Control Sub PngImageLoad(PathFilename As String, ImageControl As Image) Dim Token As Long Token = InitGDIPlus ImageControl = LoadPictureGDIPlus(PathFilename, ImageControl.Width ⁄ Screen.TwipsPerPixelX, ImageControl.Height ⁄ Screen.TwipsPerPixelY) FreeGDIPlus Token End Sub 'Load Png (Bubbelbilden) to Picture Control Sub PngPictureLoad(PathFilename As String, PictureControl As PictureBox, AutoResize As Boolean) Dim Token As Long Token = InitGDIPlus If AutoResize = False Then PictureControl = LoadPictureGDIPlus(PathFilename) Else PictureControl = LoadPictureGDIPlus(PathFilename, PictureControl.ScaleWidth ⁄ Screen.TwipsPerPixelX, PictureControl.ScaleHeight ⁄ Screen.TwipsPerPixelY) End If FreeGDIPlus Token End Sub