[Chia sẻ mã nguồn]Excel lưu dải ô hoặc biểu tượng ImageMsol dưới dạng hình ảnh(Hỗ trợ lưu thành 13 định dạng tệp khác nhau:WMF,EMF,ICO,PNG,TGA,PDF...)

Joforn · 2/12/20

Định dạng tệp mà mô-đun này hỗ trợ:

Định dạng ảnh BMP: tệp bitmap 32-bit, không hỗ trợ độ trong suốt;
Định dạng ảnh PNG: tạo ảnh nén 32-bit không mất dữ liệu với các kênh trong suốt;
Định dạng hình ảnh ICO: Tạo biểu tượng trong suốt Windows XP (Lưu ý: Biểu mẫu VBA có thể không được sử dụng trực tiếp, không được VBA hỗ trợ). Cần lưu ý rằng nếu không sử dụng ICO_SizeOrTIFF_COMPRESSION khi gọi hàm, biểu tượng tương ứng với kích thước được chỉ định, khi đó biểu tượng được tạo và Khu vực phạm vi có cùng kích thước. Điều này có nghĩa là biểu tượng được tạo không phải là biểu tượng hình vuông phổ biến như 32 × 32 hoặc 256 × 256;
Định dạng ảnh TGA: Tạo ảnh TGA 32 bit với nén không mất dữ liệu lwz kênh trong suốt. Vì ảnh TGA có thể được OpenGL gọi trực tiếp là họa tiết 3D, chúng thường phổ biến trong các tài liệu trò chơi cũ cách đây hơn mười năm, nhưng cần lưu ý rằng nếu bạn sử dụng nó PS sẽ bỏ qua kênh trong suốt (bao gồm cả hình ảnh TGA trong suốt do PS tạo ra) khi PS mở tệp TGA, nhưng phần mềm khác vẫn bình thường;
Định dạng ảnh JPG / JPEG: định dạng ảnh nén mất dữ liệu phổ biến nhất, không hỗ trợ độ trong suốt;
Định dạng hình ảnh TIFF: không hỗ trợ độ trong suốt
Định dạng ảnh GIF: Định dạng ảnh GIF với nền trong suốt không được hỗ trợ (Lưu ý: Bản thân định dạng GIF hỗ trợ độ trong suốt, nhưng tôi lười và không tự tạo tệp GIF nhị phân, vì vậy tệp GIF được lưu bởi mô-đun này không hỗ trợ độ trong suốt của nền);
Định dạng ảnh SVG: Đồ họa vector, bạn có thể sử dụng các trình duyệt web chính thống để mở và xem trực tiếp một số loại ảnh.
Định dạng hình ảnh WMF: biểu đồ vector；
Định dạng ảnh EMF: biểu đồ vectơ；
Định dạng tệp PDF；
Định dạng tệp XPS: Nên sử dụng XPS Viewer để xem (Win10 đi kèm với nó, nhưng nó cần được thêm thủ công vào thành phần)
Định dạng tệp ZIP: Mục này chỉ để giúp chúng tôi đóng gói các tệp được tạo ở trên thành một tệp. Gọi trực tiếp Shell32 để tạo mà không cần hỗ trợ DLL của bên thứ ba.

Đây là mã kiểm tra :

Mã:

Sub TestSaveRangeToPictrue()
  Dim PathName As String
  Dim FileNames() As String
  Dim FileName As String
  Dim I As Long
     
  PathName = ThisWorkbook.Path & Application.PathSeparator
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a Directory to Save Pictures:"
    .InitialFileName = PathName
    .Show
    If .SelectedItems.Count Then
      PathName = .SelectedItems(1)
    Else
      MsgBox "You choose to Cancel,The program well stop."
      Exit Sub
    End If
  End With
     
  Debug.Print "=============== Test Start ===================="
  PathName = ThisWorkbook.Path & Application.PathSeparator
 
  FileNames = Split("WMF,EMF,PDF,XPS", ",")
  For I = 0 To UBound(FileNames)
    FileName = PathName & "SaveRangeTo" & FileNames(I) & "(Vector)." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "Success", "Failure") & "]: Save" & FileNames(I) & "File""" & FileName & """"
    FileName = PathName & "Pictures.ZIP>Vector\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "success", "failure") & "]: add " & FileNames(I) & " file to ""Pictures. ZIP"""
  Next
 
  FileNames = Split("BMP,PNG,ICO,JPG,TIF,TGA,SVG,GIF", ",")
  For I = 0 To UBound(FileNames)
    FileName = PathName & "SaveRangeTo" & FileNames(I) & "(NoAlpha)." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "Success", "Failure") & "]: Save" & FileNames(I) & "File""" & FileName & """"
    FileName = PathName & "Pictures.ZIP>NoAlpha\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName), "success", "failure") & "]: add " & FileNames(I) & " pictures to ""Pictures. ZIP"""
  Next
 
  FileNames = Split("PNG,ICO,TGA,SVG", ",")
  For I = 0 To UBound(FileNames)
    FileName = PathName & "SaveRangeTo" & FileNames(I) & "(AlphaBackColor)." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "Success", "Failure") & "]: Save" & FileNames(I) & "File"" " & FileName & """"
    FileName = PathName & "Pictures.ZIP>Alpha\AlphaBackColor\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1), "Success", "Failure") & "]: Add ""SaveRangeTo" & FileNames(I) & "." & FileNames(I) & """into ""Pictures.ZIP"""
    FileName = PathName & "SaveRangeTo" & FileNames(I) & "(AlphaHalfForBackColor)." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "Success", "Failure") & "]: Save" & FileNames(I) & "File """ & FileName & """"
    FileName = PathName & "Pictures.ZIP>Alpha\AlphaHalfForBackColor\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -1, 128), "Success", "Failure") & "]: Add ""SaveRangeTo" & FileNames(I) & "." & FileNames(I) & """into ""Pictures.ZIP"""
    FileName = PathName & "SaveRangeTo" & FileNames(I) & "(AlphaHalfForAll)." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "Success", "Failure") & "]: Save" & FileNames(I) & "File """ & FileName & """"
    FileName = PathName & "Pictures.ZIP>Alpha\AlphaHalfForAll\SaveRangeTo" & FileNames(I) & "." & FileNames(I)
    Debug.Print "[" & IIf(SaveRangeToPictrue(Range("L1:R21"), FileName, -2, 128), "Success", "Failure") & "]: Add ""SaveRangeTo" & FileNames(I) & "." & FileNames(I) & """into ""Pictures.ZIP"""
  Next
  Debug.Print "===============　Test End　===================="
End Sub

Sub TestSaveImageMso()
  Dim PathName As String
  Dim FileNames() As String
  Dim FileName As String
  Dim I As Long
 
  PathName = ThisWorkbook.Path & Application.PathSeparator
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Please select a Directory to Save Pictures:"
    .InitialFileName = PathName
    .Show
    If .SelectedItems.Count Then
      PathName = .SelectedItems(1)
    Else
      MsgBox "You choose to Cancel,The program well stop."
      Exit Sub
    End If
  End With
 
  PathName = ThisWorkbook.Path & Application.PathSeparator
  FileNames = Split("About,AccessRecycleBin,BlogHomePage,ClearGrid,Folder", ",")
  For I = 0 To UBound(FileNames)
    FileName = PathName & FileNames(I)
    With CommandBars.GetImageMso(FileNames(I), 32, 32)
      Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".PNG", &HFFFFFF), "Success", "Failure") & "]: Save """ & FileNames(I) & """ icon To file """ & FileName & ".PNG"; "File"
      Debug.Print "[" & IIf(SaveBitmapToFile(.Handle, FileName & ".ICO", &HFFFFFF, , 32), "Success", "Failure") & "]: Save """ & FileNames(I) & " ""Icon to File""" & FileName & ".ICO"; "File"
    End With
  Next
End Sub

giới thiệu thử nghiệm :mô-đun này đã vượt qua hoàn hảo các bài kiểm tra của XP + Office2007, Win7 + Office2010 (64-bit), Win7 + Office2007 (32-bit), Win10 + Office2019 (64-bit)

Hướng dẫn sử dụng:
Nếu chỉ cần sử dụng các chức năng bên trong, bạn có thể xuất trực tiếp mô-đun basSaveRangeToPictrue sang các tệp khác, sau đó gọi hàm SaveRangeToPictrue theo cách gọi của mã kiểm tra trên, Ngoài ra còn có hai hàm là SaveClipboardToPictrue và SaveBitmapToFile và bạn cũng có thể sử dụng riêng Tham khảo định dạng và hướng dẫn trong mã gốc để gọi kết hợp với tình huống của riêng bạn. Ví dụ, nếu bạn muốn xuất biểu tượng Ribbon trong Excel sang ICO hoặc PNG, bạn có thể xuất trực tiếp ra tệp đĩa miễn là bạn tham khảo phương pháp sử dụng SaveBitmapToFile (mã kiểm tra trên cũng chứa Bản giới thiệu).

Mã nguồn chương trình：

Mã:

basSaveRangeToPictrue.bas

Joforn · 2/12/20

Đoạn mã đầu tiên:

Mã:

Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>>   Author:     Joforn                            <<<<<<<<<<<<<<<<<<
'>>>>>>>>   Email:      Joforn1@163.com                   <<<<<<<<<<<<<<<<<<
'>>>>>>>>   Facebook:   Joforn1@163.com                   <<<<<<<<<<<<<<<<<<
'>>>>>>>>   QQ:         42978116                          <<<<<<<<<<<<<<<<<<
'>>>>>>>>   Last time : 12/01/2020                        <<<<<<<<<<<<<<<<<<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<

#If VBA7 Then
  Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
  Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As ClipboardDataFormats) As Long
  Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As ClipboardDataFormats) As LongPtr
  Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As ClipboardDataFormats, ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As ClipboardDataFormats) As Boolean
  Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
  Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
  Private Declare PtrSafe Function GetObjectType Lib "gdi32.dll" (ByVal hgdiObj As LongPtr) As Long
  Private Declare PtrSafe Function IsBadReadPtr Lib "Kernel32.dll" (ByVal lngPtr As LongPtr, ByVal ucb As Long) As Long
  Private Declare PtrSafe Function GetLastError Lib "Kernel32.dll" () As Long

  Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
  Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal Flags As Long, ByVal Size As Long) As LongPtr
  Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As LongPtr, ByVal hpvSource As LongPtr, ByVal cbCopy As Long)
  Private Declare PtrSafe Function lstrlenA Lib "Kernel32.dll" (ByVal lpString As LongPtr) As Long
  Private Declare PtrSafe Function lstrlenW Lib "Kernel32.dll" (ByVal lpString As LongPtr) As Long
  
  Private Declare PtrSafe Function GdiplusStartup Lib "GdiPlus.dll" (ByRef mToken As Long, ByRef mInput As GDIPlusStartupInput, ByRef mOutput As GdiplusStartupOutput) As GpStatus
  Private Declare PtrSafe Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
  Private Declare PtrSafe Function GdipGetImageEncodersSize Lib "gdiplus" (ByRef numEncoders As Long, ByRef Size As Long) As Long
  Private Declare PtrSafe Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
  
  Private Declare PtrSafe Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As LongPtr, ByRef mImage As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mHeight As Long) As GpStatus
  Private Declare PtrSafe Function GdipGetImagePixelFormat Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mFormat As Long) As GpStatus
  Private Declare PtrSafe Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mWidth As Long) As GpStatus
  
  Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBitmap As LongPtr, ByVal mhPal As LongPtr, ByRef GpBitmap As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipSaveImageToFile Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByVal mFilename As LongPtr, ByRef mClsidEncoder As Any, ByVal mEncoderParams As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal mImage As LongPtr) As Long
  Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "GdiPlus.dll" (ByVal mWidth As Long, ByVal mHeight As Long, ByVal mStride As Long, ByVal mPixelFormat As GpPixelFormat, ByVal mScan0 As LongPtr, ByRef mBitmap As LongPtr) As GpStatus
