图片自动适应大小问题，求教

Question

要求是这样
条件：首先有一个固定大小的picturebox控件，想在上面加载不同分辨率的图片，图片大小不一
要求：1.一个不想用控件来适应图片大小（否掉autosize），第二不想图片比例变形(否掉拉伸)
      2.高度方向上必须和控件等高，长度方向上可以变小（也就是图片要全部显示出来）
      3.图片要在控件中居中显示请教怎么写或用什么函数？

Answer 1

改用image控件即可,Image1.Stretch 设为True

Answer 2

光用image.stretch=true图形会变形。考虑把picturebox做为image的容器，然后把image按picture高度变化比例，再居中就行了。
Private Sub Command1_Click()
     Set Image1.Container = Picture1
     Image1.Stretch = False
     Image1.Picture = LoadPicture("C:\Documents and Settings\Administrator\My Documents\My Pictures\77553_1261644150946r.jpg")
     Image1.Stretch = True
     Image1.Width = Image1.Width * (Picture1.Height / Image1.Height)
     Image1.Height = Picture1.Height
     Image1.Move (Picture1.Width - Image1.Width) / 2, 0
         
End Sub

Answer 3

另一种方法，添加image1并隐藏。
Private Sub Command2_Click()
 Image1.Visible = False
 Image1.Stretch = False
 Image1.Picture = LoadPicture("C:\Documents and Settings\Administrator\My Documents\My Pictures\2009112209293733.gif")
 Picture1.PaintPicture Image1, (Picture1.Width - Image1.Width * (Picture1.Height / Image1.Height)) / 2, 0, Image1.Width * (Picture1.Height / Image1.Height), Picture1.Height, , , Image1.Width, Image1.Height
 Image1.Picture = LoadPicture("")
End Sub

Answer 4

Option Explicit
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Type BITMAP
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
Dim bm As BITMAP
Dim hBmp As LongPublic Sub SameToPicture(ByRef pic As PictureBox, ByVal Ifilename As String)
pic.Picture = LoadPicture(Ifilename)
hBmp = pic.Picture.Handle
GetObject hBmp, LenB(bm), bm
pic.Width = bm.bmWidth * Screen.TwipsPerPixelX
pic.Height = bm.bmHeight * Screen.TwipsPerPixelY
End Sub
Private Sub Command1_Click()
SameToPicture Picture1, App.Path & "\" & "124.jpg"
Picture1.Move 0, 0
End Sub

Answer 5

Public Sub SameToPic(ByRef pic As PictureBox, ByVal Ifilename As String)
pic.Picture = LoadPicture(Ifilename)
pic.PaintPicture pic.Picture, 0, 0, pic.Width, pic.Height, 0, 0
End Sub

Answer 6

1.得知图片宽高
2.调整大小, 以固定的PictureBox为准, 使用PaintPicture重画宽高不超过PictureBox,要先计算宽高比例,宽高以何者较长为准, 依比例计算出新的图片的宽度与高度.
3.新图片在PictureBox居中, 计算新的图像的Left与Top

Answer 7

8F 代码将会使图片变型, 尤其是高度大于宽度的图片.【CBM666 的电子彩页制作系统】
http://hi.baidu.com/cbm666/blog/item/96e19b50858e436884352454.html

Answer 8

2楼试过了，功能没问题，但图片质量有问题（非代码问题），模糊看不清楚，用windows自带浏览器即使缩小到同样大小比这个清楚多了，不知道何故？

Answer 9

再给你一种方法，只要一个picturebox（picture1）控件就可以了。Private Sub Command3_Click()
    Dim p As Picture
    Set p = LoadPicture("C:\Documents and Settings\Administrator\My Documents\My Pictures\2009112209300545.jpg")
    Picture1.PaintPicture p, (Picture1.Width - ScaleX(p.Width) * Picture1.Height / ScaleY(p.Height)) / 2, 0, _
             ScaleX(p.Width) * (Picture1.Height / ScaleY(p.Height)), Picture1.Height, , , ScaleX(p.Width), ScaleY(p.Height)
    Set p = Nothing
    
End Sub