[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『画像の任意の範囲のRGB値をエクセルでデータ化したい』（てつ）
恐縮です、どなたかご教授頂ければ幸いです。
画像の任意の範囲のRGB値をエクセルでデータ化したい
任意の範囲は同一画像で数か所ございます。
また、画像は同サイズで数種類ございます。
それぞれの、画像にも対応したいです。
大まかな、手順は
１）画像を選択する
２）任意の範囲をマウスで設定する
３）作成された範囲に番号を振る
４）エクセルにボタンをつくり
クリックすると、一括でそれぞれの任意の範囲の
RGB値が抽出され、エクセルに転記される。
ざっくりな説明です申し訳ありませんが
宜しくお願い致します。
尚、フリーソフトやツールは使えません
マクロで出来れば有難いです。
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
クリップボードにビットマップ形式が来てる状態なら、その各ビットのRGB値を新規ブックに吐き出す。 というマクロ例です。
メインであるRGB値の取得の部分だけですが、ちょっとは参考になるかも知れません。(し、ならんかも知れません ^^;)
Option Explicit
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 IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Const CF_BITMAP = 2&
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
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 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 Const DIB_RGB_COLORS = 0&
Private Type typeINT32
Value As Long
End Type
Private Type typeCOLORREF
Red As Byte
Green As Byte
Blue As Byte
NoData As Byte
End Type
Private Type typeARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
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 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
.biCompression = BI_RGB
.biSizeImage = 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)
GetARGBofBmp = pxARGB
End Function
Sub クリップボートRGB値取得()
Dim hBmp As LongPtr
hBmp = GetBmpfromClipboard
If hBmp = 0 Then Exit Sub
Dim px() As typeARGB, v() As Variant, l As typeINT32, cr As typeCOLORREF
Dim r As Long, c As Long
px = GetARGBofBmp(hBmp)
ReDim v(LBound(px, 2) To UBound(px, 2), LBound(px, 1) To UBound(px, 1))
For r = LBound(px, 2) To UBound(px, 2)
For c = LBound(px, 1) To UBound(px, 1)
cr.Red = px(c, r).Red
cr.Green = px(c, r).Green
cr.Blue = px(c, r).Blue
LSet l = cr
v(r, c) = l.Value
Next
Next
Workbooks.Add
Dim a As Range
With [A1].Resize(UBound(px, 2) - LBound(px, 2) + 1, UBound(px, 1) - LBound(px, 1) + 1)
.Value = v
For Each a In .Cells
a.Interior.Color = a.Value
Next
End With
End Sub
（白茶） 2023/11/16(木) 23:37:10
もしその「画像」ってのが画像ファイルなんだったら、 先に画像全体の各ビットRGB値を書き出してしまっった方が、欲しい範囲のターゲッティングが簡単になるかもですね。
↓画像ファイルのビットを書き出す例
ビット情報の取得は速いんですけど、サイズが大きい画像は書き出しにちょっと時間掛かるかもしれません。
(試してみたら、4000px × 3000px くらいの画像で書き出しに20秒ってところでした)
Option Explicit
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
Height As Long
stride As Long
PixelFormat As Long
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 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 Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" (ByVal Filename As LongPtr, ByRef image As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal image As LongPtr, ByRef Height As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal image As LongPtr, ByRef Width As Long) As Long
Private Enum PixelFormat
PixelFormat32bppARGB = &H26200A
End Enum
Private Type typeINT32
Value As Long
End Type
Private Type typeCOLORREF
Red As Byte
Green As Byte
Blue As Byte
NoData As Byte
End Type
Private Type typeARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Private Sub WriteOutCOLORREFtoCells(pxARGB() As typeARGB)
Dim pxHeight As Long, pxWidth As Long, tmpCR As typeCOLORREF, tmpI As typeINT32
Dim v() As Variant, r As Long, c As Long
pxHeight = UBound(pxARGB, 2) - LBound(pxARGB, 2) + 1
pxWidth = UBound(pxARGB, 1) - LBound(pxARGB, 1) + 1
ReDim v(1 To pxHeight, 1 To pxWidth)
For r = 1 To pxHeight
For c = 1 To pxWidth
tmpCR.Red = pxARGB(c, r).Red
tmpCR.Green = pxARGB(c, r).Green
tmpCR.Blue = pxARGB(c, r).Blue
LSet tmpI = tmpCR
v(r, c) = tmpI.Value
Next
Next
Workbooks.Add
Cells(1, 1).Resize(pxHeight, pxWidth).Value = v
End Sub
Sub 画像ファイルのビット書き出し()
Dim hImg As LongPtr, aPath As String
aPath = Application.GetOpenFilename("画像ファイル,*.png;*.jpg;*.gif;*.bmp")
If aPath = "False" Then Exit Sub
Dim tkn As LongPtr, gi As GdiplusStartupInput, rtn As Long
Dim BmpData As BITMAPDATA
Dim px() As typeARGB, pxWidth As Long, pxHeight As Long
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
If GdipLoadImageFromFile(StrPtr(aPath), hImg) = 0 Then
Call GdipGetImageWidth(hImg, pxWidth)
Call GdipGetImageHeight(hImg, pxHeight)
ReDim px(1 To pxWidth, 1 To pxHeight)
With BmpData
.Width = pxWidth
.Height = pxHeight
.PixelFormat = PixelFormat32bppARGB
.scan0 = VarPtr(px(1, 1))
.stride = pxWidth * 4
End With
rtn = GdipBitmapLockBits(hImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeRead, PixelFormat32bppARGB, BmpData)
Call GdipBitmapUnlockBits(hImg, BmpData)
Call GdipDisposeImage(hImg)
End If
If hImg And (rtn = 0) Then Call WriteOutCOLORREFtoCells(px)
Call GdiplusShutdown(tkn)
End Sub
（白茶） 2023/11/17(金) 18:29:30
さて。前フリ2個提示したけど反応無さそうなので、私はこれで一旦失礼しますよ～ 範囲選択をどうしたもんだかなと思って色々考えてました。
> １）画像を選択する って言うけど、そもそもどこにある画像なのかも定かでないし、 > ２）任意の範囲をマウスで設定する 且つ > 画像は同サイズで数種類 ってのが厄介です。
例えばこんなユーザーフォームとか素案として検討候補になるでしょうか... ね?
Option Explicit
Rem ===============================================================================================================================================================================
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Const GWL_EXSTYLE As Long = (-20)
Private Const WS_EX_LAYERED As LongPtr = &H80000
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hWnd As LongPtr) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_ALPHA As Long = &H2
Private Const LWA_COLORKEY As Long = &H1
Rem ===============================================================================================================================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32" ( _
ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, _
ByVal dwRop As Long) As Long
Private Const vbSrcCopy As Long = &HCC0020
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 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 Const DIB_RGB_COLORS = 0&
Rem ===============================================================================================================================================================================
Private Type typeINT32
Value As Long
End Type
Private Type typeCOLORREF
Red As Byte
Green As Byte
Blue As Byte
NoData As Byte
End Type
Private Type typeARGB
Blue As Byte
Green As Byte
Red As Byte
Alpha As Byte
End Type
Rem ===============================================================================================================================================================================
Private Frame1 As MSForms.Frame
Private WithEvents Button1 As MSForms.CommandButton
Rem ===============================================================================================================================================================================
Private Function CreateBmpOfWindowRect(Optional SrchWnd As LongPtr) As LongPtr
Dim rtn As LongPtr
Dim wRect As RECT, xMax As Long, yMax As Long
Dim WidthSrc As Long, HeightSrc As Long
Dim hDCSrc As LongPtr, hDCMemory As LongPtr
Dim hBmp As LongPtr, hBmpOld As LongPtr
hDCSrc = GetDC(0&)
xMax = GetSystemMetrics(SM_CXSCREEN)
yMax = GetSystemMetrics(SM_CYSCREEN)
WidthSrc = xMax
HeightSrc = yMax
If SrchWnd Then
Call GetWindowRect(SrchWnd, wRect)
With wRect
If .Left < 0& Then .Left = 0&
If .Top < 0& Then .Top = 0&
If .Right > xMax Then .Right = xMax
If .Bottom > yMax Then .Bottom = yMax
WidthSrc = .Right - .Left
HeightSrc = .Bottom - .Top
End With
End If
hDCMemory = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpOld = SelectObject(hDCMemory, hBmp)
rtn = BitBlt(hDCMemory, 0&, 0&, WidthSrc, HeightSrc, hDCSrc, wRect.Left, wRect.Top, vbSrcCopy)
hBmp = SelectObject(hDCMemory, hBmpOld)
Call DeleteDC(hDCMemory)
Call ReleaseDC(0&, hDCSrc)
If rtn Then CreateBmpOfWindowRect = hBmp
' Call DeleteObject(hBmp)
End Function
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
.biCompression = BI_RGB
.biSizeImage = 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)
GetARGBofBmp = pxARGB
End Function
Private Sub WriteOutCOLORREFtoCells(pxARGB() As typeARGB)
Dim pxHeight As Long, pxWidth As Long, tmpCR As typeCOLORREF, tmpI As typeINT32
Dim v() As Variant, r As Long, c As Long
pxHeight = UBound(pxARGB, 2) - LBound(pxARGB, 2) + 1
pxWidth = UBound(pxARGB, 1) - LBound(pxARGB, 1) + 1
ReDim v(1 To pxHeight, 1 To pxWidth)
For r = 1 To pxHeight
For c = 1 To pxWidth
tmpCR.Red = pxARGB(c, r).Red
tmpCR.Green = pxARGB(c, r).Green
tmpCR.Blue = pxARGB(c, r).Blue
LSet tmpI = tmpCR
v(r, c) = tmpI.Value
Next
Next
Workbooks.Add
Cells(1, 1).Resize(pxHeight, pxWidth).Value = v
End Sub
Rem ===============================================================================================================================================================================
Private Sub Button1_Click()
Dim h As LongPtr, hBmp As LongPtr, px() As typeARGB
WindowFromAccessibleObject Frame1, h
hBmp = CreateBmpOfWindowRect(h)
If hBmp Then
px = GetARGBofBmp(hBmp)
Call WriteOutCOLORREFtoCells(px)
End If
End Sub
Private Sub UserForm_Initialize()
Const SIZE_PX_H As Long = 90 'ピクセル単位でサイズ指定(縦幅)
Const SIZE_PX_W As Long = 160 'ピクセル単位でサイズ指定(横幅) フォーム上にサイズ調整機能を持たせた方が便利かな
Set Frame1 = Me.Controls.Add("Forms.Frame.1", "Frame1")
Set Button1 = Me.Controls.Add("Forms.CommandButton.1", "Button1")
Frame1.BackColor = &HFF&
Frame1.SpecialEffect = fmSpecialEffectFlat
Frame1.Top = 2
Frame1.Left = 2
Frame1.Width = SIZE_PX_W * (72 / 96)
Frame1.Height = SIZE_PX_H * (72 / 96)
Button1.Top = Frame1.Top + Frame1.Height + 3
Button1.Left = Frame1.Left + Frame1.Width + 3
Button1.Caption = "Copy"
Button1.Accelerator = "C"
Call SetMySize
Dim h As LongPtr
WindowFromAccessibleObject Me, h
SetWindowLongPtr h, GWL_EXSTYLE, GetWindowLongPtr(h, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes h, &HFF&, 0&, LWA_COLORKEY
End Sub
Private Sub SetMySize()
Dim maxW As Single, maxH As Single, c As MSForms.Control
Dim minTop As Single, minLeft As Single
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top + c.Height > maxH Then maxH = c.Top + c.Height
If c.Left + c.Width > maxW Then maxW = c.Left + c.Width
End If
Next
minTop = maxH
minLeft = maxW
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top >= 0 And c.Top < minTop Then minTop = c.Top
If c.Left >= 0 And c.Left < minLeft Then minLeft = c.Left
End If
Next
Me.Width = maxW + minLeft + (Me.Width - Me.InsideWidth)
Me.Height = maxH + minTop + (Me.Height - Me.InsideHeight)
End Sub
（白茶） 2023/11/18(土) 00:12:23
↑Rapture(おにぎり)の様な使用感をUserFormで再現してみたらどうだろう。
...と思て、ちょっと気合い入れて書いてみました。(質問はもうそっちのけ。反応もない事だし)
自学ノート晒す２。^^;
Option Explicit
Rem ▼API宣言===================================================================================================
#Const TEST_MODE = 0
Rem ▽ウインドウスタイル関係------------------------------------------------------------------------------------
#If Win64 Then
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#Else
Private Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
#End If
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Const GWL_STYLE = (-16&)
Private Const GWL_EXSTYLE = (-20&)
Private Const WS_EX_TOOLWINDOW As Long = &H80 'ウィンドウは、フローティング ツールバーとして使用することを目的としています。 ツール ウィンドウには、通常のタイトル バーより短いタイトル バーがあり、ウィンドウ タイトルは小さいフォントを使用して描画されます。
Private Const WS_EX_DLGMODALFRAME As Long = &H1 'ウィンドウには二重の境界線があります。必要に応じて、dwStyle パラメーターでWS_CAPTION スタイルを指定することで、ウィンドウをタイトル バーで作成できます。
Private Const WS_EX_TOPMOST As Long = &H8 'ウィンドウは、最上位以外のすべてのウィンドウの上に配置し、ウィンドウが非アクティブ化されている場合でも、その上に配置する必要があります。 このスタイルを追加または削除するには、 SetWindowPos 関数を使用します。
Private Const WS_EX_APPWINDOW As Long = &H40000 'ウィンドウが表示されているときに、タスク バーに最上位のウィンドウを強制的に配置します。
Private Const WS_EX_LAYERED As Long = &H80000 'ウィンドウは レイヤーウィンドウです。 ウィンドウのクラス スタイルが CS_OWNDC または CS_CLASSDC の場合、このスタイルは使用できません。
Private Const WS_EX_NOACTIVATE As Long = &H8000000 'このスタイルで作成されたトップレベル ウィンドウは、ユーザーがクリックしても前景ウィンドウになりません。 ユーザーがフォアグラウンド ウィンドウを最小化または閉じると、システムはこのウィンドウをフォアグラウンドに移動しません。
Private Const WS_CAPTION As Long = &HC00000 '<= WS_BORDER(&H800000) Or WS_DLGFRAME(&H400000)
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc.dll" (ByVal IAcessible As Object, ByRef hwnd As LongPtr) As Long
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Const LWA_ALPHA As Long = &H2 'bAlpha を使用して、レイヤーウィンドウの不透明度を決定します。
Private Const LWA_COLORKEY As Long = &H1 '透明度の色として crKey を使用します。
Rem ▽ShowWindow------------------------------------------------------------------------------------------------
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
Private Const SW_HIDE As Long = 0 'ウィンドウを非表示にし、別のウィンドウをアクティブにします。
Private Const SW_SHOWNORMAL As Long = 1 'ウィンドウをアクティブにして表示します。 ウィンドウが最小化、最大化、または配置されている場合は、元のサイズと位置に復元されます。
Private Const SW_NORMAL As Long = 1 ' アプリケーションでは、ウィンドウを初めて表示するときにこのフラグを指定する必要があります。
Private Const SW_SHOWMINIMIZED As Long = 2 'ウィンドウをアクティブ化し、最小化されたウィンドウとして表示します。
Private Const SW_SHOWMAXIMIZED As Long = 3 'ウィンドウをアクティブ化し、最大化されたウィンドウとして表示します。
Private Const SW_MAXIMIZE As Long = 3 '
Private Const SW_SHOWNOACTIVATE As Long = 4 'ウィンドウを最新のサイズと位置で表示します。 この値は、ウィンドウがアクティブ化されていないことを除き、 SW_SHOWNORMALに似ています。
Private Const SW_SHOW As Long = 5 'ウィンドウをアクティブ化し、現在のサイズと位置で表示します。
Private Const SW_MINIMIZE As Long = 6 '指定したウィンドウを最小化し、Z オーダーで次の最上位ウィンドウをアクティブにします。
Private Const SW_SHOWMINNOACTIVE As Long = 7 'ウィンドウを最小化されたウィンドウとして表示します。 この値は、ウィンドウがアクティブになっていない点を除き、 SW_SHOWMINIMIZEDに似ています。
Private Const SW_SHOWNA As Long = 8 'ウィンドウを現在のサイズと位置で表示します。 この値は、ウィンドウがアクティブ化されていないことを除き、 SW_SHOWに似ています。
Private Const SW_RESTORE As Long = 9 'ウィンドウをアクティブにして表示します。 ウィンドウが最小化、最大化、または配置されている場合は、元のサイズと位置に復元されます。 最小化されたウィンドウを復元するときは、アプリケーションでこのフラグを指定する必要があります。
Private Const SW_SHOWDEFAULT As Long = 10 'アプリケーションを起動したプログラムによって CreateProcess 関数に渡される STARTUPINFO 構造体で指定されたSW_値に基づいて表示状態を設定します。
Private Const SW_FORCEMINIMIZE As Long = 11 'ウィンドウを所有するスレッドが応答していない場合でも、ウィンドウを最小化します。 このフラグは、別のスレッドからウィンドウを最小化する場合にのみ使用する必要があります。
Rem ▽WindowRect------------------------------------------------------------------------------------------------
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function AdjustWindowRect Lib "user32" (lpRect As RECT, ByVal dwStyle As Long, ByVal bMenu As Long) As Long
'Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
'Private Const SM_CXSCREEN As Long = 0
'Private Const SM_CYSCREEN As Long = 1
'Private Const SM_CYCAPTION As Long = 4
'Private Const SM_CXBORDER As Long = 5
'Private Const SM_CYBORDER As Long = 6
'Private Const SM_CXDLGFRAME As Long = 7
'Private Const SM_CYDLGFRAME As Long = 8
'Private Const SM_CYMENU As Long = 15
'Private Const SM_CYVSCROLL As Long = 20
'Private Const SM_CXHSCROLL As Long = 21
'Private Const SM_CXFRAME As Long = 32
'Private Const SM_CYFRAME As Long = 33
Rem ▽マウスカーソル関係----------------------------------------------------------------------------------------
Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
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_BITMAP As Long = 2 'ビットマップのデータ(HBITMAP)
Rem ▽デバイスコンテキスト関係----------------------------------------------------------------------------------
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
'Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const vbSrcCopy As Long = &HCC0020
'Private Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hdcDest As LongPtr, ByVal XDest As Long, ByVal YDest As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
' ByVal hDCSrc As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Rem ▽DIBit-----------------------------------------------------------------------------------------------------
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 Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
'この Bitmap オブジェクトから GDI ビットマップを作成します。
'Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, ByRef bitmap As LongPtr) As Long
'■アルファが無視されるからあんま使えない■GDI ビットマップへのハンドルと GDI パレットへのハンドルに基づいて Bitmap::Bitmap オブジェクトを作成します。
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
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal image As LongPtr, ByRef Height As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal image As LongPtr, ByRef Width As Long) 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
#If Win64 Then '**************{
Private Type typeINT64
Value As LongLong
End Type
Private Type typeINT32x2
Value1 As Long
Value2 As Long
End Type
#End If '}____________________/
Rem -------------------------------------------------------------------------------------------
Private Const DEF_H = 90!, DEF_W = 160!, SIZE_BTN = 21!
Private XLPPI, DPIX, DPIY
Private labelRect As MSForms.Label, xFrom As Single, yFrom As Single
Private selRect As RECT, pFrom As POINTAPI, pTo As POINTAPI
Private fmFullMode As Boolean
Private WithEvents ButtonCapture As MSForms.CommandButton
Private WithEvents ButtonCopy As MSForms.CommandButton
Private WithEvents ButtonSave As MSForms.CommandButton
Private WithEvents ButtonWriteOut As MSForms.CommandButton
Private Image1 As MSForms.image
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 CreatePictureByhBmp(ByVal hBmp As LongPtr, Optional hPal As LongPtr) As IPictureDisp
Dim IID_IDispatch As GUID, Bmp As PicBmp
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0&
.Data4(7) = &H46&
End With
With Bmp
.Size = Len(Bmp)
.Type = vbPicTypeBitmap
.hBmp = hBmp
.hPal = hPal
End With
Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, CreatePictureByhBmp)
End Function
Private Function CopyBmptoClipboard(hBmp As LongPtr) As Boolean
Call OpenClipboard(0&)
Call EmptyClipboard
CopyBmptoClipboard = CBool(SetClipboardData(CF_BITMAP, hBmp))
Call CloseClipboard
End Function
#If TEST_MODE Then '################################################
Private Function GetGamma(argColor As OLE_COLOR) As Single
Const prmR = 0.298912!, prmG = 0.586611!, prmB = 0.114478!
Dim tRGB As typeCOLORREF, tLng As typeINT32
tLng.Value = argColor
LSet tRGB = tLng
GetGamma = tRGB.Red * prmR + tRGB.Green * prmG + tRGB.Blue * prmB
GetGamma = GetGamma / &HFF&
End Function
#End If '###########################################################
'Private Function CopyARGBtoClipboard(hARGB As LongPtr) As Boolean
' Call OpenClipboard(0&)
' Call EmptyClipboard
' Dim aStream As IUnknown, pngGUID As GUID
' Call CreateStreamOnHGlobal(0&, 0&, aStream)
' Call CLSIDFromString(StrPtr(CLSID_PNG), pngGUID)
' If GdipSaveImageToStream(hARGB, ByVal ObjPtr(aStream), pngGUID, 0) = 0 Then
' Dim hGlobal As LongPtr, CF_PNG As Long
' Call GetHGlobalFromStream(aStream, hGlobal)
' If hGlobal Then
' CF_PNG = RegisterClipboardFormat("PNG")
' CopyARGBtoClipboard = CBool(SetClipboardData(CF_PNG, hGlobal))
' End If
' End If
' Call CloseClipboard
'End Function
'Private Function SysColor2RGB(argColor As OLE_COLOR) As OLE_COLOR
' If (argColor And &HFF000000) = &H80000000 Then
' SysColor2RGB = GetSysColor(argColor And &HFFFFFF)
' Else
' SysColor2RGB = argColor
' End If
'End Function
'#If TEST_MODE Then '################################################
'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
'#End If '###########################################################
''
'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
Private Sub WriteOutCOLORREFtoCells(pxARGB() As typeARGB)
Dim pxHeight As Long, pxWidth As Long, tmpCR As typeCOLORREF, tmpI As typeINT32
Dim v() As Variant, r As Long, c As Long
pxHeight = UBound(pxARGB, 2) - LBound(pxARGB, 2) + 1
pxWidth = UBound(pxARGB, 1) - LBound(pxARGB, 1) + 1
ReDim v(1 To pxHeight, 1 To pxWidth)
For r = 1 To pxHeight
For c = 1 To pxWidth
tmpCR.Red = pxARGB(c, r).Red
tmpCR.Green = pxARGB(c, r).Green
tmpCR.Blue = pxARGB(c, r).Blue
LSet tmpI = tmpCR
v(r, c) = tmpI.Value
Next
Next
Workbooks.Add
With Cells(1, 1).Resize(pxHeight, pxWidth)
.Value = v
#If TEST_MODE Then '################################################
Dim p As Range
For Each p In .Cells
p.Interior.Color = p.Value
p.Font.Color = IIf(GetGamma(p.Value) < 0.5!, &HFFFFFF, &H0)
Next
#End If '###########################################################
End With
End Sub
Rem ▼実験会場==================================================================================================
'Sub SaveToPng_ClipboardBitmap()
' 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 TEST_MODE Then '########################
' If HasAlphaCannel(px) Then '| ◆アルファ値が含まれている場合で ****************{ '←現実には需要無いであろう
' If IsOpaque(px) Then '| | そもそもアルファ値が全フルか
' pxfmt = PixelFormat32bppARGB '| | ユーザーがアルファチャンネルの維持を選択したら
' ElseIf MsgBox("ビットマップにアルファ値が混ざってます。" & vbCrLf & "往々にして邪魔なので無視しますか?", vbYesNo + vbQuestion) = vbNo Then
' pxfmt = PixelFormat32bppARGB '| | フォーマットを[透過有り]に再設定し
' End If '| |
' 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
'Sub LoadImageToPic1FromFile()
' Dim hImg As LongPtr, aPath As String
' aPath = Application.GetOpenFilename("画像ファイル,*.png;*.jpg;*.gif;*.bmp")
' If aPath = "False" Then Exit Sub
' Dim tkn As LongPtr, gi As GdiplusStartupInput, rtn As Long
' Dim BmpData As BITMAPDATA
' Dim px() As typeARGB, pxWidth As Long, pxHeight As Long
' gi.GdiplusVersion = 1&
' Call GdiplusStartup(tkn, gi)
' If GdipLoadImageFromFile(StrPtr(aPath), hImg) = 0 Then
' Dim hBmp As LongPtr, bkARGB As typeARGB, bkINT As typeINT32, bkOLE As typeCOLORREF
'' Call GdipGetImageWidth(hImg, pxWidth)
'' Call GdipGetImageHeight(hImg, pxHeight)
'' rtn = GdipCreateBitmapFromGraphics(pxWidth, pxHeight, hImg, hBmp)
' bkINT.Value = SysColor2RGB(Me.BackColor)
' LSet bkOLE = bkINT
' bkARGB.Red = bkOLE.Red
' bkARGB.Green = bkOLE.Green
' bkARGB.Blue = bkOLE.Blue
' LSet bkINT = bkARGB
' rtn = GdipCreateHBITMAPFromBitmap(hImg, hBmp, bkINT.Value)
' If rtn = 0 Then
' Set Image1.Picture = CreatePictureByhBmp(hBmp)
' Me.Repaint
' End If
'' ReDim px(1 To pxWidth, 1 To pxHeight)
'' With BmpData
'' .Width = pxWidth
'' .Height = pxHeight
'' .PixelFormat = PixelFormat32bppARGB
'' .scan0 = VarPtr(px(1, 1))
'' .stride = pxWidth * 4
'' End With
'' rtn = GdipBitmapLockBits(hImg, ByVal 0, ImageLockModeUserInputBuf Or ImageLockModeRead, PixelFormat32bppARGB, BmpData)
'' Call GdipBitmapUnlockBits(hImg, BmpData)
' Call GdipDisposeImage(hImg)
' End If
'' If hImg And (rtn = 0) Then Call WriteOutCOLORREFtoCells(px)
' Call GdiplusShutdown(tkn)
'End Sub
'Private Function CreateBmpOfWindowRect(Optional SrchWnd As LongPtr) As LongPtr
' Dim rtn As LongPtr
' Dim wRect As RECT, xMax As Long, yMax As Long
' Dim WidthSrc As Long, HeightSrc As Long
' Dim hDCSrc As LongPtr, hDCCopy As LongPtr
' Dim hBmp As LongPtr, hBmpOld As LongPtr
' hDCSrc = GetDC(0&)
' xMax = GetSystemMetrics(SM_CXSCREEN)
' yMax = GetSystemMetrics(SM_CYSCREEN)
' WidthSrc = xMax
' HeightSrc = yMax
' If SrchWnd Then
' Call GetWindowRect(SrchWnd, wRect)
' With wRect
' If .Left < 0& Then .Left = 0&
' If .Top < 0& Then .Top = 0&
' If .Right > xMax Then .Right = xMax
' If .Bottom > yMax Then .Bottom = yMax
' WidthSrc = .Right - .Left
' HeightSrc = .Bottom - .Top
' End With
' End If
' hDCCopy = CreateCompatibleDC(hDCSrc)
' hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
' hBmpOld = SelectObject(hDCCopy, hBmp)
' rtn = BitBlt(hDCCopy, 0&, 0&, WidthSrc, HeightSrc, hDCSrc, wRect.Left, wRect.Top, vbSrcCopy)
' hBmp = SelectObject(hDCCopy, hBmpOld)
' Call DeleteDC(hDCCopy)
' Call ReleaseDC(0&, hDCSrc)
' If rtn Then CreateBmpOfWindowRect = hBmp
'' Call DeleteObject(hBmp)
'End Function
Private Function CreateBmpBySelRect(aRect As RECT) As LongPtr
Dim rtn As LongPtr
Dim WidthSrc As Long, HeightSrc As Long
Dim hDCSrc As LongPtr, hDCCopy As LongPtr
Dim hBmp As LongPtr, hBmpOld As LongPtr
hDCSrc = GetDC(0&)
With aRect
WidthSrc = .Right - .Left
HeightSrc = .Bottom - .Top
End With
hDCCopy = CreateCompatibleDC(hDCSrc)
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpOld = SelectObject(hDCCopy, hBmp)
rtn = BitBlt(hDCCopy, 0&, 0&, WidthSrc, HeightSrc, hDCSrc, aRect.Left, aRect.Top, vbSrcCopy)
hBmp = SelectObject(hDCCopy, hBmpOld)
Call DeleteDC(hDCCopy)
Call ReleaseDC(0&, hDCSrc)
If rtn Then CreateBmpBySelRect = hBmp
End Function
Private Sub SetMySize()
Dim maxW As Single, maxH As Single, c As MSForms.Control
Dim minTop As Single, minLeft As Single
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top + c.Height > maxH Then maxH = c.Top + c.Height
If c.Left + c.Width > maxW Then maxW = c.Left + c.Width
End If
Next
minTop = maxH
minLeft = maxW
For Each c In Me.Controls
If c.Parent Is Me And c.Visible Then
If c.Top >= 0 And c.Top < minTop Then minTop = c.Top
If c.Left >= 0 And c.Left < minLeft Then minLeft = c.Left
End If
Next
Me.Width = maxW + minLeft + (Me.Width - Me.InsideWidth)
Me.Height = maxH + minTop + (Me.Height - Me.InsideHeight)
End Sub
Private Sub SetMyWinStyle(sw As Boolean)
Static fmLeftW As Single, fmTopH As Single, ws As LongPtr, wes As LongPtr
Dim hw As LongPtr, wr As RECT, cr As RECT
fmFullMode = sw
WindowFromAccessibleObject Me, hw
If sw Then
wes = GetWindowLongPtr(hw, GWL_EXSTYLE)
ws = GetWindowLongPtr(hw, GWL_STYLE)
Call GetClientRect(hw, cr)
#If Win64 Then '*******************************************{
Dim t32x2 As typeINT32x2, t64 As typeINT64
t64.Value = ws
LSet t32x2 = t64
' Debug.Print Now; Hex(t32x2.Value1), Hex(t32x2.Value2)
Call AdjustWindowRect(cr, t32x2.Value1, False)
#Else '----------------------------------------------------
Call AdjustWindowRect(cr, ws, False)
#End If '}_________________________________________________/
fmLeftW = cr.Left * (XLPPI / DPIX)
fmTopH = cr.Top * (XLPPI / DPIY)
xFrom = Me.Left - fmLeftW: yFrom = Me.Top - fmTopH
SetWindowLongPtr hw, GWL_EXSTYLE, wes And Not WS_EX_DLGMODALFRAME Or WS_EX_LAYERED
SetWindowLongPtr hw, GWL_STYLE, ws And Not WS_CAPTION
DrawMenuBar hw
SetLayeredWindowAttributes hw, 0&, &H80, LWA_ALPHA
Me.BackColor = &H0&
Image1.Visible = False
ButtonCapture.Visible = False
ButtonWriteOut.Visible = False
ButtonCopy.Visible = False
ButtonSave.Visible = False
ShowWindow hw, SW_SHOWMAXIMIZED
Else
SetLayeredWindowAttributes hw, 0&, &HFF, LWA_ALPHA
SetWindowLongPtr hw, GWL_EXSTYLE, wes
SetWindowLongPtr hw, GWL_STYLE, ws
DrawMenuBar hw
Me.BackColor = &H8000000F
Image1.AutoSize = True
Image1.AutoSize = False
Image1.Visible = True
ButtonCapture.Visible = True
ButtonWriteOut.Visible = True
ButtonCopy.Visible = True
ButtonSave.Visible = True
ButtonCapture.Top = IIf(Image1.Height < DEF_H, DEF_H, Image1.Height) - SIZE_BTN
ButtonWriteOut.Top = ButtonCapture.Top
ButtonCopy.Top = ButtonCapture.Top
ButtonSave.Top = ButtonCapture.Top
ButtonCapture.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 4
ButtonWriteOut.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 3
ButtonCopy.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 2
ButtonSave.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 1
Call SetMySize
Me.StartUpPosition = 0
Me.Move xFrom + fmLeftW, yFrom + fmTopH
xFrom = 0: yFrom = 0
Me.Hide
Me.Show vbModeless
End If
End Sub
Private Sub ButtonCapture_Click()
Call SetMyWinStyle(True)
End Sub
Private Sub ButtonCopy_Click()
If Image1.Picture Is Nothing Then Exit Sub
Call CopyBmptoClipboard(Image1.Picture.Handle)
End Sub
Private Sub ButtonSave_Click()
If Image1.Picture Is Nothing Then Exit Sub
Dim savePath As String
savePath = Application.DefaultFilePath & "\Screenshot_" & Format$(Now, "yyyymmdd_hhnnss") & ".png"
savePath = Application.GetSaveAsFilename(savePath, "PNG 形式,*.png,JPEG 形式,*.jpg,TIF 形式,*.tif,GIF 形式,*.gif,Windows ビットマップ,*.bmp")
If savePath <> "False" Then
Dim hImg As LongPtr, pxARGB() As typeARGB
Dim tkn As LongPtr, gi As GdiplusStartupInput
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
pxARGB = GetARGBofBmp(Image1.Picture.Handle)
hImg = CreateBmpByARGB(pxARGB, PixelFormat32bppRGB)
SaveToFile hImg, savePath
Call GdipDisposeImage(hImg)
Call GdiplusShutdown(tkn)
End If
End Sub
Private Sub ButtonWriteOut_Click()
If Image1.Picture Is Nothing Then Exit Sub
Dim pxARGB() As typeARGB
pxARGB = GetARGBofBmp(Image1.Picture.Handle)
Call WriteOutCOLORREFtoCells(pxARGB)
End Sub
Private Sub UserForm_Activate()
Static cnt As Long
If cnt = 0 Then Call SetMyWinStyle(True)
cnt = cnt + 1
End Sub
Private Sub UserForm_Initialize()
#If Win64 Then
Debug.Print Now; "Running in 64-bit ver"
#Else
Debug.Print Now; "Running in 32-bit ver"
#End If
Dim hDC As LongPtr
hDC = GetDC(Application.hwnd)
DPIX = GetDeviceCaps(hDC, LOGPIXELSX)
DPIY = GetDeviceCaps(hDC, LOGPIXELSY)
XLPPI = Application.InchesToPoints(1)
ReleaseDC Application.hwnd, hDC
Set Image1 = Me.Controls.Add("Forms.Image.1", "Image1")
With Image1
.BorderStyle = fmBorderStyleNone
.Width = DEF_W
.Height = DEF_H
End With
Set ButtonCapture = Me.Controls.Add("Forms.CommandButton.1", "ButtonCapture")
With ButtonCapture
.Width = SIZE_BTN
.Height = SIZE_BTN
.PicturePosition = fmPicturePositionCenter
Set .Picture = CommandBars.GetImageMso("ScreenshotInsertGallery", 16&, 16&)
.TakeFocusOnClick = False
.TabStop = False
.Accelerator = "X"
End With
Set ButtonWriteOut = Me.Controls.Add("Forms.CommandButton.1", "ButtonWriteOut")
With ButtonWriteOut
.Width = SIZE_BTN
.Height = SIZE_BTN
.PicturePosition = fmPicturePositionCenter
Set .Picture = CommandBars.GetImageMso("ExportExcel", 16&, 16&)
.TakeFocusOnClick = False
.TabStop = False
.Accelerator = "W"
End With
Set ButtonCopy = Me.Controls.Add("Forms.CommandButton.1", "ButtonCopy")
With ButtonCopy
.Width = SIZE_BTN
.Height = SIZE_BTN
.PicturePosition = fmPicturePositionCenter
Set .Picture = CommandBars.GetImageMso("Copy", 16&, 16&)
.TakeFocusOnClick = False
.TabStop = False
.Accelerator = "C"
End With
Set ButtonSave = Me.Controls.Add("Forms.CommandButton.1", "ButtonSave")
With ButtonSave
.Width = SIZE_BTN
.Height = SIZE_BTN
.PicturePosition = fmPicturePositionCenter
Set .Picture = CommandBars.GetImageMso("FileSave", 16&, 16&)
.TakeFocusOnClick = False
.TabStop = False
.Accelerator = "S"
End With
ButtonCapture.Top = Image1.Height - SIZE_BTN
ButtonWriteOut.Top = ButtonCapture.Top
ButtonCopy.Top = ButtonCapture.Top
ButtonSave.Top = ButtonCapture.Top
ButtonCapture.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 4
ButtonWriteOut.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 3
ButtonCopy.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 2
ButtonSave.Left = IIf(Image1.Width < DEF_W, DEF_W, Image1.Width) - SIZE_BTN * 1
Call SetMySize
End Sub
Private Sub UserForm_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If fmFullMode And KeyCode.Value = vbKeyEscape Then
On Error Resume Next
Me.Controls.Remove "labelRect"
On Error GoTo 0
fmFullMode = False
Call SetMyWinStyle(False)
ElseIf Not fmFullMode And Shift = 2 Then
Select Case KeyCode.Value
Case vbKeyC: ButtonCopy_Click
Case vbKeyS: ButtonSave_Click
Case vbKeyW: ButtonWriteOut_Click
End Select
ElseIf Not fmFullMode And Shift = 0 Then
Select Case KeyCode.Value
Case vbKeyUp: Me.Move Me.Left, Me.Top - (XLPPI / DPIY)
Case vbKeyLeft: Me.Move Me.Left - (XLPPI / DPIX)
Case vbKeyDown: Me.Move Me.Left, Me.Top + (XLPPI / DPIY)
Case vbKeyRight: Me.Move Me.Left + (XLPPI / DPIX)
End Select
End If
End Sub
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If fmFullMode And Button = 1 Then
xFrom = x: yFrom = y
GetCursorPos pFrom
On Error Resume Next
Me.Controls.Remove "labelRect"
On Error GoTo 0
Set labelRect = Me.Controls.Add("Forms.Label.1", "labelRect")
With labelRect
.Top = y: .Left = x
.Width = 0: .Height = 0
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = &HFFFFFF
End With
End If
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Static xTo As Single, yTo As Single
If fmFullMode And Button = 1 Then
xTo = x: yTo = y
labelRect.Left = IIf(xTo < xFrom, xTo, xFrom)
labelRect.Top = IIf(yTo < yFrom, yTo, yFrom)
labelRect.Width = Abs(xFrom - xTo)
labelRect.Height = Abs(yFrom - yTo)
GetCursorPos pTo
With selRect
.Left = IIf(pTo.x < pFrom.x, pTo.x, pFrom.x)
.Top = IIf(pTo.y < pFrom.y, pTo.y, pFrom.y)
.Bottom = IIf(pTo.y > pFrom.y, pTo.y, pFrom.y)
.Right = IIf(pTo.x > pFrom.x, pTo.x, pFrom.x)
End With
End If
End Sub
Private Sub UserForm_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If fmFullMode And Button = 1 Then
Me.Hide
On Error Resume Next
Me.Controls.Remove "labelRect"
On Error GoTo 0
Dim hBmp As LongPtr
hBmp = CreateBmpBySelRect(selRect)
If hBmp Then Set Image1.Picture = CreatePictureByhBmp(hBmp)
Call SetMyWinStyle(False)
End If
End Sub
（白茶） 2023/11/22(水) 17:14:48
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.