'  Private Declare PtrSafe Function GdipGetImagePixelFormat Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mFormat As GpPixelFormat) As GpStatus
  Private Declare PtrSafe Function GdipBitmapLockBits Lib "GdiPlus.dll" (ByVal mBitmap As LongPtr, ByRef mRect As RECTL, ByVal mFlags As ImageLockMode, ByVal mPixelFormat As GpPixelFormat, ByRef mLockedBitmapData As BitmapData) As GpStatus
  Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "GdiPlus.dll" (ByVal mBitmap As LongPtr, ByRef mLockedBitmapData As BitmapData) As GpStatus
  
  Private Declare PtrSafe Function GdipCloneImage Lib "GdiPlus.dll" (ByVal hImage As LongPtr, ByRef cloneImage As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipCreateImageAttributes Lib "GdiPlus.dll" (ByRef mImageAttr As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipDisposeImageAttributes Lib "GdiPlus.dll" (ByVal mImageAttr As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mImage As LongPtr, _
          ByVal mDstx As Long, ByVal mDsty As Long, ByVal mDstwidth As Long, ByVal mDstheight As Long, _
          ByVal mSrcx As Long, ByVal mSrcy As Long, ByVal mSrcwidth As Long, ByVal mSrcheight As Long, _
          Optional ByVal mSrcUnit As GpUnit = 2, Optional ByVal mImageAttributes As LongPtr, Optional ByVal mcallback As LongPtr, Optional ByVal mcallbackData As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "GdiPlus.dll" (ByVal mImage As LongPtr, ByRef mGraphics As LongPtr) As GpStatus
  Private Declare PtrSafe Function GdipGraphicsClear Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mColor As Long) As GpStatus
  Private Declare PtrSafe Function GdipSetImageAttributesColorKeys Lib "GdiPlus.dll" (ByVal mImageAttr As LongPtr, ByVal mType As ColorAdjustType, ByVal mEnableFlag As Boolean, ByVal mColorLow As Long, ByVal mColorHigh As Long) As GpStatus
  Private Declare PtrSafe Function GdipBitmapConvertFormat Lib "GdiPlus.dll" ( _
           ByVal pInputBitmap As LongPtr, _
           ByVal Format As GpPixelFormat, _
           ByVal DitherType As GpDitherType, _
           ByVal PaletteType As PaletteType, _
           ByVal Palette As LongPtr, _
           ByVal AlphaThresholdPercent As Single _
        ) As GpStatus

  Private Declare PtrSafe Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByRef lColorRef As Long) As Long
  
  Private Declare PtrSafe Function GetObject Lib "gdi32.dll" Alias "GetObjectW" (ByVal hObject As LongPtr, ByVal nCount As Long, ByVal lpObject As LongPtr) As Long
'  Private Declare PtrSafe Function GetBitmapBits Lib "gdi32.dll" (ByVal hBitmap As LongPtr, ByVal dwCount As Long, lpBits As Any) As Long
'  Private Declare PtrSafe Function SetBitmapBits Lib "gdi32" (ByVal hBITMAP As LongPtr, ByVal dwCount As Long, lpBits As Any) As Long

  Private Declare PtrSafe Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long

  Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
  Private Declare PtrSafe Function CopyImage Lib "user32.dll" (ByVal hBitmap As LongPtr, _
                          Optional ByVal uTyPe As EnumImageType = 0, _
                          Optional ByVal cXDesired As Long = 0, Optional ByVal cYDesired As Long = 0, _
                          Optional ByVal uFlags As ImageCopyFlags = 4) As LongPtr
  Private Declare PtrSafe Function GetEnhMetaFileBits Lib "gdi32.dll" (ByVal hEMF As LongPtr, ByVal nSize As Long, ByVal lpBuffer As LongPtr) As Long
  Private Declare PtrSafe Function GetMetaFileBitsEx Lib "gdi32.dll" (ByVal hMF As LongPtr, ByVal nSize As Long, ByVal lpvData As LongPtr) As Long
  Private Declare PtrSafe Function CopyMetaFile Lib "gdi32.dll" Alias "CopyMetaFileW" (ByVal hMF As LongPtr, ByVal lpFileName As LongPtr) As Long
  Private Declare PtrSafe Function CopyEnhMetaFile Lib "gdi32.dll" Alias "CopyEnhMetaFileW" (ByVal hemfSrc As LongPtr, ByVal lpszFile As LongPtr) As LongPtr
  Private Declare PtrSafe Function CloseMetaFile Lib "gdi32.dll" (ByVal hMF As LongPtr) As Long
  Private Declare PtrSafe Function DeleteMetaFile Lib "gdi32.dll" (ByVal hMF As LongPtr) As Long
  Private Declare PtrSafe Function DeleteEnhMetaFile Lib "gdi32.dll" (ByVal hEMF As LongPtr) As Long
  
  Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long
  Private Declare PtrSafe Function GetTempPath Lib "Kernel32.dll" Alias "GetTempPathW" (ByVal nBufferLength As Long, ByVal lpBuffer As LongPtr) As Long
  Private Declare PtrSafe Function GetTempFileName Lib "Kernel32.dll" Alias "GetTempFileNameW" (ByVal lpszPath As LongPtr, ByVal lpPrefixString As LongPtr, ByVal wUnique As Long, ByVal lpTempFileName As LongPtr) As Long
  Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr
  Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr)
  Private Declare PtrSafe Sub PathUnquoteSpacesW Lib "shlwapi.dll" (ByVal lpsz As LongPtr)
  Private Declare PtrSafe Function PathAddBackslashW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr
  Private Declare PtrSafe Function PathRemoveExtensionW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathRemoveFileSpecW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathStripPathW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As LongPtr) As LongPtr
  Private Declare PtrSafe Function PathRenameExtensionW Lib "shlwapi.dll" (ByVal pszPathas As LongPtr, ByVal pszExt As LongPtr) As Long
  Private Declare PtrSafe Function PathIsRootW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathIsDirectoryEmptyW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Boolean
  Private Declare PtrSafe Function PathFileExistsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function PathIsDirectoryW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As Long
  Private Declare PtrSafe Function DeleteFile Lib "Kernel32.dll" Alias "DeleteFileW" (ByVal lpFileName As LongPtr) As Long
  Private Declare PtrSafe Function SetFileAttributes Lib "Kernel32.dll" Alias "SetFileAttributesW" (ByVal lpFileName As LongPtr, ByVal dwFileAttributes As Long) As Long
  
  Private Declare PtrSafe Function CryptBinaryToStringW Lib "crypt32.dll" (ByRef pbBinary As Any, ByVal cbBinary As Long, _
          ByVal dwFlags As Long, ByVal pszString As LongPtr, ByRef pcchString As Long) As Long
  Private Declare PtrSafe Function CryptStringToBinaryW Lib "crypt32.dll" (ByVal pszString As LongPtr, ByVal cchString As Long, _
          ByVal dwFlags As Long, ByRef pbBinary As Any, ByRef pcbBinary As Long, Optional ByRef pdwSkip As Long, Optional ByRef pdwFlags As Long) As Long
  Private Declare PtrSafe Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, _
          ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long) As Long
  Private Declare PtrSafe Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, _
          ByVal lpWideCharStr As LongPtr, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
          Optional ByVal lpDefaultChar As LongPtr = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
  
  Private Declare PtrSafe Sub Sleep Lib "Kernel32.dll" (ByVal dwMilliseconds As Long)
#Else

Joforn · 2/12/20

Đoạn mã 2：

Mã:

  Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
  Private Declare Function CloseClipboard Lib "user32" () As Long
  Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As ClipboardDataFormats) As Long
  Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As ClipboardDataFormats) As Long
  Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As ClipboardDataFormats, ByVal hMem As Long) As Long
  Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As ClipboardDataFormats) As Boolean
  Private Declare Function CountClipboardFormats Lib "user32" () As Long
  Private Declare Function EmptyClipboard Lib "user32" () As Long
  Private Declare Function GetObjectType Lib "gdi32.dll" (ByVal hgdiObj As Long) As Long
  Private Declare Function IsBadReadPtr Lib "Kernel32.dll" (ByVal lngPtr As Long, ByVal ucb As Long) As Long
  Private Declare Function GetLastError Lib "Kernel32.dll" () As Long

  Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Private Declare Function GlobalAlloc Lib "kernel32" (ByVal Flags As Long, ByVal Size As Long) As Long
  Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByVal hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
  Private Declare Function lstrlenA Lib "Kernel32.dll" (ByVal lpString As Long) As Long
  Private Declare Function lstrlenW Lib "Kernel32.dll" (ByVal lpString As Long) As Long
  
  Private Declare Function GdiplusStartup Lib "GdiPlus.dll" (ByRef mToken As Long, ByRef mInput As GDIPlusStartupInput, ByRef mOutput As GdiplusStartupOutput) As GpStatus
  Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)
  Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (ByRef numEncoders As Long, ByRef Size As Long) As Long
  Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
  
  Private Declare Function GdipLoadImageFromFile Lib "GdiPlus.dll" (ByVal mFilename As Long, ByRef mImage As Long) As GpStatus
  Private Declare Function GdipGetImageHeight Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mHeight As Long) As GpStatus
  Private Declare Function GdipGetImagePixelFormat Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mFormat As Long) As GpStatus
  Private Declare Function GdipGetImageWidth Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mWidth As Long) As GpStatus
  
  Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GdiPlus.dll" (ByVal hBitmap As Long, ByVal mhPal As Long, ByRef GpBitmap As Long) As GpStatus
  Private Declare Function GdipSaveImageToFile Lib "GdiPlus.dll" (ByVal mImage As Long, ByVal mFilename As Long, ByRef mClsidEncoder As Any, ByVal mEncoderParams As Long) As GpStatus
  Private Declare Function GdipDisposeImage Lib "GdiPlus.dll" (ByVal mImage As Long) As Long
  Private Declare Function GdipCreateBitmapFromScan0 Lib "GdiPlus.dll" (ByVal mWidth As Long, ByVal mHeight As Long, ByVal mStride As Long, ByVal mPixelFormat As GpPixelFormat, ByVal mScan0 As Long, ByRef mBitmap As Long) As GpStatus
'  Private Declare Function GdipGetImagePixelFormat Lib "GdiPlus.dll" (ByVal mImage As  Long, ByRef mFormat As GpPixelFormat) As GpStatus
  Private Declare Function GdipBitmapLockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mRect As RECTL, ByVal mFlags As ImageLockMode, ByVal mPixelFormat As GpPixelFormat, ByRef mLockedBitmapData As BitmapData) As GpStatus
  Private Declare Function GdipBitmapUnlockBits Lib "GdiPlus.dll" (ByVal mBitmap As Long, ByRef mLockedBitmapData As BitmapData) As GpStatus
  
  Private Declare Function GdipCloneImage Lib "GdiPlus.dll" (ByVal hImage As Long, ByRef cloneImage As Long) As GpStatus
  Private Declare Function GdipCreateImageAttributes Lib "GdiPlus.dll" (ByRef mImageAttr As Long) As GpStatus
  Private Declare Function GdipDeleteGraphics Lib "GdiPlus.dll" (ByVal mGraphics As Long) As GpStatus
  Private Declare Function GdipDisposeImageAttributes Lib "GdiPlus.dll" (ByVal mImageAttr As Long) As GpStatus
  Private Declare Function GdipDrawImageRectRectI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mImage As Long, _
          ByVal mDstx As Long, ByVal mDsty As Long, ByVal mDstwidth As Long, ByVal mDstheight As Long, _
          ByVal mSrcx As Long, ByVal mSrcy As Long, ByVal mSrcwidth As Long, ByVal mSrcheight As Long, _
          Optional ByVal mSrcUnit As GpUnit = 2, Optional ByVal mImageAttributes As Long, Optional ByVal mcallback As Long, Optional ByVal mcallbackData As Long) As GpStatus
  Private Declare Function GdipGetImageGraphicsContext Lib "GdiPlus.dll" (ByVal mImage As Long, ByRef mGraphics As Long) As GpStatus
  Private Declare Function GdipGraphicsClear Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mColor As Long) As GpStatus
  Private Declare Function GdipSetImageAttributesColorKeys Lib "GdiPlus.dll" (ByVal mImageAttr As Long, ByVal mType As ColorAdjustType, ByVal mEnableFlag As Boolean, ByVal mColorLow As Long, ByVal mColorHigh As Long) As GpStatus
  Private Declare Function GdipBitmapConvertFormat Lib "GdiPlus.dll" ( _
           ByVal pInputBitmap As Long, _
           ByVal Format As GpPixelFormat, _
           ByVal DitherType As GpDitherType, _
           ByVal PaletteType As PaletteType, _
           ByVal Palette As Long, _
           ByVal AlphaThresholdPercent As Single _
        ) As GpStatus

  Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, ByRef lColorRef As Long) As Long
  
  Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectW" (ByVal hObject As Long, ByVal nCount As Long, ByVal lpObject As Long) As Long
