fully memory image processing 1

[codecref]

hi guys
I have this code to make a image on the fly and place it into picturebox and then put it into a array... but I want to skip using picturebox as holder and directly put it into array, is it possible? to increase the speed, and how do I put the stroke around the text I am making? I have attached a sample that someone did it but just don't know how to modify (I'm very newbie in imaging stuff).




Please help

Public Subx As New Subx
Public CurrentSub As Integer

'Option Explicit
Private Declare Function GetTextMetrics Lib "gdi32" Alias "GetTextMetricsA" (ByVal hdc As Long, lpMetrics As TEXTMETRIC) As Long
Private Type TEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
End Type

Declare Function StrokePath Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long


Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Const BLACK_PEN = 6
Private Const WHITE_BRUSH = 0
Private Const NULL_BRUSH = 5
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Const ANSI_CHARSET = 0
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function GetBkMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Const TRANSPARENT = 1

Public Function Txt2Image(ByVal Text As String) As StdPicture

Dim mem_dc As Long
Dim mem_bm As Long
Dim orig_bm As Long
Dim wid As Long
Dim hgt As Long
Dim old_font As Long
Dim new_font As Long
Dim old_bk_mode As Long
'GoTo Here
    
    wid = 720
    hgt = 280
    ' Create the device context.
    mem_dc = CreateCompatibleDC(hdc)

    ' Create the bitmap.
    mem_bm = CreateCompatibleBitmap(mem_dc, wid, hgt)

    ' Make the device context use the bitmap.
    orig_bm = SelectObject(mem_dc, mem_bm)

    ' Give the device context a white background.
    SelectObject mem_dc, GetStockObject(WHITE_BRUSH)
    Rectangle mem_dc, -1, -1, wid, hgt
    SelectObject mem_dc, GetStockObject(NULL_BRUSH)

    ' Draw the on the device context.
    SelectObject mem_dc, GetStockObject(BLACK_PEN)
    'MoveToEx mem_dc, 1, 1, ByVal 0&
    
    'MoveToEx mem_dc, 0, hgt, ByVal 0&
    

    ' Do not fill the background.
    old_bk_mode = GetBkMode(mem_dc)
    SetBkMode mem_dc, TRANSPARENT

    ' Give the DC a font.
    new_font = CreateFont(25, 0, 0, 0, 700, 0, 0, 0, ANSI_CHARSET, 0, 0, 0, 0, "Tahoma")
    old_font = SelectObject(mem_dc, new_font)

    ' Draw some text.
    Call AlignTextCenter(mem_dc, Text)

    ' Destroy the new font.
    SelectObject mem_dc, old_font
    DeleteObject new_font

    ' Restore the original background fill mode.
    SetBkMode mem_dc, old_bk_mode
    ImportQuestion.Picture1.AutoRedraw = True
    
    
    ' Copy the device context into the PictureBox.
    'ImportQuestion.Picture1.Picture = Nothing
    BitBlt ImportQuestion.Picture1.hdc, 0, 0, wid, hgt, _
        mem_dc, 0, 0, SRCCOPY
        
    ImportQuestion.Picture1.Picture = ImportQuestion.Picture1.Image
    'StrokeAndFillPath ImportQuestion.Picture1.hdc
    
Here:
    With ImportQuestion
        '.ForeColor = vbGreen
        'TextOut .hdc, 5, 10, Text, Len(Text)
        Set Txt2Image = .Picture1.Picture

    End With

    ' Delete the bitmap and dc.
    SelectObject mem_dc, orig_bm
    DeleteObject mem_bm
    DeleteDC mem_dc
End Function

Function AlignTextCenter(mem_dc As Long, Text As String) As Long
Dim bla As TEXTMETRIC
    GetTextMetrics mem_dc, bla
    Dim posX As Long, PosY As Long
    posX = (720 / 2) - ((bla.tmAveCharWidth * Len(Text)) / 2)
    PosY = 10 '(180 / 2) - (bla.tmHeight / 2)
    ' Draw some text.
    
With ImportQuestion
    .Picture1.ForeColor = RGB(255, 170, 0)
    'BeginPath mem_dc
    TextOut mem_dc, posX, PosY, Text, Len(Text)
    'EndPath mem_dc
    'StrokeAndFillPath mem_dc
    'StrokePath mem_dc
End With

PS: there is several unused call which I was just playing


a stroke sample

Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function StrokePath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function FillPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hdc As Long) As Long

