VBGood网站全文搜索 Google

搜索VBGood全站网页(全文搜索)

VB爱好者乐园(VBGood)

 找回密码
 立即注册
搜索
查看: 1409|回复: 0

laviewpbt旋转图片的代码 窗口上有image控件,旋转90度,

[复制链接]
发表于 2015-11-2 14:23:51 | 显示全部楼层 |阅读模式
网上看到laviewpbt旋转图片的代码,但不会调用,假如窗口上有image控件,点击按钮旋转90度,那么这个按钮事件怎么写呢
代码出自 bbs.csdn.net/topics/300136525




Private Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type RECTF
    nLeft As Single
    nTop As Single
    nWidth As Single
    nHeight As Single
End Type

Private Type BitmapData
   Width As Long
   Height As Long
   Stride As Long
   PixelFormat As Long
   scan0 As Long
   Reserved As Long
End Type


Private Enum ImageLockMode
   ImageLockModeRead = &H1
   ImageLockModeWrite = &H2
   ImageLockModeUserInputBuf = &H4
End Enum
Private Enum EncoderParameterValueType
    [EncoderParameterValueTypeByte] = 1
    [EncoderParameterValueTypeASCII] = 2
    [EncoderParameterValueTypeShort] = 3
    [EncoderParameterValueTypeLong] = 4
    [EncoderParameterValueTypeRational] = 5
    [EncoderParameterValueTypeLongRange] = 6
    [EncoderParameterValueTypeUndefined] = 7
    [EncoderParameterValueTypeRationalRange] = 8
End Enum

Private Type EncoderParameter
    GUID(0 To 3)   As Long
    NumberOfValues As Long
    Type           As EncoderParameterValueType
    Value          As Long
End Type
'-- Encoder Parameters structure
Private Type EncoderParameters
    Count     As Long
    Parameter As EncoderParameter
End Type
Private Type ImageCodecInfo
    ClassID(0 To 3)   As Long
    FormatID(0 To 3)  As Long
    CodecName         As Long
    DllName           As Long
    FormatDescription As Long
    FilenameExtension As Long
    MimeType          As Long
    flags             As Long
    Version           As Long
    SigCount          As Long
    SigSize           As Long
    SigPattern        As Long
    SigMask           As Long
End Type
Private Const PixelFormat32bppARGB = &H26200A
Private Declare Function GdiplusStartup Lib "gdiplus" (Token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" (ByVal Token As Long)

Private Declare Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As Long, hImage As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus" (ByVal Image As Long) As Long
Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As Long, Graphics As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal Graphics As Long) As Long
Private Declare Function GdipDrawImageRectRectI Lib "gdiplus" (ByVal Graphics As Long, ByVal hImage As Long, ByVal dstX As Long, ByVal dstY As Long, ByVal dstWidth As Long, ByVal dstHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, ByVal srcUnit As Long, Optional ByVal imageAttributes As Long = 0, Optional ByVal callback As Long = 0, Optional ByVal callbackData As Long = 0) As Long
Private Declare Function GdipBitmapLockBits Lib "gdiplus" (ByVal bitmap As Long, Rct As RECT, ByVal flags As ImageLockMode, ByVal PixelFormat As Long, lockedBitmapData As BitmapData) As Long
Private Declare Function GdipBitmapUnlockBits Lib "gdiplus" (ByVal bitmap As Long, lockedBitmapData As BitmapData) As Long

Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal Image As Long, Width As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal Image As Long, Height As Long) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal psString As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszProgID As Long, pCLSID As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Function GdipSaveImageToFile Lib "gdiplus" (ByVal hImage As Long, ByVal sFilename As Long, clsidEncoder As Any, encoderParams As Any) As Long

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long
Private Declare Function GdipGetImageBounds Lib "gdiplus.dll" (ByVal nImage As Long, srcRect As RECTF, srcUnit As Long) As Long
Private Declare Function GdipGetImageEncodersSize Lib "gdiplus" (numEncoders As Long, Size As Long) As Long
Private Declare Function GdipGetImageEncoders Lib "gdiplus" (ByVal numEncoders As Long, ByVal Size As Long, Encoders As Any) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal Stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long

