[[20240215172026]]　『「ユーザーフォームのイメージを」[あん]　につい』（ｈｍ）　ページの最後に飛ぶ

『「ユーザーフォームのイメージを」[あん]　について』（ｈｍ）

投稿
[[20080518112807]] 『ユーザーフォームのイメージを』（あん）　
について...

＜使用 Excel：Excel2021、使用 OS：Windows10 ＞

質問は何ですか？質問なら内容が伝わるものにして下さい。
誤操作ならその旨断って終了して下さい。
（遊ばないで） 2024/02/15(木) 18:58:41

    Rem [UserForm1]モジュール(あらかじめ.Pictureに画像がロード済みとする)===========================================================================================================
    Option Explicit
    #If False Then
    Dim RotateFlipType
    Const RotateNoneFlipNone = 0
    Const Rotate90FlipNone = 1
    Const Rotate180FlipNone = 2
    Const Rotate270FlipNone = 3
    Const RotateNoneFlipX = 4
    Const Rotate90FlipX = 5
    Const Rotate180FlipX = 6
    Const Rotate270FlipX = 7
    Const RotateNoneFlipY = 6
    Const Rotate90FlipY = 7
    Const Rotate180FlipY = 4
    Const Rotate270FlipY = 5
    Const RotateNoneFlipXY = 2
    Const Rotate90FlipXY = 3
    Const Rotate180FlipXY = 0
    Const Rotate270FlipXY = 1
    #End If
    Private Type GUID
        Data1 As Long
        Data2 As Integer
        Data3 As Integer
        Data4(7) As Byte
    End Type
    Private Type PicBmp
        Size As Long
        Type As Long
        hBmp As LongPtr
        hPal As LongPtr
        Reserved As Long
    End Type
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) As Long
    Private Const vbPicTypeBitmap = 1&
    Private Const IID_IPictureDisp As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "gdiplus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As Long) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus.dll" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, ByRef bitmap As LongPtr) As Long
    Private Enum RotateFlipType
        RotateNoneFlipNone = 0  '時計回りの回転も反転も行わないことを指定します。
        Rotate90FlipNone = 1    '反転せずに時計回りに 90 度回転することを指定します。
        Rotate180FlipNone = 2   '反転せずに時計回りに 180 度回転することを指定します。
        Rotate270FlipNone = 3   '反転せずに時計回りに 270 度回転することを指定します。
        RotateNoneFlipX = 4     '時計回りに回転せずに水平方向に反転することを指定します。
        Rotate90FlipX = 5       '時計回りに 90 度回転してから、水平方向に反転することを指定します。
        Rotate180FlipX = 6      '時計回りに 180 度回転してから、水平方向に反転することを指定します。
        Rotate270FlipX = 7      '時計回りに 270 度回転してから、水平方向に反転することを指定します。
        RotateNoneFlipY = 6     '時計回りに回転せずに垂直方向に反転することを指定します。
        Rotate90FlipY = 7       '時計回りに 90 度回転してから、垂直方向に反転することを指定します。
        Rotate180FlipY = 4      '時計回りに 180 度回転してから、垂直方向に反転することを指定します。
        Rotate270FlipY = 5      '時計回りに 270 度回転してから、垂直方向に反転することを指定します。
        RotateNoneFlipXY = 2    '時計回りに回転せずに水平方向と垂直方向に反転することを指定します。
        Rotate90FlipXY = 3      '時計回りに 90 度回転してから、水平方向と垂直方向に反転することを指定します。
        Rotate180FlipXY = 0     '時計回りに 180 度回転してから、水平方向と垂直方向に反転することを指定します。
        Rotate270FlipXY = 1     '時計回りに 270 度回転してから、水平方向と垂直方向に反転することを指定します。
    End Enum
    Private Declare PtrSafe Function GdipImageRotateFlip Lib "gdiplus.dll" (ByVal image As LongPtr, ByVal rfType As RotateFlipType) As Long
    Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    Private tkn As LongPtr, gi As GdiplusStartupInput
    Private Function RotateBmp(hbm As LongPtr, hPal As LongPtr) As LongPtr
        Dim rtn As Long, bitmap As LongPtr
        rtn = GdipCreateBitmapFromHBITMAP(hbm, hPal, bitmap)
        rtn = GdipImageRotateFlip(bitmap, Rotate90FlipNone)
        rtn = GdipCreateHBITMAPFromBitmap(bitmap, RotateBmp, 0&)
    End Function
    Private Function CreatePictureByhBmp(ByVal hBmp As LongPtr, Optional hPal As LongPtr) As IPictureDisp
        Dim IID_IDispatch As GUID, Bmp As PicBmp
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0&
            .Data4(7) = &H46&
        End With
        With Bmp
            .Size = Len(Bmp)
            .Type = vbPicTypeBitmap
            .hBmp = hBmp
            .hPal = hPal
        End With
        Call OleCreatePictureIndirect(Bmp, IID_IDispatch, 1, CreatePictureByhBmp)
    End Function
    Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
    Private Sub UserForm_Click()
        If Me.Picture Is Nothing Then Exit Sub
        Dim hbm As LongPtr
        hbm = RotateBmp(Me.Picture.Handle, 0&)
        Me.Picture = CreatePictureByhBmp(hbm)
    End Sub
    Private Sub UserForm_Initialize()
        gi.GdiplusVersion = 1&
        Call GdiplusStartup(tkn, gi)
    End Sub
    Private Sub UserForm_Terminate()
        Call GdiplusShutdown(tkn)
    End Sub

（白茶） 2024/02/15(木) 19:29:38

コメント返信：

[ 一覧(最新更新順) ]

[[20240215172026]] 『「ユーザーフォームのイメージを」[あん] につい』（ｈｍ） ページの最後に飛ぶ

[[20240215172026]]　『「ユーザーフォームのイメージを」[あん]　につい』（ｈｍ）　ページの最後に飛ぶ