| 投稿日 | ： 2007/04/10(Tue) 18:02 |
| 投稿者 | ： なな |
| Ｅメール | ： |
| ＵＲＬ | ： |
| タイトル | ： Re^12: PictureBox上のLineを回転させる方法 |
ダンボ様
回転と、左右回転のアドバイス。テストなど
ご回答ありがとうございます。
「解決した」と思っていましたが、画像も同時に回転してみると問題がありました。
教えていただいたソースを組込むとx1,y1を中心に回転しており、画像にラインがついてきていません・・・。
左右回転も、同様でした・・・。
以下は回転のソースです。
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
Const PAI = 3.1415926
Dim R As Double
Dim T As Double
'ピクチャボックスを90度回転させます
Public Sub PicRot90(ByRef myPicture As PictureBox)
Const SRCCOPY = &HCC0020
Const DIB_RGB_COLORS = 0&
Const BI_RGB = 0&
Dim myContainer As Object
Dim intScaleMode As Integer
Dim sngScaleWidth As Single
Dim sngScaleHeight As Single
Dim sngScaleLeft As Single
Dim sngScaleTop As Single
Dim lngWidth As Long
Dim lngHeight As Long
Dim XX As Long
Dim 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
'コントロール位置・サイズを調整
.Move .Left, .Top, .Height, .Width
'ピクチャボックスへ転記
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
Private Sub Command1_Click()
Picture1.Visible = False
Call PicRot90(Picture1)
Picture1.Visible = True
T = T + Radian(90)
Line1.X2 = R * Cos(T) + Line1.X1
Line1.Y2 = R * Sin(T) + Line1.Y1
End Sub
Private Sub Form_Load()
Picture1.Picture = LoadPicture("C:\sample.bmp")
With Line1
R = Sqr((.X2 - .X1) ^ 2 + (.Y2 - .Y1) ^ 2)
T = ArcTan(.X2 - .X1, .Y2 - .Y1)
End With
End Sub
Private Function Radian(D As Double) As Double
Radian = PAI * D / 180
End Function
Private Function ArcTan(X As Double, Y As Double) As Double
Select Case X
Case Is > 0
ArcTan = Atn(Y / X)
Case Is < 0
ArcTan = Atn(Y / X) + PAI
Case Else
ArcTan = Sgn(Y) * PAI / 2
End Select
End Function