Vâng cám ơn Thầy vì đã hướng dẫn cách này, bởi cái thủ tục Insert Picture đó là học (nói đúng ra là sao chép toàn bộ) của Thầy NDU vì thấy nó hay quá mà em chưa thể tự mình nghiên cứu được khi phải trả lời ngay bài này ạ.
Cám ơn Thầy đã chỉ cho một hướng đi ngắn gọn.
Nếu bạn hiểu được bản chất của mỗi vấn đề, nếu bạn hiểu được code, hiểu được system thì bạn sẽ biết cách thao tác.
Tôi thấy bạn thích "vọc" nên giải thích chút cho bạn hiểu. Nếu nói về IPictureDisp thì bạn đã biết cách tạo. Chỉ cần có bitmap handle là tạo được, bất luận bạn có bitmap handle từ đâu bằng cách nào.
Nếu nói về Picture (interface IPictureDisp) thì ta xét một đoạn của Function PictureFromObject
[GPECODE=vb]
If hPtr <> 0 Then
Dim uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPictureDisp
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(PicType = CF_BITMAP, PicType_BITMAP, PicType_ENHMETAFILE)
.hPic = hCopy
End With
OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
Set PictureFromObject = IPic
End If
[/GPECODE]
Tức muốn tạo IPic (as IPictureDisp) thì ta phải gọi hàm OleCreatePictureIndirect và truyền cấu trúc uPicInfo. Muốn thiết lập các trường của cấu trúc uPicInfo thì bạn phải có hCopy. Nếu bạn hiểu được API và hiểu được bitmap thì bạn sẽ biết hCopy chẳng qua là "bitmap handle". Thế thôi.
1. bitmap handle là gì. Trong Windows có rất nhiều "object" có cái gọi là handle. Hiểu nôm na là "số nhận dạng". Vd. bạn gọi SetWindowLong để thiết lập style cho cửa sổ (không có thanh tiêu đề) thì Windows muốn biết bạn định thao tác cho cửa sổ nào trong system vì trong system có muôn vàn cửa sổ. Vậy khi gọi hàm SetWindowLong thì bạn truyền cái gọi là "window handle" - hwnd (mà bạn có được "bằng cách nào đấy"). Có rất nhiều hàm API để thao tác với cửa sổ, bitmap, brusk, font, device context v...v mà mỗi "loại" thì có muôn vàn trong system, vậy khi gọi hàm API bạn phải truyền 1 tham số để system biết phải thao tác trên "object" cụ thể nào. Vì thế Windows "bịa" ra cái gọi là handle. Mỗi cửa sổ, bitmap, brusk, font, device context v...v được tạo ra trong RAM bởi Windows được Windows "gán" cho 1 con số gọi là handle (y như mã nhân viên vậy). Chúng là duy nhất trong system nên có thể dùng chúng để xác định được "object" đang nói tới là object nào trong RAM. Từ đó cứ gọi hàm API và truyền vào "handle" là Windows biết cần phải thao tác trên cửa sổ, bitmap, brusk, font, device context v...v nào trong muôn vàn cửa sổ, bitmap, brusk, font, device context v...v có trong system.
2. Handle "đọc" ra từ đâu? Có muôn vàn cách đọc. Ví như handle của cửa sổ bạn đọc ra bằng hàm FindWindow. Nhưng có muôn vàn cách khác, vd. EnumWindows, và nhiều cách khác nữa. Tương tự như bitmap handle. Bitmap handle là bitmap handle, nôm na là "số nhận dạng" của bitmap. Chả có liên quan gì tới clipboard cả. Tất nhiên nếu bitmap được copy vào clipboard thì có thể dùng API đọc ra bitmap handle. Nhưng có những bitmap không được copy vào clipboard. Chúng có handle nhưng làm gì có trong clipboard để mà đọc ra từ clipboard.
Tóm lại với bitmap handle cũng có muôn vàn cách đọc ra. Nếu đã được copy vào clipboard thì bạn biết cách đọc ra rồi. Nhưng cũng có muôn vàn cách đọc.
Tôi cho 2 vd.: tạo ảnh của cửa sổ Excel và tự tạo ảnh 1 hình vuông đỏ có chữ nền trong RAM rồi đọc ra bitmap handle của chúng. Sau khi có bitmap handle thì gọi OleCreatePictureIndirect để có IPictureDisp.
Trong 2 ví dụ này, hoặc nếu ta kiểm tra xem trong clipboard có bitmap không để đọc ra handle của nó (vd. do người dùng giải lao với Excel và làm việc một chút với Paint và copy ảnh nào đó vào clipboard) thì làm gì có object nào để mà truyền vào hàm PictureFromObject? Pictures, shape, Range?
module1
[GPECODE=vb]
Private Const SRCCOPY As Long = &HCC0020
Private Const TRANSPARENT As Long = 1
Private Type RECT
left As Long
top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long,
ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function Rectangle Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetRect Lib "user32.dll" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function TextOutW Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Function HBITMAPFromWindowHandle(ByVal hwnd As Long)
Dim DC As Long, memDC As Long, hbmp As Long, w As Long, h As Long, old As Long, rc As RECT
' đọc ra device context (DC) for the entire window
DC = GetWindowDC(hwnd)
' đọc ra tọa độ của cửa sổ - hình chữ nhật trên desktop
GetWindowRect hwnd, rc
' chiều dài của cửa sổ
w = rc.Right - rc.left
' chiều cao của cửa sổ
h = rc.Bottom - rc.top
' tạo memory device context (DC) compatible với device context của cửa sổ
memDC = CreateCompatibleDC(DC)
' tạo bitmap compatible với device context của cửa sổ, có chiều dài là w và chiều rộng là h, tức có kích thước của cửa sổ
hbmp = CreateCompatibleBitmap(DC, w, h)
' chọn bitmap vừa tạo vào memory device context
old = SelectObject(memDC, hbmp)
' chuyển dữ liệu mầu từ device context của cửa sổ sang memory device context (có chứa bitmap được tạo)
BitBlt memDC, 0, 0, w, h, DC, 0, 0, SRCCOPY
' chọn lại bitmap đã có từ trước trong memory device context vào nó
SelectObject memDC, old
' hủy memory device context đã tạo lúc trước
DeleteDC memDC
' giải phóng device context của cửa sổ
ReleaseDC hwnd, DC
' trả về bitmap đã tạp trong bộ nhớ và đã có các dữ liệu mầu của cửa sổ
HBITMAPFromWindowHandle = hbmp
End Function
Function CreateSomethingBitmap() As Long
Dim ScreenDC As Long, memDC As Long, old As Long, tmpold As Long, tmpHandle As Long
Dim hBrush As Long, oldBrush As Long, rc As RECT, text As String
' tạo memory device context
ScreenDC = CreateCompatibleDC(0)
' đọc display device context
memDC = GetDC(0)
' tạo bitmap có dài và rộng = 300
tmpHandle = CreateCompatibleBitmap(memDC, 300, 300)
' giải phóng device context
ReleaseDC 0, memDC
' tạo memory device context
memDC = CreateCompatibleDC(0)
' chọn bitmap vào memory device context
tmpold = SelectObject(memDC, tmpHandle)
' tạo brush có mầu đỏ
hBrush = CreateSolidBrush(RGB(255, 0, 0))
' chọn brush vào memory device context
oldBrush = SelectObject(memDC, hBrush)
' thiết lập một "hình chữ nhật" có cạnh = 300
SetRect rc, 0, 0, 300, 300
' "đổ" mầu vào memory device context mà trong đó có bitmap 300x300 vào vùng có kích thước 300x300, tức đổ "kín" bitmap
FillRect memDC, rc, hBrush
' thiết lập background cho memory device context thành "trong suốt" vì nếu không thì khi viết Text sẽ có nền mầu trắng
SetBkMode memDC, TRANSPARENT
text = "He he he hic hic hic ten ten"
' viết text lên bitmap có trong memory device context
TextOutW memDC, 50, 150, StrConv(text, vbUnicode), Len(text)
' chọn old brush vào lại memory device context
SelectObject memDC, hBrush
' chọn lại old bitmap vào memory device context
SelectObject memDC, tmpold
' hủy brush đã tạo
DeleteObject hBrush
' hủy device context đã tạo lúc trước
DeleteDC ScreenDC
' hủy device context đã tạo lúc trước
DeleteDC memDC
' trả về bitmap handle đã tạo, đã được "đổ" mầu và viết text
CreateSomethingBitmap = tmpHandle
End Function
[/GPECODE]
module2
[GPECODE=vb]
Sub Button1_Click()
Dim hbmp As Long
hbmp = HBITMAPFromWindowHandle(Application.hwnd)
UserForm1.Picture = HBITMAPToIPicture(hbmp)
With UserForm1
.left = Application.left
.top = Application.top
.Width = Application.Width
.Height = Application.Height
End With
UserForm1.Show
End Sub
Sub Button2_Click()
Dim hBitmap As Long
hBitmap = CreateSomethingBitmap
UserForm1.Picture = HBITMAPToIPicture(hBitmap)
UserForm1.Show
End Sub
[/GPECODE]
module modPicture
[GPECODE=vb]
Const PICTYPE_BITMAP = 1
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
'cấu trúc GUID
Private Type GUID
D1 As Long
D2 As Integer
D3 As Integer
D4(0 To 7) As Byte
End Type
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
hPal As Long
End Type
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As GUID, ByVal fOwn As Long, lplpvObj As Any) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Function RangeToHBITMAP(rng As range) As Long
Dim hRes As Long
rng.Copy
OpenClipboard 0
hRes = GetClipboardData(CF_BITMAP)
If hRes <> 0 Then RangeToHBITMAP = CopyImage(hRes, IMAGE_BITMAP, 0, 0,
LR_COPYRETURNORG)
CloseClipboard
Application.CutCopyMode = False
End Function
Function HBITMAPToIPicture(ByVal hbmp As Long) As IPictureDisp
Dim lpPictDesc As PictDesc, riid As GUID, pic As IPictureDisp
' nếu c bitmap handle
If hbmp <> 0 Then
' GUID của Interface IPicture - {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With riid
.D1 = &H7BF80980
.D2 = &HBF32
.D3 = &H101A
.D4(0) = &H8B
.D4(1) = &HBB
.D4(2) = &H0
.D4(3) = &HAA
.D4(4) = &H0
.D4(5) = &H30
.D4(6) = &HC
.D4(7) = &HAB
End With
With lpPictDesc
.cbSizeofStruct = Len(lpPictDesc) ' độ lớn của cấu trúc PictDesc
.picType = PICTYPE_BITMAP ' dạng ảnh
.hImage = hbmp ' bitmap handle
.hPal = 0
End With
' tạo Picture
If OleCreatePictureIndirect(lpPictDesc, riid, True, pic) = 0 Then
Set HBITMAPToIPicture = pic
End If
End If
End Function
[/GPECODE]
, chắc phải ít thời gian nữa mới lĩnh hội được. 
