gdiplusloadimg.bas

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

Attribute VB_Name = "GDIPlusLoadImg"


Public Type ImageInfo
  Height As Long
  Width As Long
  FilePath As String
  ImageName As String
  Type As String
  FileSize As Long   'KB
End Type

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

Dim gdip_Token As Long
Dim gdip_Image As Long
Dim gdip_Graphics As Long

'-------------缩略图函数-----------
Public Function ShowTNImg(hDC As Long, ImagePath As String, WMax As Long, HMax As Long) As ImageInfo
'WMax为最大宽度，HMax为最大高度，这段代码会根据最大宽度和高度调整图片大小。

Dim Wid As Long, Hgt As Long, Top As Long, Left As Long

LoadGDIP

If GdipCreateFromHDC(hDC, gdip_Graphics) <> 0 Then
    MsgBox "出现错误！", vbCritical, "错误"
    GdiplusShutdown gdip_Token
    End
End If

'载入图片到内存中
GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image

'获取图片长和宽
GdipGetImageWidth gdip_Image, Wid
GdipGetImageHeight gdip_Image, Hgt

With ShowTNImg
  .Width = Wid
  .Height = Hgt
  .FilePath = ImagePath
  .FileSize = FileLen(ImagePath) / 1024
  .ImageName = Right(ImagePath, Len(ImagePath) - InStrRev(ImagePath, "\"))
  .Type = Right(ImagePath, Len(ImagePath) - InStrRev(ImagePath, "."))
End With


'智能调整图片大小和留空处理，根据最长边调整
If (Wid > WMax) Or (Hgt > HMax) Then
  If Wid > Hgt Then
    Hgt = Hgt / Wid * WMax
    Wid = WMax
    Top = (HMax - Hgt) / 2
  Else
    Wid = Wid / Hgt * HMax
    Hgt = HMax
    Left = (WMax - Wid) / 2
  End If
Else
  Top = (HMax - Hgt) / 2
  Left = (WMax - Wid) / 2
End If
  

'使用GDI+直接从内存中缩略并绘图，GDI+有很好的抗锯齿能力
If GdipDrawImageRect(gdip_Graphics, gdip_Image, Left, Top, Wid, Hgt) <> Ok Then Debug.Print "显示失败。。。"

DisposeGDIP

End Function


'加载显示完整图片
Public Sub ShowFullImg(PBox As PictureBox, ImagePath As String)

LoadGDIP

If GdipCreateFromHDC(PBox.hDC, gdip_Graphics) <> Ok Then
    MsgBox "出现错误！", vbCritical, "错误"
    GdiplusShutdown gdip_Token
    End
End If

GdipLoadImageFromFile StrConv(ImagePath, vbUnicode), gdip_Image

If GdipDrawImage(gdip_Graphics, gdip_Image, 0, 0) <> Ok Then Debug.Print "显示失败。。。"

DisposeGDIP

End Sub


Public Sub LoadGDIP()
Dim GpInput As GdiplusStartupInput
GpInput.GdiplusVersion = 1

If GdiplusStartup(gdip_Token, GpInput) <> 0 Then
    MsgBox "加载GDI+失败！", vbCritical, "加载错误"
    End
End If
End Sub

Public Sub DisposeGDIP()
  GdipDisposeImage gdip_Image
  GdipDeleteGraphics gdip_Graphics
  GdiplusShutdown gdip_Token
End Sub

'--------------------------- THE END ----------------------------------
'----------------------------------------------------------------------