REDIMENSIONNEMENT DE PHOTOS PAR LOT

Commentaire de gillardg le 14/07/2009 00:27:54

pouvoir y ajouter une notice de copyright serait pas mal
en texte  (watermarks) en image (addimg)
Imports System
Imports System.Collections.Generic
Imports System.Text
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Drawing.Drawing2D
Module Module1

    Public Function watermarks(ByVal Copyright As String, ByVal imgPhoto As Image) As Image
        Dim phWidth As Integer = imgPhoto.Width
        Dim phHeight As Integer = imgPhoto.Height 'create a Bitmap the Size of the original photograph
        Dim bmPhoto As New Bitmap(phWidth, phHeight, PixelFormat.Format24bppRgb)
        bmPhoto.SetResolution(imgPhoto.HorizontalResolution, imgPhoto.VerticalResolution)
        Dim grPhoto As Graphics = Graphics.FromImage(bmPhoto) 'load the Bitmap into a Graphics object
        'Dim tmp As String = My.Computer.FileSystem.GetTempFileName & ".bmp"
        Dim imgWatermark As Image = New Bitmap(phWidth, phHeight) 'create a image object containing the watermark
        Dim wmWidth As Integer = imgWatermark.Width
        Dim wmHeight As Integer = imgWatermark.Height 'Step #1 - Insert Copyright message
        grPhoto.SmoothingMode = SmoothingMode.AntiAlias 'Set the rendering quality for this Graphics object
        grPhoto.DrawImage(imgPhoto, New Rectangle(0, 0, phWidth, phHeight), 0, 0, phWidth, phHeight, GraphicsUnit.Pixel) ' Units of measure
        Dim sizes() As Integer = {16, 14, 12, 10, 8, 6, 4}
        Dim crFont As Font = Nothing
        Dim crSize As New SizeF()
        For i As Integer = 0 To 6
            Application.DoEvents()
            crFont = New Font("arial", sizes(i), FontStyle.Bold)
            'Measure the Copyright string in this Font
            crSize = grPhoto.MeasureString(Copyright, crFont)
            If CUShort(crSize.Width) < CUShort(phWidth) Then
                Exit For
            End If
        Next i
        Dim yPixlesFromBottom As Integer = CInt(Fix(phHeight * 0.05))
        Dim yPosFromBottom As Single = ((phHeight - yPixlesFromBottom) - (crSize.Height / 2))
        Dim xCenterOfImg As Single = (phWidth \ 2)
        Dim StrFormat As New StringFormat()
        StrFormat.Alignment = StringAlignment.Center
        Dim semiTransBrush2 As New SolidBrush(Color.FromArgb(153, 0, 0, 0))
        grPhoto.DrawString(Copyright, crFont, semiTransBrush2, New PointF(xCenterOfImg + 1, yPosFromBottom + 1), StrFormat)
        Dim semiTransBrush As New SolidBrush(Color.FromArgb(153, 255, 255, 255))
        grPhoto.DrawString(Copyright, crFont, semiTransBrush, New PointF(xCenterOfImg, yPosFromBottom), StrFormat) 'Text alignment
        Dim bmWatermark As New Bitmap(bmPhoto)
        bmWatermark.SetResolution(imgPhoto.HorizontalResolution, imgPhoto.VerticalResolution)
        Dim grWatermark As Graphics = Graphics.FromImage(bmWatermark)
        Dim imageAttributes As New ImageAttributes()
        Dim colorMap As New ColorMap()
        colorMap.OldColor = Color.FromArgb(255, 0, 255, 0)
        colorMap.NewColor = Color.FromArgb(0, 0, 0, 0)
        Dim remapTable() As ColorMap = {colorMap}
        imageAttributes.SetRemapTable(remapTable, ColorAdjustType.Bitmap)
        Dim colorMatrixElements()() As Single = {New Single() {1.0F, 0.0F, 0.0F, 0.0F, 0.0F}, New Single() {0.0F, 1.0F, 0.0F, 0.0F, 0.0F}, New Single() {0.0F, 0.0F, 1.0F, 0.0F, 0.0F}, New Single() {0.0F, 0.0F, 0.0F, 0.3F, 0.0F}, New Single() {0.0F, 0.0F, 0.0F, 0.0F, 1.0F}}
        Dim wmColorMatrix As New ColorMatrix(colorMatrixElements)
        imageAttributes.SetColorMatrix(wmColorMatrix, ColorMatrixFlag.Default, ColorAdjustType.Bitmap)
        Dim xPosOfWm As Integer = ((phWidth - wmWidth) - 10)
        Dim yPosOfWm As Integer = 10
        grWatermark.DrawImage(imgWatermark, New Rectangle(xPosOfWm, yPosOfWm, wmWidth, wmHeight), 0, 0, wmWidth, wmHeight, GraphicsUnit.Pixel, imageAttributes) 'ImageAttributes Object
        imgPhoto = bmWatermark
        grPhoto.Dispose()
        grWatermark.Dispose()
        Return imgPhoto
        imgPhoto.Dispose()
        imgWatermark.Dispose()
    End Function

    'add an image to the bitmap
    Public Function addImg(ByVal ibitmap As Image, ByVal imagename As String, ByVal ILeft As Integer, ByVal ITop As Integer) As Boolean
        Dim i As Image = Image.FromFile(imagename)
        Dim g As Graphics = Graphics.FromImage(ibitmap)
        g.DrawImage(i.Clone, ILeft, ITop, i.Width, i.Height)
        g.Dispose()
        i.Dispose()
    End Function

End Module