cimage.cls

vb做的看图系统

  GdiErrorString = S
End Function


Public Function Picture() As StdPicture
  Dim retval        As Long
  Dim uPictDesc     As PICTDESC
  Dim aGuid(0 To 3) As Long
  Dim hImg As Long
  
    If m_Image = 0 Then Exit Function   'no image was loaded
    
    '-- Create bitmap
    If m_Bitmap = 0 Then
        retval = GdipCreateHBITMAPFromBitmap(m_Image, hImg, vbBlack)
    Else
        retval = GdipCreateHBITMAPFromBitmap(m_Bitmap, hImg, vbBlack)
    End If
    
    If retval = 0 Then
        '-- Fill struct
        With uPictDesc
            .Size = Len(uPictDesc)
            .Type = vbPicTypeBitmap
            .hBmpOrIcon = hImg
            .hPal = 0
        End With
        
        '-- Fill in the IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
        aGuid(0) = &H7BF80980
        aGuid(1) = &H101ABF32
        aGuid(2) = &HAA00BB8B
        aGuid(3) = &HAB0C3000
        
        '-- Create picture from bitmap handle
        OleCreatePictureIndirect uPictDesc, aGuid(0), -1, Picture
        
        'not sure if this is needed but putting it in incase
        'GdipDisposeImage hImg
    End If
End Function


'-----------------
'PRIVATE FUNCTIONS
'-----------------
Private Function ConvertBMPtoPicture(ByVal hBMP As Long, Optional ByVal hPal As Long) As Picture
    Dim r As Long
    Dim Pic As PICTDESC
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID

    'Fill GUID info
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With

    'Fill picture info
    With Pic
        .Size = Len(Pic)            ' Length of structure
        .Type = vbPicTypeBitmap     ' Type of Picture (bitmap)
        .hBmpOrIcon = hBMP          ' Handle to bitmap
        .hPal = hPal                ' Handle to palette (may be null)
    End With

    'Create the picture
    r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

    'Return the new picture
    Set ConvertBMPtoPicture = IPic
End Function

Private Function ReportError(ByVal lError As Long, Optional sTitle As String, Optional sText As String)
    'uncomment msgbox or do whatever with the error message
    Dim m As String
    Dim sT1 As String
    
    sT1 = "Error"
    If Len(sTitle) > 0 Then
        sT1 = sT1 & " : " & sTitle
    End If
    
    m = m & "Error code " & lError & vbCrLf
    m = m & GdiErrorString(lError) & vbCrLf
    
    If Len(sText) > 0 Then
        m = m & sText & vbCrLf
    End If
    
    'MsgBox M, vbCritical, sT1
End Function

Private Function GetEncoderClsid(sMimeType As String) As CLSID
   Dim lNumCoders       As Long
   Dim lSize            As Long
   Dim uInfo()          As ImageCodecInfo
   Dim lIdx             As Long
   Dim strEncoder       As String

   GdipGetImageEncodersSize lNumCoders, lSize
   If lSize > 0 Then
      ReDim uInfo(0 To lSize \ LenB(uInfo(0))) As ImageCodecInfo
      GdipGetImageEncoders lNumCoders, lSize, uInfo(0)
      For lIdx = 0 To lNumCoders - 1
        strEncoder = PtrToStrW(uInfo(lIdx).MimeTypePtr)
         If StrComp(strEncoder, sMimeType, vbTextCompare) = 0 Then
            GetEncoderClsid = uInfo(lIdx).CLSID
            Exit For
         End If
      Next
   End If
End Function

'   Dereferences an ANSI or Unicode string pointer
'   and returns a normal VB BSTR
Private Function PtrToStrW(ByVal lpsz As Long) As String
   Dim sOut             As String
   Dim lLen             As Long

   lLen = lstrlenW(lpsz)

   If (lLen > 0) Then
      'was sOut = StrConv(String$(lLen, vbNullChar), vbUnicode)
      sOut = String$(lLen * 2, vbNullChar)
      CopyMemory ByVal sOut, ByVal lpsz, lLen * 2
      'PtrToStrW = StrConv(sOut, vbFromUnicode)
      PtrToStrW = TrimNulls(sOut)
   End If
End Function

Private Function TrimNulls(ByRef sText As String) As String
    Dim lPos As Long
   ' Locate the first instance of a Chr$(0) (NULL) character, and trim everything after it.
   lPos = InStr(1, sText, Chr$(0))
   If lPos <> 0 Then
      sText = Mid$(sText, 1, lPos - 1)
   End If
   TrimNulls = sText
End Function

