|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub 图片压宿(ByVal tempfilename As String, ByVal imagefilename As String, ByVal x As Integer)
Dim filetype As String = ".jpg"
'高质量图像名称
' imagefilename = "F:\1234.jpg"
' tempfilename = "F:\123.jpg" '原始图像
If tempfilename Like "*gif" Then
filetype = ".gif"
End If
''大图生小图,生成统计长度
Dim image As System.Drawing.Image
image = System.Drawing.Image.FromFile(tempfilename)
'''''''按照比例相应缩小,
Dim iscal As Double
If image.Width > x Then
iscal = image.Width / x
Else
iscal = 1
End If
'’取得图像大小的位置
Dim size As System.Drawing.Size
size = New System.Drawing.Size(image.Width / iscal, image.Height / iscal) '按比例宿小
'新建一个图片()
Dim ibitmap As System.Drawing.Bitmap = New System.Drawing.Bitmap(size.Width, size.Height)
'新建一个画版
Dim g As System.Drawing.Graphics = System.Drawing.Graphics.FromImage(ibitmap)
'设置高质量插值法
g.InterpolationMode = Drawing.Drawing2D.InterpolationMode.High
'设置高质量,低速度呈现平滑程度
g.SmoothingMode = Drawing.Drawing2D.SmoothingMode.HighQuality
g.Clear(Color.Blue)
'在指定位置画图片
g.DrawImage(image, New System.Drawing.Rectangle(0, 0, ibitmap.Width, ibitmap.Height), _
New System.Drawing.Rectangle(0, 0, image.Width, image.Height), GraphicsUnit.Pixel)
If filetype = ".gif" Then
ibitmap.Save(imagefilename, System.Drawing.Imaging.ImageFormat.Gif)
End If
If filetype = ".jpg" Then
ibitmap.Save(imagefilename, System.Drawing.Imaging.ImageFormat.Jpeg)
End If
'取得原图像的普通缩略图
'Dim img As System.Drawing.Image = image.GetThumbnailImage(300, 200, null, IntPtr.Zero)
image.Dispose()
g.Dispose()
End Sub
|
|