modbitmap.bas

ktv场所的包房开房、迎宾、预定管理系统。

' If the function fails, the return is FALSE
'
' --------------------------------------------------
' These type definitions were taken from OCIDL.H
' --------------------------------------------------
' typedef LONG OLE_XPOS_HIMETRIC;
' typedef LONG OLE_YPOS_HIMETRIC;
' typedef LONG OLE_XSIZE_HIMETRIC;
' typedef LONG OLE_YSIZE_HIMETRIC;
'
'========================================================================================================
Public Function Convert_PX_HM(ByVal InputHeight As Long, _
                              ByVal InputWidth As Long, _
                              ByRef OutputHeight As Long, _
                              ByRef OutputWidth As Long, _
                              Optional ByVal VB_Picture As Boolean = True) As Boolean
On Error Resume Next
  
  Dim TwipsX    As Single
  Dim TwipsY    As Single
  
  ' Reset the return values
  OutputHeight = 0
  OutputWidth = 0
  
  ' Make sure the parameters passed are valid
  If InputHeight = 0 And InputWidth = 0 Then Exit Function
  
  ' If the user specifies to do the convertion for a Visual Basic Picture, use the
  ' "Screen" object to get the approximate TwipsPerPixel
  If VB_Picture = True Then
    OutputHeight = CLng(((InputHeight * Screen.TwipsPerPixelY) / 1440) * 2540)
    OutputWidth = CLng(((InputWidth * Screen.TwipsPerPixelX) / 1440) * 2540)
    
  ' If the user doesn't specify to do the convertion for a Visual Basic Picture, assume
  ' it's for a Win32 API call and calculate the exact TwipsPerPixel to be more accurate
  Else
    If GetDisplayInfo(, , TwipsX, TwipsY) = False Then Exit Function
    OutputHeight = CLng(((InputHeight * TwipsX) / 1440) * 2540)
    OutputWidth = CLng(((InputWidth * TwipsY) / 1440) * 2540)
  End If
  
  ' Function succeeded
  Convert_PX_HM = True
  
End Function


'========================================================================================================
'
' CopyPicture
'
' This function takes the handle to the picture passed in via the "IN_hPicture" parameter and makes a
' copy of it... returning it via the "OUT_hPicture" parameter.
'
' Parameter:              Use:
' --------------------------------------------------
' IN_hPicture             Specifies the handle to the picture to copy
' OUT_hPicture            Returns the newly created copy of the original picture
' PictureType             Optional. Specifies the type of image to copy (Bitmap, Icon, Cursor, Enh Metafile)
' PictureWidth            Optional. Specifies the width of the image to copy.  If this is not specified,
'                         this function attempts to get the width from the image.
' PictureHeight           Optional. Specifies the height of the image to copy.  If this is not specified,
'                         this function attempts to get the height from the image.
' ReturnMonochrome        Optional. If set to TRUE, the return is a black and white version of the image
'
' Return:
' -------
' If the function succeeds, the return is TRUE
' If the function fails, the return is FALSE
'
'========================================================================================================
Public Function CopyPicture(ByVal IN_hPicture As Long, _
                            ByRef OUT_hPicture As Long, _
                            Optional ByVal PictureType As PictureTypes = IMAGE_BITMAP, _
                            Optional ByVal PictureWidth As Long, _
                            Optional ByVal PictureHeight As Long, _
                            Optional ByVal ReturnMonochrome As Boolean = False) As Boolean
  
  Dim TempEMH      As ENHMETAHEADER
  Dim TempBITMAP   As BITMAP
  Dim hBMP_Mask    As Long
  Dim hBMP_Image   As Long
  Dim ReturnValue  As Long
  Dim Flags        As Long
  
  ' Set the default return value
  OUT_hPicture = 0
  
  ' Make sure parameters passed are valid
  If IN_hPicture = 0 Then Exit Function
  
  ' Get the dimentions and type of picture to copy
  If PictureWidth = 0 Or PictureHeight = 0 Then
    Select Case PictureType
      
      Case IMAGE_BITMAP
        If GetObjectAPI(IN_hPicture, Len(TempBITMAP), TempBITMAP) = 0 Then Exit Function
        PictureWidth = TempBITMAP.bmWidth
        PictureHeight = TempBITMAP.bmHeight
        
      Case IMAGE_ICON, IMAGE_CURSOR
        If GetIconBitmaps(IN_hPicture, hBMP_Mask, hBMP_Image) = False Then Exit Function
        ReturnValue = GetObjectAPI(hBMP_Image, Len(TempBITMAP), TempBITMAP)
        DeleteObject hBMP_Mask
        DeleteObject hBMP_Image
        If ReturnValue = 0 Then Exit Function
        PictureWidth = TempBITMAP.bmWidth
        PictureHeight = TempBITMAP.bmHeight
        
      Case IMAGE_ENHMETAFILE
        TempEMH.nSize = Len(TempEMH)
        TempEMH.iType = EMR_HEADER
        TempEMH.dSignature = ENHMETA_SIGNATURE
        TempEMH.nVersion = &H10000
        If GetEnhMetaFileHeader(IN_hPicture, Len(TempEMH), TempEMH) = 0 Then Exit Function
        PictureWidth = TempEMH.rclBounds.Right
        PictureHeight = TempEMH.rclBounds.Bottom
        
    End Select
  End If
  
  ' Copy the image
  If ReturnMonochrome = True Then Flags = LR_MONOCHROME
  OUT_hPicture = CopyImage(IN_hPicture, CLng(PictureType), PictureWidth, PictureHeight, Flags)
  If OUT_hPicture <> 0 Then CopyPicture = True
  
