imagegdi.bas

电话本信息 基本上实现电话功能 自己下载侃侃吧

Attribute VB_Name = "ImageGDI"
Option Explicit

Private Type GdiplusStartupInput
   GdiplusVersion As Long
   DebugEventCallback As Long
   SuppressBackgroundThread As Long
   SuppressExternalCodecs As Long
End Type

Private Enum GpStatus   'Status
   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 Declare Function GdiplusStartup Lib "gdiplus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As GpStatus
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As GpStatus
Private Declare Function GdipDrawImage Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Single, ByVal y As Single) As GpStatus
Private Declare Function GdipDrawImageRect Lib "gdiplus" (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 GpStatus
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hdc As Long, graphics As Long) As GpStatus
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As GpStatus
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal fileName As String, Image As Long) As GpStatus
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As GpStatus
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As Long, Width As Long) As GpStatus
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As Long, Height As Long) As GpStatus
Private Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal Image As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As GpStatus

Private GDIP_Image As Long, GDIP_Token As Long, ImageFileName As String

Public Function LoadImage(ByVal ImagePath As String, Optional ByVal DelFile As Boolean = True) As Boolean
    Dim GpInput As GdiplusStartupInput, GDIP_Token As Long
    On Error Resume Next
    GpInput.GdiplusVersion = 1
    LoadImage = GdiplusStartup(GDIP_Token, GpInput) = 0
    If LoadImage Then
        '载入图片到内存中
        ImageFileName = IIf(DelFile, ImagePath, vbNullString)
        GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), GDIP_Image
    End If
End Function

Public Sub DisposeImage()
  On Error Resume Next
  GdipDisposeImage GDIP_Image
  GdiplusShutdown GDIP_Token
  GDIP_Token = 0: GDIP_Image = 0
  If Len(ImageFileName) Then Kill ImageFileName
End Sub

Public Sub GetImageWH(w As Long, h As Long)
    '获取图片原宽度和高度
    GdipGetImageWidth GDIP_Image, w
    GdipGetImageHeight GDIP_Image, h
End Sub

'-------------缩略图函数-----------
Public Function ShowImage(ByVal hdc As Long, ByVal WMax As Long, ByVal HMax As Long, _
    Optional ByVal Top As Long = 0, Optional ByVal Left As Long = 0, _
    Optional ByRef ZoomP As Single = 0, Optional ByVal LSMode As Boolean = True) As Boolean
       
    'WMax为最大宽度，HMax为最大高度，这段代码会根据最大宽度和高度调整图片大小。
    Dim w As Long, h As Long
    Dim gdip_Graphics As Long
    
    On Error Resume Next
    
    ShowImage = False
    
    If GdipCreateFromHDC(hdc, gdip_Graphics) Then
      DisposeImage
      Exit Function
    End If
    
    GetImageWH w, h
    
    If ZoomP <> 0 Then
        w = w * ZoomP
        h = h * ZoomP
    End If
    
    '智能调整图片大小和留空处理，根据最长边调整位置
    If (w > WMax) Or (h > HMax) Then
        If w > h Then
            ZoomP = CSng(WMax) / CSng(w)
            h = ZoomP * h
            w = WMax
            Top = (HMax - h) / 2 + Top
        Else
            ZoomP = CSng(HMax) / CSng(h)
            w = w * ZoomP
            h = HMax
            Left = (WMax - w) / 2 + Left
        End If
    ElseIf LSMode Then
        If w > h Then
            ZoomP = CSng(WMax) / CSng(w)
            h = ZoomP * h
            w = WMax
            Top = (HMax - h) / 2 + Top
        Else
            ZoomP = CSng(HMax) / CSng(h)
            w = w * ZoomP
            h = HMax
            Left = (WMax - w) / 2 + Left
        End If
    Else
        Top = (HMax - h) / 2 + Top
        Left = (WMax - w) / 2 + Left
    End If
  

    '使用GDI+直接从内存中缩略并绘图，GDI+有很好的抗锯齿能力
    ShowImage = GdipDrawImageRect(gdip_Graphics, GDIP_Image, Left, Top, w, h) = 0
    GdipDeleteGraphics gdip_Graphics
    ShowImage = True
End Function