andromedakiev
Junior Member | Редактировать | Профиль | Сообщение | Цитировать | Сообщить модератору
На VBA нужно вытянуть картинку из Picture1 на форме и разместить ее в массив.
Код заимствован из инета. Вызываю функцию так:
GetImage Ary, GetDC(UserForm1.Picture1.Picture.Handle), UserForm1.Picture1.Picture.Handle
в итоге - не работает. ((
Прошу руку помощи! Помогите решить задачу!
{Module1
Public Declare Function CreateCompatibleBitmap Lib "gdi32" _
(ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Public Declare Function GetDiBits Lib "gdi32" Alias "GetDIBits" _
(ByVal hdc As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, ByVal nNumScans As Long, _
ByRef lpBits As Any, lpBI As BITMAPINFO, _
ByVal wUsage As Long) As Long
Public Declare Function SelectObject Lib "gdi32" _
(ByVal hdc As Long, _
ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Type RGBQUAD
b As Byte
g As Byte
r As Byte
Reserved As Byte
End Type
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
Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
Public Const DIB_RGB_COLORS = 0 ' color table in RGBs
Public Function GetImage(ByRef Ary() As RGBQUAD, hdc As Long, hBMP As Long)
Dim BMI As BITMAPINFO
Dim w As Long, h As Long
With BMI.bmiHeader
.biSize = Len(BMI.bmiHeader)
End With
GetDiBits hdc, hBMP, 0, 1, ByVal 0&, BMI, DIB_RGB_COLORS
With BMI.bmiHeader
w = .biWidth
h = Abs(.biHeight)
.biBitCount = 32
.biHeight = -h
End With
If w <= 0 Or h <= 0 Then
Err.Raise 11111, "GetImage", "Failed."
End If
ReDim Ary(0 To w - 1, 0 To h - 1)
GetDiBits hdc, hBMP, 0, h, Ary(0, 0), BMI, DIB_RGB_COLORS
End Function
}
{ module2
Option Explicit
Public Declare Function GetPixel Lib "gdi32" _
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function FindWindow32 Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, _
ByVal yPoint As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
}
вызываю так:
Dim Ary() As RGBQUAD
GetImage Ary, GetDC(UserForm1.Picture1.Picture.Handle), UserForm1.Picture1.Picture.Handle
|
Естественно, приведенные процедуры должны находиться на объекте ThisWorkbook.
