Logo Foltyn Presentation
Table of Contents Previous Page Next Page
Content-Symbol-Img

Ein Programm in der Programmiersprache A program in the programming language
Visual BASIC 2015
Code für eine Bildverkleinerung durch Pixel-Rechnung Code for an Image-Downsize by Pixel-Calculus

Ein Bild wird verkleinert durch Pixelrechnung mit unganzzahligen Pixels. Es sind 2 Methoden zur Auswahl, 1. GetSetPixelBitmap und 2. LockUnlockBitmap. GetSetPixel ist etwas langsamer im Zugriff auf das Bitmap-Objekt. Die LockUnlockBitmap-Prozedur ist in einer eigenen Klasse, weil es kompliziertere Funktionen enthält. Die Prozedure kopiert die Bildinformation in ein Array und wieder zurück. Dazwischen kann sie im Array nach Belieben verarbeitet werden und sie stört nicht in der Main, wo viele andere Funktionen vorkommen können.

A picture is sized down by pixel-calculus with uninteger pixels. There are 2 methods selectable, 1. GetSetPixelBitmap und 2. LockUnlockBitmap. GetSetPixel is slower in access to the bitmap-object. The LockUnlockBitmap-procedure is in a separated class, because it contains more complicated functions. The procedure copies the image-information into an array and back again. In between it can be processed in the array at pleasure and does not disturb in the Main, where many other functions can occor.

Nähere Erläuterung des Prinzips der Pixelrechnung auf der Seite

Gemacht mit der Unterstützung der ActiveVB-Community

Das Programm ist getestet vor der Publikation, aber es kann keine Garantie gegeben werden, dass es fehlerfrei ist
Closer explaination of the principle of the pixel-calculus on page

Made with the support of the ActiveVB-Community

The program ist tested before publication, but there can be given no guarantee, that it is free of errors
2. Juli 2016 July 2nd 2016

Image Downsize

Display in the PictureBox


Program-Code

' Program in Visual BASIC 2015
' ==============================================================================================
Option Strict On
Option Explicit On
 
Public Class Form1
    Private PGM As New Program
 
    Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
        PGM.Main()
        PGM.DisplayResult()
    End Sub
    Private Sub TextBox1_TextChanged(sender As Object, e As EventArgs) Handles TextBox1.TextChanged
        If Not IsNumeric(TextBox1.Text) Then DownSizeFactor = 0 : Exit Sub
        DownSizeFactor = CSng(Val(TextBox1.Text))
        If DownSizeFactor >= 100 Then DownSizeFactor = 0
    End Sub
End Class
' ==============================================================================================
Option Strict On
Option Explicit On
 
Module GlobalSpecs
    Public Const fSpec_Img1 As String = "D:\YourPath\doll-big.jpg" ' for loading
    Public Const method As String = "LockUnlockBitmap" ' GetSetPixel, LockUnlockBitmap
    Public DownSizeFactor As Single = 0 ' in %
    Public PiBxW As Integer = Form1.PictureBox1.Width
    Public PiBxH As Integer = Form1.PictureBox1.Height
    Public xCenter As Integer = PiBxW \ 2
    Public Img1, Img2 As Image
    Public ImgArray(PiBxW - 1, PiBxH - 1, 2) As Integer
    Public Img1Array(PiBxW - 1, PiBxH - 1, 2) As Integer
    Public Img2Array(PiBxW - 1, PiBxH - 1, 2) As Integer
    Public Img1Width As Integer = PiBxW, Img1Height As Integer = PiBxH
    Public Img2Width As Integer = PiBxW, Img2Height As Integer = PiBxH
    Public BrkErrMsg As New List(Of String)
    Public aTmp(,,) As Integer = Nothing
 
    Public Sub CopyArrayToTmp(ToFrom As String, aNr As Byte)
        Dim ToTmp As Boolean = ToFrom = "To"
        Select Case aNr
            Case 1 : If ToTmp Then aTmp = Img1Array Else Img1Array = aTmp
            Case 2 : If ToTmp Then aTmp = Img2Array Else Img2Array = aTmp
        End Select
    End Sub
End Module
' ==============================================================================================
Option Strict On
Option Explicit On
 