'  Private Declare Function GetBitmapBits Lib "gdi32.dll" (ByVal hBitmap As  Long, ByVal dwCount As Long, lpBits As Any) As Long
'  Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBITMAP As  Long, ByVal dwCount As Long, lpBits As Any) As Long

  Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long

  Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
  Private Declare Function CopyImage Lib "user32.dll" (ByVal hBitmap As Long, _
                          Optional ByVal uTyPe As EnumImageType = 0, _
                          Optional ByVal cXDesired As Long = 0, Optional ByVal cYDesired As Long = 0, _
                          Optional ByVal uFlags As ImageCopyFlags = 4) As Long
  Private Declare Function GetEnhMetaFileBits Lib "gdi32.dll" (ByVal hEMF As Long, ByVal nSize As Long, ByVal lpBuffer As Long) As Long
  Private Declare Function GetMetaFileBitsEx Lib "gdi32.dll" (ByVal hMF As Long, ByVal nSize As Long, ByVal lpvData As Long) As Long
  Private Declare Function CopyMetaFile Lib "gdi32.dll" Alias "CopyMetaFileW" (ByVal hMF As Long, ByVal lpFileName As Long) As Long
  Private Declare Function CopyEnhMetaFile Lib "gdi32.dll" Alias "CopyEnhMetaFileW" (ByVal hemfSrc As Long, ByVal lpszFile As Long) As Long
  Private Declare Function CloseMetaFile Lib "gdi32.dll" (ByVal hMF As Long) As Long
  Private Declare Function DeleteMetaFile Lib "gdi32.dll" (ByVal hMF As Long) As Long
  Private Declare Function DeleteEnhMetaFile Lib "gdi32.dll" (ByVal hEMF As Long) As Long
  
  Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Long
  Private Declare Function GetTempPath Lib "Kernel32.dll" Alias "GetTempPathW" (ByVal nBufferLength As Long, ByVal lpBuffer As Long) As Long
  Private Declare Function GetTempFileName Lib "Kernel32.dll" Alias "GetTempFileNameW" (ByVal lpszPath As Long, ByVal lpPrefixString As Long, ByVal wUnique As Long, ByVal lpTempFileName As Long) As Long
  Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long)
  Private Declare Sub PathUnquoteSpacesW Lib "shlwapi.dll" (ByVal lpsz As Long)
  Private Declare Function PathAddBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathRemoveBackslashW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathRemoveExtensionW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathRemoveFileSpecW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathStripPathW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathFindExtension Lib "shlwapi.dll" Alias "PathFindExtensionW" (ByVal pszPath As Long) As Long
  Private Declare Function PathRenameExtensionW Lib "shlwapi.dll" (ByVal pszPathas As Long, ByVal pszExt As Long) As Long
  Private Declare Function PathIsRootW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathIsDirectoryEmptyW Lib "shlwapi.dll" (ByVal pszPath As Long) As Boolean
  Private Declare Function PathFileExistsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function PathIsDirectoryW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long
  Private Declare Function DeleteFile Lib "Kernel32.dll" Alias "DeleteFileW" (ByVal lpFileName As Long) As Long
  Private Declare Function SetFileAttributes Lib "Kernel32.dll" Alias "SetFileAttributesW" (ByVal lpFileName As Long, ByVal dwFileAttributes As Long) As Long
  
  Private Declare Function CryptBinaryToStringW Lib "crypt32.dll" (ByRef pbBinary As Any, ByVal cbBinary As Long, _
          ByVal dwFlags As Long, ByVal pszString As Long, ByRef pcchString As Long) As Long
  Private Declare Function CryptStringToBinaryW Lib "crypt32.dll" (ByVal pszString As Long, ByVal cchString As Long, _
          ByVal dwFlags As Long, ByRef pbBinary As Any, ByRef pcbBinary As Long, Optional ByRef pdwSkip As Long, Optional ByRef pdwFlags As Long) As Long
  Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, _
          ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
  Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, _
          ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByRef lpMultiByteStr As Any, ByVal cchMultiByte As Long, _
          Optional ByVal lpDefaultChar As Long = 0, Optional ByVal lpUsedDefaultChar As Long = 0) As Long
  
  Private Declare Sub Sleep Lib "Kernel32.dll" (ByVal dwMilliseconds As Long)
#End If

Joforn · 2/12/20

Đoạn mã 3

Mã:

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\      结构定义开始        /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'
Private Type RECTL
    Left      As Long
    Top       As Long
    Width     As Long
    Height    As Long
End Type

Private Type ColorPalette
    Flags     As PaletteFlags
    Count     As Long
    Entries(0 To 255) As Long
End Type

Private Type DataArray
    Format    As ClipboardDataFormats
    Type      As Long
    Size      As Long
    bData()   As Byte
End Type

Private Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End Type

Private Type ARGB
    rgbBlue         As Byte
    rgbGreen        As Byte
    rgbRed          As Byte
    rgbAlpha        As Byte
End Type

Private Type BITMAPINFO_1BPP
    bmiHeader         As BITMAPINFOHEADER
    bmiColors(0 To 1) As ARGB
End Type

#If VBA7 Then
  Private Type METAFILEPICT
    mm    As Long
    xExt  As Long
    yExt  As Long
    hMF   As LongPtr
  End Type

  Private Type GDIPlusStartupInput
    GdiPlusVersion            As Long
    DebugEventCallback        As LongPtr
    SuppressBackgroundThread  As Boolean
    SuppressExternalCodecs    As Boolean
  End Type

  Private Type GdiplusStartupOutput
    NotificationHook          As LongPtr
    NotificationUnhook        As LongPtr
  End Type
  
  Private Type ImageCodecInfo
    ClassID(0 To 3)     As Long
    FormatID(0 To 3)    As Long
    CodecName           As LongPtr
    DllName             As LongPtr
    FormatDescription   As LongPtr
    FilenameExtension   As LongPtr
    MimeType            As LongPtr
    Flags               As Long
    Version             As Long
    SigCount            As Long
    SigSize             As Long
    SigPattern          As LongPtr
    SigMask             As Long
  End Type
  
  Private Type BITMAP
    bmType        As Long
    bmWidth       As Long
    bmHeight      As Long
    bmWidthBytes  As Long
    bmPlanes      As Integer
    bmBitsPixel   As Integer
    bmBits        As LongPtr
  End Type
  
  Private Type BitmapData
    Width               As Long
    Height              As Long
    Stride              As Long
    PixelFormat         As Long
    Scan0Ptr            As LongPtr
    ReservedPtr         As LongPtr
  End Type
#Else
  Private Type METAFILEPICT
    mm    As Long
    xExt  As Long
    yExt  As Long
    hMF   As Long
  End Type

  Private Type GDIPlusStartupInput
    GdiPlusVersion            As Long
    DebugEventCallback        As Long
    SuppressBackgroundThread  As Boolean
    SuppressExternalCodecs    As Boolean
  End Type

  Private Type GdiplusStartupOutput
    NotificationHook          As Long
    NotificationUnhook        As Long
  End Type
  
  Private Type ImageCodecInfo
    ClassID(0 To 3)     As Long
    FormatID(0 To 3)    As Long
    CodecName           As Long
    DllName             As Long
    FormatDescription   As Long
    FilenameExtension   As Long
    MimeType            As Long
    Flags               As Long
    Version             As Long
    SigCount            As Long
    SigSize             As Long
    SigPattern          As Long
    SigMask             As Long
  End Type
  
  Private Type BITMAP
    bmType        As Long
    bmWidth       As Long
    bmHeight      As Long
    bmWidthBytes  As Long
    bmPlanes      As Integer
    bmBitsPixel   As Integer
    bmBits        As Long
  End Type
  
  Private Type BitmapData
    Width               As Long
    Height              As Long
    Stride              As Long
    PixelFormat         As Long
    Scan0Ptr            As Long
    ReservedPtr         As Long
  End Type
#End If

'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'>\\\\\\\\\\\\\\\\\\\\\\\        结构定义结束       ////////////////////////<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Dim nFormats As Long
Dim ClipboardData() As DataArray

Joforn · 2/12/20

Đoạn mã 4

Mã:

Private 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
    ProfileNotFound = 21
End Enum

Public Enum ClipboardDataFormats
    CF_Text = 1
    CF_Bitmap = 2
    CF_METAFILEPICT = 3
    CF_SymbolicLink = 4
    CF_Dif = 5
    CF_Tiff = 6
    CF_OemText = 7
    CF_Dib = 8
    CF_Palette = 9
    CF_PenData = 10
    CF_Riff = 11
    CF_WaveAudio = 12
    CF_UnicodeText = 13
    CF_EnhancedMetafile = 14
    CF_FileDrop = 15
    CF_Locale = 16
    CF_DibV5 = 17
    CF_RTF = 49330
    CF_HTML = 49414
    CF_Xaml = 49786
    CF_StringFormat = 49804
    CF_CommaSeparatedValue = 50030
    CF_XamlPackage = 50245
    CF_Serializable = 50258
End Enum

Public Enum EnumImageType
    IMAGE_BITMAP = 0&
    IMAGE_ICON
    IMAGE_CURSOR
    IMAGE_ENHMETAFILE
End Enum

Public Enum ImageCopyFlags
    LR_MONOCHROME = &H1
    LR_COPYRETURNORG = &H4
    LR_COPYDELETEORG = &H8
    LR_COPYFROMRESOURCE = &H4000
End Enum

Private Const GMEM_ZEROINIT As Long = &H40

Private Enum GpPixelFormat
    PixelFormat1bppIndexed = &H30101
    PixelFormat4bppIndexed = &H30402
    PixelFormat8bppIndexed = &H30803
    PixelFormat16bppGreyScale = &H101004
    PixelFormat16bppRGB555 = &H21005
    PixelFormat16bppRGB565 = &H21006
    PixelFormat16bppARGB1555 = &H61007
    PixelFormat24bppRGB = &H21808
    PixelFormat32bppRGB = &H22009
    PixelFormat32bppARGB = &H26200A
    PixelFormat32bppPARGB = &HE200B
    PixelFormat48bppRGB = &H10300C
    PixelFormat64bppARGB = &H34400D
    PixelFormat64bppPARGB = &H1C400E
End Enum

Public Enum TIFCOMPRESSION
    COMPRESSION_NONE = 1
    COMPRESSION_CCITTRLE = 2
    COMPRESSION_CCITTFAX3 = 4
    COMPRESSION_CCITT_T4 = 3
    COMPRESSION_CCITTFAX4 = 4
    COMPRESSION_CCITT_T6 = 4
    COMPRESSION_LZW = 5
    COMPRESSION_OJPEG = 6
    COMPRESSION_JPEG = 7
    COMPRESSION_ADOBE_DEFLATE = 8
    COMPRESSION_NEXT = 32766
    COMPRESSION_CCITTRLEW = 32771
    COMPRESSION_PACKBITS = 32773
    COMPRESSION_THUNDERSCAN = 32809
    COMPRESSION_IT8CTPAD = 32895
    COMPRESSION_IT8LW = 32896
    COMPRESSION_IT8MP = 32897
    COMPRESSION_IT8BL = 32898
    COMPRESSION_PIXARFILM = 32908
    COMPRESSION_PIXARLOG = 32909
    COMPRESSION_DEFLATE = 32946
    COMPRESSION_DCS = 32947
    COMPRESSION_JBIG = 34661
    COMPRESSION_SGILOG = 34676
    COMPRESSION_SGILOG24 = 34677
    COMPRESSION_JP2000 = 34712