End Function


'========================================================================================================
'
' CreateCursorFromBMP
'
' This function takes the handle to the mask and image BITMAPS that make up an cursor, and combine them
' to make a transparent icon.
'
' Parameter:              Use:
' --------------------------------------------------
' hBMP_Mask               Handle to the mask BITMAP to use
' hBMP_Image              Handle to the image BITMAP to use
'
' Return:
' -------
' If the function succeeds, the return is the handle to the newly created icon
' If the function fails, the return is ZERO (0)
'
'========================================================================================================
Public Function CreateCursorFromBMP(ByVal hBMP_Mask As Long, _
                                    ByVal hBMP_Image As Long, _
                                    Optional ByVal HotspotX As Long, _
                                    Optional ByVal HotspotY As Long) As Long
  
  Dim TempICONINFO As ICONINFO
  
  If hBMP_Mask = 0 Or hBMP_Image = 0 Then Exit Function
  
  TempICONINFO.fIcon = 0
  TempICONINFO.hbmMask = hBMP_Mask
  TempICONINFO.hbmColor = hBMP_Image
  TempICONINFO.xHotspot = HotspotX
  TempICONINFO.yHotspot = HotspotY
  
  CreateCursorFromBMP = CreateIconIndirect(TempICONINFO)
  
End Function


'========================================================================================================
'
' CreateIconFromBMP
'
' This function takes the handle to the mask and image BITMAPS that make up an icon, and combine them
' to make a transparent icon.
'
' Parameter:              Use:
' --------------------------------------------------
' hBMP_Mask               Handle to the mask BITMAP to use
' hBMP_Image              Handle to the image BITMAP to use
'
' Return:
' -------
' If the function succeeds, the return is the handle to the newly created icon
' If the function fails, the return is ZERO (0)
'
'========================================================================================================
Public Function CreateIconFromBMP(ByVal hBMP_Mask As Long, _
                                  ByVal hBMP_Image As Long) As Long
  
  Dim TempICONINFO As ICONINFO
  
  If hBMP_Mask = 0 Or hBMP_Image = 0 Then Exit Function
  
  TempICONINFO.fIcon = 1
  TempICONINFO.hbmMask = hBMP_Mask
  TempICONINFO.hbmColor = hBMP_Image
  
  CreateIconFromBMP = CreateIconIndirect(TempICONINFO)
  
End Function


'========================================================================================================
'
' CreateMask
'
' This function takes the specified picture and creates a sprite and a mask from it.  The sprite is the
' same as the original picture, but the color that is specified by the "TransparentColor" parameter is
' changed to WHITE (this serves to designate where the transparency will be).  The mask is a black
' silhouette of the original picture with a white background.
'
' When the mask is combined with another picture using the Win32 "BitBlt" API with the "MERGEPAINT"
' raster operation, it puts a white silhouette of the original picture (without the transparent region).
' When the sprite is combined with the picture that the mask was combined with in the same location
' as the mask using the Win32 "BitBlt" API with the "SRCAND" raster operation, the original picture is
' displayed on the picture as a transparent picture (the specified background color, or transparent
' color no longer shows up.
'
'