Private Declare Function GdipLoadImageFromStream Lib "gdiplus" (ByVal Stream As IUnknown, Image As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Function Rotate90(FileName As String) As Long
    Dim i                   As Long, j                      As Long
   
    Dim Token               As Long
    Dim Gsp                 As GdiplusStartupInput
    Dim BmpData             As BitmapData, Image            As Long
    Dim Dimensions          As RECTF, Rct                   As RECT
   
    Dim DataArr(0)          As Long, pDataArr(0 To 0)       As Long
    Dim OldArrPtr           As Long, OldpArrPtr             As Long
    Dim LineAddBytes        As Long
   
    Dim DataArrC(0)         As Long, pDataArrC(0 To 0)      As Long
    Dim OldArrPtrC          As Long, OldpArrPtrC            As Long
    Dim mPtrC               As Long
   
    Dim Width               As Long, Height                 As Long
    Dim Stride              As Long, Pointer                As Long
   
   Rotate90 = GetTickCount - Rotate90
    Gsp.GdiplusVersion = 1
    GdiplusStartup Token, Gsp
    GdipLoadImageFromFile StrPtr(FileName), Image
   
    GdipGetImageBounds Image, Dimensions, 2
    Rct.Right = Dimensions.nWidth
    Rct.Bottom = Dimensions.nHeight
   
    GdipBitmapLockBits Image, Rct, ImageLockModeRead, PixelFormat32bppARGB, BmpData
      
   
    mPtrC = GlobalAlloc(GPTR, BmpData.Stride * BmpData.Height)
    CopyMemory ByVal mPtrC, ByVal BmpData.scan0, BmpData.Stride * BmpData.Height
     
    MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
    MakePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC
    Pointer = BmpData.scan0
    Width = BmpData.Width
    Height = BmpData.Height
    Stride = BmpData.Stride
    pDataArr(0) = mPtrC
    For j = 1 To Width
        pDataArrC(0) = Pointer + 4 * (Width - j)
        For i = 1 To Height
            DataArr(0) = DataArrC(0)
            pDataArr(0) = pDataArr(0) + 4
            pDataArrC(0) = pDataArrC(0) + Stride
        Next
    Next
    FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
    FreePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC

    GdipBitmapUnlockBits Image, BmpData
    GdipDisposeImage Image
      
    GdipCreateBitmapFromScan0 Height, Width, Height * 4, PixelFormat32bppARGB, ByVal mPtrC, Image
  
    SavePictureToFile Image, FileName
  
    GdipDisposeImage Image
    GlobalFree mPtrC
   
    GdiplusShutdown Token
    Rotate90 = GetTickCount
End Function

Private Function SavePictureToFile(Image As Long, FileName As String, Optional ByVal Quality As Long = 80) As Boolean
    Dim aEncParams()         As Byte
    Dim uEncCLSID(0 To 3)   As Long, uEncParams         As EncoderParameters
    Const EncoderQuality As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
    If GetEncoderClsID("image/jpeg", uEncCLSID) <> -1 Then
        uEncParams.Count = 1                                        ' 设置自定义的编码参数,这里为1个参数
        ReDim aEncParams(1 To Len(uEncParams))
        With uEncParams.Parameter
            .NumberOfValues = 1
            .Type = [EncoderParameterValueTypeLong]                 ' 设置参数值的数据类型为长整型
            Call CLSIDFromString(StrPtr(EncoderQuality), .GUID(0))  ' 设置参数唯一标志的GUID,这里为编码品质
            If Quality < 0 Then
                Quality = 0
            ElseIf Quality > 100 Then
                Quality = 100
            End If
            .Value = VarPtr(Quality)                                ' 设置参数的值:品质等级,最高为100,图像文件大小与品质成正比
        End With
        CopyMemory aEncParams(1), uEncParams, Len(uEncParams)
        'If FileExist(FileName) Then Kill FileName
        SavePictureToFile = (GdipSaveImageToFile(Image, StrPtr(FileName), uEncCLSID(0), aEncParams(1)) = 0&)
    End If
End Function

Private Function GetEncoderClsID(strMimeType As String, ClassID() As Long) As Long
    Dim Num         As Long
    Dim Size        As Long
    Dim i           As Long
    Dim Info()      As ImageCodecInfo
    Dim Buffer()    As Byte
    GetEncoderClsID = -1
    '得到解码器数组的大小
    Call GdipGetImageEncodersSize(Num, Size)
    If (Size = 0) Then Exit Function ' 失败
    ReDim Info(1 To Num) As ImageCodecInfo  '给数组动态分配内存
    ReDim Buffer(1 To Size) As Byte

    Call GdipGetImageEncoders(Num, Size, Buffer(1))           '得到数组和字符数据
    Call CopyMemory(Info(1), Buffer(1), (Len(Info(1)) * Num))      '复制类头
   
    For i = 1 To Num             '循环检测所有解码
        If (StrComp(PtrToStrW(Info(i).MimeType), strMimeType, vbTextCompare) = 0) Then         '必须把指针转换成可用的字符
            CopyMemory ClassID(0), Info(i).ClassID(0), 16 '保存类的ID
            GetEncoderClsID = i      '返回成功的索引值
            Exit For
        End If
    Next
    Erase Info
    Erase Buffer
End Function

Public Function PtrToStrW(ByVal lpsz As Long) As String
    Dim Out         As String
    Dim lLen        As Long
    lLen = lstrlenW(lpsz)

    If (lLen > 0) Then
        Out = StrConv(String$(lLen, vbNullChar), vbUnicode)
        Call CopyMemory(ByVal Out, ByVal lpsz, lLen * 2)
        PtrToStrW = StrConv(Out, vbFromUnicode)
    End If
End Function

Private Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long)
    Dim Temp As Long, TempPtr As Long
    CopyMemory Temp, ByVal DataArrPtr, 4        '得到DataArrPtr的SAFEARRAY结构的地址
    Temp = Temp + 12                            '这个指针偏移12个字节后就是pvData指针
    CopyMemory TempPtr, ByVal pDataArrPtr, 4    '得到pDataArrPtr的SAFEARRAY结构的地址
    TempPtr = TempPtr + 12                      '这个指针偏移12个字节后就是pvData指针
    CopyMemory OldpArrPtr, ByVal TempPtr, 4     '保存旧地址
    CopyMemory ByVal TempPtr, Temp, 4           '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指针
    CopyMemory OldArrPtr, ByVal Temp, 4         '保存旧地址
End Sub

'*****************************************************************************************
'**    过 程 名 :  FreePoint
'**    输    入 :
'**    功能描述 :  取消绑定模拟数组
'**    开发日期 :  2007-4-02
'**    作    者 :  laviewpbt
'**    修改日期 :
'**    版    本 :  Version 1.2.1
'****************************************************************************************

Private Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal OldpArrPtr As Long)
    Dim TempPtr As Long
    CopyMemory TempPtr, ByVal DataArrPtr, 4         '得到DataArrPtr的SAFEARRAY结构的地址
    CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4   '恢复旧地址
    CopyMemory TempPtr, ByVal pDataArrPtr, 4        '得到pDataArrPtr的SAFEARRAY结构的地址
    CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4  '恢复旧地址
End Sub


Public Function FileExist(FileName As String) As Boolean
   
    On Error GoTo Handler
    If (GetAttr(FileName) And vbArchive) = vbArchive Then
         FileExist = True
    End If
    Exit Function
Handler:

End Function
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

文字版|手机版|小黑屋|VBGood  

GMT+8, 2022-7-5 10:45

VB爱好者乐园(VBGood)
快速回复 返回顶部 返回列表