End Enum

Private Enum ImageLockMode
    ImageLockModeRead = &H1
    ImageLockModeWrite = &H2
    ImageLockModeUserInputBuf = &H4
End Enum

Private Enum ColorAdjustType
    ColorAdjustTypeDefault = &H0
    ColorAdjustTypeBitmap = &H1
    ColorAdjustTypeBrush = &H2
    ColorAdjustTypePen = &H3
    ColorAdjustTypeText = &H4
    ColorAdjustTypeCount = &H5
    ColorAdjustTypeAny = &H6
End Enum

Private Enum GpUnit
    UnitWorld = &H0
    UnitDisplay = &H1
    UnitPixel = &H2
    UnitPoint = &H3
    UnitInch = &H4
    UnitDocument = &H5
    UnitMillimeter = &H6
End Enum

Private Enum GpDitherType
    DitherTypeNone = 0
    DitherTypeSolid = 1
    DitherTypeOrdered4x4 = 2
    DitherTypeOrdered8x8 = 3
    DitherTypeOrdered16x16 = 4
    DitherTypeSpiral4x4 = 5
    DitherTypeSpiral8x8 = 6
    DitherTypeDualSpiral4x4 = 7
    DitherTypeDualSpiral8x8 = 8
    DitherTypeErrorDiffusion = 9
    DitherTypeMax = 10
End Enum

Private Enum PaletteType
    PaletteTypeCustom = 0
    PaletteTypeOptimal = 1
    PaletteTypeFixedBW = 2
    PaletteTypeFixedHalftone8 = 3
    PaletteTypeFixedHalftone27 = 4
    PaletteTypeFixedHalftone64 = 5
    PaletteTypeFixedHalftone125 = 6
    PaletteTypeFixedHalftone216 = 7
    PaletteTypeFixedHalftone252 = 8
    PaletteTypeFixedHalftone256 = 9
End Enum

Private Enum PaletteFlags
    PaletteFlagsHasAlpha = &H1
    PaletteFlagsGrayScale = &H2
    PaletteFlagsHalftone = &H4
End Enum

Private Enum TransformFlags
    None = 0
    ReverseLine = 1
    AlphaColors = 2
    AlphaAll = 4
    AlphaMode = AlphaColors Or AlphaAll
End Enum

Private Enum PictureSizeMode
  Clip = 0      '
  Stretch = 1   '
  Zoom = 3      '
End Enum

Public Enum CRYPT_STRING_TYPE
  CRYPT_STRING_BASE64 = 1
  CRYPT_STRING_HEX = 4
End Enum

Joforn · 2/12/20

Đoạn mã 5

Mã:

        Optional ByVal AlphaColorOrJPEGQuality As Variant, _
        Optional ByVal AlphaDepthOrColorDepth As Long, _
        Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION, _
        Optional ByVal SaveClipboardFlag As Boolean = False) As Boolean

  Dim FileName1     As String
  Dim FileName2     As String
  Dim TargetPath    As Object
  Dim I             As Long
  Dim CenterHorizontally As Boolean, CenterVertically As Boolean
  
  On Error Resume Next
        
  If Target Is Nothing Then Exit Property
  If Target.Areas.Count > 1 Then Exit Property
  If Target.Cells.Count < 1 Then Exit Property
  
    
  FileName2 = PathRemoveArgs(PathGetArgs(FileName, 1))
  FileName1 = PathRemoveArgs(FileName)
  Select Case LCase$(GetFileExtension(PathRemoveArgs(FileName1)))
    Case ".pdf"
      I = 1
    Case ".xps"
      I = 2
    Case ".zip"
    
      I = CreateZipFile(FileName1, FileName2, TargetPath)
      If I <> 0 Then
        If I > 1 Then
          SaveRangeToPictrue = SaveRangeToPictrue(Target, FileName2, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION, SaveClipboardFlag)
          If SaveRangeToPictrue Then
            I = TargetPath.Items.Count
            MoveFileToFolder TargetPath, FileName2
          ElseIf I And 2& Then
            KillFile FileName2
          End If
          
          FileName2 = ExtractPathDirctory(FileName2)
          RmDir FileName2
        End If
      End If
      Exit Property
    Case Else
      I = 0
      If SaveClipboardFlag Then SaveClipboard
      
      Target.Copy
      SaveRangeToPictrue = SaveClipboardToPictrue(FileName, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION)
      Application.CutCopyMode = False
      
      If SaveClipboardFlag Then RestoreClipboard
      Exit Property
  End Select
  
  On Error GoTo SaveRangeToPictrueError
  If I > 0 And I <= 2 Then
    I = I - 1
    With Target.Worksheet
      With .PageSetup
        FileName = .PrintArea
        .PrintArea = Target.Address
        CenterHorizontally = .CenterHorizontally
        CenterVertically = .CenterVertically
        .CenterHorizontally = True
        .CenterVertically = True
      End With
      .ExportAsFixedFormat Type:=I, FileName:=FileName1, OpenAfterPublish:=False, IgnorePrintAreas:=False
      With .PageSetup
        .PrintArea = FileName
        .CenterHorizontally = CenterHorizontally
        .CenterVertically = CenterVertically
      End With
      SaveRangeToPictrue = FileLen(FileName1)
    End With
  End If
SaveRangeToPictrueError:
End Property

Public Property Get SaveClipboardToPictrue(ByVal FileName As String, _
       Optional ByVal AlphaColorOrJPEGQuality As Variant, _
       Optional ByVal AlphaDepthOrColorDepth As Long, _
       Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION) As Boolean
       
  #If VBA7 Then
    Dim hBitmap   As LongPtr
    Dim ptrVar    As LongPtr
  #Else
    Dim hBitmap   As Long
    Dim ptrVar    As Long
  #End If
 
  Dim MetaFile    As METAFILEPICT
  
  Dim lngRet        As Long
  Dim bytFile() As Byte, hFile  As Long
  Dim strFileExt    As String
  Dim FileName2     As String
  
  On Error Resume Next
  
  FileName2 = PathRemoveArgs(PathGetArgs(FileName, 1))
  FileName = PathRemoveArgs(FileName)
  strFileExt = LCase$(GetFileExtension(FileName))
  Select Case strFileExt
    Case ".emf"
      
      If Not (KillFile(FileName)) Then Exit Property
      If IsClipboardFormatAvailable(CF_EnhancedMetafile) Then
        If OpenClipboard(0) Then
          hBitmap = GetClipboardData(CF_EnhancedMetafile)
          lngRet = GetEnhMetaFileBits(hBitmap, 0, 0)
          If (lngRet > 0) Then
            ReDim bytFile(0 To lngRet - 1)
            GetEnhMetaFileBits hBitmap, lngRet, VarPtr(bytFile(0))
            hFile = FreeFile
            Open FileName For Binary As hFile
            Put hFile, , bytFile
            Close hFile
            SaveClipboardToPictrue = PathFileExistsW(StrPtr(FileName))
          End If
          CloseClipboard
        End If
      End If
    Case ".wmf"
      
      If Not (KillFile(FileName)) Then Exit Property
      If IsClipboardFormatAvailable(CF_METAFILEPICT) Then
        If OpenClipboard(0) Then
          hBitmap = GetClipboardData(CF_METAFILEPICT)
          ptrVar = GlobalLock(hBitmap)
          CopyMemory VarPtr(MetaFile), ptrVar, LenB(MetaFile)
          lngRet = GetMetaFileBitsEx(MetaFile.hMF, 0, 0)
          If (lngRet > 0) Then
            ReDim bytFile(0 To lngRet - 1)
            GetMetaFileBitsEx MetaFile.hMF, lngRet, VarPtr(bytFile(0))
            hFile = FreeFile
            Open FileName For Binary As hFile
            Put hFile, , bytFile
            Close hFile
            SaveClipboardToPictrue = PathFileExistsW(StrPtr(FileName))
          End If
          GlobalUnlock hBitmap
          CloseClipboard
        End If
      End If
    Case Else
      If OpenClipboard(0) Then
        hBitmap = GetClipboardData(CF_Bitmap)
        CloseClipboard
        SaveClipboardToPictrue = SaveBitmapToFile(hBitmap, FileName & vbNullChar & FileName2, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION)
      End If
  End Select
End Property

Joforn · 2/12/20

Đoạn mã 6

Mã:

