サンプル投稿用掲示板 VB2005 〜 用トップページ VB6.0 用 トップページ
- 日時： 2007/09/14 20:24
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[描画・画像][][] *
* キーワード：グラフィック,ビットマップ,ピクチャー,90度毎に回転,, *
***********************************************************************************
このサイトを開設した当初大変お世話になった、ゆう(U) さんに投稿頂いた分を第一弾に選んで見ました。
(突然WEB上から見かけなくなったのですが何方か、ゆう(U) さんの消息をご存知の方おられないでしょうか？)
かなり高速に画像を回転表示させる事ができます。
【VB6.0用の開設当初の掲示板のログより】
-------------------------------------------------------------------------------------
No.4143 Re：画像を９０度回転表示する方法 投稿者：ゆう(U) [2002/03/22(金)19：34分]
-------------------------------------------------------------------------------------
サンプル）
[標準モジュールへ]
Option Explicit
Private Declare Function CreateCompatibleDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32" _
(ByVal hDC As Long, _
ByRef pBitmapInfo As BITMAPINFO, _
ByVal un As Long, _
ByRef lplpVoid As Long, _
ByVal handle As Long, _
ByVal dw As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hObject As Long) As Long
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 Declare Function GetDIBits Lib "gdi32" _
(ByVal aHDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As BITMAPINFO, _
ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" _
(ByVal hDC As Long, _
ByVal hBitmap As Long, _
ByVal nStartScan As Long, _
ByVal nNumScans As Long, _
ByRef lpBits As Any, _
ByRef lpBI As BITMAPINFO, _
ByVal wUsage As Long) 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 RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Private Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors As RGBQUAD
End Type
'ピクチャボックスを90度回転させます
Public Sub PicRot90(ByRef myPicture As PictureBox, _
Optional ByVal Center As Boolean = False)
Const SRCCOPY = &HCC0020
Const DIB_RGB_COLORS = 0&
Const BI_RGB = 0&
Dim myContainer As Object
Dim intScaleMode As Integer
Dim sngScaleWidth As Single, sngScaleHeight As Single
Dim sngScaleLeft As Single, sngScaleTop As Single
Dim lngWidth As Long, lngHeight As Long
Dim XX As Long, YY As Long
Dim hDC_Temp As Long
Dim hDC_Object As Long
Dim hBitmap As Long
Dim ppvBits As Long
Dim myBMPINFO As BITMAPINFO
Dim myBMPINFO1 As BITMAPINFO
Dim myBMPINFO2 As BITMAPINFO
Dim lngArray() As Long
Dim lngArray2() As Long
Dim blnAutoRedraw As Boolean
Dim blnVisible As Boolean
Dim lngResult As Long
With myPicture
'継続表示属性でなかった絵は消えます
blnAutoRedraw = .AutoRedraw
.AutoRedraw = True
'表示画像サイズ取得
lngWidth = .ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
lngHeight = .ScaleY(.ScaleHeight, .ScaleMode, vbPixels)
'作業用hDC取得
hDC_Temp = CreateCompatibleDC(.hDC)
'作業用hBitmap作成
With myBMPINFO
With .bmiHeader
.biSize = LenB(myBMPINFO.bmiHeader)
.biWidth = lngWidth
.biHeight = lngHeight
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
End With
hBitmap = CreateDIBSection(hDC_Temp, myBMPINFO, DIB_RGB_COLORS, ppvBits, 0, 0)
'画像コピー(現在のコントロールサイズ分)
hDC_Object = SelectObject(hDC_Temp, hBitmap)
lngResult = BitBlt(hDC_Temp, 0, 0, lngWidth, lngHeight, .hDC, 0, 0, SRCCOPY)
Call SelectObject(hDC_Temp, hDC_Object)
'元画像用の配列を確保
ReDim lngArray(0 To lngWidth - 1, 0 To lngHeight - 1)
'画像コピーから色配列取得
myBMPINFO1.bmiHeader.biSize = Len(myBMPINFO1.bmiHeader)
lngResult = GetDIBits(hDC_Temp, hBitmap, 0, lngHeight, ByVal 0&, _
myBMPINFO1, DIB_RGB_COLORS)
lngResult = GetDIBits(hDC_Temp, hBitmap, 0, lngHeight, lngArray(0, 0), _
myBMPINFO1, DIB_RGB_COLORS)
'作業用hBitMapを削除
Call DeleteObject(hBitmap)
'加工用の配列を確保
ReDim lngArray2(0 To lngHeight - 1, 0 To lngWidth - 1)
'色配列を加工(時計回りに90度)
For YY = 0 To lngHeight - 1: For XX = 0 To lngWidth - 1
lngArray2(YY, (lngWidth - 1) - XX) = lngArray(XX, YY)
Next: Next
'加工後のhBitmap作成
With myBMPINFO
With .bmiHeader
.biSize = LenB(myBMPINFO.bmiHeader)
.biWidth = lngHeight
.biHeight = lngWidth
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
End With
hBitmap = CreateDIBSection(hDC_Temp, myBMPINFO, DIB_RGB_COLORS, ppvBits, 0, 0)
'色配列をBitmapへ
myBMPINFO2.bmiHeader.biSize = Len(myBMPINFO2.bmiHeader)
lngResult = GetDIBits(hDC_Temp, hBitmap, 0, lngWidth, ByVal 0&, myBMPINFO2, DIB_RGB_COLORS)
'GetDIBits後でなければSetDIBitsに失敗するので
lngResult = GetDIBits(hDC_Temp, hBitmap, 0, lngWidth, lngArray(0, 0), _
myBMPINFO2, DIB_RGB_COLORS)
Erase lngArray '不要
lngResult = SetDIBits(hDC_Temp, hBitmap, 0, lngWidth, lngArray2(0, 0), _
myBMPINFO2, DIB_RGB_COLORS)
Erase lngArray2 '不要
'コンテナ移動が発生するのを隠すのが主な目的
blnVisible = .Visible
.Visible = False
'コンテナをフォームに(コントロール位置・サイズ変更計算簡略化の為)
Set myContainer = .Container
Set .Container = .Parent
'フォームのScaleを保存
With .Parent
intScaleMode = .ScaleMode
If .ScaleMode = vbUser Then
sngScaleLeft = .ScaleLeft
sngScaleTop = .ScaleTop
sngScaleWidth = .ScaleWidth
sngScaleHeight = .ScaleHeight
End If
.ScaleMode = vbPixels
End With
'コントロール位置・サイズを調整
If Center Then
.Move .Left + (.Width - .Height) / 2, _
.Top + (.Height - .Width) / 2, _
.Height, .Width
Else
.Move .Left, .Top, .Height, .Width
End If
'ピクチャボックスへ転記
hDC_Object = SelectObject(hDC_Temp, hBitmap)
lngResult = BitBlt(.hDC, 0, 0, lngHeight, lngWidth, hDC_Temp, 0, 0, SRCCOPY)
Call SelectObject(hDC_Temp, hDC_Object)
'不要になったハンドルを削除
Call DeleteObject(hBitmap)
Call DeleteDC(hDC_Temp)
'元の状態へ戻す
With .Parent
If intScaleMode = vbUser Then
.ScaleLeft = sngScaleLeft
.ScaleTop = sngScaleTop
.ScaleWidth = sngScaleWidth
.ScaleHeight = sngScaleHeight
Else
.ScaleMode = intScaleMode
End If
End With
Set .Container = myContainer
.Visible = blnVisible
.AutoRedraw = blnAutoRedraw
End With
End Sub
 |