Private Sub Picture1_Paint()

    'KPD-Team 2000
    'URL: [URL unfurl="true"]http://www.allapi.net/[/URL]
    'E-Mail: KPDTeam@Allapi.net
    Dim hBrush As Long, oldBrush As Long
    Const sText = "Hello"
    'set the form's font to 'Times New Roman, size 48'
    Picture1.FontName = "Times New Roman"
    Picture1.FontSize = 48
    'make sure picture1.TextHeight returns a value in Pixels
    Picture1.ScaleMode = vbPixels
    'create a new, white brush
    hBrush = CreateSolidBrush(vbWhite)
    'replace the current brush with the new white brush
    oldBrush = SelectObject(Picture1.hdc, hBrush)
    'set the fore color to black
    Picture1.ForeColor = vbBlack
    'open a path bracket
    BeginPath Picture1.hdc
    'draw the text
    TextOut Picture1.hdc, 0, 0, sText, Len(sText)
    'close the path bracket
    EndPath Picture1.hdc
    
    'render the specified path by using the current pen
    StrokePath Picture1.hdc
    'begin a new path
    BeginPath Picture1.hdc
    TextOut Picture1.hdc, 0, Picture1.TextHeight(sText), sText, Len(sText)
    EndPath Picture1.hdc
    'fill the path’s interior by using the current brush and polygon-filling mode
    FillPath Picture1.hdc
    
    'begin a new path
    BeginPath Picture1.hdc
    TextOut Picture1.hdc, 0, Picture1.TextHeight(sText) * 2, sText, Len(sText)
    EndPath Picture1.hdc
    'stroke the outline of the path by using the current pen and fill its interior by using the current brush
    StrokeAndFillPath Picture1.hdc
    'replace this form's brush with the original one
    SelectObject Picture1.hdc, oldBrush
    'delete our white brush
    DeleteObject hBrush
End Sub

PS: to run this code you just paste it into a form without any object

 

[Hypetia]

See the following code. It does all the image processing in memory.

This code goes in the form.
___
[tt]
Option Explicit
Private Sub Form_Load()
Dim myFont As New StdFont
myFont.Name = "Arial"
myFont.Size = 72
Me.Picture = Text2Image("Hello!", myFont, vbRed, vbGreen, vbBlue, 3)
Set myFont = Nothing
End Sub[/tt]
___

And this one goes in a standard code module.
___
[tt]
Option Explicit
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function StrokeAndFillPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function BeginPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function EndPath Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function OleTranslateColor Lib "oleaut32" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Private Declare Sub OleCreatePictureIndirect Lib "oleaut32" (ByRef lpPictDesc As PictDesc, riid As Any, ByVal fOwn As Long, lplpvObj As Any)
Private Declare Sub CLSIDFromString Lib "ole32" (ByVal lpsz As Long, pclsid As Any)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Type PictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long
xExt As Long
yExt As Long
End Type
Const PS_SOLID = 0

Function Text2Image(Text As String, Font As IFont, ByVal BackColor As OLE_COLOR, ByVal FillColor As OLE_COLOR, LineColor As OLE_COLOR, ByVal LineWidth As Long) As StdPicture
Dim hdc As Long, hBmp As Long, hFont As Long, hBrush As Long, hPen As Long
Dim hDC0 As Long
OleTranslateColor BackColor, 0, BackColor
OleTranslateColor FillColor, 0, FillColor
OleTranslateColor LineColor, 0, LineColor
hDC0 = GetDC(0)
hdc = CreateCompatibleDC(hDC0)

hFont = SelectObject(hdc, Font.hFont)

Dim sz As Size, rc As RECT
GetTextExtentPoint32 hdc, Text, Len(Text), sz

hBmp = CreateCompatibleBitmap(hDC0, sz.cx, sz.cy)
hBmp = SelectObject(hdc, hBmp)

ReleaseDC 0, hDC0

rc.Right = sz.cx
rc.Bottom = sz.cy
hBrush = CreateSolidBrush(BackColor)
FillRect hdc, rc, hBrush
DeleteObject hBrush

hBrush = CreateSolidBrush(FillColor)
hBrush = SelectObject(hdc, hBrush)

hPen = CreatePen(PS_SOLID, LineWidth, LineColor)
hPen = SelectObject(hdc, hPen)

BeginPath hdc
TextOut hdc, 0, 0, Text, Len(Text)
EndPath hdc
StrokeAndFillPath hdc

hPen = SelectObject(hdc, hPen)
DeleteObject hPen

hBrush = SelectObject(hdc, hBrush)
DeleteObject hBrush

hBmp = SelectObject(hdc, hBmp)
DeleteDC hdc

Dim pd As PictDesc, IPic(15) As Byte
pd.cbSizeofStruct = Len(pd)
pd.picType = vbPicTypeBitmap
pd.hImage = hBmp

CLSIDFromString StrPtr("{00020400-0000-0000-C000-000000000046}"), IPic(0)
OleCreatePictureIndirect pd, IPic(0), True, Text2Image
End Function[/tt]
___

Run the program. The Text2Image function creates a picture on the fly using the supplied arguments and the picture returned is assigned directly to the picture property of the form. You can store these pictures in an array of picture objects as you want.

The code might look quite scary to you but it is straight forward. All the GDI functions used here are discussed many times and you may find more stuff if you search previous threads.

Hope that helps.

 

[codecref]

thanks for very much for your interesting trick, your code works like charm...

but one thing I was wonder was Anti-Aliasing, is it possible to apply that easily? I tried to search many sites but no luck.

thanks again

 

[strongm]

Sadly, GDI does not include antialiasing for any of its drawing primitives. So in general you would have to render your drawing to a larger image, typically 2 to 4 times bigger than the final target image, and then use StretchBlit with an appropriate StretchMode set (see my code in thread222-539638 for an example).

Alternatively, you might want to consider trying to use GDI+, rather than GDI. Much of GDI+ is not designed for use from VB, so you'd need a type library. The one I use can be found here:

http://www.vbaccelerator.com/home/VB/Type_Libraries/GDIPlus_Type_Library/GDIplus_Type_Library.asp

and some keyword searching in this forum should find some examples from me on how to use it (although no specific antialiasing examples as far as I can recall)