Public Class Program
    Private LOCK As New BitMapBitLock
 
    Public Sub Main() ' Jumping out of the sub means BrkErr with automatic display
        With Form1.PictureBox1
            If Not LoadImgFromDisk(fSpec_Img1) Then Exit Sub ' as bitmap in img1
            .Image = Img1 ' PictureBox.Image is a property of PictureBox
 
            If DownSizeFactor = 0 Then MsgBox("Input Downsize-Faktor") : Exit Sub
            MsgBox("start downsize")
 
            If method = "GetSetPixel" Then CopyImgToArray(1, 1) ' Img1 to Img1Array
            If method = "LockUnlockBitmap" Then LOCK.CopyImgToArray(1, 1)
 
            DownsizeImage(DownSizeFactor) ' Result in Img2Array
 
            If method = "GetSetPixel" Then CopyArrayToImg(2, 1) ' Img2Array to Img1
            If method = "LockUnlockBitmap" Then LOCK.CopyArrayToImg(2, 1)
            .Image = Img1 ' Display result in PictureBox
        End With
    End Sub
    Public Sub DisplayResult() ' as text in the picturebox
        If BrkErrMsg.Count < 1 Then Exit Sub
        BrkErrMsg.Insert(0, "BrkErrMsg")
        DrawListOfString(BrkErrMsg, 50) ' BrkErrMsg, y
    End Sub
 
    Sub DrawListOfString(LofS As List(Of String), y As Integer)
        ' Display of Text as Graphic-Text on PictureBox
        With Form1.PictureBox1 : Dim sizes = {12, 9}, d = 0
            Dim size As Integer
            Dim myFont As Font, myBrush As Brush
            Dim myGraphics As Graphics = .CreateGraphics
            Dim myFormat As New StringFormat
            myFormat.Alignment = StringAlignment.Center
            myBrush = New SolidBrush(Color.Red) : size = sizes(0)
            For i = 0 To LofS.Count - 1 : If i > 7 Then Exit For
                myFont = New Font("Verdana", size, FontStyle.Bold)
                myGraphics.DrawString(LofS.Item(i), myFont, myBrush, xCenter, y + d, myFormat)
                If i = 0 Then d += 30 : size = sizes(1) : Else d += 20
            Next
        End With
    End Sub
    Private Function LoadImgFromDisk(xfSpec As String) As Boolean
        ' These possibilities, but exclude each other in use
        ' PictureBox1.Load(xfSpec)
        ' PictureBox1.Image = Image.FromFile(xfSpec)
        Try : Img1 = Image.FromFile(xfSpec)
        Catch ex As Exception : BrkErrMsg.Add("Img-File not found") : Return False
        End Try : Return True
    End Function
    Public Sub CopyImgToArray(ImgNr As Byte, aNr As Byte)
        Dim xRGB(2), w, h As Integer, pxcol As Color ' RGB is a VB-own function
        CopyArrayToTmp("To", aNr)
        If ImgNr = 1 Then w = Img1Width : h = Img1Height
        If ImgNr = 2 Then w = Img2Width : h = Img2Height
        For y = 0 To h - 1
            For x = 0 To w - 1
                If ImgNr = 1 Then pxcol = CType(Img1, Drawing.Bitmap).GetPixel(x, y)
                If ImgNr = 2 Then pxcol = CType(Img2, Drawing.Bitmap).GetPixel(x, y)
                ConvertToRGB(xRGB, Hex(pxcol.ToArgb))
                For c = 0 To 2 : aTmp(x, y, c) = xRGB(c) : Next
            Next
        Next : CopyArrayToTmp("From", aNr)
    End Sub
    Private Sub CopyArrayToImg(aNr As Byte, ImgNr As Byte) ' RGB is a VB-own function
        Dim xRGB(2), w, h As Integer, ImgObj As Drawing.Bitmap = Nothing
        CopyArrayToTmp("To", aNr) : w = UBound(aTmp, 1) : h = UBound(aTmp, 2)
        If ImgNr = 1 Then ImgObj = CType(Img1, Drawing.Bitmap)
        If ImgNr = 2 Then ImgObj = CType(Img2, Drawing.Bitmap)
        For y As Integer = 0 To h - 1
            For x As Integer = 0 To w - 1
                For c = 0 To 2 : xRGB(c) = aTmp(x, y, c) : Next
                ImgObj.SetPixel(x, y, Color.FromArgb(xRGB(0), xRGB(1), xRGB(2)))
            Next
        Next
        If ImgNr = 1 Then Img1 = CType(ImgObj, Image)
        If ImgNr = 2 Then Img2 = CType(ImgObj, Image)
    End Sub
    Private Sub ConvertToRGB(ByRef xRGB() As Integer, ByVal xhex As String)
        Dim s As String
        For c = 0 To 2 : s = Mid(xhex, 2 * c + 3, 2)
            xRGB(c) = Convert.ToInt32(s, 16) ' 16 = convert to hex
        Next
    End Sub
 
    Private Sub DownsizeImage(v As Single) ' downsize factor in %
        ' in the squares of the green raster the calculation,
        ' shown in the following Visual-Basic-Code, delivers a medium pixel-color
 
        ' h = heiht, w = width, v = downsizefactor in %
        ' Xd, Yd ... pixel-coordinates of the daughter-picture
        ' x1, y1 ... upper left corner of a green square
        ' x2, y2 ... lower right corner of a green square
        ' r1x, r2x, r1y, r2y .... xy coordinates within a pixel (of the mother-img)
        ' c = 0 (for rd), c = 1 (for gn), c = 2 (for bl)
        Dim w = Img1Width, h = Img1Height
        Dim Xd, x2, x10, x20, kx, xx As Single
        Dim Yd, y2, y10, y20, ky, yy As Single
        Dim r1y, r2y, r1x, r2x As Single
        Dim tmp As Integer : Dim xRGB = {0, 0, 0} : If v = 0 Then Exit Sub
        Dim d = 100 / v : Yd = -1 : ClearImageArray(2)
 
        For y1 As Single = 0 To h - 1 Step d : Yd += 1
            y2 = y1 + d : If y2 > h - 1 Then y2 = h - 1
            y10 = Int(y1) : y20 = Int(y2)
            r1y = y1 - y10 : r2y = y2 - y20 : Xd = -1
            For x1 As Single = 0 To w - 1 Step d : Xd += 1
                x2 = x1 + d : If x2 > w - 1 Then x2 = w - 1
                x10 = Int(x1) : x20 = Int(x2)
                r1x = x1 - x10 : r2x = x2 - x20
                ' ---------- Square ------------
                For y = y10 To y20 : ky = 1
                    If y = y10 Then ky = 1 - r1y
                    If y = y20 Then ky = r2y
                    If ky < 0 Then ky = 0
 
                    For x = x10 To x20 : kx = 1
                        If x = x10 Then kx = 1 - r1x
                        If x = x20 Then kx = r2x
                        If kx < 0 Then kx = 0
                        For c = 0 To 2
                            xRGB(c) += CInt(kx * ky * Img1Array(CInt(x), CInt(y), c))
                        Next
                    Next
                Next : xx = x2 - x1 : yy = y2 - y1
                For c = 0 To 2 : tmp = CInt(xRGB(c) / (xx * yy))
                    If tmp < 0 Then tmp = 0
                    If tmp > 255 Then tmp = 255
                    Img2Array(CInt(Xd), CInt(Yd), c) = tmp
                    xRGB(c) = 0
                Next
                ' ---------- End of the square ------------
            Next
        Next
    End Sub
    Sub ClearImageArray(aNr As Byte)
        Dim w, h As Integer ', aTmp(,,) As Integer = Nothing
        CopyArrayToTmp("To", aNr) : w = UBound(aTmp, 1) : h = UBound(aTmp, 2)
        For y = 0 To h
            For x = 0 To w
                For c = 0 To 2 : aTmp(x, y, c) = 0 : Next
            Next
        Next : CopyArrayToTmp("From", aNr)
    End Sub
