Platforms to show: All Mac Windows Linux Cross-Platform

/Picture/Picture To Memoryblock


Required plugins for this example: MBS Picture Plugin, MBS Util Plugin, MBS Main Plugin

You find this example project in your Plugins Download as a Xojo project file within the examples folder: /Picture/Picture To Memoryblock

This example is the version from Sun, 10th Dec 2016.

Project "Picture To Memoryblock.xojo_binary_project"
Class App Inherits Application
Const kEditClear = "&Löschen"
Const kFileQuit = "Beenden"
Const kFileQuitShortcut = ""
End Class
Class Window1 Inherits Window
Control List Inherits Listbox
ControlInstance List Inherits Listbox
EventHandler Function CellBackgroundPaint(g As Graphics, row As Integer, column As Integer) As Boolean // Color lines which have a color if row<me.ListCount then dim v as Variant = me.RowTag(row) if v.Type = Variant.TypeColor then dim c as color = v g.ForeColor = c g.FillRect 0,0,g.Width,g.Height Return true end if end if End EventHandler
End Control
Control Canvas1 Inherits Canvas
ControlInstance Canvas1 Inherits Canvas
End Control
EventHandler Sub Open() dim pic as Picture = LogoMBS(500) dim mask as Picture = new Picture(500,500,32) mask.Graphics.ForeColor = &cFFFFFF mask.Graphics.FillRect 0,0,mask.Width,mask.Height mask.Graphics.ForeColor = &c000000 mask.Graphics.FillOval 0,0,mask.Width,mask.Height dim m as MemoryBlock Check1(pic, "RGB16") Check1(pic, "ARGB16") Check1(pic, "RGB16_565") Check1(pic, "ARGB32") Check1(pic, "RGB32") Check1(pic, "RGB24") Check1(pic, "MASK8") Check2(pic, mask, "RGB16") Check2(pic, mask, "ARGB16") Check2(pic, mask, "RGB16_565") Check2(pic, mask, "ARGB32") Check2(pic, mask, "RGB32") Check2(pic, mask, "RGB24") Check2(pic, mask, "MASK8") // done pic.mask.Graphics.DrawPicture mask,0,0 canvas1.Backdrop = pic End EventHandler
Sub Check(m1 as MemoryBlock, m2 as MemoryBlock) if m1<>nil and m2<>nil then if m1.Size = m2.size then List.AddRow "Size equal" if m1.BytesEqualMBS(0, m1.Size, m2, 0) then List.AddRow "Bytes equal" else List.AddFail "Bytes not equal" dim c as integer = m1.Size-1-32 for i as integer = 0 to c if m1.Int8Value(i)<>m2.Int8Value(i) then List.AddFail "Position: "+str(i) List.AddFail EncodingToHexMBS(m1.StringValue(i,32)) List.AddFail EncodingToHexMBS(m2.StringValue(i,32)) exit end if next end if else List.AddFail "Size not equal" end if end if End Sub
Sub Check1(pic as Picture, mode as string) #pragma DisableBackgroundTasks dim d as Double dim m1,m2 as MemoryBlock d = Microseconds for i as integer = 1 to 10 m1 = GetMBfromPicture(pic, mode) next d = Microseconds-d if m1 = nil then List.AddFail "GetMBfromPicture(pic, "+mode+") Failed" else List.AddRow "GetMBfromPicture(pic, "+mode+") = "+Format(d/10.0/1000000.0,"0.0000") end if d = Microseconds for i as integer = 1 to 10 m2 = GetMBfromPictureMBS(pic, mode) next d = Microseconds-d if m2 = nil then List.AddFail "GetMBfromPictureMBS(pic, "+mode+") Failed" else List.AddRow "GetMBfromPictureMBS(pic, "+mode+") = "+Format(d/10.0/1000000.0,"0.0000") end if Check m1,m2 End Sub
Sub Check2(pic as Picture, mask as picture, mode as string) #pragma DisableBackgroundTasks dim d as Double dim m1,m2 as MemoryBlock d = Microseconds for i as integer = 1 to 10 m1 = GetMBfromPicture(pic, mask, mode) next d = Microseconds-d if m1 = nil then List.AddFail "GetMBfromPicture(pic, mask, "+mode+") Failed" else List.AddRow "GetMBfromPicture(pic, mask, "+mode+") = "+Format(d/10.0/1000000.0,"0.0000") end if d = Microseconds for i as integer = 1 to 10 m2 = GetMBfromPictureMBS(pic, mask, mode) next d = Microseconds-d if m2 = nil then List.AddFail "GetMBfromPictureMBS(pic, mask, "+mode+") Failed" else List.AddRow "GetMBfromPictureMBS(pic, mask, "+mode+") = "+Format(d/10.0/1000000.0,"0.0000") end if Check m1,m2 End Sub
End Class
MenuBar MenuBar1
MenuItem FileMenu = "&Ablage"
MenuItem FileQuit = "#App.kFileQuit"
MenuItem EditMenu = "&Bearbeiten"
MenuItem EditUndo = "&Rückgängig"
MenuItem UntitledMenu1 = "-"
MenuItem EditCut = "&Ausschneiden"
MenuItem EditCopy = "&Kopieren"
MenuItem EditPaste = "&Einfügen"
MenuItem EditClear = "#App.kEditClear"
MenuItem UntitledMenu0 = "-"
MenuItem EditSelectAll = "&Alles auswählen"
End MenuBar
Module Module1
Sub AddFail(extends l as listbox, s as string) // add line with red color l.AddRow s l.RowTag(l.LastIndex)=&cFF7777 End Sub
Function GetMBfromPicture(pic As Picture, mask As Picture, type As String = "RGB32") As MemoryBlock // Converts a picture into a MemoryBlock. // Will set w and h to the picture's width & height respectively. //image must be in power of 2! be sure to trap for this (by cropping texture when importing) #pragma DisableBackgroundTasks dim x, y, offset,height,width as integer Dim xx, yy As Integer Dim rgb as RGBSurface Dim rgbMask As RGBSurface dim c as color Dim texData As MemoryBlock Dim p, pmask As Picture p = new Picture(pic.Width,pic.Height,32) p.Graphics.DrawPicture pic,0,0 height = pic.graphics.height width = pic.graphics.width // Use if you want pass ByRef h & w as Integer 'h = height 'w = width // Set texData MemoryBlock to hold the exact size // of a pixel' color. Select Case type Case "RGB16", "ARGB16", "RGB16_565" texData = New MemoryBlock(height*width * 2) texData.LittleEndian = False Case "ARGB32", "RGB32", "RGB24" texData = New MemoryBlock(height*width * 4) texData.LittleEndian = True Case "MASK8" texData = New MemoryBlock(height*width) // 8-bit picture mask texData.LittleEndian = False End Select rgb = p.RGBSurface if mask <> nil then pmask = new Picture(p.Width, p.Height, 32) pmask.Graphics.DrawPicture mask,0,0 rgbMask = pmask.RGBsurface end if xx = width - 1 yy = height - 1 for y = 0 to yy for x = 0 to xx Select Case type // Parse RGB data Case "RGB32", "RGB24" c = rgb.Pixel(x,y) texData.ColorValue(offset,24) = c texData.UInt8Value(offset+3) = 255 offset = offset + 4 Case "ARGB32" c = rgb.Pixel(x,y) texData.ColorValue(offset,24) = c c = rgbMask.Pixel(x,y) // mask texData.UInt8Value(offset+3) = c.red offset = offset + 4 Case "RGB16" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "ARGB16" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "RGB16_565" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "MASK8"// Parse mask data c = rgbMask.Pixel(x,y) texData.Byte(offset) = c.red offset = offset + 1 End Select next next Return texData End Function
Function GetMBfromPicture(pic As Picture, type As String = "RGB32") As MemoryBlock // Converts a picture into a MemoryBlock. // Will set w and h to the picture's width & height respectively. //image must be in power of 2! be sure to trap for this (by cropping texture when importing) #pragma DisableBackgroundTasks dim x, y, offset,height,width as integer Dim xx, yy As Integer dim rgb as RGBSurface dim maskS As RGBSurface dim c as color Dim texData As MemoryBlock Dim p As Picture p = new Picture(pic.Width,pic.Height,32) p.Graphics.DrawPicture pic,0,0 height = p.graphics.height width = p.graphics.width // Use if you want pass ByRef h & w as Integer 'h = height 'w = width // Set texData MemoryBlock to hold the exact size // of a pixel' color. Dim clr As MemoryBlock= New MemoryBlock(4) Select Case type Case "RGB16", "ARGB16", "RGB16_565" texData = New MemoryBlock(height*width * 2) texData.LittleEndian = False Case "ARGB32", "RGB32", "RGB24" texData = New MemoryBlock(height*width * 4) texData.LittleEndian = True Case "MASK8" texData = New MemoryBlock(height*width) // 8-bit picture mask texData.LittleEndian = False End Select rgb = p.RGBSurface maskS = p.Mask.RGBSurface 'if p.Mask <> nil then xx = width - 1 yy = height - 1 for y = 0 to yy for x = 0 to xx Select Case type // Parse RGB data Case "RGB32", "RGB24" c = rgb.Pixel(x,y) texData.ColorValue(offset,24) = c texData.UInt8Value(offset+3) = 255 offset = offset + 4 Case "ARGB32" c = rgb.Pixel(x,y) texData.ColorValue(offset,24) = c c = maskS.Pixel(x,y) // mask texData.UInt8Value(offset+3) = c.red offset = offset + 4 Case "RGB16" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "ARGB16" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "RGB16_565" c = rgb.Pixel(x,y) texData.ColorValue(offset,16) = c offset = offset + 2 Case "MASK8"// Parse mask data c = maskS.Pixel(x,y) texData.Byte(offset) = c.red offset = offset + 1 End Select next next Return texData End Function
End Module
End Project

See also:

The items on this page are in the following plugins: MBS Picture Plugin.


The biggest plugin in space...