Private Property Get SaveBitmapToFile2(ByRef lngBitmap() As Long, ByVal FileName As String, _
    Optional ByVal AlphaColorOrJPEGQuality As Variant, _
    Optional ByVal AlphaDepthOrColorDepth As Long, _
    Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION = COMPRESSION_OJPEG) As Boolean
    
  #If VBA7 Then
    Dim hBitmap   As LongPtr
    Dim hImage    As LongPtr
    Dim ptrVar    As LongPtr
  #Else
    Dim hBitmap   As Long
    Dim hImage    As Long
    Dim ptrVar    As Long
  #End If
  
  Dim gdiToken    As Long
  Dim MetaFile    As METAFILEPICT
  
  Dim lngRet        As Long
  Dim lngColor      As Long
  Dim TargetPath    As Object
  Dim FileItem      As Object
  
  Dim vBitmap       As BITMAP
  Dim CLSID(0 To 3) As Long
  Dim EncoderParameter(0 To 16) As Long
  Dim bytFile() As Byte, hFile  As Long
  Dim BitmapBits()  As Long
  Dim strFileExt    As String
  Dim FileName2     As String
  Dim strTemp       As String
  
  On Error Resume Next
  
  If UBound(lngBitmap()) - LBound(lngBitmap()) < 1 Then Exit Property
  CopyMemory VarPtr(hBitmap), VarPtr(lngBitmap(0)), LenB(hBitmap)
  
  FileName2 = PathRemoveArgs(PathGetArgs(FileName, 1))
  FileName = PathRemoveArgs(FileName)
  strFileExt = LCase$(GetFileExtension(FileName))
  
  Select Case strFileExt
    Case ".jpg", ".jpeg"
      Select Case VarType(AlphaColorOrJPEGQuality)
        Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
          lngColor = AlphaColorOrJPEGQuality
          If lngColor < 1 Then
            lngColor = 100
          ElseIf lngColor > 100 Then
            lngColor = 100
          End If
        Case Else
          lngColor = 100
      End Select
      
      gdiToken = StartUpGDIPlus
      If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hImage) = Ok Then
        If GetEncoderClsID("Image/jpeg", CLSID) Then
          EncoderParameter(0) = 1
          ptrVar = VarPtr(lngColor)
          EncoderParameter(1) = &H1D5BE4B5: EncoderParameter(2) = &H452DFA4A: EncoderParameter(3) = &HB35DDD9C: EncoderParameter(4) = &HEBE70551
          EncoderParameter(5) = &H1&: EncoderParameter(6) = &H4&
          CopyMemory VarPtr(EncoderParameter(7)), VarPtr(ptrVar), Len(ptrVar)
          SaveBitmapToFile2 = GdipSaveImageToFile(hImage, StrPtr(FileName), CLSID(0), VarPtr(EncoderParameter(0))) = Ok
        End If
        GdipDisposeImage hImage
      End If
      GdiplusShutdown gdiToken
      
    Case ".tif", ".tiff"
      gdiToken = StartUpGDIPlus
      If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hImage) = Ok Then
        If GetEncoderClsID("Image/tiff", CLSID) Then
          Select Case AlphaDepthOrColorDepth
            Case 1, 4, 8, 24, 32:
            Case Else:  AlphaDepthOrColorDepth = 24
          End Select
          Select Case ICO_SizeOrTIFF_COMPRESSION
            Case TIFCOMPRESSION.COMPRESSION_NONE To TIFCOMPRESSION.COMPRESSION_ADOBE_DEFLATE
            Case COMPRESSION_NEXT, COMPRESSION_CCITTRLEW, COMPRESSION_PACKBITS, COMPRESSION_THUNDERSCAN
            Case COMPRESSION_IT8CTPAD, COMPRESSION_IT8LW, COMPRESSION_IT8MP, COMPRESSION_IT8BL, COMPRESSION_PIXARFILM, COMPRESSION_PIXARLOG
            Case COMPRESSION_DEFLATE, COMPRESSION_DCS, COMPRESSION_JBIG, COMPRESSION_SGILOG, COMPRESSION_SGILOG24, COMPRESSION_JP2000
            Case Else
              ICO_SizeOrTIFF_COMPRESSION = 6
          End Select
          EncoderParameter(0) = 2
          ptrVar = VarPtr(ICO_SizeOrTIFF_COMPRESSION): lngRet = Len(ptrVar)
          EncoderParameter(1) = &HE09D739D: EncoderParameter(2) = &H44EECCD4: EncoderParameter(3) = &HBF3FBA8E: EncoderParameter(4) = &H58FCE48B
          EncoderParameter(5) = &H1&: EncoderParameter(6) = &H4&
          CopyMemory VarPtr(EncoderParameter(7)), VarPtr(ptrVar), lngRet

          ptrVar = VarPtr(AlphaDepthOrColorDepth): lngRet = 6 + lngRet \ Len(lngRet)
          EncoderParameter(lngRet + 1) = &H66087055: EncoderParameter(lngRet + 2) = &H4C7CAD66: EncoderParameter(lngRet + 3) = &HA238189A: EncoderParameter(lngRet + 4) = &H37830B31
          EncoderParameter(lngRet + 5) = &H1&: EncoderParameter(lngRet + 6) = &H4&
          CopyMemory VarPtr(EncoderParameter(lngRet + 7)), VarPtr(ptrVar), Len(ptrVar)
          SaveBitmapToFile2 = GdipSaveImageToFile(hImage, StrPtr(FileName), CLSID(0), VarPtr(EncoderParameter(0))) = Ok
        End If
        GdipDisposeImage hImage
      End If
      GdiplusShutdown gdiToken
      
    Case ".gif"
      gdiToken = StartUpGDIPlus
      If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hImage) = Ok Then
        If GetEncoderClsID("Image/gif", CLSID) Then
          SaveBitmapToFile2 = GdipSaveImageToFile(hImage, StrPtr(FileName), CLSID(0), 0) = Ok
        End If
        GdipDisposeImage hImage
      End If
      GdiplusShutdown gdiToken
      
    Case ".png"
      gdiToken = StartUpGDIPlus
      Select Case VarType(AlphaColorOrJPEGQuality)
        Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
          lngColor = -3
          lngColor = CLng(AlphaColorOrJPEGQuality)
          If OleTranslateColor(lngColor, 0, lngColor) Then
            If lngColor = -2 Then
              hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaAll, 0, AlphaDepthOrColorDepth And &HFF&)
            Else
              hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&)
            End If
          Else
            hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors, lngColor, AlphaDepthOrColorDepth And &HFF&)
          End If
        Case vbBoolean
          If AlphaColorOrJPEGQuality Then
            hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&)
          Else
            hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), TransformFlags.None)
          End If
        Case Else
          hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), TransformFlags.None)
      End Select
                      
      If hImage Then
        If GetEncoderClsID("Image/png", CLSID) Then
          SaveBitmapToFile2 = GdipSaveImageToFile(hImage, StrPtr(FileName), CLSID(0), 0) = Ok
        End If
        GdipDisposeImage hImage
      End If
      GdiplusShutdown gdiToken
      
    Case ".tga"
      If GetObject(hBitmap, LenB(vBitmap), VarPtr(vBitmap)) Then
        With vBitmap
          If (.bmWidth > 0) And (.bmWidth < 65535) And _
             (.bmHeight < 65535) And (.bmHeight > 0) And (.bmWidthBytes > 0) Then
             
            gdiToken = StartUpGDIPlus
            
            Select Case VarType(AlphaColorOrJPEGQuality)
              Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
                lngColor = -3
                lngColor = CLng(AlphaColorOrJPEGQuality)
                If OleTranslateColor(lngColor, 0, lngColor) Then
                  If lngColor = -2 Then
                    hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaAll Or ReverseLine, 0, AlphaDepthOrColorDepth And &HFF&)
                  Else
                    hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&)
                  End If
                Else
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, lngColor, AlphaDepthOrColorDepth And &HFF&)
                End If
              Case vbBoolean
                If AlphaColorOrJPEGQuality Then
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&)
                Else
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), ReverseLine, 0, &HFF&)
                End If
              Case Else
                lngRet = &HFF&
                hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), ReverseLine, 0, &HFF&)
            End Select
                            
            If hImage Then
              If (GdipGetImageWidth(hImage, .bmWidth) Or GdipGetImageHeight(hImage, .bmHeight)) = Ok Then
                If .bmWidth > 0 And .bmWidth <= &HFFFF& And .bmHeight > 0 And .bmHeight <= &HFFFF& Then
                  lngRet = .bmWidth
                  CopyMemory VarPtr(lngRet) + 2, VarPtr(.bmHeight), 2
                  hFile = FreeFile
                  Open FileName For Binary As hFile
                  Put hFile, , &H20000
                  Put hFile, , 0&
                  Put hFile, , 0&
                  Put hFile, , lngRet
                  Put hFile, , 2080
                  Seek hFile, 19
                  Put hFile, , BitmapBits()
                  Close hFile
                  SaveBitmapToFile2 = True
                Else
                  'Debug.Print "Save TGA Error."
                End If
              End If
              GdipDisposeImage hImage
            End If
            GdiplusShutdown gdiToken
          End If
        End With
      End If
      
    Case ".ico"
      If GetObject(hBitmap, LenB(vBitmap), VarPtr(vBitmap)) Then
        With vBitmap
          If (.bmWidth > 0) And (.bmWidthBytes > 0) Then
            Select Case ICO_SizeOrTIFF_COMPRESSION
              Case Is < 0     '
                .bmHeight = Abs(.bmHeight)
                If .bmWidth > .bmHeight Then
                  If .bmWidth Mod 16 Then .bmWidth = ((.bmWidth \ 16) + 1) * 16
                  .bmHeight = .bmWidth
                ElseIf .bmHeight Mod 16 Then
                  .bmHeight = ((.bmHeight \ 16) + 1) * 16
                  .bmWidth = .bmHeight
                End If
                ICO_SizeOrTIFF_COMPRESSION = PictureSizeMode.Clip
              Case 0          '
                ICO_SizeOrTIFF_COMPRESSION = PictureSizeMode.Clip
              Case Else       '
                .bmHeight = ICO_SizeOrTIFF_COMPRESSION: .bmWidth = ICO_SizeOrTIFF_COMPRESSION
                ICO_SizeOrTIFF_COMPRESSION = PictureSizeMode.Zoom
            End Select
            gdiToken = StartUpGDIPlus
            
            Select Case VarType(AlphaColorOrJPEGQuality)
              Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
                lngColor = -3
                lngColor = CLng(AlphaColorOrJPEGQuality)
                If OleTranslateColor(lngColor, 0, lngColor) Then
                  If lngColor = -2 Then
                    hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaAll Or ReverseLine, 0, AlphaDepthOrColorDepth And &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
                  Else
                    hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
                  End If
                Else
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, lngColor, AlphaDepthOrColorDepth And &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
                End If
              Case vbBoolean
                If AlphaColorOrJPEGQuality Then
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), AlphaColors Or ReverseLine, GetSysColor(5), AlphaDepthOrColorDepth And &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
                Else
                  hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), ReverseLine, 0, &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
                End If
              Case Else
                hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), ReverseLine, 0, &HFF&, .bmWidth, .bmHeight, ICO_SizeOrTIFF_COMPRESSION)
            End Select
                            
            If hImage Then
              GdipGetImageHeight hImage, .bmHeight
              GdipGetImageWidth hImage, .bmWidth
              GdipDisposeImage hImage
              lngRet = IIf(.bmWidth < 256, .bmWidth, 0)
              lngColor = IIf(.bmHeight < 256, .bmHeight, 0)
              CopyMemory VarPtr(lngRet) + 1, VarPtr(lngColor), 1
              CopyMemory VarPtr(lngRet) + 2, VarPtr(lngRet), 2
              lngRet = (lngRet And &HFFFF0000) Or 1&
              
              hFile = FreeFile
              Open FileName For Binary As hFile
              Put hFile, , &H10000
              Put hFile, , lngRet
              Put hFile, , 0&
              lngRet = .bmWidth * .bmHeight * 4
              lngColor = .bmWidth \ 8
              If lngColor Mod 4 Then
                lngColor = ((lngColor \ 4) + 1) * 4 * .bmHeight
              Else
                lngColor = lngColor * .bmHeight
              End If
              Seek hFile, 15
              Put hFile, , lngRet + lngColor + 40
              Put hFile, , 22&
              
              Put hFile, , 40&
              Put hFile, , .bmWidth
              Put hFile, , .bmHeight * 2
              Put hFile, , &H200001
              Put hFile, , 0&
              Put hFile, , lngRet + lngColor
              Put hFile, , 0&
              Put hFile, , 0&
              Put hFile, , 0&
              Put hFile, , 0&
              Put hFile, , BitmapBits()
              lngColor = (lngColor \ .bmHeight) \ 4
              ReDim BitmapBits(1 To lngColor * .bmHeight)
              Put hFile, , BitmapBits()
              Close hFile
              SaveBitmapToFile2 = True
            End If
            GdiplusShutdown gdiToken
          End If
        End With
      End If
      
    Case ".svg"
      FileName2 = ExtractFileName(FileName2)
      If Len(FileName2) > 3 Then
        strFileExt = GetFileExtension(FileName2)
        Select Case strFileExt
          Case ".wmf", ".emf"
            GoTo SVGLoop01
          Case ".png", ".jpg", ".jpeg", ".bmp", ".tif", ".tiff", ".gif"
            GoTo SVGLoop01
          Case Else
            SaveBitmapToFile2 = SaveBitmapToFile(hBitmap, FileName, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION)
        End Select
      Else
