[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『copypictureメソッドで作成した画像が白紙になる』（アーダスター）
20枚の画像をセルの範囲で取ってきて指定したフォルダにpngとして保存したいのですが、何故かすべての画像が白紙になりました。
ネットにも似たような質問は色々あったので見てみたのですが、うまく行かなかったので助けていただければと思います。
Sub 画像化()
' 定数の定義
Const NUM_IMAGES As Long = 20
Const SAVE_FOLDER_PATH As String = "C:\〇〇\〇〇\〇〇\〇〇\〇〇"
Dim pic As ChartObject
Dim picNameArray As Variant
Dim rngArray As Variant
Dim saveFolderPath As String
Dim currentSheet As Worksheet
Dim i As Long
' 「グラフ」シートをアクティブにする
Worksheets("グラフ").Activate
' 画像とセル範囲の配列
picNameArray = Array("\1.png", "\2.png", "\3.png", "\4.png", "\5.png", "\6.png", "\7.png", "\8.png", "\9.png", "\10.png", "\11.png", "\12.png", "\13.png", "\14.png", "\15.png", "\16.png", "\17.png", "\18.png", "\19.png", "\20.png")
rngArray = Array(Range("A1:Y26"), Range("A27:Y52"), Range("A53:Y78"), Range("A79:Y104"), Range("A105:Y130"), Range("A131:Y156"), Range("A157:Y182"), Range("A183:Y208"), Range("A209:Y234"), Range("A235:Y260"), Range("A261:Y286"), Range("A287:Y312"), Range("A313:Y338"), Range("A339:Y364"), Range("A365:Y390"), Range("A391:Y416"), Range("A417:Y442"), Range("A443:Y468"), Range("A469:Y494"), Range("A495:Y520"))
' 保存フォルダの設定
saveFolderPath = SAVE_FOLDER_PATH
' ズームレベルを変更（オプション）
ActiveWindow.Zoom = 150
' Withステートメントを使用してcurrentSheetを指定
With ActiveSheet
' 保存先フォルダが存在しない場合は作成する
If Dir(saveFolderPath, vbDirectory) = "" Then
MkDir saveFolderPath
End If
For i = 0 To NUM_IMAGES - 1
Dim rng As Range
Dim picName As String
' オブジェクトの初期化
Set rng = rngArray(i)
picName = picNameArray(i)
' セル範囲を画像データでコピーする。
rng.CopyPicture
' 新しいChartObjectを作成し、保存する。
Set pic = .ChartObjects.Add(0, 0, rng.Width, rng.Height)
pic.Chart.Paste
pic.Chart.Export saveFolderPath & picName
' 作成完了後、ChartObjectを削除。
pic.Delete
Set pic = Nothing
Next i
End With
' ズームレベルを元に戻す（オプション）
ActiveWindow.Zoom = 70
End Sub
＜ 使用 Excel：Excel2019、使用 OS：Windows11 ＞
蛇足ながら、勝手に自学ノート晒しておきます。 (以前にも似たようなモノを晒してるやも知れません ^^;)
クリップボードに画像(ビットマップと認識できる情報)が来ていればPNGファイルに保存する実験コードです。 オートシェイプをアルファ(透明度)維持したままpngに保存したい時とかに使ってます。
Option Explicit
Rem ■参考文献==================================================================================================
Rem GitHub -takanaweb5 / IconEditor: EXCELでアイコンを作成するツール
Rem https://github.com/takanaweb5/IconEditor
Rem BMPファイルのフォーマット
Rem http://www5d.biglobe.ne.jp/~noocyte/Programming/Windows/BmpFileFormat.html
Rem ▼API宣言===================================================================================================
#If False Then 'VBEにEnum定数名の大文字・小文字を認識させる為の対処
Dim ImageLockMode
Const ImageLockModeRead = 1
Const ImageLockModeWrite = 2
Const ImageLockModeUserInputBuf = 4
Dim PixelFormat
Const PixelFormat1bppIndexed = &H30101
Const PixelFormat4bppIndexed = &H30402
Const PixelFormat8bppIndexed = &H30803
Const PixelFormat16bppGreyScale = &H101004
Const PixelFormat16bppRGB555 = &H21005
Const PixelFormat16bppRGB565 = &H21006
Const PixelFormat16bppARGB1555 = &H61007
Const PixelFormat24bppRGB = &H21808
Const PixelFormat32bppRGB = &H22009
Const PixelFormat32bppARGB = &H26200A
Const PixelFormat32bppPARGB = &HE200B
Const PixelFormat48bppRGB = &H10300C
Const PixelFormat64bppARGB = &H34400D
Const PixelFormat64bppPARGB = &H1C400E
#End If
Rem ▽クリップボード関係----------------------------------------------------------------------------------------
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
'Private Const CF_TEXT = 1& 'テキスト形式のデータ。各行は復帰改行(CR-LF)コードで終わる
Private Const CF_BITMAP = 2& 'ビットマップのデータ(HBITMAP)
'Private Const CF_METAFILEPICT = 3& 'メタファイル画像形式。METAFILEPICT構造体のメモリオブジェクト
'Private Const CF_SYLK = 4& 'Microsoftシンボリックリンク(SYLK)形式のデータ
'Private Const CF_DIF = 5& 'SoftwareArts社のDIFデータ交換形式
'Private Const CF_TIFF = 6& 'TIFF形式の画像データ
'Private Const CF_OEMTEXT = 7& 'OEM文字セットの文字を持つテキスト形式データ
'Private Const CF_DIB = 8& 'BITMAPINFO構造体とビットマップビットからなるメモリオブジェクト
'Private Const CF_PALETTE = 9& 'カラーパレットのハンドル
'Private Const CF_PENDATA = 10& 'Windowsのペン拡張機能のためのデータ
'Private Const CF_RIFF = 11& 'RIFF形式の音声データ
'Private Const CF_WAVE = 12& 'WAVE形式の音声データ
'Private Const CF_UNICODETEXT = 13& 'Unicodeのテキスト形式
'Private Const CF_ENHMETAFILE = 14& '拡張メタファイルのデータです(HENHMETAFILE)
'Private Const CF_FILES = 15& 'FILES
'Private Const CF_HDROP = 15& 'HDROP型
'Private Const CF_LOCALE = 16& 'テキストデータのロケールIDハンドル
'Private Const CF_DIBV5 = 17& 'BITMAPV5HEADER構造体の後にビットマップの色空間情報とビットマップビットが続くメモリオブジェクト
'Private Const CF_OWNERDISPLAY = &H80& 'オーナー表示形式
'Private Const CF_DSPTEXT = &H81& 'プライベートな形式のテキストデータ
'Private Const CF_DSPBITMAP = &H82& 'プライベートな形式のビットマップデータ
'Private Const CF_DSPMETAFILEPICT = &H83& 'プライベートな形式の拡張メタファイルデータ
'Private Const CF_DSPENHMETAFILE = &H8E& 'プライベートな形式の拡張メタファイルデータ
Rem ▽デバイスコンテキスト関係----------------------------------------------------------------------------------
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
'Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Rem ▽DIBit関係-------------------------------------------------------------------------------------------------
'Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Type BITMAPINFOHEADER
biSize As Long 'この構造体のサイズ (バイト数)
biWidth As Long 'ビットマップの幅 (画素数) biCompression が BI_JPEG または BI_PNG の場合 biWidth は解凍された JPEG または PNG 画像の幅を表す
biHeight As Long 'ビットマップの高さ (画素数)
' biHeight>0 ならボトムアップDIBで原点は左下隅。biHeight<0 ならトップダウンDIBで原点は左上隅。
' トップダウン DIB の場合 biCompression は BI_RGB または BI_BITFIELDS でなければならず圧縮はできない
' biCompression が BI_JPEG または BI_PNG の場合 biWidth は解凍された JPEG または PNG 画像の高さを表す
biPlanes As Integer 'ターゲット・デバイスのプレーンの枚数(1でなければならない)
biBitCount As Integer '１画素当たりのビット数 (Bits-Per-Pixel，BPP)
biCompression As Long 'ビットマップの圧縮方式を指定する トップダウン DIB は圧縮できない
biSizeImage As Long 'ビットマップデータのサイズ (バイト数) BI_RGB(非圧縮形式) の場合は0でもよい
' BI_JPEG または BI_PNG の場合 biSizeImage はそれぞれ JPEG または PNG の画像バッファのサイズを示す
' 0やデタラメな値が入っていることがあるので アテにしてはいけない
' BI_RGB や BI_BITFIELDS の場合biSizeImage の正しい値は biWidth，biHeight，biBitCount から計算できるのでこの値を使う必要はない
biXPelsPerMeter As Long 'ターゲット・デバイスの水平および垂直解像度 (単位は画素数/ｍ)
biYPelsPerMeter As Long ' アプリケーションはこれらの値を リソースグループの中からデバイスに最適なビットマップを選択するために使用してもよい
biClrUsed As Long 'ビットマップが実際に使用するカラーテーブルのエントリ数
' biClrUsed=0 の場合ビットマップは biBitCount に対応する最大色数を使用する
' biClrUsed>0 かつ biBitCount<16 の場合biClrUsed は実際に使用される色数
' biBitCount>=16 の場合biClrUsed はシステムカラーパレットの性能を最適化するのに用いられるカラーテーブルのサイズ
' biBitCount=16 または 32 の場合最適カラーパレットは３つの DWORD マスクの直後から始まる
biClrImportant As Long 'ビットマップを表示するのに必要な色数 (<=カラーテーブルのエントリ数)0ならばすべての色が必要(常に0を設定しておけばよし)
End Type
'Private Type RGBQUAD
' rgbBlue As Byte '青の輝度
' rgbGreen As Byte '緑の輝度
' rgbRed As Byte '赤の輝度
' rgbReserved As Byte '予約(常に0)
'End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
' bmiColors As RGBQUAD '当モジュールでは使わんので省略
End Type
Private Declare PtrSafe Function GetDIBits Lib "gdi32" (ByVal aHDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
'Private Declare PtrSafe Function SetDIBits Lib "gdi32" (ByVal hDC As LongPtr, ByVal hBitmap As LongPtr, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Const DIB_RGB_COLORS = 0&
'Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hDC As LongPtr, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
'Rem ▽IPicture作成----------------------------------------------------------------------------------------------
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
'Private Type PicBmp
' Size As Long
' Type As Long
' hBmp As LongPtr
' hPal As LongPtr
' Reserved As Long
'End Type
'Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
'Private Const vbPicTypeBitmap = 1&
''Private Const IID_IPictureDisp As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
'Rem ▽CopyImage-------------------------------------------------------------------------------------------------
'Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
'Private Const IMAGE_BITMAP = 0&
'Private Const LR_CREATEDIBSECTION = &H2000&
Rem ▽GDI+関係--------------------------------------------------------------------------------------------------
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Enum ImageLockMode
ImageLockModeRead = 1
ImageLockModeWrite = 2
ImageLockModeUserInputBuf = 4
End Enum
Private Type BITMAPDATA
Width As Long 'Bitmapオブジェクトの幅(ピクセル単位)を取得または設定します。これを1つのスキャンラインのピクセル数と考えることもできます。
Height As Long 'Bitmapオブジェクトの高さ(ピクセル単位)を取得または設定します。スキャンラインの数を指す場合もあります。
stride As Long 'Bitmapオブジェクトのストライド幅 (スキャン幅とも呼ばれる)を取得または設定します。
' ストライドは、1行のピクセル(スキャンライン)の幅で、4バイトの境界に切り上げられます。
' ストライドが正の場合、ビットマップは上から下に表示されます。
' ストライドが負の場合、ビットマップはボトムアップになります。
PixelFormat As Long 'このBitmapDataオブジェクトを返したBitmapオブジェクトに格納されているピクセル情報の形式を取得または設定します。
scan0 As LongPtr 'ビットマップ内の最初のピクセル データのアドレス。
Reserved As LongPtr '予約済み。使用しないでください。
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, ByRef scan0 As Any, ByRef nBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipBitmapSetResolution Lib "gdiplus" (ByVal pbitmap As LongPtr, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef RECT As Any, ByVal flags As Long, ByVal PixelFormat As Long, ByRef lockedBitmapData As Any) As Long
Private Declare PtrSafe Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As LongPtr, ByRef lockedBitmapData As Any) As Long
Private Enum PixelFormat
' PixelFormat1bppIndexed = &H30101 '1ピクセルあたり1ビットのインデックス付き。したがって、カラーテーブルには2色含まれています。
' PixelFormat4bppIndexed = &H30402 '1ピクセルあたり4ビットのインデックス付き。
' PixelFormat8bppIndexed = &H30803 '1ピクセルあたり8ビットのインデックス付き。したがって、カラーテーブルには256色含まれています。
' PixelFormat16bppGreyScale = &H101004 '1ピクセルあたり16ビット。このカラー情報は、65,536種類の灰色の濃淡を指定します。
' PixelFormat16bppRGB555 = &H21005 '1ピクセルあたり16ビット。赤緑青のコンポーネントに、それぞれ5ビットを使用します。残りのビットは使用されません。
' PixelFormat16bppRGB565 = &H21006 '1ピクセルあたり16ビット。そのうちの5ビットが赤のコンポーネント、6ビットが緑のコンポーネント、5ビットが青のコンポーネントに使用されることを指定します。
' PixelFormat16bppARGB1555 = &H61007 '1ピクセルあたり16ビット。このカラー情報は、32,768種類の色の濃淡を指定します。この情報の5ビットが赤、5ビットが緑、5ビットが青、1ビットがアルファです。
' PixelFormat24bppRGB = &H21808 '1ピクセルあたり24ビット。赤緑青のコンポーネントに、それぞれ8ビットを使用します。
PixelFormat32bppRGB = &H22009 '1ピクセルあたり32ビット。赤緑青のコンポーネントに、それぞれ8ビットを使用します。残りの8ビットは使用されません。
PixelFormat32bppARGB = &H26200A '1ピクセルあたり32ビット。アルファ、赤緑青のコンポーネントに、それぞれ8ビットを使用します。
' PixelFormat32bppPARGB = &HE200B '1ピクセルあたり32ビット。アルファ、赤緑青のコンポーネントに、それぞれ8ビットを使用します。アルファコンポーネントに応じて赤緑青のコンポーネントが事前乗算されます。
' PixelFormat48bppRGB = &H10300C '1ピクセルあたり48ビット。赤緑青のコンポーネントに、それぞれ16ビットを使用します。
' PixelFormat64bppARGB = &H34400D '1ピクセルあたり64ビット。アルファ、赤緑青のコンポーネントに、それぞれ16ビットを使用します。
' PixelFormat64bppPARGB = &H1C400E '1ピクセルあたり64ビット。アルファ、赤緑青のコンポーネントに、それぞれ16ビットを使用します。アルファコンポーネントに応じて赤緑青のコンポーネントが事前乗算されます。
End Enum
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, ByRef pCLSID As GUID) As Long
Private Const CLSID_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_GIF As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_TIF As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
TypeAPI As Long
Value As LongPtr
End Type
Private Type EncoderParameters
Count As Long
Parameter(0 To 15) As EncoderParameter
End Type
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, ByVal Filename As LongPtr, ByRef clsidEncoder As GUID, encoderParams As Any) As Long
'Private Declare PtrSafe Function GdipSaveImageToStream Lib "gdiplus" (ByVal image As LongPtr, ByVal Stream As LongPtr, ByRef clsidEncoder As GUID, ByVal encoderParams As LongPtr) As Long
'Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" (ByVal Filename As LongPtr, ByRef image As LongPtr) As Long
Private Declare PtrSafe Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As LongPtr, ByRef image As LongPtr) As Long
Private Declare PtrSafe Function CreateStreamOnHGlobal Lib "ole32" (ByVal hGlobal As LongPtr, ByVal fDeleteOnRelease As Long, ppstm As Any) As Long
'Private Declare PtrSafe Function GetHGlobalFromStream Lib "ole32" (ByVal Stream As IUnknown, ByRef hGlobal As LongPtr) As Long
Rem ▼その他変数・定数==========================================================================================
'Private Type typeINT32
' Value As Long
'End Type
'Private Type typeCOLORREF '0x00BBGGRR (COLORREF値 [Windows GDI]でRGB色を指定するDWORD値)
' Red As Byte ' [OLE_COLOR]ってのは、このCOLORREF値か
' Green As Byte ' あるいは
' Blue As Byte ' 0x800000ii (iiは有効なGetSysColorインデックス)
' NoData As Byte ' で表現されるシステムカラー。っていう定義
'End Type
Private Type typeARGB '0xAARRGGBB (ARGB値 [.NET Framework]のColor構造体)
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Rem ▼サブルーチン==============================================================================================
Private Function GetBmpfromClipboard() As LongPtr
If IsClipboardFormatAvailable(CF_BITMAP) = 0 Then Exit Function
If OpenClipboard(0&) <> 0 Then
GetBmpfromClipboard = GetClipboardData(CF_BITMAP)
Call CloseClipboard
End If
End Function
Private Function GetPngfromClipboard() As LongPtr
Dim CF_PNG As Long
CF_PNG = RegisterClipboardFormat("PNG")
If IsClipboardFormatAvailable(CF_PNG) = 0 Then Exit Function
If OpenClipboard(0&) <> 0 Then
GetPngfromClipboard = GetClipboardData(CF_PNG)
Call CloseClipboard
End If
End Function
Private Function CreateBmpByARGB(pxARGB() As typeARGB, PixelFormat As Long) As LongPtr
Dim pxWidth As Long, pxHeight As Long, hImg As LongPtr
pxWidth = UBound(pxARGB, 1)
pxHeight = UBound(pxARGB, 2)
If GdipCreateBitmapFromScan0(pxWidth, pxHeight, 0, PixelFormat32bppARGB, ByVal 0, hImg) = 0 Then
Call GdipBitmapSetResolution(hImg, 96!, 96!) 'Win標準DPIにリテラル設定
Dim BmpData As BITMAPDATA
With BmpData
.Width = pxWidth
.Height = pxHeight
.PixelFormat = PixelFormat32bppARGB
.scan0 = VarPtr(pxARGB(1, 1))
.stride = pxWidth * 4
End With
Call GdipBitmapLockBits(hImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeWrite, PixelFormat, BmpData)
Call GdipBitmapUnlockBits(hImg, BmpData)
CreateBmpByARGB = hImg
End If
End Function
Private Sub SaveToFile(hImg As LongPtr, Filename As String, Optional ByVal jpgQuarity As Long = 85)
Dim fGUID As GUID, p As EncoderParameters 'web用画像の↑一般最適値
Select Case UCase$(CreateObject("Scripting.FilesystemObject").GetExtensionName(Filename))
Case "JPG"
Call CLSIDFromString(StrPtr(CLSID_JPG), fGUID)
If jpgQuarity > 100 Then jpgQuarity = 100 '100超えてたら上限値に補正する
If jpgQuarity < 1 Then jpgQuarity = 85 'ゼロ以下は省略したものとみなす
p.Count = 1
With p.Parameter(0)
Call CLSIDFromString(StrPtr(QUALITY_PARAMS), .GUID)
.TypeAPI = 4
.NumberOfValues = 1
.Value = VarPtr(jpgQuarity)
End With
Case "TIF": Call CLSIDFromString(StrPtr(CLSID_TIF), fGUID)
Case "GIF": Call CLSIDFromString(StrPtr(CLSID_GIF), fGUID)
Case "BMP": Call CLSIDFromString(StrPtr(CLSID_BMP), fGUID)
Case Else: Call CLSIDFromString(StrPtr(CLSID_PNG), fGUID) '他は何でもPNGで保存
End Select
If p.Count Then
Call GdipSaveImageToFile(hImg, StrPtr(Filename), fGUID, p)
Else
Call GdipSaveImageToFile(hImg, StrPtr(Filename), fGUID, ByVal 0&)
End If
End Sub
Private Function GetARGBofBmp(ByVal hBmp As LongPtr) As typeARGB()
Const BI_RGB = 0&
Dim Rtn As Long, pxWidth As Long, pxHeight As Long
Dim bi As BITMAPINFO
Dim hDC As LongPtr ', hOld As LongPtr
Dim pxARGB() As typeARGB, r As Long, c As Long, vRGB() As Variant
hDC = CreateCompatibleDC(0&)
bi.bmiHeader.biSize = Len(bi.bmiHeader)
Rtn = GetDIBits(hDC, hBmp, 0&, 0&, ByVal 0&, bi, DIB_RGB_COLORS)
' hOld = SelectObject(hDC, hBmp)
With bi.bmiHeader
pxWidth = .biWidth
pxHeight = Abs(.biHeight)
.biHeight = -pxHeight 'トップダウン走査
.biPlanes = 1 '１でなければならない
.biBitCount = 32 '32Bit
.biCompression = BI_RGB
.biSizeImage = 0 'BI_RGB(非圧縮形式) の場合は0でよい
End With
ReDim pxARGB(1 To pxWidth, 1 To pxHeight)
Rtn = GetDIBits(hDC, hBmp, 0&, pxHeight, pxARGB(1, 1), bi, DIB_RGB_COLORS)
' Call SelectObject(hDC, hOld)
Call DeleteDC(hDC)
' If Rtn = 0 Then Exit Function
GetARGBofBmp = pxARGB
End Function
'Private Function HasAlphaCannel(pxARGB() As typeARGB) As Boolean
' Dim r As Long, c As Long
' For r = 1 To UBound(pxARGB, 1)
' For c = 1 To UBound(pxARGB, 2)
' If pxARGB(r, c).Alpha Then
' HasAlphaCannel = True
' Exit Function
' End If
' Next
' Next
'End Function
'Private Function IsOpaque(pxARGB() As typeARGB) As Boolean
' Dim r As Long, c As Long
' For r = 1 To UBound(pxARGB, 1)
' For c = 1 To UBound(pxARGB, 2)
' If pxARGB(r, c).Alpha <> &HFF& Then Exit Function
' Next
' Next
' IsOpaque = True
'End Function
Private Function NumberedFilename(Filename As String) As String
Dim i As Long, p As String, b As String, e As String, fn As String
With CreateObject("Scripting.FilesystemObject")
p = .GetParentFolderName(Filename)
b = .GetBaseName(Filename)
e = .GetExtensionName(Filename)
fn = .GetFileName(Filename)
i = 1
Do
NumberedFilename = .BuildPath(p, fn)
If Not .FileExists(NumberedFilename) Then Exit Do
i = i + 1
fn = b & Format$(i, " (0).") & e
Loop
End With
End Function
Rem ▼メソッド==================================================================================================
Sub クリップボートPNG保存()
Dim hPng As LongPtr, hBmp As LongPtr, i As LongPtr, savePath As String
savePath = Application.DefaultFilePath & "\Clipboard_" & Format$(Now, "yyyymmdd_hhnnss") & ".png"
hPng = GetPngfromClipboard ' PNG形式が来てればそれそのまま使うけど
If hPng = 0 Then '◆来てなかったら *****************************{
hBmp = GetBmpfromClipboard '| ビットマップ形式で再取得を試みる
If hBmp = 0 Then Exit Sub '| それも取れないなら「画像なし」との判断で終了
End If '}_____________________________________________/
Dim tkn As LongPtr, gi As GdiplusStartupInput
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
If hPng Then '◆PNG形式で取れてれば *************************************{
Dim Stream As IUnknown '| ストリームからイメージをそのまま取得
If CreateStreamOnHGlobal(ByVal hPng, 0, Stream) = 0 Then Call GdipLoadImageFromStream(ObjPtr(Stream), i)
Else '◆取れてなければ ------------------------------------------+
Dim px() As typeARGB, pxfmt As Long '|
pxfmt = PixelFormat32bppRGB '| 一旦、基本フォーマットを[透過無し]に設定しておき
px = GetARGBofBmp(hBmp) '| ビットマップから各ピクセル情報を採取して
' If HasAlphaCannel(px) Then '| ◆アルファ値が含まれている場合で ****************{ '←需要無いから実装からは外す
' If IsOpaque(px) Then '| | そもそもアルファ値が全フルか
' pxfmt = PixelFormat32bppARGB '| | ユーザーがアルファチャンネルの維持を選択したら
' ElseIf MsgBox("ビットマップにアルファ値が混ざってます。" & vbCrLf & "往々にして邪魔なので無視しますか?", vbYesNo + vbQuestion) = vbNo Then
' pxfmt = PixelFormat32bppARGB '| | フォーマットを[透過有り]に再設定し
' End If '| |
' End If '| }________________________________________________/
i = CreateBmpByARGB(px, pxfmt) '| 設定フォーマットに従ってイメージを生成
End If '}__________________________________________________________/
If i <> 0 Then '◆イメージが取れていれば *********************{
savePath = Application.GetSaveAsFilename(savePath, "PNG 形式,*.png,JPEG 形式,*.jpg,TIF 形式,*.tif,GIF 形式,*.gif,Windows ビットマップ,*.bmp")
If savePath <> "False" Then '| ◆保存先が指定されれば ***************{
savePath = NumberedFilename(savePath) '| | 上書き防止措置して
SaveToFile i, savePath '| | ファイルに保存
End If '| }_____________________________________/
Call GdipDisposeImage(i) '|
End If '}_____________________________________________/
Call GdiplusShutdown(tkn)
End Sub
（白茶） 2024/01/25(木) 12:24:35
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.