Results of 1 - 1 of about 37684 for IF (0.007 sec.)
- [[20231116211156]]
- #score: 1591
- @digest: 3caa95c77945788607260dacf92956b1
- @id: 95574
- @mdate: 2023-11-22T08:14:48Z
- @size: 73773
- @type: text/plain
- #keywords: longptr (255219), pxargb (248195), pxheight (189419), pxwidth (186206), typeargb (134398), gdiplus (128169), buttoncapture (118249), ptrsafe (110331), hbmp (96921), hdcsrc (94825), widthsrc (88334), buttonwriteout (83469), buttonsave (83469), heightsrc (82527), buttoncopy (76172), bmpdata (73953), selectobject (73452), himg (69327), bmiheader (68210), pixelformat (67199), biheight (63807), declare (62902), bitmap (55877), image1 (55347), gdi32 (55190), ビッ (43031), savepath (38164), hdc (36994), ネン (35524), user32 (34772), green (32760), private (31575)
- 『画像の任意の範囲のRGB値をエクセルでデータ化したい』（てつ）
恐縮です、どなたかご教授頂ければ幸いです。 画像の任意の範囲のRGB値をエクセルでデータ化したい 任意の範囲は同一画像で数か所ございます。 また、画像は同サイズで数種類ございます。 それぞれの、画像にも対応したいです。 大まかな、手順は 1）画像を選択する 2）任意の範囲をマウスで設定する 3）作成された範囲に番号を振る 4）エクセルにボタンをつくり クリックすると、一括でそれぞれの任意の範囲の 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個提示したけど反応無さそうなので、私はこれで一旦失礼しますよ〜 範囲選択をどうしたもんだかなと思って色々考えてました。 > 1）画像を選択する って言うけど、そもそもどこにある画像なのかも定かでないし、 > 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 ---- KNY Studio https://www.knystudio.net/ ↑Rapture(おにぎり)の様な使用感をUserFormで再現してみたらどうだろう。 ...と思て、ちょっと気合い入れて書いてみました。(質問はもうそっちのけ。反応もない事だし) 自学ノート晒す2。^^; 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 '1画素当たりのビット数 (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 'ターゲット・デバイスの水平および垂直解像度 (単位は画素数/m) biYPelsPerMeter As Long ' アプリケーションはこれらの値を リソースグループの中からデバイスに最適なビットマップを選択するために使用してもよい biClrUsed As Long 'ビットマップが実際に使用するカラーテーブルのエントリ数 ' biClrUsed=0 の場合ビットマップは biBitCount に対応する最大色数を使用する ' biClrUsed>0 かつ biBitCount<16 の場合biClrUsed は実際に使用される色数 ' biBitCount>=16 の場合biClrUsed はシステムカラーパレットの性能を最適化するのに用いられるカラーテーブルのサイズ ' biBitCount=16 または 32 の場合最適カラーパレットは3つの 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 '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... - https://www.excel.studio-kazu.jp/wiki/kazuwiki/202311/20231116211156.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97044 documents and 608215 words.
訪問者：