SVGLoop01:
        FileName2 = CreateTempDirectory & ExtractFileName(FileName, False) & ".PNG"
        If SaveBitmapToFile(hBitmap, FileName2, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION) Then
          gdiToken = StartUpGDIPlus
          If GdipLoadImageFromFile(StrPtr(FileName2), hImage) = Ok Then
            GdipGetImageWidth hImage, lngRet
            GdipGetImageHeight hImage, lngColor
            GdipDisposeImage hImage
            
            strFileExt = "PD94bWwgdmVyc2lvbj0iMS4wIiBlbmNvZGluZz0iVVRGLTgiPz4NCjwhLS0gQ3Jl" & _
                        "YXRvcjogSm9mb3JuIC0tPg0KPHN2ZyB4bWxucz0iaHR0cDovL3d3dy53My5vcmcv" & _
                        "MjAwMC9zdmciIHhtbDpzcGFjZT0icHJlc2VydmUiIHdpZHRoPSJbV10iIGhlaWdo" & _
                        "dD0iW0hdIiB2ZXJzaW9uPSIxLjEiIHN0eWxlPSJzaGFwZS1yZW5kZXJpbmc6Z2Vv" & _
                        "bWV0cmljUHJlY2lzaW9uOyB0ZXh0LXJlbmRlcmluZzpnZW9tZXRyaWNQcmVjaXNp" & _
                        "b247IGltYWdlLXJlbmRlcmluZzpvcHRpbWl6ZVF1YWxpdHk7IGZpbGwtcnVsZTpl" & _
                        "dmVub2RkOyBjbGlwLXJ1bGU6ZXZlbm9kZCINCnZpZXdCb3g9IjAgMCBbV10gW0hd" & _
                        "Ig0KIHhtbG5zOnhsaW5rPSJodHRwOi8vd3d3LnczLm9yZy8xOTk5L3hsaW5rIj4N" & _
                        "CiA8ZGVmcz4NCiAgIDxjbGlwUGF0aCBpZD0iSm9mb3JuX1BhdGgwIj4NCiAgICA8" & _
                        "cmVjdCB4PSIwIiB5PSIwIiB3aWR0aD0ie1d9IiBoZWlnaHQ9IntIfSIvPg0KICAg" & _
                        "PC9jbGlwUGF0aD4NCiA8L2RlZnM+DQogPGcgaWQ9IlBpY3RydWVfMSI+DQogIDxt" & _
                        "ZXRhZGF0YSBpZD0iSm9mb3JuX0RhdGEwIi8+DQogIDxnIHN0eWxlPSJjbGlwLXBh" & _
                        "dGg6dXJsKCNKb2Zvcm5fUGF0aDApIj4NCiAgIDxpbWFnZSBpZD0iW05dIiB4PSIw" & _
                        "IiB5PSIwIiB3aWR0aD0ie1d9IiBoZWlnaHQ9IntIfSIgeGxpbms6aHJlZj0iZGF0" & _
                        "YTppbWFnZS9bRV07YmFzZTY0LFtGXSIvPg0KICA8L2c+DQogPC9nPg0KPC9zdmc+DQo="
            If CryptStringToBinary(strFileExt, bytFile()) Then
              strFileExt = Replace(Replace(StrConv(bytFile(), vbUnicode), "[N]", ExtractFileName(FileName2)), "[E]", "png")
              strTemp = GetFileBase64(FileName2, True)
              If Len(strTemp) Then
                strFileExt = Replace(strFileExt, "[F]", strTemp)
                strFileExt = Replace(strFileExt, "{W}", lngRet)
                strFileExt = Replace(strFileExt, "{H}", lngColor)
                strFileExt = Replace(strFileExt, "[W]", lngRet * 10)
                strFileExt = Replace(strFileExt, "[H]", lngColor * 10)
                If StrToUTF8(strFileExt, bytFile()) > 0 Then
                  hFile = FreeFile
                  Open FileName For Binary As hFile
                  Put hFile, , bytFile()
                  Close hFile
                  SaveBitmapToFile2 = True
                End If
              End If
            Else
              GdipDisposeImage hImage
            End If
          End If
          GdiplusShutdown gdiToken
        End If
        KillFile FileName2
        RmDir ExtractPathDirctory(FileName2)
      End If
      
    Case ".bmp"
      gdiToken = StartUpGDIPlus
      hImage = Create32bppARGBBitmapFromHBITMAP(hBitmap, BitmapBits(), None)
      If hImage Then
        If GetEncoderClsID("Image/BMP", CLSID) Then
          SaveBitmapToFile2 = GdipSaveImageToFile(hImage, StrPtr(FileName), CLSID(0), 0) = Ok
        End If
        GdipDisposeImage hImage
      End If
      GdiplusShutdown gdiToken
  End Select
End Property

Joforn · 2/12/20

Đoạn mã 7

Mã:

Private Function Create32bppARGBBitmapFromHBITMAP2(ByRef lngBitmap() As Long, ByRef lngIamge() As Long, _
                  ByRef BitmapBits() As Long, _
                  Optional ByVal TransformFlag As TransformFlags = None, _
                  Optional ByVal AlphaColor As Long, _
                  Optional ByVal AlphaByte As Long, _
                  Optional ByVal NewWidth As Long, _
                  Optional ByVal NewHeight As Long, _
                  Optional ByVal PictureSizeMode As PictureSizeMode = Zoom) As Boolean
  #If VBA7 Then
    Dim hImage    As LongPtr
    Dim hBitmap   As LongPtr
    Dim hBitmap1  As LongPtr
    Dim hGraph    As LongPtr
    Dim ptrBits   As LongPtr
    Dim ptrTemp   As LongPtr
  #Else
    Dim hImage    As Long
    Dim hBitmap   As Long
    Dim hBitmap1  As Long
    Dim hGraph    As Long
    Dim ptrBits   As Long
    Dim ptrTemp   As Long
  #End If
  Dim vBitmap     As BITMAP
  Dim lngRet()    As Long
  Dim RECT        As RECTL
  Dim X As Long, Y  As Long, Width As Long, Height As Long
  
  Dim BitmapData As BitmapData, BitmapData1 As BitmapData
  Dim sngZOOM   As Single
  
  On Error Resume Next
  
  If UBound(lngBitmap()) - LBound(lngBitmap()) < 1 Then Exit Function
  CopyMemory VarPtr(hBitmap), VarPtr(lngBitmap(0)), LenB(hBitmap)
  ReDim lngIamge(0 To 1)
  
  If GdipCreateBitmapFromHBITMAP(hBitmap, 0, hImage) = Ok Then
    If GdipBitmapConvertFormat(hImage, PixelFormat32bppARGB, DitherTypeNone, PaletteTypeCustom, 0, 0) = Ok Then
      If GdipGetImageWidth(hImage, RECT.Width) Or GdipGetImageHeight(hImage, RECT.Height) Then
        GdipDisposeImage hImage: Exit Function
      ElseIf RECT.Height = 0 And RECT.Width = 0 Then
        GdipDisposeImage hImage: Exit Function
      End If
    Else
      GdipDisposeImage hImage: Exit Function
    End If
    
    If GdipBitmapLockBits(hImage, RECT, ImageLockModeRead Or ImageLockModeWrite, PixelFormat32bppARGB, BitmapData) = Ok Then
      With BitmapData
        ReDim BitmapBits(1 To .Width, 1 To .Height)
        CopyMemory VarPtr(BitmapBits(1, 1)), .Scan0Ptr, .Stride * .Height
        
        '透明化处理
        Select Case TransformFlag And AlphaMode
          Case TransformFlags.AlphaColors
            ptrTemp = VarPtr(AlphaColor)
            AlphaColor = (AlphaColor And &HFF00FF00) Or ((AlphaColor And &HFF&) * &H10000) Or ((AlphaColor And &HFF0000) \ &H10000)
            ptrTemp = VarPtr(AlphaByte)
            For Height = 1 To .Height
              For Width = 1 To .Width
                If (BitmapBits(Width, Height) And &HFFFFFF) = AlphaColor Then
                  CopyMemory VarPtr(BitmapBits(Width, Height)) + 3, ptrTemp, 1
                End If
              Next Width
            Next Height
            
          Case TransformFlags.AlphaAll
            If AlphaByte < 255 Then
              ptrTemp = VarPtr(AlphaByte)
              For Height = 1 To .Height
                For Width = 1 To .Width
                  CopyMemory VarPtr(BitmapBits(Width, Height)) + 3, ptrTemp, 1
                Next Width
              Next Height
            End If
        End Select
       
        CopyMemory .Scan0Ptr, VarPtr(BitmapBits(1, 1)), .Stride * .Height
        GdipBitmapUnlockBits hImage, BitmapData
        
        If (NewHeight > 0) Or (NewWidth > 0) Then   '
          If NewHeight <= 0 Then NewHeight = .Height
          If NewWidth <= 0 Then NewWidth = .Width

          ReDim BitmapBits(1 To NewWidth, 1 To NewHeight)
          
          If GdipCreateBitmapFromScan0(NewWidth, NewHeight, NewWidth * 4, PixelFormat32bppARGB, VarPtr(BitmapBits(1, 1)), hBitmap1) = Ok Then
            If GdipGetImageGraphicsContext(hBitmap1, hGraph) = Ok Then
              GdipGraphicsClear hGraph, &HFFFFFF
              Select Case PictureSizeMode
                Case Clip       '
                  If NewWidth >= .Width Then
                    X = (NewWidth - .Width) \ 2
                    Width = .Width
                  Else
                    X = 0
                    Width = NewWidth
                    .Width = NewWidth
                  End If
                  If NewHeight >= .Height Then
                    Y = (NewHeight - .Height) \ 2
                    Height = .Height
                  Else
                    Y = 0
                    Height = NewHeight
                    .Height = NewHeight
                  End If
                  
                Case Stretch      '
                  X = 0: Y = 0
                  Width = NewWidth: Height = NewHeight
                  
                Case Zoom         '
                  Width = Abs(Abs(NewWidth) - Abs(.Width))
                  Height = Abs(Abs(NewHeight) - Abs(.Height))
                  
                  If Height > Width Then
                    sngZOOM = CSng(Abs(NewWidth)) / CSng(Abs(.Width))
                    X = 0: Width = NewWidth
                    Height = sngZOOM * .Height
                    Y = (NewHeight - Height) \ 2
                  Else
                    sngZOOM = CSng(Abs(NewHeight)) / CSng(Abs(.Height))
                    Y = 0: Height = NewHeight
                    Width = sngZOOM * .Width
                    X = (NewWidth - Width) \ 2
                  End If
              End Select
              
              If GdipDrawImageRectRectI(hGraph, hImage, X, Y, Width, Height, 0, 0, .Width, .Height, UnitPixel) = Ok Then
                GdipDisposeImage hImage: hImage = 0
                If GdipCloneImage(hBitmap1, hImage) = Ok Then
                  GdipDisposeImage hBitmap1: hBitmap1 = 0
                  RECT.Width = NewWidth: RECT.Height = NewHeight
                  If GdipBitmapLockBits(hImage, RECT, ImageLockModeRead, PixelFormat32bppARGB, BitmapData) = Ok Then
                    CopyMemory VarPtr(BitmapBits(1, 1)), .Scan0Ptr, .Stride * .Height
                    GdipBitmapUnlockBits hImage, BitmapData
                  End If
                Else
                  GdipDisposeImage hBitmap1: hBitmap1 = 0
                  GoTo ExitFunction
                End If
              Else
                GdipDisposeImage hBitmap1
              End If
            Else
              GdipDisposeImage hBitmap1
            End If
          Else
          
          End If
        End If
        
        If TransformFlag And ReverseLine Then   '
          ReDim bytRow(1 To .Stride)
          ptrTemp = VarPtr(bytRow(1))
          For Height = 1 To .Height \ 2
            ptrBits = VarPtr(BitmapBits(1, .Height + 1 - Height))
            CopyMemory ptrTemp, VarPtr(BitmapBits(1, Height)), .Stride
            CopyMemory VarPtr(BitmapBits(1, Height)), ptrBits, .Stride
            CopyMemory ptrBits, ptrTemp, .Stride
          Next Height
        End If
        
      End With
    End If
    ReDim lngIamge(0 To 1)
    CopyMemory VarPtr(lngIamge(0)), VarPtr(hImage), LenB(hImage)
    Create32bppARGBBitmapFromHBITMAP2 = hImage <> 0
  End If
ExitFunction:
End Function

Private Sub MoveFileToFolder(ByVal TargetFolder As Object, ByVal FileName As String)
  Dim Shell       As Object
  Dim Folder      As Object
  Dim FolderItem  As Object
  Dim I As Long, K As Long
  
  On Error Resume Next
  
  Set Shell = CreateObject("Shell.Application")
  Set Folder = Shell.Namespace(ExtractPathDirctory(FileName))
  Set FolderItem = Folder.ParseName(ExtractFileName(FileName, True))
  I = TargetFolder.Items.Count
  TargetFolder.MoveHere FolderItem, 4
  WaintShell32 TargetFolder, I
End Sub

Joforn · 2/12/20

Đoạn mã 8

Mã:

Private Sub WaintShell32(ByVal Folder As Object, ByVal ItemsCount As Long, Optional ByVal MaxTimes As Long = 100)
  Dim RunTimes As Long
  
  On Error GoTo ExitWaintShell32
  Do While ItemsCount = Folder.Items.Count
    Sleep 100
    DoEvents
    RunTimes = RunTimes + 1
    If RunTimes > MaxTimes Then Exit Do
  Loop
ExitWaintShell32:
End Sub
  