Private Function SplitStrFromRight(ByVal searchStr, ByVal lookFor, Optional leftStr, Optional rightStr)
    'searches from right to left
    'for a single char within the searchString
    'when it finds it it returns the left and right sides
    Dim tempChar As String
    
    If Len(searchStr) = 0 Then Exit Function
    If IsMissing(rightStr) Then rightStr = ""
        
    tempChar = Right$(searchStr, 1)
    leftStr = Left(searchStr, Len(searchStr) - 1)
    If LCase(tempChar) <> LCase(lookFor) Then
        rightStr = tempChar & rightStr
        SplitStrFromRight leftStr, lookFor, leftStr, rightStr
    Else
        'we made a match, return values
    End If

End Function

Private Function pathExists(ByVal sPath As String, Optional bMakeIt As Boolean = False) As Boolean
    'checks to see if a path exists
    Dim retval As Long
    Dim Security As SECURITY_ATTRIBUTES
    
    retval = GetFileAttributes(sPath)
    If retval <> -1 Then
        pathExists = True
    Else
        If bMakeIt Then
            retval = CreateDirectory(sPath, Security)
            If retval <> 0 Then
                pathExists = True
            End If
        End If
    End If
End Function

Private Function EnsureBackslash(ByRef StrIn As String)
    'makes sure the last char is a backslash
    If Not Right(StrIn, 1) = "\" Then
        StrIn = StrIn & "\"
    End If
    EnsureBackslash = StrIn
End Function

Private Function Dispose()
    'clears any left overs
    DisposeGraphic
    DisposeImage
    
End Function
Private Function DisposeGraphic()
    GdipDeleteGraphics m_Graphic
    m_Graphic = 0
End Function
Private Function DisposeImage()
    GdipDisposeImage m_Image
    m_Image = 0
End Function


'---------------
'CLASS FUNCTIONS
'---------------
Private Sub Class_Initialize()
    'start the GDI engine
    On Error GoTo Handler
    
    Dim GpInput As GdiplusStartupInput
    GpInput.GdiplusVersion = 1
    GdiplusStartup m_hGDIplus, GpInput
    
    Exit Sub
Handler:
    ReportError Err.Number, "Initialising GDI+", Err.Description
    Resume Next

End Sub

Private Sub Class_Terminate()
    If Initialised Then
        DisposeImage
        Call GdiplusShutdown(m_hGDIplus)
    End If
End Sub

Public Function Rotate(ByVal angle As Rot_Angle) As Boolean
    Dim sngScale As Single
    Dim sngWidth As Single
    Dim sngHeight As Single
    Dim lPixelFormat As Long
    Dim scaleMode As Long
    
'--clear up
    DisposeGraphic
    If m_Image = 0 Then Exit Function

'--defaults
    scaleMode = InterpolationModeHighQualityBilinear
    
'--Establish resize measurements
    'find out what we have now
    GdipGetImageDimension m_Image, sngWidth, sngHeight
    'bail if its a bad image
    If (sngWidth <= 0) Or (sngHeight <= 0) Then Exit Function
    'get the existing scale
    GdipGetImagePixelFormat m_Image, lPixelFormat
    If angle <> Deg180 Then
    GdipCreateBitmapFromScan0 sngHeight, sngWidth, 0, lPixelFormat, ByVal 0&, m_Bitmap
    Else
    GdipCreateBitmapFromScan0 sngWidth, sngHeight, 0, lPixelFormat, ByVal 0&, m_Bitmap
   End If
    'get a handle to the graphics object of our new bitmap
    GdipGetImageGraphicsContext m_Bitmap, m_Graphic
    'could use something like this if you want it to be displayed on screen
    'GdipCreateFromHDC formGDItest.Picture1.hDC, m_Graphic
   
    'set the method that we want to use to do this transformation
    GdipGetInterpolationMode m_Graphic, scaleMode
    Select Case angle
    Case Deg90:
        GdipRotateWorldTransform m_Graphic, 90, MatrixOrderAppend
        'GdipDrawImageRect m_Graphic, m_Image, 0, -sngHeight + 0.8, sngWidth, sngHeight
        GdipDrawImageRect m_Graphic, m_Image, 0, -sngHeight, sngWidth, sngHeight
    Case Deg180:
        GdipRotateWorldTransform m_Graphic, 180, MatrixOrderAppend
        GdipDrawImageRect m_Graphic, m_Image, -sngWidth, -sngHeight, sngWidth, sngHeight
    Case Deg270:
        GdipRotateWorldTransform m_Graphic, 270, MatrixOrderAppend
        'GdipDrawImageRect m_Graphic, m_Image, -sngWidth + 0.8, 0, sngWidth, sngHeight
         GdipDrawImageRect m_Graphic, m_Image, -sngWidth, 0, sngWidth, sngHeight
    End Select
                    
    Rotate = True
End Function

Private Function WriteFileToDisk(sFileName As String, uEncParams As EncoderParameters) As Long
    'does the actual saving of the image
    Dim sEncoder As String
    sEncoder = "image/jpeg"
  
    WriteFileToDisk = GdipSaveImageToFile(m_Image, sFileName, GetEncoderClsid(sEncoder), uEncParams)

End Function