home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / PSCSearch_19445110302005.psc / modImgSize.bas < prev    next >
BASIC Source File  |  2005-10-30  |  3KB  |  80 lines
  1. Attribute VB_Name = "modImgSize"
  2. Option Explicit
  3.  
  4. Public sAccessCode As String
  5. Public iMaxEntries As Integer
  6.  
  7. Public Sub LogicalSize(ContainerObj As Object, ImgObj As Object, ByVal Cushion As Integer)
  8.     Dim VertChg, HorzChg As Integer
  9.     Dim iRatio As Double
  10.     Dim ActualH, ActualW As Integer
  11.     Dim ContH, ContW As Integer
  12.     On Error GoTo LogicErr
  13.  
  14.  
  15.     With ImgObj 'hide picture While changing size
  16.         .Visible = False
  17.         .Stretch = False 'set actual size
  18.     End With
  19.  
  20.     VertChg = 0: HorzChg = 0
  21.     ActualH = ImgObj.Height 'actual picture height
  22.     ActualW = ImgObj.Width 'actual picture width
  23.     ContH = ContainerObj.Height - Cushion 'set max. picture height
  24.     ContW = ContainerObj.Width - Cushion 'set max. picture width
  25.     CenterCTL ContainerObj, ImgObj 'center picture
  26.     
  27.     If ImgObj.Top < Cushion Or ImgObj.Left < Cushion Then 'is picture larger than container
  28.         If ActualH <> ActualW Then 'picture is Not square
  29.             If ActualH > ActualW Then 'height is greater
  30.                 iRatio = (ActualH / ActualW) 'get ratio between height and width
  31.                 HorzChg = 10 'scale down by 10 units per Loop
  32.                 VertChg = CInt(Format(iRatio * 10, "####"))
  33.             Else 'width is greater
  34.                 iRatio = (ActualW / ActualH) 'get ratio between height and width
  35.                 VertChg = 10 'scale down by 10 units per Loop
  36.                 HorzChg = CInt(Format(iRatio * 10, "####")) 'round number
  37.             End If
  38.             
  39.         Else 'picture is square
  40.             VertChg = 10 'scale both height and width equally
  41.             HorzChg = 10
  42.         End If
  43.         
  44.         Do Until ActualH <= ContH And ActualW <= ContW
  45.             ActualH = ActualH - VertChg 'scale height down
  46.             ActualW = ActualW - HorzChg 'scale width down
  47.             
  48.             If ActualH < 100 Then
  49.                 ActualH = 100 'set min. picture height=100
  50.                 Exit Do
  51.             ElseIf ActualW < 100 Then
  52.                 ActualW = 100 'set min. picture width=100
  53.                 Exit Do
  54.             End If
  55.         Loop
  56.         
  57.         With ImgObj 'set new height and width
  58.             .Stretch = True
  59.             .Height = ActualH
  60.             .Width = ActualW
  61.         End With
  62.  
  63.     End If
  64.  
  65.     CenterCTL ContainerObj, ImgObj 'center picture in container
  66.     ImgObj.Visible = True 'show picture
  67.     Exit Sub
  68. LogicErr:
  69.     MsgBox "An Error occured While rescaling this image. Image size maybe invalid.", vbSystemModal + vbExclamation, "Resize Error!"
  70. End Sub
  71.  
  72. Public Sub CenterCTL(FRMObj As Object, OBJ As Control)
  73.     With OBJ
  74.         .Top = (FRMObj.Height / 2) - (OBJ.Height / 2)
  75.         .Left = (FRMObj.Width / 2) - (OBJ.Width / 2)
  76.         .ZOrder
  77.     End With
  78. End Sub
  79.  
  80.