Visual Basic 中学校 掲示板 投稿内容
タグのない投稿を抽出 統計 RSS

Visual Basic 中学校 > 投稿一覧 >

VBAでワークシート部分のgetpixelしたいです 解決済み

タグの編集...

投稿者 snowmansnow   (社会人)   投稿日時 2021/6/5 16:53:14
VBAのピクセルの色で質問があります。
エクセルのワークシート部分(クライアント領域?)に画像を読み込んだり、
セルに色を付けたり、絵を描いた状態で、
指定のピクセルの色を取得する方法は、ありますか?
エクセルのデバイスコンテキストを取得して、GETPXELをしても
-1にしかならなくて、
(https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1387601913と同様。)
参考のURLもリンクが切れていて確認できませんでした・・・
Formのloadpictureではpngはエラーになりますが、
ActiveSheet.Pictures.Insert(〇×)では、pngを貼り付けられます。
貼り付けた画像部分のgetpixelをするvbaは可能ですか?
netでクラスライブラリではpngのgetpixelは実現できたのですが、
vbaで実現してみたいです。
よろしくお願いします。


投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/5 21:21:38
> エクセルのデバイスコンテキストを取得して、GETPXELをしても-1にしかならなくて、
GETPXEL というのは、GDI API の
GetPixel のことでしょうか?
' COLORREF GetPixel( HDC hdc, int x, int y ); 
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As LongByVal y As LongAs Long
https://excel.syogyoumujou.com/memorandum/get_bmp.html

こちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
現象を再現可能な実際のコードを提示できますか?


> netでクラスライブラリではpngのgetpixelは実現できたのですが、
.NET の System.Drawing 名前空間のほとんどは、
GDI+ の API を使って VBA から呼び出せます。

Bitmap.GetPixel メソッドなら、GdipBitmapGetPixel API です。
' GpStatus WINGDIPAPI GdipBitmapGetPixel(GpBitmap* bitmap, INT x, INT y, ARGB *color) 
Private Declare PtrSafe Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As LongPtr, ByVal x As LongByVal y As LongByRef color As LongAs Long


GDI の時はデバイコンテキストハンドルを指定しましたが、
GDI+ の時は Bitmap オブジェクトを指定します。といっても、他にも初期化処理や
解放処理など、いくつか手続きが必要なのですが…(どこかにサンプル無いかな)。
http://gdipluscode.sakura.ne.jp/gdip/gdip.html
https://excel.syogyoumujou.com/memorandum/without_picture.html

Excel の画面領域を撮影するのは、.NET なら Graphics.CopyFromScreen メソッドを
使うところですが、これは GDI+ API ではなく GDI の BitBlt API で実装されています。
ちなみに Graphics オブジェクトからデバイスコンテキストへの変換は、
GdipGetDC API です(解放は GdipReleaseDC)。

ただ… GDI+ の GdipBitmapGetPixel にせよ、GDI の GetPixel にせよ、
処理速度は比較的遅い処理となります。もしも高速に取得する必要がある場合には、
GDI なら GetDIBits API、GDI+ なら GdipCreateBitmapFromScan0 API を使う手があります。
ビットマップ データの構造を分かっていないと解析できないので、
GetPixel よりはコードが煩雑になりますけれどね。

投稿者 snowmansnow   (社会人)   投稿日時 2021/6/5 23:22:48
こんばんは魔界の弁士様。いつもありがとうございます。

①GETPXEL というのは、GDI API の
 GetPixel のことでしょうか?
 ⇒はい、そうです。
②こちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
 現象を再現可能な実際のコードを提示できますか?
 ⇒はい、何度も変更してたので、できるだけ元にもどしてみました。
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As LongByVal yPoint As LongAs Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongAs Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongByVal lpString As StringByVal cch As LongAs Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongByVal hdc As LongAs Long
Private Declare Function GetPixel Lib "gdi32.dll" _
 (ByVal hdc As LongPtr, ByVal nXPos As LongByVal nYPos As LongAs Long

Sub hdc2()

Dim color As Long
Dim hwnd As Long
Dim X As Long
Dim Y As Long
Dim hdc As Long

hwnd = WindowFromPoint(0, 0)
hdc = GetDC(hwnd)
If hdc = 0 Then
MsgBox "失敗しました。"
Else

Call GetWindowText(hwnd, Title, 20)
MsgBox Title

'https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1387601913 

For X = 1 To 100
For Y = 1 To 100
    color = GetPixel(hdc, X, Y)
    Cells(Y + 20, X).Value = color
Next
Next
'    Call ReleaseDC(0, hdc) 
   
Call ReleaseDC(hTargetWin, hdc)
End If
End Sub




③教えていただいた
 http://gdipluscode.sakura.ne.jp/gdip/gdip.html
 https://excel.syogyoumujou.com/memorandum/without_picture.html
 ⇒情報量が多くて、直ぐには見れなさそうです、明日以降拝見します。

④.NET の System.Drawing 名前空間のほとんどは、
  GDI+ の API を使って VBA から呼び出せます。
 ⇒net(c#)では、webのコードを参考に、私でも非常に簡単に出来ました。
using System;
using System.Drawing;
using System.Runtime.InteropServices;
using System.Net;

namespace GetpxelFormAppCS
{
    [Guid(Getp.ClassId)]
    public class Getp
    {
        //  COM用のGUID値
        public const string ClassId = "DC6E18DD-3731-4DC0-BC4F-4C64947E652A";
        
       public  string Getpxel(string fn, int x, int y)
        {
            //https://qiita.com/Tachibana446/items/31cdda5cac78cf571a04
            //https://www.atmarkit.co.jp/fdotnet/dotnettips/961dpiresolution/dpiresolution.html
            //
         
            System.Drawing.Bitmap bitmap;
            // ローカルファイルの場合
            bitmap = new Bitmap(fn);
       
            int w = bitmap.Width, h = bitmap.Height;

            Color pixel = bitmap.GetPixel(x-1, y-1);
            
            byte R = pixel.R; 
            byte G = pixel.G; 
            byte B = pixel.B;

            long color = R * 256 * 256 + G * 256 + B;
            double height = color * 0.01;

            bitmap.Dispose();
            return R + ";" + G + ";" + B + ";" + color + ";" + w + ";" + h + ";" + height;
            
        }
}


こんな感じで、クラスライブラリ呼び出ししております。
これを、勉強を兼ねて、VBAで、出来たらなぁと思っております。

投稿者 snowmansnow   (社会人)   投稿日時 2021/6/6 00:02:56
こんばんは、魔界の仮面弁士様
③教えていただいたwebなど見てみました
まだAPIが良くわかっておらず
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As LongAs Long
  Dim pSrcBmp As Long, pDstBmp As Long
  Dim color As Long
' GpStatus WINGDIPAPI GdipBitmapGetPixel(GpBitmap* bitmap, INT x, INT y, ARGB *color) 
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As LongPtr, ByVal x As LongByVal y As LongByRef color As LongAs Long

Sub MacroGDIP()

   GdipCreateBitmapFromFile "E:\hogehoge\TEST.png", pSrcBmp
   GdipBitmapGetPixel pSrcBmp, 200, 200, color
   
   MsgBox color
 
 End Sub


という感じかなぁ?と思いましたが、答えは0になってしまいました・・・
どの辺が間違っているのでしょうか?


投稿者 snowmansnow   (社会人)   投稿日時 2021/6/6 07:43:23
おはようございます。魔界の弁士様。
初期化とかが必要と書いて頂いてましたので、修正しました
'GDI+開始 
Private Declare Function GdiplusStartup Lib "gdiplus" (token As Long, pInput As GdiplusStartupInput, _
        pOutput As Any) As Long
'GDI+終了 
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal token As Long)

'Image削除 
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongAs Long
'Imageの寸法取得 
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As LongAs Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As LongAs Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As LongAs Long
' GpStatus WINGDIPAPI GdipBitmapGetPixel(GpBitmap* bitmap, INT x, INT y, ARGB *color) 
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As LongPtr, ByVal x As LongByVal y As LongByRef color As LongAs Long
Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
Private Type PICTDESC
    cbSizeofStruct As Long
    picType As Long
    hbitmap As Long
    hpal As Long
    unused_wmf_yExt As Long
End Type
  Dim pDstBmp As Long
  Dim color As Long
   Dim pd As PICTDESC
    Dim lngToken  As Long
    Dim udtInput  As GdiplusStartupInput
    Dim pSrcBmp   As Long
    Dim lngWidth  As Long, lngHeight As Long

    Dim fn As String
    Dim R As Long
    Dim G As Long
    Dim B As Long
    Dim c1 As Long
    Dim c2 As Long
    Dim color1 As Long
    
Sub MacroGDIP()
   fn = "E:\HOGEHOGE\TEST.png"
 ' 初期化 
    udtInput.GdiplusVersion = 1
    If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
        MsgBox "a1"
    End If
    ' 画像の読みこみ 
    If GdipCreateBitmapFromFile(ByVal StrPtr(fn), pSrcBmp) <> 0 Then
        GdiplusShutdown lngToken
        MsgBox "a2"
    End If
   
   
    ' 元画像サイズの取得 
    GdipGetImageWidth pSrcBmp, lngWidth
    GdipGetImageHeight pSrcBmp, lngHeight

   Call GdipBitmapGetPixel(pSrcBmp, 199, 199, color)
    
    R = Int(color / 256 / 256)
    G = Int(color / 256) Mod 256
    B = color Mod 256
    
    'ここが良くわかりませんでした。 
    R = R + 256
    G = G + 256
    B = B + 256
    h = R * 256 * 256 + G * 256 + B
    
    MsgBox R & ";" & G & ";" & B & ";" & lngWidth & ";" & lngHeight & ";" & h

 
 End Sub


一応、クラスライブラリと値が同じになったのですが、
COLORが最初、マイナスになってしまいます。


投稿者 snowmansnow   (社会人)   投稿日時 2021/6/6 15:28:49
こんにちは、魔界の仮面弁士様
当初のワークシートのgetpixelがうまくいきません。
幅と高さは、取れてそうですが、色がおかしいです・・・
Private Const CF_BITMAP   As Long = 2

' // GDI+関係 
Private Declare Function GdiplusStartup Lib "gdiplus" ( _
        ByRef token As Long, _
        ByRef inputBuf As GdiplusStartupInput, _
        ByVal outputBuf As LongAs Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
        ByVal token As Long)
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" ( _
        ByVal hbm As Long, _
        ByVal hpal As Long, _
        ByRef bitmap As LongAs Long
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
        ByVal image As LongAs Long
'Imageの寸法取得 
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As LongAs Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As LongAs Long
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As LongPtr, ByVal x As LongByVal y As LongByRef color As LongAs Long

Private Type GdiplusStartupInput
        GdiplusVersion           As Long    ' UINT32 GdiplusVersion 
        DebugEventCallback       As Long    ' DebugEventProc DebugEventCallback 
        SuppressBackgroundThread As Long    ' BOOL SuppressBackgroundThread 
        SuppressExternalCodecs   As Long    ' BOOL SuppressExternalCodecs 
End Type
Private Type GUID
        Data1                    As Long    ' unsigned long Data1 
        Data2                    As Integer ' unsigned short Data2 
        Data3                    As Integer ' unsigned short Data3 
        Data4(7)                 As Byte    ' unsigned char Data4[8] 
End Type

Sub Sample()
    Dim shp    As Shape
    Dim hBmp   As OLE_HANDLE
        ' GDI+ を初期化する 
    If GDIplus_Initialize() = False Then
        MsgBox "GDI+ を初期化できません", vbCritical
        Exit Sub
    End If
    
        ActiveSheet.Pictures.Insert( _
        "C:\hogehoge\TEST.png").Select
    Selection.ShapeRange.Left = 0
    Selection.ShapeRange.Top = 0

    Range(Cells(1, 1), Cells(12, 5)).Select
    Call Selection.CopyPicture(xlScreen, xlBitmap)
    hBmp = pvGetHBitmapFromClipboard()
    
    If hBmp = 0 Then
    MsgBox "a3"
    End If
    Ret = GdipCreateBitmapFromHBITMAP(hBmp, 0&, GdipBmpHdl)
    GdipGetImageWidth GdipBmpHdl, lngWidth
    GdipGetImageHeight GdipBmpHdl, lngHeight

  Call GdipBitmapGetPixel(GdipBmpHdl, 0, 0, color)

    R = Int(color / 256 / 256)
    G = Int(color / 256) Mod 256
    B = color Mod 256
    h = R * 256 * 256 + G * 256 + B

    MsgBox R & ";" & G & ";" & B & ";" & lngWidth & ";" & lngHeight & ";" & h
    
    Call Gdiplus_Shutdown
End Sub

' // GDI+ 初期化 
Private Function GDIplus_Initialize() As Boolean
    Dim uGdiStartupInput As GdiplusStartupInput
    Dim nStatus          As Long
  
    If m_GDIplusToken Then Call Gdiplus_Shutdown
    With uGdiStartupInput
        .GdiplusVersion = 1
        .DebugEventCallback = 0
        .SuppressBackgroundThread = 0
        .SuppressExternalCodecs = 0
    End With
    nStatus = GdiplusStartup(m_GDIplusToken, uGdiStartupInput, 0&)
    GDIplus_Initialize = CBool(nStatus = 0)
End Function

' // GDI+ 終了 
Private Function Gdiplus_Shutdown() As Long
    If m_GDIplusToken Then
        Call GdiplusShutdown(m_GDIplusToken)
        m_GDIplusToken = 0
    End If
End Function

' // クリップボード hBitmap を取得する 
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
    If OpenClipboard(0&) <> 0 Then
        pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
        Call CloseClipboard
    Else
        pvGetHBitmapFromClipboard = 0
    End If
End Function


白黒画像?とかになってるのでしょうか?
色が4固定になってしまいます。・・




投稿者 (削除されました)   ()   投稿日時 2021/6/6 18:00:40
(削除されました)

投稿者 (削除されました)   ()   投稿日時 2021/6/6 18:01:21
(削除されました)

投稿者 (削除されました)   ()   投稿日時 2021/6/6 18:01:54
(削除されました)

投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/6 18:39:36
> こんばんは魔界の弁士様。
> こんばんは、魔界の仮面弁士様
> おはようございます。魔界の弁士様。
> こんにちは、魔界の仮面弁士様

「魔界の仮面弁士」です…。

回答が遅くなりました。
沢山投稿していただいたので、順に回答していきます。


[2021/6/5 16:53:14]への返信
> VBAのピクセルの色で質問があります。
Excel ワークシートの色ということなので、
ここでいう VBA とは、Excel の VBA という事で良いのですよね。

質問時には明記されていませんでしたが、お使いの Office バージョンは何ですか?
https://support.microsoft.com/ja-jp/office/932788b8-a3ce-44bf-bb09-e334518b8b19?WT.mc_id=DT-MVP-8907&ui=ja-JP&rs=ja-JP&ad=JP

2010 以降かつ 32bit 版であろうという点までは推察できますが、手元の環境は
64bit 版なので、頂いたコードを手直ししないとコンパイルすら通らないです…。


凡例:🔸サポート期限切れ/🔷サポート期間内

🔸Office 2007 … 32bit 版のみ
🔸Office 2010 … 32bit/64bit 版の 2種類(通常は 32bit 版がインストールされる)
 条件付き定数 VBA7 と Win64 、PtrSafe キーワードなどが追加された最初のバージョン。
🔷Excel 2012/2013/2016 … 32bit/64bit 版の 2種類が存在。
 特に指定しなければ 32bit 版がインストールされる。
🔷Excel 2019 (現行の 365) … 32bit/64bit 版の 2種類が存在。
 特に指定しなければ 64 bit 版がインストールされる。



[2021/6/5 23:22:48]への返信
> hwnd = WindowFromPoint(0, 0)
> hdc = GetDC(hwnd)
> If hdc = 0 Then
> MsgBox "失敗しました。"
> Else
取得失敗を判定するなら、Exit Sub するなり Err.Raise するなりした方が良いでしょう。
今のコードだと、hdc の取得が失敗したときにも処理を続行して、
GetPixel や ReleaseDC を呼び出してしまいます。


で…そもそもデバイスコンテキストを取得処理に問題があります。

0,0 位置に Excel のワークシート領域があるとは限りませんし、
仮に Excel が最大化されていたとしても、
 hwnd = WindowFromPoint(0, 0)
で得られる値は、Excel VBA の Application.Hwnd プロパティと変わりません。

しかもそれはワークシート領域を指すウィンドウのハンドルではありませんし、
そこから GetDC しても、求める色は得られないでしょう。

代わりに「hDC = GetDC(ByVal CLngPtr(0))」を試してみてください。
あるいは CreateDC で "DISPLAY" のコンテキストを得るようにします。

例えばこんな感じ。[ページレイアウト]-[背景]で挿入した画像の色を取得できています。


Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function CreateDCW Lib "gdi32" (ByVal pwszDriver As LongPtr, ByVal pwszDevice As LongPtr, ByVal pszPort As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal nXPos As LongByVal nYPos As LongAs OLE_COLOR
#Else
Private Declare PtrSafe Function CreateDCW Lib "gdi32" (ByVal pwszDriver As OLE_HANDLE, ByVal pwszDevice As OLE_HANDLE, ByVal pszPort As OLE_HANDLE) As OLE_HANDLE
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As OLE_HANDLE) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal nXPos As LongByVal nYPos As LongAs OLE_COLOR
#End If

Public Function GetColor(x&, y&) As OLE_COLOR
#If VBA7 Then
    Dim hDC As LongPtr
    hDC = CreateDCW(StrPtr("DISPLAY"), 0, 0)
#Else
    Dim hDC As OLE_HANDLE
    hDC = CreateDCW(ByVal StrPtr("DISPLAY"), ByVal 0&, ByVal 0&)
#End If
    If 
    GetColor = GetPixel(hDC, x, y)
    DeleteDC hDC
End Function


上記はスクリーン全体が対象となるため、Excel 以外のデスクトップ領域も対象となります。
ワークシート左上の座標を取得したい場合には、A1 セルが左上に表示された状態にして
 x = ActiveWindow.PointsToScreenPixelsX(0)
 y = ActiveWindow.PointsToScreenPixelsY(0)
で求めることが出来ます。


> ⇒net(c#)では、
net ではなく .NET (ドットネット) ですよ。
ポータルサイトの URL も https://dot.net/ ですし。

また、「c#」ではなく 「C#」と書きます。
JIS X 3015 の規格 (および ECMA-334) において、次のように定められていますので。
>> C#は,“しーしゃーぷ”と発音する。 
>> C#は,LATIN CAPITAL LETTER C (U+0043)の次に NUMBER SIGN # (U+0023)を書く。 


> Alias "GetWindowTextA"
GetWindowTextW などの Wide 系 API にすることで、Shift_JIS にない文字列にも対応できます。
(Win9x 系が駆逐された今、ANSI 系 API でなければならない理由はほとんど無いはず)

> webのコードを参考に、私でも非常に簡単に出来ました。
> // ローカルファイルの場合
> bitmap = new Bitmap(fn);
そのコードは、画像ファイルの画素を取り出すものであって、肝心の
Excel ワークシート部分の画素を取り出すものではないですよね。

ワークシート部分を fn で示されたファイルに変換するためのコードはどうされましたか?

投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/6 18:40:17
[2021/6/6 07:43:23]への返信
> 初期化とかが必要と書いて頂いてましたので、修正しました
GdipCreateBitmapFromFile が失敗したときにしか GdiplusShutdown が呼びだされておらず、
GdipCreateBitmapFromFile が失敗したときにも GdipGetImageWidth を呼んでいますね。

ActiveX の場合と違って、API 利用時は手順を間違えるとリソースリークに繋がるので、
 MsgBox "a1"
 MsgBox "a2"
などの異常系に到達した場合の流れもきちんと作りこみましょう。


> Private Type PICTDESC
提示頂いたコードでは未使用のようですが、もしかして、
OleCreatePictureIndirect API 等を使おうとしている?

あと、Long と LongPtr の使い分けに統一感が無いので、そこも整理した方が良さそうです。


> COLORが最初、マイナスになってしまいます。
GetPixel API は 24bit な色空間 (COLORREF)を返しますが、
GdipBitmapGetPixel は 32bit な色空間 (ARGB) を返すためです。

不透明度(Alpha) が &H00~&H7F の範囲ならば正数となり、
&H80~&HFF であれば負数になります。
完全不透明な色の場合、Alpha 値は FF です。

透明な背景を持つ Gif 画像の場合や、
半透明部を持つ Png 画像の場合は正数を返す可能性があります。


> R = Int(color / 256 / 256)
> G = Int(color / 256) Mod 256
> B = color Mod 256
もっと単純に「Int(color / 256 / 256)」→「color \ 256 \ 256」で良いと思います。

また、COLORREF は 24bit なので問題無いですが、
ARGB や OLE_COLOR などの 32bit にも対応させる場合は、こう書けます。
Dim c As Long
c = &H13579BDF

'上記を「&H13」「&H57」「&H9B」「&HDF」に分解する 
c0 = ((c And &HFF000000) \ &H1000000) And &HFF&
c1 = (c And &HFF0000) \ &H10000
c2 = (c And &HFF00&) \ &H100&
c3 = c And &HFF&

' OLE_COLOR … 00BBGGRR な 24bit 色(もしくは 800000nn で管理されるシステム色) 
' COLORREF  … 00RRGGBB な 24bit 色 
' ARGB      … AARRGGBB な 32bit 色 



> 'ここが良くわかりませんでした。 
> R = R + 256
> G = G + 256
> B = B + 256
> h = R * 256 * 256 + G * 256 + B
この h は何を求めるためのコードですか?



[2021/6/6 15:28:49]への返信
> Ret = GdipCreateBitmapFromHBITMAP(hBmp, 0&, GdipBmpHdl)
HBITMAP から GpBitmap に変換するまでは良いのですが、
その後、GdipDisposeImage で解放するのを忘れていますよ。
後始末はきちんと行いましょう。


> 色が4固定になってしまいます。・・

color 変数の宣言を忘れているのではありませんか?
変数宣言漏れの場合、たとえば
 MsgBox Color
という処理を書いた場合に、
 MsgBox stdole.LoadPictureConstants.Color
の意味になるので、おそらくこれが「4」の原因かと推察します。

投稿者 (削除されました)   ()   投稿日時 2021/6/6 19:14:46
(削除されました)

投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/6 21:15:10
ごめんなさい。一部訂正します。

[2021/6/6 18:39:36]への訂正
>> #Else
>> Private Declare PtrSafe Function CreateDCW Lib ……

VBA7 未満での PtrSafe は余計でしたね。
取り除いておいてください。


[2021/6/6 18:40:17]への訂正と追記
> ' OLE_COLOR … 00BBGGRR な 24bit 色(もしくは 800000nn で管理されるシステム色) 
> ' COLORREF  … 00RRGGBB な 24bit 色 
> ' ARGB      … AARRGGBB な 32bit 色

書き間違い。orz
COLORREF は 00RRGGBB ではなく 00BBGGRR です!
(なので、ActiveCell.Interior.Color にもそのまま渡せます)

GetPixel の戻り値を意図的に As OLE_COLOR と書いたのも、
VB の 24bit 色と同じ並びであるからのことだったのに、我ながら何やってんだろう…。orz


> あと、Long と LongPtr の使い分けに統一感が無いので、そこも整理した方が良さそうです。

32bit 環境だと、Long も LongPtr も OLE_HANDLE も差が無いのですが、
64bit 環境だと意味合いが変わってきます。

自分の場合、VBA でハンドルやポインタを扱うときは
 VBA7 以降 … As LongPtr   (32bit なら As Long 相当、64bit なら As LongLong 相当)
 VBA7 未満 … As OLE_HANDLE (As Long と同義だが、意図的にこうしている)
で統一するようにしています。

なお、HBITMAP や HICON は void* 相当であるため、
Win32 では 32bit サイズ、Win64 では 64bit サイズですが、
OLE_HANDLE は Win32/Win64 いずれでも 32bit サイズなので注意。



投稿者 snowmansnow   (社会人)   投稿日時 2021/6/6 23:37:45
こんばんは、魔界の仮面弁士様。
また、お名前を間違えてごめんなさい。
最初の頃に、るきお様に注意されたのに、気を付けます。

VBAは、Excel の VBAです。
エクセルは、2016の32bit版です。OSはWIN1Oproの64bitです。
確認環境で、エクセルは、2016の64bit版(OSはWIN1Oproの64bit)も使用する場合がございます。

>取得失敗を判定するなら
取得失敗を判定は、MSGBOXが易しいので多用しております。気をつけます。

>あるいは CreateDC で "DISPLAY" のコンテキストを得るようにします。
CreateDC で "DISPLAY" のコンテキストは、なぜかエラーになってしまい、
>代わりに「hDC = GetDC(ByVal CLngPtr(0))」を試してみてください。
hDC = GetDC(ByVal CLngPtr(0))で、試してみました。
無事、色を取得できたようですが、
なぜか、RGBが逆さな気がしました。
また、元の貼り付けた画像のPIXELと違う気がしました。
 x = ActiveWindow.PointsToScreenPixelsX(0)
 y = ActiveWindow.PointsToScreenPixelsY(0)
 の、最初のPIXELの色は、合致してる事を確認できました。

>net ではなく .NET (ドットネット) ですよ。
>また、「c#」ではなく 「C#」と書きます。
net(c#)も
.NET、C#を使うように気をつけます。

>GetWindowTextW などの Wide 系 API にすること
GetWindowTextAも文字列が影響する事をしらなかったので、注意します。

>ワークシート部分を fn で示されたファイルに変換するためのコードはどうされましたか?
画像ファイルの画素を取り出すコードは、途中経過で、
今回の質問については、後述しております。

>異常系に到達した場合の流れもきちんと作りこみましょう。
最初、エラーに気が付かなくて、修正して作ったつもりでしたので、
ENDIFの位置に気を付けます。

>> Private Type PICTDESC
>提示頂いたコードでは未使用のようですが、もしかして、
引用したコードを精査しておりませんでした。未使用の定義でした。他意はございません。

>Long と LongPtr の使い分けに統一感が無い
64bitと32bitの使い分けが、まだはっきりわかっておらず、
また、2つの環境で使う予定な事と、PTRSAFEのような明確なエラーにならないので、
整理できておりませんでした、徐々に出来るようになりたいです。(まだ呪文)

>GdipBitmapGetPixel は 32bit な色空間 (ARGB) を返す
別なWEBでPNGの透明化に言及されておられましたが、気が付きませんでした。

>' OLE_COLOR … 00BBGGRR な 24bit 色(もしくは 800000nn で管理されるシステム色) 
>' COLORREF  … 00RRGGBB な 24bit 色 
>' ARGB      … AARRGGBB な 32bit 色 
先ほどの色が逆さの謎が解けました。

>この h は何を求めるためのコードですか?
国土地理院様の高度タイルのPNGから高度を求める途中式(100倍)です。

>GdipDisposeImage で解放するのを忘れていますよ。
>後始末はきちんと行いましょう。
気をつけます。

>color 変数の宣言を忘れているのではありませんか?
はい、定義しましたら、色が出てきました。
※WEBにUPする時に、文字制限に引っかかったので、クリップボード関係の定義を削除してしまいました

>VBA7 未満での PtrSafe は余計でしたね。
これ以外なのか、私の環境ではエラーになってしまいました・・・(上記)

>書き間違い。orz
>VB の 24bit 色と同じ並び
こんがらがっちゃいました(上記)

>VBA でハンドルやポインタを扱うときは
ハンドルは、(64bitの呪文を何かで拝見しました)。
ポインタは、まだよくわかりません。

>OLE_HANDLE は 
難しいですが、注意できるようになりたいです。


今回は、国土地理院タイルの、高度タイルの標高を求めたい所からスタートしました。
LOADPICTUREで、すぐ出来ると思ったのですが、色んな回り道をして、まだ、
ワークシート画像からは、高度を求める所まで行ってません。(pixelが違う気が・・・)
(クラスライブラリや、APIで直接PNGを扱った方が、今のところ、私は間違いないです)
クラスライブラリも、コードは容易でしたが、クラスライブラリも、コンソールアプリもダメで、
フォームアプリのクラスライブラリに到達するまで時間がかかりました。

GDI+を教えてもらって、やっぱりVBAは、まだまだ凄いなぁ、と思いました。
いっぱい指摘を受けましたが、大変勉強になりました。
クラスライブラリも好きですが、VBA単体で出来る事を増やしていきたいです。
大変ありがとうございました。
また宜しくお願いします。




投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/7 12:28:36
>> あるいは CreateDC で "DISPLAY" のコンテキストを得るようにします。
> CreateDC で "DISPLAY" のコンテキストは、なぜかエラーになってしまい、

ごめんなさい、先のサンプル色々間違いだらけですね。寝ぼけてたかな…。

正しくはこうです。32bit 版の Excel 2016 で動作することを確認済み。

Option Explicit

#If VBA7 Then
Private Declare PtrSafe Function CreateDCW Lib "gdi32" (ByVal pwszDriver As LongPtr, ByVal pwszDevice As LongPtr, ByVal pszPort As LongPtr, ByVal pdm As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal nXPos As LongByVal nYPos As LongAs OLE_COLOR
#Else
Private Declare Function CreateDCW Lib "gdi32" (ByVal pwszDriver As OLE_HANDLE, ByVal pwszDevice As OLE_HANDLE, ByVal pszPort As OLE_HANDLE, ByVal pdm As OLE_HANDLE) As OLE_HANDLE
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As OLE_HANDLE) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As OLE_HANDLE, ByVal nXPos As LongByVal nYPos As LongAs OLE_COLOR
#End If

Public Function GetColor(ByVal x As LongByVal y As LongAs OLE_COLOR
#If VBA7 Then
    Dim hDC As LongPtr, NullPtr As LongPtr
#Else
    Dim hDC As OLE_HANDLE, NullPtr As LongPtr
#End If
    NullPtr = 0
    hDC = CreateDCW(StrPtr("DISPLAY"), NullPtr, NullPtr, NullPtr)
    GetColor = GetPixel(hDC, x, y)
    DeleteDC hDC
End Function



> hDC = GetDC(ByVal CLngPtr(0))で、試してみました。
CLngPtr は Office 2010 以降で無いと使えないので、バージョン依存性を減らす場合は
#If ディレクティブの併用が必要ですね。


GetDC( ゼロ ) か CreateDCW("DISPLAY",...) に頼らない場合は、
下記の正攻法のルートになるのでしょうけれども、
これを VBA から呼び出すのはなかなかキツそうです。
https://qiita.com/eguo/items/90604787a6098af404d9


> 無事、色を取得できたようですが、
> なぜか、RGBが逆さな気がしました。
> 先ほどの色が逆さの謎が解けました。
混乱させてしまい申し訳ありません。先に訂正した通り、
GetPixel で得られる COLORREF は 0x00bbggrr の順です。
https://docs.microsoft.com/ja-jp/windows/win32/gdi/colorref

純赤の場合、HTML や CSS の世界だと #FF0000 で表現されますが、
VBA の vbRed や RGB(255, 0, 0) だと 0000FF になります。
GetPixel API も同様に 0000FF で返します。

純青の場合、HTML や CSS の世界だと #0000FF で表現されますが
VBA の vbBlue や RGB(0, 0, 255) だと FF0000 になります。
GetPixel API も同様に FF0000 で返します。

GDI+ の Bitmap.GetPixel メソッド(GdipBitmapGetPixel API)は、
透明度0%(不透明)の純赤なら FFFF0000、透明度75% なら 40FF0000
透明度0%(不透明)の純青なら FF0000FF、透明度75% なら 400000FF です。

Option Explicit

Private Type COLORREF
    R As Byte
    G As Byte
    B As Byte
    'Reserved As Byte 
End Type

Private Type DWORD
    Value As Long
End Type

Private Sub ColorTest()
    Dim c As COLORREF
    Dim d As DWORD

    d.Value = vbRed
    LSet c = d
    Debug.Print Hex(d.Value) 'FF 
    Debug.Print Hex(c.R), Hex(c.G), Hex(c.B) 'FF 0 0 

    d.Value = vbBlue
    LSet c = d
    Debug.Print Hex(d.Value) 'FF0000 
    Debug.Print Hex(c.R), Hex(c.G), Hex(c.B) '0 0 FF 

    d.Value = &HEDA96521
    LSet c = d
    Debug.Print Hex(d.Value) 'EDA96521 
    Debug.Print Hex(c.R), Hex(c.G), Hex(c.B) '21 65 A9 
End Sub


投稿者 魔界の仮面弁士   (社会人)   投稿日時 2021/6/7 12:29:23
> 今回は、国土地理院タイルの、高度タイルの標高を求めたい所からスタートしました。
ワークシートから得たいというのは二次的なもので、
スタートは画像ファイル(png)からだったのですね?

だったら WIA を使って png 画像から直接読み取った方が手っ取り早そう。


'Private Declare PtrSafe Function URLDownloadToFileW Lib "urlmon" (ByVal pCaller As IUnknown, ByVal szURL As LongPtr, ByVal szFileName As LongPtr, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) As Long 
'Private Declare Function URLDownloadToFileW Lib "urlmon" (ByVal pCaller As IUnknown, ByVal szURL As OLE_HANDLE, ByVal szFileName As OLE_HANDLE, ByVal dwReserved As Long, ByVal lpfnCB As OLE_HANDLE) As Long 
Private Sub Test()
    'URLDownloadToFileW Nothing, StrPtr("https://cyberjapandata.gsi.go.jp/xyz/relief/6/56/25.png"), StrPtr("D:\6_56_25.png"), 0, 0 

    ' wiaaut.dll を参照設定しておく 
    '  Microsoft Windows Image Acquisition Library v2.0 
    
    Dim objIF As WIA.ImageFile
    Set objIF = New WIA.ImageFile
    objIF.LoadFile "D:\6_56_25.png"

    'Set UserForm1.Picture = objIF.FileData.Picture 
    'UserForm1.Show 

    Dim h As Long, w As Long
    h = objIF.Height
    w = objIF.Width

    Dim vnt As Variant, rng As Excel.Range
    Set rng = Sheet1.Range("A1", Sheet1.Cells(h, w))
    vnt = rng.Value

    Dim vec As WIA.Vector
    Set vec = objIF.ARGBData

    Dim x As Long, y As Long
    For y = 1 To h
        For x = 1 To w
            vnt(y, x) = Right("00000000" & Hex(vec.Item(x + (y - 1) * w)), 8)
        Next
    Next
    rng.Value = vnt
End Sub


投稿者 snowmansnow   (社会人)   投稿日時 2021/6/8 23:05:17
こんばんは、魔界の仮面弁士様
追加の御教授ありがとうございます
WIAも10進数に変換して、
全て確認できました。
WIAは、初めて使いましたが、非常に簡便にコードが書け、勉強になりました。
他にも使えるか、勉強してみたいです。

<補足>
jhondoe様のtrail-noteに触発されて、
国土地理院様の地図タイルや、
高度(標高)タイルを
VBAで実現してみたいと思いました。
最初jsの関数をVBAから取得できないか試していたのですが、
まだうまくいってなくて
VBA単独で出来ないか、試していました。

http://www.trail-note.net/tech/coordinate/の式で、
①ハイパボリックタンジェントの逆関数をVBAに出来たら、
x、y座標を取得できて、
②PNGをDL出来て
③PNGの色を読み取れたら、
高度を取得できると、考えました。

①はWEBを参考に自分で、
②は
@notmushroom様などの
https://qiita.com/notmushroomを参考にDLできました。
残る③が、クラスライブラリでは実現できましたが、VBA単独で実現できず、
るきお様のところで、魔界の仮面弁士様の助けを借りて実現できました。
クラスライブラリか、APIか、WIAで取得できるようになりました。

Function piVBA() As Double
Dim pi As Double
piVBA = 4 * Atn(1)
End Function

Function atanhVBA(X As Double)
'http://tancro.e-central.tv/grandmaster/excel/vba-function-triangle.html 
  If X <= -1 Then
    atanhVBA = 0
  ElseIf X >= 1 Then
    atanhVBA = 0
  Else
    atanhVBA = 1 / 2 * Log((1 + X) / (1 - X))
  End If
End Function


で、①を実現できると思いますので、
サーチエンジンなどで、「国土地理院タイル」で、ここにたどり着いた人で、
VBAで、やってみたい方は、御覧になってみて下さい。