VBAでワークシート部分のgetpixelしたいです
投稿者 魔界の仮面弁士 (社会人)
投稿日時
2021/6/5 21:21:38
> エクセルのデバイスコンテキストを取得して、GETPXELをしても-1にしかならなくて、
こちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
現象を再現可能な実際のコードを提示できますか?
> netでクラスライブラリではpngのgetpixelは実現できたのですが、
.NET の System.Drawing 名前空間のほとんどは、
GDI+ の API を使って VBA から呼び出せます。
Bitmap.GetPixel メソッドなら、GdipBitmapGetPixel API です。
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 よりはコードが煩雑になりますけれどね。
GETPXEL というのは、GDI API の
GetPixel のことでしょうか?
GetPixel のことでしょうか?
' COLORREF GetPixel( HDC hdc, int x, int y );
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Longこちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
現象を再現可能な実際のコードを提示できますか?
> 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 Long, ByVal y As Long, ByRef color As Long) As LongGDI の時はデバイコンテキストハンドルを指定しましたが、
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 のことでしょうか?
⇒はい、そうです。
②こちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
現象を再現可能な実際のコードを提示できますか?
⇒はい、何度も変更してたので、できるだけ元にもどしてみました。
③教えていただいた
http://gdipluscode.sakura.ne.jp/gdip/gdip.html
https://excel.syogyoumujou.com/memorandum/without_picture.html
⇒情報量が多くて、直ぐには見れなさそうです、明日以降拝見します。
④.NET の System.Drawing 名前空間のほとんどは、
GDI+ の API を使って VBA から呼び出せます。
⇒net（ｃ#)では、webのコードを参考に、私でも非常に簡単に出来ました。
こんな感じで、クラスライブラリ呼び出ししております。
これを、勉強を兼ねて、VBAで、出来たらなぁと思っております。
①GETPXEL というのは、GDI API の
GetPixel のことでしょうか?
⇒はい、そうです。
②こちらでも確認してみたいので、デバイスコンテストの取得部分も含めて、
現象を再現可能な実際のコードを提示できますか?
⇒はい、何度も変更してたので、できるだけ元にもどしてみました。
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetPixel Lib "gdi32.dll" _
(ByVal hdc As LongPtr, ByVal nXPos As Long, ByVal nYPos As Long) As 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（ｃ#)では、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が良くわかっておらず
という感じかなぁ？と思いましたが、答えは0になってしまいました・・・
どの辺が間違っているのでしょうか？
③教えていただいたwebなど見てみました
まだAPIが良くわかっておらず
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As Long) As 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 Long, ByVal y As Long, ByRef color As Long) As 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
おはようございます。魔界の弁士様。
初期化とかが必要と書いて頂いてましたので、修正しました
一応、クラスライブラリと値が同じになったのですが、
COLORが最初、マイナスになってしまいます。
初期化とかが必要と書いて頂いてましたので、修正しました
'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 Long) As Long
'Imageの寸法取得
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (FileName As Any, bitmap As Long) 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 Long, ByVal y As Long, ByRef color As Long) As 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がうまくいきません。
幅と高さは、取れてそうですが、色がおかしいです・・・
白黒画像？とかになってるのでしょうか？
色が４固定になってしまいます。・・
・
当初のワークシートの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 Long) As 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 Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" ( _
ByVal image As Long) As Long
'Imageの寸法取得
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As LongPtr, ByVal x As Long, ByVal y As Long, ByRef color As Long) As 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
白黒画像？とかになってるのでしょうか？
色が４固定になってしまいます。・・
・
投稿者 (削除されました) ()
投稿日時
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" のコンテキストを得るようにします。
例えばこんな感じ。[ページレイアウト]-[背景]で挿入した画像の色を取得できています。
上記はスクリーン全体が対象となるため、Excel 以外のデスクトップ領域も対象となります。
ワークシート左上の座標を取得したい場合には、A1 セルが左上に表示された状態にして
x = ActiveWindow.PointsToScreenPixelsX(0)
y = ActiveWindow.PointsToScreenPixelsY(0)
で求めることが出来ます。
> ⇒net（ｃ#)では、
net ではなく .NET (ドットネット) ですよ。
ポータルサイトの URL も https://dot.net/ ですし。
また、「ｃ#」ではなく 「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/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 Long, ByVal nYPos As Long) As 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 Long, ByVal nYPos As Long) As 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（ｃ#)では、
net ではなく .NET (ドットネット) ですよ。
ポータルサイトの URL も https://dot.net/ ですし。
また、「ｃ#」ではなく 「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 にも対応させる場合は、こう書けます。
> 'ここが良くわかりませんでした。
> 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 で解放するのを忘れていますよ。
後始末はきちんと行いましょう。
> 色が４固定になってしまいます。・・
color 変数の宣言を忘れているのではありませんか?
変数宣言漏れの場合、たとえば
MsgBox Color
という処理を書いた場合に、
MsgBox stdole.LoadPictureConstants.Color
の意味になるので、おそらくこれが「4」の原因かと推察します。
> 初期化とかが必要と書いて頂いてましたので、修正しました
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 で解放するのを忘れていますよ。
後始末はきちんと行いましょう。
> 色が４固定になってしまいます。・・
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 サイズなので注意。
[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#」と書きます。
net（ｃ#)も
.NET、C#を使うように気をつけます。
>GetWindowTextW などの Wide 系 API にすること
GetWindowTextAも文字列が影響する事をしらなかったので、注意します。
>ワークシート部分を fn で示されたファイルに変換するためのコードはどうされましたか?
画像ファイルの画素を取り出すコードは、途中経過で、
今回の質問については、後述しております。
>異常系に到達した場合の流れもきちんと作りこみましょう。
最初、エラーに気が付かなくて、修正して作ったつもりでしたので、
ENDIFの位置に気を付けます。
>> Private Type PICTDESC
>提示頂いたコードでは未使用のようですが、もしかして、
引用したコードを精査しておりませんでした。未使用の定義でした。他意はございません。
>Long と LongPtr の使い分けに統一感が無い
64bitと32bitの使い分けが、まだはっきりわかっておらず、
また、２つの環境で使う予定な事と、PTRSAFEのような明確なエラーにならないので、
整理できておりませんでした、徐々に出来るようになりたいです。（まだ呪文）
>GdipBitmapGetPixel は 32bit な色空間 (ARGB) を返す
別なＷＥＢでＰＮＧの透明化に言及されておられましたが、気が付きませんでした。
>' OLE_COLOR … 00BBGGRR な 24bit 色(もしくは 800000nn で管理されるシステム色)
>' COLORREF … 00RRGGBB な 24bit 色
>' ARGB … AARRGGBB な 32bit 色
先ほどの色が逆さの謎が解けました。
>この h は何を求めるためのコードですか?
国土地理院様の高度タイルのPNGから高度を求める途中式（１００倍）です。
>GdipDisposeImage で解放するのを忘れていますよ。
>後始末はきちんと行いましょう。
気をつけます。
>color 変数の宣言を忘れているのではありませんか?
はい、定義しましたら、色が出てきました。
※WEBにUPする時に、文字制限に引っかかったので、クリップボード関係の定義を削除してしまいました
>VBA7 未満での PtrSafe は余計でしたね。
これ以外なのか、私の環境ではエラーになってしまいました・・・（上記）
>書き間違い。orz
>VB の 24bit 色と同じ並び
こんがらがっちゃいました（上記）
>VBA でハンドルやポインタを扱うときは
ハンドルは、（64bitの呪文を何かで拝見しました）。
ポインタは、まだよくわかりません。
>OLE_HANDLE は
難しいですが、注意できるようになりたいです。
今回は、国土地理院タイルの、高度タイルの標高を求めたい所からスタートしました。
LOADPICTUREで、すぐ出来ると思ったのですが、色んな回り道をして、まだ、
ワークシート画像からは、高度を求める所まで行ってません。(pixelが違う気が・・・）
（クラスライブラリや、ＡＰＩで直接PNGを扱った方が、今のところ、私は間違いないです）
クラスライブラリも、コードは容易でしたが、クラスライブラリも、コンソールアプリもダメで、
フォームアプリのクラスライブラリに到達するまで時間がかかりました。
GDI+を教えてもらって、やっぱりVBAは、まだまだ凄いなぁ、と思いました。
いっぱい指摘を受けましたが、大変勉強になりました。
クラスライブラリも好きですが、VBA単体で出来る事を増やしていきたいです。
大変ありがとうございました。
また宜しくお願いします。
また、お名前を間違えてごめんなさい。
最初の頃に、るきお様に注意されたのに、気を付けます。
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#」と書きます。
net（ｃ#)も
.NET、C#を使うように気をつけます。
>GetWindowTextW などの Wide 系 API にすること
GetWindowTextAも文字列が影響する事をしらなかったので、注意します。
>ワークシート部分を fn で示されたファイルに変換するためのコードはどうされましたか?
画像ファイルの画素を取り出すコードは、途中経過で、
今回の質問については、後述しております。
>異常系に到達した場合の流れもきちんと作りこみましょう。
最初、エラーに気が付かなくて、修正して作ったつもりでしたので、
ENDIFの位置に気を付けます。
>> Private Type PICTDESC
>提示頂いたコードでは未使用のようですが、もしかして、
引用したコードを精査しておりませんでした。未使用の定義でした。他意はございません。
>Long と LongPtr の使い分けに統一感が無い
64bitと32bitの使い分けが、まだはっきりわかっておらず、
また、２つの環境で使う予定な事と、PTRSAFEのような明確なエラーにならないので、
整理できておりませんでした、徐々に出来るようになりたいです。（まだ呪文）
>GdipBitmapGetPixel は 32bit な色空間 (ARGB) を返す
別なＷＥＢでＰＮＧの透明化に言及されておられましたが、気が付きませんでした。
>' OLE_COLOR … 00BBGGRR な 24bit 色(もしくは 800000nn で管理されるシステム色)
>' COLORREF … 00RRGGBB な 24bit 色
>' ARGB … AARRGGBB な 32bit 色
先ほどの色が逆さの謎が解けました。
>この h は何を求めるためのコードですか?
国土地理院様の高度タイルのPNGから高度を求める途中式（１００倍）です。
>GdipDisposeImage で解放するのを忘れていますよ。
>後始末はきちんと行いましょう。
気をつけます。
>color 変数の宣言を忘れているのではありませんか?
はい、定義しましたら、色が出てきました。
※WEBにUPする時に、文字制限に引っかかったので、クリップボード関係の定義を削除してしまいました
>VBA7 未満での PtrSafe は余計でしたね。
これ以外なのか、私の環境ではエラーになってしまいました・・・（上記）
>書き間違い。orz
>VB の 24bit 色と同じ並び
こんがらがっちゃいました（上記）
>VBA でハンドルやポインタを扱うときは
ハンドルは、（64bitの呪文を何かで拝見しました）。
ポインタは、まだよくわかりません。
>OLE_HANDLE は
難しいですが、注意できるようになりたいです。
今回は、国土地理院タイルの、高度タイルの標高を求めたい所からスタートしました。
LOADPICTUREで、すぐ出来ると思ったのですが、色んな回り道をして、まだ、
ワークシート画像からは、高度を求める所まで行ってません。(pixelが違う気が・・・）
（クラスライブラリや、ＡＰＩで直接PNGを扱った方が、今のところ、私は間違いないです）
クラスライブラリも、コードは容易でしたが、クラスライブラリも、コンソールアプリもダメで、
フォームアプリのクラスライブラリに到達するまで時間がかかりました。
GDI+を教えてもらって、やっぱりVBAは、まだまだ凄いなぁ、と思いました。
いっぱい指摘を受けましたが、大変勉強になりました。
クラスライブラリも好きですが、VBA単体で出来る事を増やしていきたいです。
大変ありがとうございました。
また宜しくお願いします。
投稿者 魔界の仮面弁士 (社会人)
投稿日時
2021/6/7 12:28:36
>> あるいは CreateDC で "DISPLAY" のコンテキストを得るようにします。
> CreateDC で "DISPLAY" のコンテキストは、なぜかエラーになってしまい、
ごめんなさい、先のサンプル色々間違いだらけですね。寝ぼけてたかな…。
正しくはこうです。32bit 版の Excel 2016 で動作することを確認済み。
> 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 です。
> 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 Long, ByVal nYPos As Long) As 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 Long, ByVal nYPos As Long) As OLE_COLOR
#End If
Public Function GetColor(ByVal x As Long, ByVal y As Long) As 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 画像から直接読み取った方が手っ取り早そう。
ワークシートから得たいというのは二次的なもので、
スタートは画像ファイル(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も１０進数に変換して、
全て確認できました。
WIAは、初めて使いましたが、非常に簡便にコードが書け、勉強になりました。
他にも使えるか、勉強してみたいです。
＜補足＞
jhondoe様のtrail-noteに触発されて、
国土地理院様の地図タイルや、
高度（標高）タイルを
VBAで実現してみたいと思いました。
最初jsの関数をVBAから取得できないか試していたのですが、
まだうまくいってなくて
VBA単独で出来ないか、試していました。
http://www.trail-note.net/tech/coordinate/の式で、
①ハイパボリックタンジェントの逆関数をVBAに出来たら、
ｘ、ｙ座標を取得できて、
②PNGをDL出来て
③PNGの色を読み取れたら、
高度を取得できると、考えました。
①はWEBを参考に自分で、
②は
@notmushroom様などの
https://qiita.com/notmushroomを参考にDLできました。
残る③が、クラスライブラリでは実現できましたが、VBA単独で実現できず、
るきお様のところで、魔界の仮面弁士様の助けを借りて実現できました。
クラスライブラリか、APIか、WIAで取得できるようになりました。
で、①を実現できると思いますので、
サーチエンジンなどで、「国土地理院タイル」で、ここにたどり着いた人で、
VBAで、やってみたい方は、御覧になってみて下さい。
追加の御教授ありがとうございます
WIAも１０進数に変換して、
全て確認できました。
WIAは、初めて使いましたが、非常に簡便にコードが書け、勉強になりました。
他にも使えるか、勉強してみたいです。
＜補足＞
jhondoe様のtrail-noteに触発されて、
国土地理院様の地図タイルや、
高度（標高）タイルを
VBAで実現してみたいと思いました。
最初jsの関数をVBAから取得できないか試していたのですが、
まだうまくいってなくて
VBA単独で出来ないか、試していました。
http://www.trail-note.net/tech/coordinate/の式で、
①ハイパボリックタンジェントの逆関数をVBAに出来たら、
ｘ、ｙ座標を取得できて、
②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で、やってみたい方は、御覧になってみて下さい。
投稿者 snowmansnow (社会人)
投稿日時
2022/1/30 14:59:48
こんにちは、
VBA、EXCELL2016です。
国土地理院タイルの標高PNGタイルの値取得について御教授いただいて、
WIAの使い方を教えて頂きましたが、
WIAを更に勉強して、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
Sub maintest()
Dim fol As String
Dim 緯度min As Double
Dim 緯度max As Double
Dim 経度min As Double
Dim 経度max As Double
緯度min = 23.998297
緯度max = 46.328724
経度min = 125.683591
経度max = 150.257812
fol = "C:\Users\Y2\Desktop\ファイルフォルダー\"
t = Now()
Call dl(fol, 経度min, 経度max, 緯度max, 緯度min)
MsgBox t & "-" & Now()
End Sub
Sub dl(fol As String, 経度min As Double, 経度max As Double, 緯度max As Double, 緯度min As Double)
Dim i As Long
Dim xタイルmin As Long
Dim xタイルmax As Long
Dim yタイルmin As Long
Dim yタイルmax As Long
xタイルmin = xタイル(6, 緯度max, 経度min)
xタイルmax = xタイル(6, 緯度min, 経度max)
yタイルmin = yタイル(6, 緯度max, 経度min)
yタイルmax = yタイル(6, 緯度min, 経度max)
i = 1
For y = yタイルmin To yタイルmax
For x = xタイルmin To xタイルmax
URLDownloadToFileW Nothing, StrPtr("https://cyberjapandata.gsi.go.jp/xyz/relief/6/" & x & "/" & y & ".png"), StrPtr(fol & Right("00" & i, 2) & ".png"), 0, 0
i = i + 1
Next
Next
Call test4WIAタイル3(xタイルmax - xタイルmin + 1, yタイルmax - yタイルmin + 1, fol)
End Sub
Sub test4WIAタイル3(x As Long, y As Long, fol As String)
' wiaaut.dll を参照設定しておく
' Microsoft Windows Image Acquisition Library v2.0
'
Dim objIF() As WIA.ImageFile
Dim h() As Long
Dim w() As Long
Dim vec() As WIA.vector
ReDim objIF(1 To x, 1 To y)
ReDim h(1 To x, 1 To y)
ReDim w(1 To x, 1 To y)
ReDim vec(1 To x, 1 To y)
'https://www.relief.jp/docs/excel-vba-redim-2d-array.html
Dim vecT As WIA.vector
Dim yc As Long
Dim xc As Long
Dim yH As Long
Dim xW As Long
Dim xx As Long
Dim st As String
For yc = 1 To y
For xc = 1 To x
Set objIF(xc, yc) = New WIA.ImageFile
st = fol & Right("00" & (xc + (yc - 1) * x), 2) & ".png"
objIF(xc, yc).LoadFile st
h(xc, yc) = objIF(xc, yc).Height
w(xc, yc) = objIF(xc, yc).Width
Set vec(xc, yc) = objIF(xc, yc).ARGBData
Next
Next
Set vecT = objIF(1, 1).ARGBData
vecT.Clear
For yH = 1 To y
For yy = 1 To h(1, 1)
For xW = 1 To x
For xx = 1 To w(1, 1)
vecT.Add vec(xW, yH).Item(xx + (yy - 1) * w(1, 1))
Next
Next
Next
Next
Dim objIFnew As WIA.ImageFile
Set oIFNew = vecT.ImageFile(w(1, 1) * x, h(1, 1) * y)
oIFNew.SaveFile fol & "0T(" & x & "," & y & ")" & (x * y) & ".png"
End Sub
投稿者 snowmansnow (社会人)
投稿日時
2022/1/30 15:00:56
つづきです
Function piVBA() As Double
Dim pi As Double
piVBA = 4 * Atn(1)
End Function
Function sinhVBA(RAD As Double) As Double
'https://www.vba-ie.net/function/exp.php
sinhVBA = (Exp(RAD) - Exp(-1 * RAD)) / 2
End Function
Function coshVBA(RAD As Double) As Double
'https://www.vba-ie.net/function/exp.php
coshVBA = (Exp(RAD) + Exp(-1 * RAD)) / 2
End Function
Function tanhVBA(RAD As Double) As Double
'https://www.vba-ie.net/function/exp.php
tanhVBA = sinhVBA(RAD) / coshVBA(RAD)
End Function
Function asinVBA(x As Double)
'http://tancro.e-central.tv/grandmaster/excel/vba-function-triangle.html
If x <= -1 Then
asinVBA = 3 * piVBA() / 2
ElseIf x >= 1 Then
asinVBA = piVBA() / 2
Else
asinVBA = Atn(x / Sqr(1 - x ^ 2))
End If
End Function
Function acosVBA(x As Double)
'http://tancro.e-central.tv/grandmaster/excel/vba-function-triangle.html
If x <= -1 Then
acosVBA = piVBA()
ElseIf x >= 1 Then
acosVBA = 0
Else
acosVBA = Atn(-x / Sqr(-x ^ 2 + 1)) + piVBA() / 2
End If
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
Function y座標VBA(ZOOM As Long, 緯度十進 As Double, 経度十進 As Double) As Double
Dim t2 As Double
t2 = 2 ^ (ZOOM + 7) / piVBA() * (-atanhVBA(Sin(piVBA() / 180 * 緯度十進)) + atanhVBA(Sin(piVBA() / 180 * 85.05112878)))
y座標VBA = t2
End Function
Function x座標(ZOOM As Long, 緯度十進 As Double, 経度十進 As Double) As Double
Dim t1 As Double
t1 = Int(2 ^ (ZOOM + 7) * (経度十進 / 180 + 1) Mod 256)
x座標 = t1
End Function
Function xタイル(ZOOM As Long, 緯度十進 As Double, 経度十進 As Double) As Long
Dim t1 As Double
t1 = Int(2 ^ (ZOOM + 7) * (経度十進 / 180 + 1) / 256)
xタイル = t1
End Function
Function yタイル(ZOOM As Long, 緯度十進 As Double, 経度十進 As Double) As Long
Dim t2 As Double
t2 = Int(2 ^ (ZOOM + 7) / WorksheetFunction.pi() * (-WorksheetFunction.Atanh(Sin(WorksheetFunction.pi() / 180 * 緯度十進)) + WorksheetFunction.Atanh(Sin(WorksheetFunction.pi() / 180 * 85.05112878))) / 256)
yタイル = t2
End Function
投稿者 snowmansnow (社会人)
投稿日時
2022/2/2 22:04:45
こんばんは、
WIAで、タイリングだけでなく、直線を描く事もできます。
Public Type points
x As Long
y As Long
End Type
Sub LINETEST_WIA()
Dim newp() As points
Dim cnt As Long
Dim cp As points
Dim tp As points
Dim tp2 As points
cp.x = 300
cp.y = 1200
tp.x = 1200
tp.y = 1000
newp = LINEf(cp.x, cp.y, tp.x, tp.y, 10)
Dim fn As String
Dim fn2 As String
fn = "C:\Users\Y2\Desktop\ファイルフォルダー\0T(5,6)30.png"
fn2 = "C:\Users\Y2\Desktop\ファイルフォルダー\0T(5,6)30_LINE.png"
Call test5LINE_WIA(newp, fn, fn2)
End Sub
Sub test5LINE_WIA(p() As points, fn As String, fn2 As String)
' wiaaut.dll を参照設定しておく
' Microsoft Windows Image Acquisition Library v2.0
'
Dim objIF As WIA.ImageFile
Set objIF = New WIA.ImageFile
objIF.LoadFile fn
Dim h As Long, w As Long
h = objIF.height
w = objIF.width
Dim pi() As Long
ReDim pi(UBound(p))
pi = points2index(p, w, h)
Dim vec As WIA.vector
Set vec = objIF.ARGBData
Dim vecT As WIA.vector
Set vecT = objIF.ARGBData
vecT.Clear
Dim temp() As Long
ReDim temp(h * w)
For t = 1 To UBound(pi)
temp(pi(t)) = 1
Next
i = 0
For y = 1 To h
For x = 1 To w
i = i + 1
If temp(i) = 1 Then
vecT.Add -65536
Else
vecT.Add vec.Item(i)
End If
Next
Next
Dim objIFnew As WIA.ImageFile
Set oIFNew = vecT.ImageFile(w, h)
oIFNew.SaveFile fn2
End Sub
Function points2index(p() As points, width As Long, height As Long) As Long()
Dim temp() As Long
cnt = UBound(p)
Dim y As Long
Dim x As Long
ReDim temp(UBound(p))
For i = 0 To cnt - 1
y = p(i).y
x = p(i).x
temp(i) = y * width + x
Next
points2index = temp
End Function
Function LINEf(x0 As Long, y0 As Long, x1 As Long, y1 As Long, 太さ As Long) As points()
'https://fussy.web.fc2.com/algo/algo1-1.htm
Dim E As Long
Dim x As Long
Dim y As Long
Dim dx As Long
Dim dy As Long
Dim sx As Long
Dim sy As Long
Dim temp() As points
Dim temp2() As points
Dim temp3() As points
Dim newpT() As points
If (x1 > x0) Then
dx = x1 - x0
sx = 1
Else
dx = x0 - x1
sx = -1
End If
If (y1 > y0) Then
dy = y1 - y0
sy = 1
Else
dy = y0 - y1
sy = -1
End If
' 傾きが1より小さい場合
太さ = Int(太さ / 2 + 0.5) * 2
If (dx > dy) Then
ReDim Preserve temp(dx * (太さ + 1))
E = -dx
x = x0
y = y0
For i = 0 To dx Step 1
For B = 0 To 太さ / 2
temp(i + B * dx).y = y + B
temp(i + B * dx).x = x
Next
For B = 太さ / 2 + 1 To 太さ
temp(i + B * dx).y = y - (B - 太さ / 2)
temp(i + B * dx).x = x
Next
x = x + sx
E = E + 2 * dy
If (E >= 0) Then
y = y + sy
E = E - 2 * dx
Else
End If
Next
Else
ReDim Preserve temp(dy * (太さ + 1))
' 傾きが1以上の場合
E = -dy
x = x0
y = y0
For i = 0 To dy Step 1
For B = 0 To 太さ / 2
temp(i + B * dy).y = y
temp(i + B * dy).x = x + B
Next
For B = 太さ / 2 + 1 To 太さ
temp(i + B * dy).y = y
temp(i + B * dy).x = x - (B - 太さ / 2)
Next
y = y + sy
E = E + 2 * dx
If (E >= 0) Then
x = x + sx
E = E - 2 * dy
Else
End If
Next
End If
LINEf = temp
End Function
少し遅いですが、遊んでみて下さい
エクセルのワークシート部分（クライアント領域？）に画像を読み込んだり、
セルに色を付けたり、絵を描いた状態で、
指定のピクセルの色を取得する方法は、ありますか？
エクセルのデバイスコンテキストを取得して、GETPXELをしても
-1にしかならなくて、
（https://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q1387601913と同様。）
参考のＵＲＬもリンクが切れていて確認できませんでした・・・
Formのloadpictureではpngはエラーになりますが、
ActiveSheet.Pictures.Insert（〇×）では、pngを貼り付けられます。
貼り付けた画像部分のgetpixelをするvbaは可能ですか？
netでクラスライブラリではpngのgetpixelは実現できたのですが、
vbaで実現してみたいです。
よろしくお願いします。