• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Lưu hình trong Picture ra file JPG, GIF, TIF, PNG

Các thủ thuật về âm thanh, đồ họa, truyền thông đa phương tiện...
tindl88
Thành viên tâm huyết
Thành viên tâm huyết
Bài viết: 363
Ngày tham gia: T.Bảy 26/04/2008 6:10 pm
Has thanked: 16 time
Been thanked: 10 time

Lưu hình trong Picture ra file JPG, GIF, TIF, PNG

Gửi bàigửi bởi tindl88 » T.Sáu 07/11/2008 7:05 pm

Thủ thuật: Lưu hình trong Picture ra file JPG, GIF, TIF, PNG
Tác giả: Sưu tầm
Mô tả: Lưu hình trong Picture ra file JPG, GIF, TIF, PNG


Mã: Chọn hết

  1.  
  2. Lưu hình trong Picture ra file JPG (Tùy chọn chất lượng ảnh)
  3. 'Cần 1 PictureBox(Đã load sẵn hình ảnh)
  4. Option Explicit
  5.  
  6. Private Type GUID
  7.    Data1 As Long
  8.    Data2 As Integer
  9.    Data3 As Integer
  10.    Data4(0 To 7) As Byte
  11. End Type
  12.  
  13. Private Type GdiplusStartupInput
  14.    GdiplusVersion As Long
  15.    DebugEventCallback As Long
  16.    SuppressBackgroundThread As Long
  17.    SuppressExternalCodecs As Long
  18. End Type
  19.  
  20. Private Type EncoderParameter
  21.    GUID As GUID
  22.    NumberOfValues As Long
  23.    Type As Long
  24.    Value As Long
  25. End Type
  26.  
  27. Private Type EncoderParameters
  28.    Count As Long
  29.    Parameter As EncoderParameter
  30. End Type
  31.  
  32. Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
  33. Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
  34. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
  35. Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
  36. Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
  37. Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long
  38.  
  39. Public Sub SaveJPG(ByVal pict As StdPicture, ByVal filename As String, Optional ByVal Quality As Byte = 80)
  40.  
  41. Dim tSI As GdiplusStartupInput
  42. Dim lRes As Long
  43. Dim lGDIP As Long
  44. Dim lBitmap As Long
  45.    ' Initialize GDI+
  46.    tSI.GdiplusVersion = 1
  47.    lRes = GdiplusStartup(lGDIP, tSI)
  48.    If lRes = 0 Then
  49.       ' Create the GDI+ bitmap
  50.       ' from the image handle
  51.       lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
  52.       If lRes = 0 Then
  53.          Dim tJpgEncoder As GUID
  54.          Dim tParams As EncoderParameters
  55.          ' Initialize the encoder GUID
  56.          CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
  57.          ' Initialize the encoder parameters
  58.          tParams.Count = 1
  59.          With tParams.Parameter ' Quality
  60.             ' Set the Quality GUID
  61.             CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
  62.             .NumberOfValues = 1
  63.             .Type = 4
  64.             .Value = VarPtr(Quality)
  65.          End With
  66.  
  67.          ' Save the image
  68.          lRes = GdipSaveImageToFile(lBitmap, StrPtr(filename), tJpgEncoder, tParams)
  69.  
  70.          ' Destroy the bitmap
  71.          GdipDisposeImage lBitmap
  72.       End If
  73.       ' Shutdown GDI+
  74.       GdiplusShutdown lGDIP
  75.    End If
  76.    If lRes Then
  77.       Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
  78.    End If
  79. End Sub
  80.  
  81. Private Sub Picture1_DblClick()
  82.     SaveJPG Picture1, "C:\Jpg.jpg", 100
  83. End Sub


'Một thủ thuật nữa, Lưu thêm các định dạng ảnh GIF, TIF, PNG