Private Function CreateZipFile(ByVal ZIPFileName As String, Optional ByRef FileName As String, Optional ByRef TargetPath As Object) As Long
  Dim Shell       As Object
  Dim FolderItem  As Object
  Dim hFile       As Long
  Dim strTempPath As String
  Dim I           As Long
  
  On Error Resume Next
  
  Set Shell = CreateObject("Shell.Application")
  If Shell Is Nothing Then Exit Function
  
  If Not FileExists(ZIPFileName) Then
    hFile = FreeFile
    Open ZIPFileName For Binary As hFile
    Put hFile, , 101010256
    Seek hFile, 19
    Put hFile, , 0&
    Close hFile
    If FileExists(ZIPFileName) Then
      CreateZipFile = 3
    Else
      Exit Function
    End If
  End If
  
  Set TargetPath = Shell.Namespace(CVar(ZIPFileName))
  If TargetPath Is Nothing Then
    If CreateZipFile = 0 Then CreateZipFile = 1
    Exit Function
  End If
  
  strTempPath = CreateTempDirectory
  If PathIsDirectoryEmptyW(StrPtr(strTempPath)) Then
    If MKZipPath(TargetPath, ExtractPathDirctory(FileName), Shell.Namespace(CVar(strTempPath))) Then
      FileName = ExtractFileName(FileName, True)
      Set FolderItem = TargetPath.ParseName(FileName)
      If Not (FolderItem Is Nothing) Then
        I = TargetPath.Items.Count
        Shell.Namespace(CVar(strTempPath)).MoveHere FolderItem
        WaintShell32 TargetPath, I
      End If
      FileName = strTempPath & FileName
      KillFile FileName
      CreateZipFile = CreateZipFile Or 4
    End If
  End If
End Function
  
Private Function MKZipPath(ByRef objFolder As Object, ByVal strPath As String, ByVal TempPath As Object) As Boolean
  Dim I As Long, K  As Long
  Dim strFileName   As String
  Dim strPathName   As String
  Dim FolderItem    As Object
  Dim FolderMove    As Object
  Dim PathArray()   As String
  Dim lngFile       As Long
  
  On Error Resume Next
  
  If (objFolder Is Nothing) Or (TempPath Is Nothing) Then Exit Function
  If objFolder.Self Is Nothing Then
    If objFolder.IsFolder Then
      Set objFolder = objFolder.GetFolder
      If objFolder.Self Is Nothing Then Exit Function
    End If
  End If
  
  If Len(strPath) Then
    strPathName = strPath
    Do While Len(strPathName) > 0
      strFileName = ExtractFileName(strPathName, True)
      Select Case strFileName
        Case Application.PathSeparator: Exit Do
        Case "..", ".":                 Exit Function
        Case Else
          If Len(strFileName) Then
            strPathName = ExtractPathDirctory(strPathName)
            If PathIsRoot(strPathName) Then
              Exit Function
            Else
              ReDim Preserve PathArray(0 To I)
              PathArray(I) = strFileName
              I = I + 1
            End If
          Else
            Exit Do
          End If
      End Select
    Loop
    
    If I > 0 Then
      For I = UBound(PathArray) To LBound(PathArray) Step -1
        Set FolderItem = objFolder.ParseName(PathArray(I))
        If FolderItem Is Nothing Then
          TempPath.NewFolder PathArray(I)
          Set FolderMove = TempPath.ParseName(PathArray(I))
          lngFile = FreeFile
          Open FolderMove.Path & "\1.TXT" For Binary As lngFile
          Close lngFile
          K = objFolder.Items.Count
          objFolder.MoveHere FolderMove
          WaintShell32 objFolder, K
          
          Set FolderItem = objFolder.ParseName(PathArray(I))
          If FolderItem Is Nothing Then Exit Function
          Set objFolder = FolderItem.GetFolder
          Do
            Set FolderMove = objFolder.ParseName("1.TXT")
            DoEvents
          Loop While FolderMove Is Nothing
          TempPath.MoveHere FolderMove
          WaintShell32 TempPath, 0
          Set FolderMove = Nothing
          KillFile TempPath.Self.Path & "\1.TXT"
        Else
          Set objFolder = FolderItem.GetFolder
        End If
        Set FolderItem = Nothing
      Next I
    End If
  End If
  MKZipPath = True
End Function
        
Private Property Get PathRemoveArgs(ByVal strPath As String) As String
  Dim I As Long
  
  strPath = Split(Replace(strPath, ">", vbNullChar), vbNullChar)(0)
  strPath = Trim$(strPath) & vbNullChar
  PathRemoveArgsW StrPtr(strPath)
  PathUnquoteSpacesW StrPtr(strPath)
  I = InStr(strPath, vbNullChar)
  If I > 0 Then strPath = Left(strPath, I - 1)
  PathRemoveArgs = Trim(strPath)
End Property

Private Property Get PathGetArgs(ByVal strPath As String, Optional ByVal Index As Long) As String
  Dim I         As Long

  Dim strArray() As String
  If Len(strPath) Then
    strArray() = Split(Replace(strPath, ">", vbNullChar), vbNullChar)
    
    Select Case Index
      Case Is > UBound(strArray): Exit Property
      Case Is <= 0:               PathGetArgs = strArray(0)
      Case Else:                  PathGetArgs = strArray(Index)
    End Select
  End If
End Property

