Sign in to follow this  
  • entry
    1
  • comments
    0
  • views
    85

Procedural Generated Bitmaps In VB.net application

Sign in to follow this  
aominmeiho

417 views

Surely, VB.net and C# (in Visual Studio express and other editions) Bitmaps were creatable from its GDI+ methods.(ex. Dim b as bitmap = new bitmap(image))

But not supported programming-based procedural generated bitmaps, only bitmaps from bitmap-files or its (related) objects or classes supported.

Now, this article describes about algorithm-based generated bitmaps in VB.net/C# using both built-in GDI+ methods and external Windows APIs.

so-called "binary" bitmaps created from the Createbitmap API. But its usage was not simple, pretty difficult.

Then I show up samples in source codes below.

1.form(an app-window) initialization (on this app, form.size fixed in 1600*900)

    Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Me.Load
        bmp = New Bitmap(1601, 865, Imaging.PixelFormat.Format32bppRgb) 'screen resolutions in 1600*864

        Sm = "Scene 1" : At = 1 : g = Me.CreateGraphics: BmphDC = g.GetHdc : MainhDC = CreateCompatibleDC(BmphDC)
        Me.Top = 0 : Me.Left = 0 : SetTextColor(MainhDC, &H32A77400) : SetBkColor(MainhDC, 0) : SetBkMode(MainhDC, 1)

        Dim f As New Font(New FontFamily("Times New Roman"), 14, FontStyle.Regular, GraphicsUnit.Pixel, 1, False) : SelectObject(MainhDC, f.ToHfont)
    End Sub 

mixed .net objects/methods and windows APIs up. those codes were working correctly as it is...

Then cleanups.

    Private Sub Form1_FormClosing(ByVal sender As Object, ByVal e As System.Windows.Forms.FormClosingEventArgs)
        DeleteDC(MainhDC) : g.ReleaseHdc(BmphDC) : End
    End Sub

2.binding binary values to bitmap

    Public Function LenB(ByVal stTarget As String) As Integer
        Return System.Text.Encoding.GetEncoding(932).GetByteCount(stTarget)
    End Function
    Private Sub RefreshScenes() 
        ' Create a new bitmap and Lock the bitmap's bits.
        Dim rect As New Rectangle(0, 0, bmp.Width, bmp.Height)
        Dim bmpData As System.Drawing.Imaging.BitmapData = bmp.LockBits(rect, Drawing.Imaging.ImageLockMode.WriteOnly, bmp.PixelFormat)
        Dim ptr As IntPtr = bmpData.Scan0 ' Get the address of the first line.
        ' Declare an array to hold the bytes of the bitmap.This code is specific to a bitmap with 32 bits per pixels.
        Dim bytes As Integer = Math.Abs(bmpData.Stride) * bmp.Height ':Dim rgbValues(bytes - 1) As Byte
        ' Copy the RGB values back to the bitmap
        System.Runtime.InteropServices.Marshal.Copy(rgbValues, 0, ptr, bytes)        
        bmp.UnlockBits(bmpData) ' Unlock the bits. 
        bmpHandle = bmp.GetHbitmap : SelectObject(MainhDC, bmpHandle)
        'TextOut(MainhDC, 637, 10, "A Single Textout Line called like this", 19) 
        For Iu As Integer = 0 To 9
            If Not DispMsgShown(Iu) = "" Then
                Dim RenCache As Integer = LenB(DispMsgShown(Iu))
                TextOut(MainhDC, 27, 21 + (Iu * 22), DispMsgShown(Iu), RenCache)
            End If
        Next Iu : BitBlt(BmphDC, 0, 0, 1601, 865, MainhDC, 0, 0, SRCCOPY) : DeleteObject(bmpHandle)
    End Sub

3.texts to be used in overlays 
    Private Sub StrLoader()
        Select Case At
            Case 1
                DispMsgShown(0) = "textout sample..."
                DispMsgShown(1) = "at the same time using bitblt and textout..."
                DispMsgShown(2) = "likely this way to code."
                DispMsgShown(3) = " "
                DispMsgShown(4) = "coffee-drinking is relaxing us"
                DispMsgShown(5) = ""
                DispMsgShown(6) = ""
                DispMsgShown(7) = "yoga included the same affects "
                DispMsgShown(8) = ""
            Case 2
                DispMsgShown(0) = "A"
                DispMsgShown(1) = "B"
                DispMsgShown(2) = "C"
                DispMsgShown(3) = "D"
                DispMsgShown(4) = "E"
                DispMsgShown(5) = "F"
                DispMsgShown(6) = "G"
                DispMsgShown(7) = "H"
                DispMsgShown(8) = "I"
                DispMsgShown(9) = "JKLMNOPQRSTUVWXYZ...thanks!"

        End Select
    End Sub
 