Mã: Chọn hết

  1. 'Form code:
  2. 'Cần 1 Picture đã load hình sẵn. 1 TextBox ="Test", 1 ComboBox, 1 CommandButton
  3. Option Explicit
  4.  
  5. Private Sub Command1_Click()
  6.     If SavePictureFromHDC(Picture1.Picture, Text1.Text & Combo1.Text) = True Then
  7.         MsgBox Text1.Text & Combo1.Text & " Saved OK!"
  8.     Else
  9.         MsgBox "ERROR! " & Text1.Text & Combo1.Text & " Not Saved!"
  10.     End If
  11. End Sub
  12.  
  13. Private Sub Form_Load()
  14.    
  15.     StartUpGDIPlus GdiPlusVersion
  16.    
  17.     Combo1.AddItem ".GIF"
  18.     Combo1.AddItem ".JPG"
  19.     Combo1.AddItem ".PNG"
  20.     Combo1.AddItem ".TIF"
  21.     Combo1.Text = ".GIF"
  22. End Sub
  23.  
  24. Private Sub Form_Unload(Cancel As Integer)
  25.     ShutdownGDIPlus
  26. End Sub
  27.  
  28. 'Module code:
  29. Option Explicit
  30.  
  31. Private GdipToken       As Long
  32. Private GdipInitialized As Boolean
  33.  
  34. Public Const GdiPlusVersion     As Long = 1
  35. Private Const CP_ACP            As Long = 0
  36.  
  37. Private Type GUID
  38.     Data1 As Long
  39.     Data2 As Integer
  40.     Data3 As Integer
  41.     Data4(0 To 7) As Byte
  42. End Type
  43.  
  44. Private Type ImageCodecInfo
  45.    ClassID As GUID
  46.    FormatID As GUID
  47.    CodecName As Long
  48.    DllName As Long
  49.    FormatDescription As Long
  50.    FilenameExtension As Long
  51.    MimeType As Long
  52.    flags As Long
  53.    Version As Long
  54.    SigCount As Long
  55.    SigSize As Long
  56.    SigPattern As Long
  57.    SigMask As Long
  58. End Type
  59.  
  60. Private Type GDIPlusStartupInput
  61.     GdiPlusVersion As Long
  62.     DebugEventCallback As Long
  63.     SuppressBackgroundThread As Long
  64.     SuppressExternalCodecs As Long
  65. End Type
  66.  
  67. Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
  68. Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long
  69. Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal codepage As Long, ByVal dwFlags As Long, lpWideCharStr As Any, ByVal cchWideChar As Long, lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpDefaultChar As String, ByVal lpUsedDefaultChar As Long) As Long
  70. Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef token As Long, ByRef lpInput As GDIPlusStartupInput, Optional ByRef lpOutput As Any) As Long
  71. Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal token As Long) As Long
  72. Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal Image As Long, ByVal FileName As Long, ByRef clsidEncoder As GUID, ByRef encoderParams As Any) As Long
  73. Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
  74. Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As Long, ByVal hpal As Long, nBitmap As Long) As Long
  75. Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (ByRef numEncoders As Long, ByRef size As Long) As Long
  76. Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal size As Long, ByRef Encoders As Any) As Long
  77.  
  78. Public Function SavePictureFromHDC(ByVal hBitmap As Long, ByVal sFileName As String) As Boolean
  79.     Dim lBitmap As Long
  80.     Dim PicEncoder As GUID
  81.     Dim sID As String
  82.    
  83.     ' Use file name extention to determine,
  84.     ' what format we want to save the file in.
  85.     Select Case LCase$(Right$(sFileName, 4))
  86.         Case ".png"
  87.             sID = "image/png"
  88.         Case ".gif"
  89.             sID = "image/gif"
  90.         Case ".jpg"
  91.             sID = "image/jpeg"
  92.         Case ".tif"
  93.             sID = "image/tiff"
  94.         Case ".bmp"
  95.             sID = "image/bmp"
  96.         Case Else
  97.             Exit Function
  98.     End Select
  99.    
  100.     If GdipCreateBitmapFromHBITMAP(hBitmap, 0&, lBitmap) = 0 Then
  101.         If GetEncoderClsid(sID, PicEncoder) = True Then
  102.             SavePictureFromHDC = (GdipSaveImageToFile(lBitmap, StrPtr(sFileName), PicEncoder, ByVal 0) = 0)
  103.         End If
  104.         GdipDisposeImage lBitmap
  105.     End If
  106. End Function
  107.  
  108. Private Function GetEncoderClsid(strMimeType As String, ClassID As GUID) As Boolean
  109.    
  110.     Dim num As Long
  111.     Dim size As Long
  112.     Dim imgCodecInfo() As ImageCodecInfo
  113.     Dim lval As Long
  114.     Dim buffer() As Byte
  115.  
  116.     GdipGetImageEncodersSize num, size
  117.     If size Then
  118.         ReDim imgCodecInfo(num) As ImageCodecInfo
  119.         ReDim buffer(size) As Byte
  120.  
  121.         GdipGetImageEncoders num, size, buffer(0)
  122.         CopyMemory imgCodecInfo(0), buffer(0), (Len(imgCodecInfo(0)) * num)
  123.  
  124.         For lval = 0 To num - 1
  125.             'image/bmp,image/jpeg,image/gif,image/tiff,image/png
  126.             If StrComp(GetStrFromPtrW(imgCodecInfo(lval).MimeType), strMimeType, vbTextCompare) = 0 Then
  127.                 ClassID = imgCodecInfo(lval).ClassID
  128.                 GetEncoderClsid = True
  129.                 Exit For
  130.             End If
  131.         Next
  132.         Erase imgCodecInfo
  133.         Erase buffer
  134.     End If
  135.    
  136. End Function
  137.  
  138. Private Function GetStrFromPtrW(lpszW As Long) As String
  139.    
  140.     Dim sRV As String
  141.  
  142.     sRV = String$(lstrlenW(ByVal lpszW) * 2, vbNullChar)
  143.     WideCharToMultiByte CP_ACP, 0, ByVal lpszW, -1, ByVal sRV, Len(sRV), 0, 0
  144.     GetStrFromPtrW = Left$(sRV, lstrlenW(StrPtr(sRV)))
  145.    
  146. End Function
  147.  
  148. Public Sub StartUpGDIPlus(ByVal GdipVersion As Long)
  149.    
  150.     Dim GdipStartupInput As GDIPlusStartupInput
  151.    
  152.     GdipStartupInput.GdiPlusVersion = GdipVersion
  153.     GdipInitialized = (GdiplusStartup(GdipToken, GdipStartupInput, ByVal 0&) = 0)
  154.  
  155. End Sub
  156.  
  157. Public Sub ShutdownGDIPlus()
  158.    
  159.     If GdipInitialized Then
  160.         GdiplusShutdown GdipToken
  161.     End If
  162.    
  163. End Sub
  164.  
