tagCANDY CGI VBレスキュー(花ちゃん) - VBレスキュー(花ちゃん)の投稿サンプル用掲示板 - Visual Basic 6.0 VB2005 VB2010
VB2005用トップページへVBレスキュー(花ちゃん)のトップページVB6.0用のトップページ
VBレスキュー(花ちゃん)の投稿サンプル用掲示板
     サンプル投稿用掲示板  VB2005 〜 用トップページ  VB6.0 用 トップページ
画像を高速に90度毎に回転表示する方法(VB6.0) ( No.0 )  [親スレッドへ]
日時: 2007/09/14 20:24
名前: 花ちゃん

***********************************************************************************
* カテゴリー:[描画・画像][][]                                                    *
* キーワード:グラフィック,ビットマップ,ピクチャー,90度毎に回転,,                 *
***********************************************************************************

このサイトを開設した当初大変お世話になった、ゆう(U) さんに投稿頂いた分を第一弾に選んで見ました。
(突然WEB上から見かけなくなったのですが何方か、ゆう(U) さんの消息をご存知の方おられないでしょうか?)

かなり高速に画像を回転表示させる事ができます。

【VB6.0用の開設当初の掲示板のログより】

-------------------------------------------------------------------------------------
No.4143 Re:画像を90度回転表示する方法  投稿者:ゆう(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




 [スレッド一覧へ] [親スレッドへ]