resizepic.txt

一部分关于VB编程的小技巧

Option Explicit

Private dx As Double, dy As Double
Private sX As Double, sY As Double
Private bInitializing As Boolean
Private bChange As Boolean
Private Working As Boolean
Private iPictureResizeMethod  As Integer
Private iResizeOptionsEnum As Integer
Private iMaxWidth As Integer
Private iMaxHeight As Integer
Private iBoxColor As ColorConstants
Private bStickPictureToFrame As Boolean
Private ClickedAgain As Boolean

Private Type tXY
    X As Integer
    Y As Integer
End Type

Public Enum ResizeOptionsEnum
    ResizeOnlySmaller = 1
    ResizeNormal = 0
End Enum

Public Enum PictureResMethod
    Normal = 0
    NoResize = 1
End Enum

Private Buffer As StdPicture

Public Function PictureRes(ToObj As Image, PicturePath As String, ByVal ResizeOptions As ResizeOptionsEnum, ByVal iMaxWidth As Integer, ByVal iMaxHeight As Integer) As Boolean
    Dim tONE As tXY
    Dim tTWO As tXY

    Set Buffer = LoadPicture(PicturePath)

    If ResizeOptions = ResizeOnlySmaller Then
        iMaxHeight = Buffer.Height
        iMaxWidth = Buffer.Width
    End If
    
    If iMaxWidth > Buffer.Width Then iMaxWidth = Buffer.Width
    If iMaxHeight > Buffer.Height Then iMaxHeight = Buffer.Height

    ResizeToWidth iMaxWidth
    If dx > 32000 Then dx = 32000
    If dy > 32000 Then dy = 32000
    tONE.X = dx
    tONE.Y = dy
    ResizeToHeight iMaxHeight
    If dx > 32000 Then dx = 32000
    If dy > 32000 Then dy = 32000
    tTWO.X = dx
    tTWO.Y = dy

    Select Case Buffer.Width
    Case Is > Buffer.Height
        If tONE.X <= iMaxWidth Then
            dx = tONE.X
            dy = tONE.Y
        Else
            dx = tTWO.X
            dy = tTWO.Y
        End If
    Case Else
        If tONE.Y <= iMaxHeight Then
            dx = tONE.X
            dy = tONE.Y
        Else
            dx = tTWO.X
            dy = tTWO.Y
        End If
    End Select

    LoadMainPic ToObj
    PictureRes = True
End Function

Private Function ResizeToWidth(ByVal Width As Integer)
    Dim i As Single

    sX = Buffer.Width
    sY = Buffer.Height

    Select Case sX
    Case Is <= Width
        i = Width / sX
        dx = sX * i
        dy = sY * i
    Case Else
        i = sX / Width
        dx = sX / i
        dy = sY / i
    End Select

End Function

Private Function ResizeToHeight(ByVal iHeight As Integer)
    Dim i As Double

    sX = Buffer.Width
    sY = Buffer.Height

    Select Case sY
    Case Is >= iHeight
        i = iHeight / sY
        dx = sX * i
        dy = sY * i
    Case Else
        i = iHeight / sY
        dx = sX * i
        dy = sY * i
    End Select

End Function

Private Function LoadMainPic(MainPic As Image)
    MainPic.Stretch = True
    MainPic.Visible = False
    MainPic.Width = dx
    MainPic.Height = dy
    MainPic.Picture = Buffer
    MainPic.Visible = True
End Function