End Class
' ==============================================================================================
Option Strict On
Option Explicit On
 
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
 
Public Class BitMapBitLock
 
    Public Sub CopyImgToArray(ImgNr As Integer, aNr As Byte) ' Image-Object
        If ImgNr = 1 Then ImageToFromArray("To", CType(Img1, Bitmap))
        If ImgNr = 2 Then ImageToFromArray("To", CType(Img2, Bitmap))
        aTmp = ImgArray : CopyArrayToTmp("From", aNr)
    End Sub
    Public Sub CopyArrayToImg(aNr As Byte, ImgNr As Integer) ' Image-Object
        CopyArrayToTmp("To", aNr) : ImgArray = aTmp
        Dim xbmp As Bitmap = New Bitmap(PiBxW, PiBxH)
        ImageToFromArray("From", xbmp)
        If ImgNr = 1 Then Img1 = CType(xbmp, Image)
        If ImgNr = 2 Then Img2 = CType(xbmp, Image)
    End Sub
 
    Public Sub ImageToFromArray(Mode As String, ByRef bmp As Bitmap) ' Bitmap only
        Dim w, h, x, y, c As Integer
        If Mode = "From" Then
            w = UBound(ImgArray, 1) + 1 : h = UBound(ImgArray, 2) + 1
            bmp = New Bitmap(w, h, PixelFormat.Format24bppRgb)
        End If
        With bmp
            If Mode = "To" Then w = .Width : h = .Height : ReDim ImgArray(w, h, 2)
            Dim rect As New Rectangle(0, 0, w, h)
            Dim bmpData As BitmapData = .LockBits(rect, ImageLockMode.ReadWrite, .PixelFormat)
            Dim ptr As IntPtr = bmpData.Scan0
            Dim bytes As Integer = Math.Abs(bmpData.Stride) * h
            Dim rgbValues(bytes - 1) As Byte
            Marshal.Copy(ptr, rgbValues, 0, bytes) : x = 0 : y = 0
            For BytePos As Integer = 0 To rgbValues.Length - 1 Step3
                For c = 0 To 2
                    If Mode = "To" Then ImgArray(x, y, c) = CInt(rgbValues(BytePos + 2 - c))
                    If Mode = "From" Then rgbValues(BytePos + 2 - c) = CByte(ImgArray(x, y, c))
                Next : x += 1 : If x > w - 1 Then x = 0 : y += 1
            Next : Marshal.Copy(rgbValues, 0, ptr, bytes) : .UnlockBits(bmpData)
        End With
    End Sub
End Class
' ==============================================================================================