古代VBプログラマ質問スレ（Ver.6.0 まで） part65 [転載禁止]©2ch.net (835ﾚｽ)
上下前次1-新
抽出解除 必死ﾁｪｯｶｰ(本家) (べ) 自ID ﾚｽ栞 あぼーん

---

783: デフォルトの名無しさん [sage] 2023/05/09(火) 16:11:08.45 ID:WGtTQQBV(1/4) AAS
>>781

これでどうでしょうか？

フォーム上に Picture1 と Command1 を置きました。
Picture1 上には任意の Image を置いてください。

※ Picture1 の ScaleMode プロパティは、「3 - ピクセル」に設定してください。

---

784: デフォルトの名無しさん [sage] 2023/05/09(火) 16:11:45.13 ID:WGtTQQBV(2/4) AAS
Option Explicit

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long

Private Const SRCCOPY = &HCC0020

Private Declare Function BitBlt Lib "gdi32" (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 Const CF_BITMAP As Long = 2

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal uFormat As Long, ByVal hData As Long) As Long

---

785: デフォルトの名無しさん [sage] 2023/05/09(火) 16:12:13.61 ID:WGtTQQBV(3/4) AAS
Private Sub Command1_Click()

Dim hDC As Long
Dim hBitmap As Long
Dim hBitmapOld As Long

hDC = CreateCompatibleDC(Picture1.hDC)
hBitmap = CreateCompatibleBitmap(Picture1.hDC, Picture1.ScaleWidth, Picture1.ScaleHeight)
hBitmapOld = SelectObject(hDC, hBitmap)

BitBlt hDC, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, Picture1.hDC, 0, 0, SRCCOPY

If OpenClipboard(Me.hWnd) Then
If (EmptyClipboard()) Then
SetClipboardData CF_BITMAP, hBitmap
End If

CloseClipboard
End If

SelectObject hDC, hBitmapOld
'DeleteObject hBitmap
DeleteDC hDC

End Sub

---

786: デフォルトの名無しさん [sage] 2023/05/09(火) 16:12:29.38 ID:WGtTQQBV(4/4) AAS
全 Image を Picture1 に BitBlt する必要な無いみたいです。

VB6 の Clipboard オブジェクトを使用する場合は、StdPicture にする必要があるみたいですが、
hBitmap を StdPicture に変換するより Clipboard API を使用して hBitmap を渡す方が簡単だと思ったので
この様にしました。

---

上下前次1-新書関写板覧索設栞歴

---

ｽﾚ情報 赤ﾚｽ抽出 画像ﾚｽ抽出 歴の未読ｽﾚ AAｻﾑﾈｲﾙ

---

ぬこの手 ぬこTOP 1.395s*