Sửa lần cuối bởi tindl88 vào ngày T.Hai 10/11/2008 10:12 am với 1 lần sửa.


cứng nhắc...vớ vẩn

Hình đại diện của người dùng
DQHung
Guru
Guru
Bài viết: 576
Ngày tham gia: T.Hai 12/02/2007 3:24 pm
Đến từ: Rach Gia - Kien Giang
Been thanked: 40 time
Liên hệ:

Re: Lưu hình trong Picture ra file JPG

Gửi bàigửi bởi DQHung » T.Bảy 08/11/2008 10:52 am

sửa lại cái CLSID là có thể lưu ra tùm lum định dạng luôn :),trừ icon là ko đc.Nhưng cái này ko dùng trên Win9x được nên nếu có cho vào Vblib thì nên để rõ.

Lysander
Bài viết: 2
Ngày tham gia: CN 23/09/2012 7:02 pm

Re: Lưu hình trong Picture ra file JPG, GIF, TIF, PNG

Gửi bàigửi bởi Lysander » CN 23/09/2012 7:26 pm

Em nghĩ cái này mình dùng Office copy từ Clipboard rồi lưu cũng được nhưng hơi bị dở.

Hình đại diện của người dùng
NTN
Thành viên tâm huyết
Thành viên tâm huyết
Bài viết: 472
Ngày tham gia: T.Tư 05/02/2014 3:43 pm
Đến từ: Cao Lãnh, Đồng Tháp,Việt Nam
Has thanked: 19 time
Been thanked: 7 time
Liên hệ:

Re: Lưu hình trong Picture ra file JPG, GIF, TIF, PNG

Gửi bàigửi bởi NTN » T.Bảy 08/02/2014 8:17 am

Cái nài sử dụng không được


Quay về “[VB] Âm thanh và Đồ họa”

Đang trực tuyến

Đang xem chuyên mục này: Không có thành viên nào trực tuyến.1 khách