4. Procedual generation samples using above and a timer component

   Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
        Cur += 1 : Randomize()    
        Dim RRInt As Integer = Int(Math.Sqrt(Cur * 410)), Sr As New System.Random
        Dim X2, Y2 As Integer, Iu As Integer
        Select Case Sm
            Case "Scene 1"
                Select Case At
                    Case 1 
                        For Iu2 As Integer = 0 To 13
                            For Iu = 0 To Math.Sqrt(Cur * 173) + 37
retry:
                                X2 = -Int(RRInt * 1.5) + Sr.Next(RRInt * 3) : Y2 = -RRInt + Sr.Next(RRInt * 2)                                
                                If Y2 < 0 And Y2 ^ 3 + X2 ^ 2 < RRInt * 40 Then GoTo Retry
                                Pset1(800 + X2, 510 + Y2, Math.Min(255, Sr.Next(RRInt)), Math.Min(255, Sr.Next(RRInt)), Math.Min(255, Sr.Next(RRInt)))
                            Next Iu
                        Next Iu2 
                        Math.DivRem((Cur - 1) * 5, 460, SecCur)
                        For Iu2 As Integer = 0 To 4 
                            'If Cur < 460 Then
                            For Iu = 0 To Math.Sqrt(SecCur) + 14
                                Pset3(1140 + SecCur + Iu2, 10 + Iu, 40, 60, 70, , , Math.Sqrt(SecCur * 7) + Iu * 2)
                                Pset3(1140 + SecCur + Iu2, 44 + Iu, 40, 60, 70, , Math.Sqrt(SecCur * 7) + Iu * 2)
                                Pset3(1140 - SecCur - Iu2, 74 - Iu, 40, 60, 70, Math.Sqrt(SecCur * 7) + Iu * 2)
                                Pset3(1140 - SecCur - Iu2, 40 - Iu, 40, 60, 70, , Math.Sqrt(SecCur * 4) + Iu, Math.Sqrt(SecCur * 4) + Iu)
                            Next Iu    ':End If
                        Next Iu2
                    Case 2

                        Dim SecCur As Integer
                        If Cur < 2100 Then
                            For Iu2 As Integer = 0 To 780
                                'Pset1(1600 - Cur, 120 + Int(Math.Sqrt(Cur)), 60, 240, 140)
                                Pset1(1600 - Cur * 2 + Iu2 * 4, 120 + Int(Math.Sqrt(Cur * 3)) + Iu2, 60 - Int(Math.Sqrt(Iu2)), 240 - Int(Math.Sqrt(Iu2)) * 3, 140 + Int(Math.Sqrt(Iu2)) * 2)
                                Pset1(1600 - Cur * 2 - 1 + Iu2 * 4, 120 + Int(Math.Sqrt(Cur * 3)) + Iu2, 60 - Int(Math.Sqrt(Iu2)), 240 - Int(Math.Sqrt(Iu2)) * 3, 140 + Int(Math.Sqrt(Iu2)) * 2)

                            Next Iu2
                        Else
                            SecCur = Cur - 2100
                            For Iu2 As Integer = 0 To 780 
                                'Pset1(1600 - Cur, 120 + Int(Math.Sqrt(Cur)), 60, 240, 140)
                                Pset1(1600 - SecCur * 2 + Iu2 * 4, 120 + Int(Math.Sqrt(SecCur * 3)) + Iu2, 160, 240 - Int(Math.Sqrt(Iu2)), 160 + Int(Math.Sqrt(Iu2)))
                                Pset1(1600 - SecCur * 2 - 1 + Iu2 * 4, 120 + Int(Math.Sqrt(SecCur * 3)) + Iu2, 160, 240 - Int(Math.Sqrt(Iu2)), 160 + Int(Math.Sqrt(Iu2)))

                            Next Iu2
                        End If

                End Select
        End Select : StrLoader():RefreshScenes()
    End Sub

If you hope to add more scenes, one solution is increasing "case" statement .

Surely In a large project, external package files required I think. 

5.Header declarations within Windows APIs and module-common values

    Private Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As IntPtr, ByVal hdc As IntPtr) As Long
    Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As IntPtr, ByVal hObject As IntPtr) As IntPtr
    Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As IntPtr) As Boolean
    Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As IntPtr) As IntPtr
    Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hWnd As IntPtr) As IntPtr
    Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As IntPtr) As IntPtr
    Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As IntPtr) As Boolean
    Private Declare Function SetTextColor Lib "gdi32.dll" (ByVal hDC As IntPtr, ByVal crColor As Integer) As Boolean
    Private Declare Function SetBkColor Lib "gdi32.dll" (ByVal hDC As IntPtr, ByVal crColor As Integer) As Boolean
    Private Declare Auto Function BitBlt Lib "gdi32.dll" (ByVal hdcDest As IntPtr, ByVal nXDest As Integer, ByVal nYDest As Integer, ByVal nWidth As Integer, _
         ByVal nHeight As Integer, ByVal hdcSrc As IntPtr, ByVal nXSrc As Integer, ByVal nYSrc As Integer, ByVal dwRop As System.Int32) As Boolean
    Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As IntPtr, ByVal x As Integer, ByVal y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Boolean
    Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As IntPtr, ByVal iBkMode As Integer) As Boolean
    Private Const SRCCOPY As Integer = &HCC0020
    Private Sm As String, At As Integer, Cur As Integer, Bm As Bitmap, rgbValues(5539459) As Byte
    Private g As Graphics, Iu As Integer, SecCur As Integer, bmp As Bitmap, bmpHandle As IntPtr
    Private MainhDC, BmphDC As IntPtr, DispMsgShown(9) As String
    Private Stride_Value As Integer = 6404 'stride values related in bitmap's X-width
 