Private Property Get PathIsRoot(ByVal strPath As String) As Boolean
  strPath = strPath & String(5, vbNullChar)
  If InStrRev(strPath, "\") > 2 Then PathAddBackslashW StrPtr(strPath)
  PathIsRoot = PathIsRootW(StrPtr(strPath))
End Property

Private Property Get ExtractFileName(ByVal strPath As String, Optional ByVal ExtensionReturn As Boolean = True) As String
  Dim I As Long, J As Long
  
  PathStripPathW StrPtr(strPath)
  
  PathRemoveBackslashW StrPtr(strPath)
  If Not ExtensionReturn Then PathRemoveExtensionW StrPtr(strPath)
  I = InStr(strPath, vbNullChar)
  If I > 0 Then strPath = Left(strPath, I - 1)
  ExtractFileName = Trim$(strPath)
End Property

Private Property Get ExtractPathDirctory(ByVal strPath As String) As String
  Dim I         As Long
  #If VBA7 Then
    Dim ptrVar1 As LongPtr
    Dim ptrVar2 As LongPtr
  #Else
    Dim ptrVar1 As Long
    Dim ptrVar2 As Long
  #End If
  Dim strTemp   As String
  
  strPath = Trim(strPath)
  strTemp = strPath
  PathRemoveBackslashW StrPtr(strPath)
  If PathRemoveFileSpecW(StrPtr(strPath)) Then
    Do
      ptrVar1 = ptrVar2
      ptrVar2 = PathRemoveBackslashW(StrPtr(strPath))
    Loop While ptrVar1 <> ptrVar2
    
    I = InStr(strPath, vbNullChar)
    If I > 0 Then strPath = Left$(strPath, I - 1)
    strPath = Trim$(strPath)
    If strPath <> "\\" Then ExtractPathDirctory = Trim$(strPath)
  End If
End Property

Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long

  Dim Num         As Long
  Dim Size        As Long
  Dim I           As Long
  Dim Info()      As ImageCodecInfo
  Dim Buffer()    As Byte

  GdipGetImageEncodersSize Num, Size
  If Size <> 0 Then
    ReDim Info(1 To CLng(Num)) As ImageCodecInfo
    ReDim Buffer(1 To CLng(Size)) As Byte
    GdipGetImageEncoders Num, Size, Buffer(1)
    CopyMemory VarPtr(Info(1)), VarPtr(Buffer(1)), (Len(Info(1)) * CLng(Num))
    For I = 1 To CLng(Num)
     If (StrComp(PtrToStrW(Info(I).MimeType), strMimeType, vbTextCompare) = 0) Then
       CopyMemory VarPtr(ClassID(0)), VarPtr(Info(I).ClassID(0)), 16
       GetEncoderClsID = I
       Exit For
     End If
    Next
  End If
End Function

Private Function SaveClipboard() As Long
  Dim Format As Long
  #If VBA7 Then
    Dim hMem As LongPtr
    Dim mPtr As LongPtr
  #Else
    Dim hMem As Long
    Dim mPtr As Long
  #End If
  Dim mSize As Long
  
  nFormats = 0
  If CountClipboardFormats > 0 Then
    OpenClipboard 0
    
    On Error Resume Next
    
    Format = EnumClipboardFormats(0)
    Do While Format
      hMem = GetClipboardData(Format)
      mSize = GetObjectType(hMem)
      If mSize Then
        nFormats = nFormats + 1
        ReDim Preserve ClipboardData(1 To nFormats)
        With ClipboardData(nFormats)
          .Type = mSize
          .Size = Len(hMem)
          .Format = Format
          ReDim .bData(1 To .Size)
          CopyMemory VarPtr(.bData(1)), VarPtr(hMem), .Size
        End With
      ElseIf IsBadReadPtr(hMem, 1) Then
        Debug.Print "SaveClipboard:read Memory error."
      Else
        mSize = GlobalSize(hMem)
        If mSize > 0 Then
          mPtr = GlobalLock(hMem)
          nFormats = nFormats + 1
          ReDim Preserve ClipboardData(1 To nFormats)
          
          With ClipboardData(nFormats)
            .Format = Format
            .Size = LenB(mSize)
            .Type = 0
            ReDim .bData(1 To mSize)
            CopyMemory VarPtr(.bData(1)), mPtr, mSize
          End With

          GlobalUnlock hMem
        End If
      End If
      
      Format = EnumClipboardFormats(Format)
    Loop
    CloseClipboard
  End If
  SaveClipboard = nFormats
End Function

Private Function RestoreClipboard(Optional ByVal nFormat As ClipboardDataFormats = -1) As Long
  #If VBA7 Then
    Dim hMem  As LongPtr
    Dim mPtr  As LongPtr
  #Else
    Dim hMem  As Long
    Dim mPtr  As Long
  #End If
  Dim I       As Long, K As Long

  If nFormats > 0 Then
    OpenClipboard 0
    EmptyClipboard
    For I = 1 To nFormats
      With ClipboardData(I)
        If ((.Size > 0) And ((nFormat = .Format) Or (nFormat = -1))) Then
          If .Type Then
            CopyMemory VarPtr(hMem), VarPtr(.bData(1)), .Size
            SetClipboardData .Format, hMem
            RestoreClipboard = RestoreClipboard + 1
          Else
            hMem = GlobalAlloc(GMEM_ZEROINIT, .Size)
            If hMem Then
              mPtr = GlobalLock(hMem)
              CopyMemory mPtr, VarPtr(.bData(1)), .Size
              GlobalUnlock hMem
              SetClipboardData .Format, hMem
              RestoreClipboard = RestoreClipboard + 1
            End If
          End If
        End If
      End With
    Next I
    CloseClipboard
    nFormats = 0
    Erase ClipboardData()
  End If
End Function

Private Function FileExists(ByVal strFileName As String) As Boolean
  If Len(strFileName) Then
    strFileName = strFileName & String(5, vbNullChar)
    If PathFileExistsW(StrPtr(strFileName)) Then
      FileExists = PathIsDirectoryW(StrPtr(strFileName)) = 0
    End If
  End If
End Function

Private Function KillFile(ByVal FileName As String) As Boolean
  #If VBA7 Then
    Dim lpFileName As LongPtr
  #Else
    Dim lpFileName As Long
  #End If
  FileName = FileName & vbNullChar
  lpFileName = StrPtr(FileName)
  If PathFileExistsW(lpFileName) Then
    If PathIsDirectoryW(lpFileName) Then Exit Function
    SetFileAttributes lpFileName, 0
    KillFile = DeleteFile(lpFileName)
  Else
    KillFile = True
  End If
End Function

Private Function GetFileExtension(ByVal strFileName As String) As String
  #If VBA7 Then
    Dim ptrExt As LongPtr
  #Else
    Dim ptrExt As Long
  #End If
  Dim ExtLen      As Long

  ptrExt = PathFindExtension(StrPtr(strFileName))
  If ptrExt Then
    ExtLen = lstrlenW(ptrExt)
    If ExtLen > 0 Then
      GetFileExtension = String(ExtLen, vbNullChar)
      CopyMemory StrPtr(GetFileExtension), ptrExt, LenB(GetFileExtension)
    End If
  End If
End Function

Private Function StartUpGDIPlus(Optional ByVal GdipVersion As Long = 1&) As Long
    Dim GdipToken As Long
    Dim GdipStartupInput  As GDIPlusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    
    GdipStartupInput.GdiPlusVersion = GdipVersion
    If GdiplusStartup(GdipToken, GdipStartupInput, GdipStartupOutput) = Ok Then
        StartUpGDIPlus = GdipToken
    End If
End Function

#If VBA7 Then
  Public Property Get SaveBitmapToFile(ByVal hBitmap As LongPtr, ByVal FileName As String, _
      Optional ByVal AlphaColorOrJPEGQuality As Variant, _
      Optional ByVal AlphaDepthOrColorDepth As Long, _
      Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION = COMPRESSION_OJPEG) As Boolean
      
      Dim lngBitmap() As Long
      ReDim lngBitmap(0 To 1)
      CopyMemory VarPtr(lngBitmap(0)), VarPtr(hBitmap), LenB(hBitmap)
      SaveBitmapToFile = SaveBitmapToFile2(lngBitmap(), FileName, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION)
  End Property
    
  Private Function Create32bppARGBBitmapFromHBITMAP(ByVal hBitmap As LongPtr, ByRef BitmapBits() As Long, _
                    Optional ByVal TransformFlag As TransformFlags = None, _
                    Optional ByVal AlphaColor As Long, _
                    Optional ByVal AlphaByte As Long, _
                    Optional ByVal NewWidth As Long, _
                    Optional ByVal NewHeight As Long, _
                    Optional ByVal PictureSizeMode As PictureSizeMode = Zoom) As LongPtr
    
      Dim lngBitmap() As Long
      
      ReDim lngBitmap(0 To 1)
      CopyMemory VarPtr(lngBitmap(0)), VarPtr(hBitmap), LenB(hBitmap)
      If Create32bppARGBBitmapFromHBITMAP2(lngBitmap(), lngBitmap(), BitmapBits(), TransformFlag, AlphaColor, AlphaByte, NewWidth, NewHeight, PictureSizeMode) Then
        CopyMemory VarPtr(Create32bppARGBBitmapFromHBITMAP), VarPtr(lngBitmap(0)), LenB(Create32bppARGBBitmapFromHBITMAP)
      End If
  End Function
  
  Private Function PtrToStrW(ByVal lpsz As LongPtr) As String
    Dim Length      As Long
    Length = lstrlenW(lpsz)
    If Length > 0 Then
        PtrToStrW = String$(Length, vbNullChar)
        CopyMemory StrPtr(PtrToStrW), lpsz, Length * 2
    End If
  End Function
#Else
  Public Property Get SaveBitmapToFile(ByVal hBitmap As Long, ByVal FileName As String, _
      Optional ByVal AlphaColorOrJPEGQuality As Variant, _
      Optional ByVal AlphaDepthOrColorDepth As Long, _
      Optional ByVal ICO_SizeOrTIFF_COMPRESSION As TIFCOMPRESSION = COMPRESSION_OJPEG) As Boolean
      
      Dim lngBitmap() As Long
      ReDim lngBitmap(0 To 1)
      lngBitmap(0) = hBitmap
      SaveBitmapToFile = SaveBitmapToFile2(lngBitmap(), FileName, AlphaColorOrJPEGQuality, AlphaDepthOrColorDepth, ICO_SizeOrTIFF_COMPRESSION)
  End Property
    
  Private Function Create32bppARGBBitmapFromHBITMAP(ByVal hBitmap As Long, ByRef BitmapBits() As Long, _
                    Optional ByVal TransformFlag As TransformFlags = None, _
                    Optional ByVal AlphaColor As Long, _
                    Optional ByVal AlphaByte As Long, _
                    Optional ByVal NewWidth As Long, _
                    Optional ByVal NewHeight As Long, _
                    Optional ByVal PictureSizeMode As PictureSizeMode = Zoom) As Long
    
      Dim lngBitmap() As Long
      
      ReDim lngBitmap(0 To 1)
      lngBitmap(0) = hBitmap
      If Create32bppARGBBitmapFromHBITMAP2(lngBitmap(), lngBitmap(), BitmapBits(), TransformFlag, AlphaColor, AlphaByte, NewWidth, NewHeight, PictureSizeMode) Then
        Create32bppARGBBitmapFromHBITMAP = lngBitmap(0)
      End If
  End Function

  Private Function PtrToStrW(ByVal lpsz As Long) As String
    Dim Length      As Long
    Length = lstrlenW(lpsz)
    If Length > 0 Then
        PtrToStrW = String$(Length, vbNullChar)
        CopyMemory StrPtr(PtrToStrW), lpsz, Length * 2
    End If
  End Function
#End If

Private Function CryptBinaryToString(ByRef bytBuff() As Byte, Optional ByVal CRYPTFlags As CRYPT_STRING_TYPE = CRYPT_STRING_BASE64) As String
  Dim lngLowBound   As Long
  Dim cbBinary      As Long
  Dim strBase64     As String
  Dim lngBase64Len  As Long
  
  On Error Resume Next
  lngLowBound = &H7FFFFFFF
  lngLowBound = LBound(bytBuff)
  cbBinary = UBound(bytBuff)
  If cbBinary < lngLowBound Then Exit Function
  cbBinary = cbBinary - lngLowBound + 1
  If CryptBinaryToStringW(bytBuff(lngLowBound), cbBinary, CRYPTFlags, 0, lngBase64Len) Then
    If lngBase64Len > 0 Then
      strBase64 = String(lngBase64Len, vbNullChar)
      CryptBinaryToStringW bytBuff(lngLowBound), cbBinary, CRYPTFlags, StrPtr(strBase64), lngBase64Len
      CryptBinaryToString = Replace(strBase64, vbNullChar, vbNullString)
    End If
  End If
End Function

Private Function CryptStringToBinary(ByVal strBase64 As String, bytBuff() As Byte, _
       Optional ByVal CRYPTFlags As CRYPT_STRING_TYPE = CRYPT_STRING_BASE64) As Long
  Dim lngLen    As Long

  If Len(strBase64) Then
    If CryptStringToBinaryW(StrPtr(strBase64), Len(strBase64), CRYPT_STRING_BASE64, ByVal 0&, lngLen) Then
      ReDim bytBuff(0 To lngLen - 1)
      CryptStringToBinary = CryptStringToBinaryW(StrPtr(strBase64), Len(strBase64), CRYPT_STRING_BASE64, bytBuff(0), lngLen)
    End If
  End If
End Function

Joforn · 2/12/20

Đoạn mã 9:

Mã:

Private Function StringToBase64(ByVal str1 As String, Optional ByVal CodePage = 65001) As String
  Dim bytBuff()     As Byte
  Dim lngRet        As Long
  Dim strLen        As Long
  strLen = Len(str1)
  If strLen Then
    lngRet = WideCharToMultiByte(CodePage, 0, StrPtr(str1), strLen, ByVal 0&, 0)
    If lngRet > 0 Then
      ReDim bytBuff(0 To lngRet - 1)
      WideCharToMultiByte CodePage, 0, StrPtr(str1), strLen, bytBuff(0), lngRet
      StringToBase64 = CryptBinaryToString(bytBuff, CRYPT_STRING_BASE64)
    End If
  End If
End Function

Private Function Base64ToString(ByVal strBase64 As String, Optional ByVal CodePage = 65001) As String
  Dim bytBuff()     As Byte
  Dim lngRet        As Long

  If CryptStringToBinary(strBase64, bytBuff) Then
    lngRet = MultiByteToWideChar(CodePage, 0, bytBuff(0), UBound(bytBuff) + 1, 0, 0)
    If lngRet Then
      Base64ToString = String(lngRet, vbNullChar)
      MultiByteToWideChar CodePage, 0, bytBuff(0), UBound(bytBuff) + 1, StrPtr(Base64ToString), lngRet
    End If
  End If
End Function

Private Function StrToUTF8(ByVal str1 As String, bytBuff() As Byte) As Long
  Dim lngRet        As Long
  Dim strLen        As Long
  strLen = Len(str1)
  If strLen Then
    lngRet = WideCharToMultiByte(65001, 0, StrPtr(str1), strLen, ByVal 0&, 0)
    If lngRet > 0 Then
      ReDim bytBuff(0 To lngRet - 1)
      StrToUTF8 = WideCharToMultiByte(65001, 0, StrPtr(str1), strLen, bytBuff(0), lngRet)
    End If
  End If
End Function

Private Function StrFromUTF8(bytBuff() As Byte) As String
  Dim lngRet        As Long
  Dim strLen        As Long

  On Error Resume Next
  If UBound(bytBuff()) < LBound(bytBuff()) Then Exit Function
  lngRet = MultiByteToWideChar(65001, 0, bytBuff(0), UBound(bytBuff) + 1, 0, 0)
  If lngRet Then
    StrFromUTF8 = String(lngRet, vbNullChar)
    MultiByteToWideChar 65001, 0, bytBuff(0), UBound(bytBuff) + 1, StrPtr(StrFromUTF8), lngRet
  End If
End Function

Private Property Get CreateTempDirectory(Optional ByVal AddBackslash As Boolean = True) As String
  Dim PathName  As String
  Dim I         As Long
  
  PathName = String(512, vbNullChar)
  If GetTempPath(512, StrPtr(PathName)) Then
    If GetTempFileName(StrPtr(PathName), StrPtr("Ron"), 0, StrPtr(PathName)) Then
      KillFile PathName
      PathAddBackslashW StrPtr(PathName)
      If MakeSureDirectoryPathExists(PathName) Then
        If Not AddBackslash Then PathRemoveBackslashW StrPtr(PathName)
        I = InStr(PathName, vbNullChar)
        If I > 0 Then PathName = Left$(PathName, I - 1)
        CreateTempDirectory = PathName
      End If
    End If
  End If
End Property

Private Function GetFileBase64(ByVal FileName As String, Optional ByVal TrimMode As Boolean) As String
  Dim hFile     As Long
  Dim bytArr()  As Byte
  Dim I As Long
  Dim lngBase64Len  As Long
  
  I = FileLen(FileName)
  If I > 0 Then
    ReDim bytArr(1 To I)
    hFile = FreeFile
    Open FileName For Binary As hFile
    Get hFile, , bytArr()
    Close hFile

    If CryptBinaryToStringW(bytArr(1), I, CRYPT_STRING_BASE64, 0, lngBase64Len) Then
      If lngBase64Len > 0 Then
        GetFileBase64 = String(lngBase64Len, vbNullChar)
        If CryptBinaryToStringW(bytArr(1), I, CRYPT_STRING_BASE64, StrPtr(GetFileBase64), lngBase64Len) Then
          If TrimMode Then
            GetFileBase64 = Replace$(GetFileBase64, vbNullChar, vbNullString)
            
            I = 1: lngBase64Len = Len(GetFileBase64)
            Do While I <= lngBase64Len
              Select Case Mid$(GetFileBase64, I, 1)
                Case vbTab, vbNullChar, vbCrLf, " ", "　"
                  I = I + 1
                Case Else
                  Exit Do
              End Select
            Loop
            If I > 1 Then
              If I <= lngBase64Len Then
                GetFileBase64 = Mid$(GetFileBase64, I)
              Else
                GetFileBase64 = vbNullString
              End If
            End If
            
            I = Len(GetFileBase64): lngBase64Len = I
            Do While I > 0
              Select Case Mid$(GetFileBase64, I, 1)
                Case vbTab, vbNullChar, vbCrLf, " ", "　"
                  I = I - 1
                Case Else
                  Exit Do
              End Select
            Loop
            If I < lngBase64Len Then GetFileBase64 = Left$(GetFileBase64, I)
          End If
        End If
      End If
    End If
  End If
End Function

Deleted member 1392 · 2/12/20

Bạn có thể mô tả rõ hơn về chương trình của bạn được dùng vào mục đích, trường hợp nào không. Nếu có thể, bạn có thể dẫn link chương trình gởi lên sẽ rất tuyệt vời.

[Chia sẻ mã nguồn]Excel lưu dải ô hoặc biểu tượng ImageMsol dưới dạng hình ảnh(Hỗ trợ lưu thành 13 định dạng tệp khác nhau:WMF,EMF,ICO,PNG,TGA,PDF...)

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Joforn

Yêu THVBA

Deleted member 1392

Guest