6.methods in pixel painting (compatible only this application)

    Private Sub Pset1(ByVal XPos As Integer, ByVal YPos As Integer, ByVal RedValue As Byte, ByVal GreenValue As Byte, ByVal BlueValue As Byte)
        If YPos > 864 Then YPos = 864
        If YPos < 0 Then YPos = 0
        If XPos > 1600 Then XPos = 1600
        If XPos < 0 Then XPos = 0

        Dim AddressOfBinaryIndex As Integer = XPos * 4 + YPos * 6404
        rgbValues(AddressOfBinaryIndex) = Math.Max(rgbValues(AddressOfBinaryIndex), BlueValue)
        rgbValues(AddressOfBinaryIndex + 1) = Math.Max(rgbValues(AddressOfBinaryIndex + 1), GreenValue)
        rgbValues(AddressOfBinaryIndex + 2) = Math.Max(rgbValues(AddressOfBinaryIndex + 2), RedValue)
    End Sub
    Private Sub Pset3(ByVal XPos As Integer, ByVal YPos As Integer, ByVal RedValue As Byte, ByVal GreenValue As Byte, ByVal BlueValue As Byte, Optional ByVal AdditionalRedValue As Byte = 0, Optional ByVal AdditionalGreenValue As Byte = 0, Optional ByVal AdditionalBlueValue As Byte = 0)
        If YPos > 864 Then YPos = 864
        If YPos < 0 Then YPos = 0
        If XPos > 1600 Then XPos = 1600
        If XPos < 0 Then XPos = 0

        RedValue = Math.Min(255, AdditionalRedValue + RedValue) : GreenValue = Math.Min(255, AdditionalGreenValue + GreenValue) : BlueValue = Math.Min(255, AdditionalBlueValue + BlueValue)

        Dim AddressOfBinaryIndex As Integer = XPos * 4 + YPos * 6404 : rgbValues(AddressOfBinaryIndex) = Math.Min(255, BlueValue)
        rgbValues(AddressOfBinaryIndex + 1) = Math.Min(255, GreenValue) : rgbValues(AddressOfBinaryIndex + 2) = Math.Min(255, RedValue)
    End Sub

    Private Sub Pset2(ByVal XPos As Integer, ByVal YPos As Integer, ByVal RedValue As Byte, ByVal GreenValue As Byte, ByVal BlueValue As Byte, Optional ByVal AdditionalRedValue As Byte = 0, Optional ByVal AdditionalGreenValue As Byte = 0, Optional ByVal AdditionalBlueValue As Byte = 0)
        If YPos > 864 Then YPos = 864
        If YPos < 0 Then YPos = 0
        If XPos > 1600 Then XPos = 1600
        If XPos < 0 Then XPos = 0

        RedValue = Math.Min(255, AdditionalRedValue + RedValue) : GreenValue = Math.Min(255, AdditionalGreenValue + GreenValue) : BlueValue = Math.Min(255, AdditionalBlueValue + BlueValue)

        Dim AddressOfBinaryIndex As Integer = XPos * 4 + YPos * 6404
        rgbValues(AddressOfBinaryIndex) = Math.Max(rgbValues(AddressOfBinaryIndex), BlueValue)
        rgbValues(AddressOfBinaryIndex + 1) = Math.Max(rgbValues(AddressOfBinaryIndex + 1), GreenValue)
        rgbValues(AddressOfBinaryIndex + 2) = Math.Max(rgbValues(AddressOfBinaryIndex + 2), RedValue)
    End Sub
 

7.Buttons on form to proceed scenes

    Private Sub ResetScreen()
        Dim Iu As Integer : For Iu = 0 To rgbValues.Length - 1 Step 4
            rgbValues(Iu) = 0 : rgbValues(Iu + 1) = 0 : rgbValues(Iu + 2) = 0
        Next
    End Sub
    Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
        If At = 1 Then
            ResetScreen() : At = 2 : Cur = 0
        End If
        If At = 2 Then
            MsgBox("sample application finished. thanks for downloading!")
        End If
    End Sub

A VB2010 sample solution will be attached later. I'd like readers to download it!

Of course it also enables binding DirectX interop APIs and above bitmaps in additional coding with slimdx or sharpdx, If you require GPU optimization.

thanks for long reading

AMStudiosSample1.zip

Sign in to follow this  


0 Comments


Recommended Comments

There are no comments to display.

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now