' Empty GUI script created on 11-16-2011 10:04:11 by largo_winch (ThinAIR)
' Empty GUI script created on 11-14-2011 14:33:05 by largo_winch (ThinAIR)
'--------------> GDIPLUS TEST FOR THINBASIC -------------------->
'------------------------->
' Example original from
' http://www.jose.it-berater.org/smfforum/index.php?topic=1827.0
'------------------------->
Uses "UI", "console"
'---------------------------->
'#INCLUDE "GDIPLUS_LW1b.INC"
'---------------------------->
'--------------------------------------------------------------------------------------------------
%UnitPixel = 2 ' Sets each unit to be one device pixel
'--------------------------------------------------------------------------------------------------
'//--------------------------------------------------------------------------
'// FontStyle: face types and common styles
'//--------------------------------------------------------------------------
' enum FontStyle
%FontStyleRegular = 0
%FontStyleBold = 1
%FontStyleItalic = 2
%FontStyleBoldItalic = 3
%FontStyleUnderline = 4
%FontStyleStrikeout = 8
' enum Unit
%UnitWorld = 0 ' // 0 -- World coordinate (non-physical unit)
%UnitDisplay = 1 ' // 1 -- Variable -- for PageTransform only
%UnitPixel = 2 ' // 2 -- Each unit is one device pixel.
%UnitPoint = 3 ' // 3 -- Each unit is a printer's point, or 1/72 inch.
%UnitInch = 4 ' // 4 -- Each unit is 1 inch.
%UnitDocument = 5 ' // 5 -- Each unit is 1/300 inch.
%UnitMillimeter = 6 ' // 6 -- Each unit is 1 millimeter.
Begin ControlID
%Canvas_Gdip
%bClose
End ControlID
'----------------------> problemzone solved by jose roca :)
Type RectF
x As Single 'Long
y As Single 'Long
width As Single 'As Long
height As Single 'Long
End Type
'----------------------> problemzone solved by jose roca :)
Type GDIP_BGRA_STRUCT Byte
blue As Byte
green As Byte
red As Byte
alpha As Byte
End Type
' // Size = 4 bytes
Union GDIP_BGRA_UNION
Colors As DWord
GDIP_BGRA_STRUCT
End Union
'-------------> BEGIN OF EXAMPLE ----------------------->
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function TBMain() As Long
Local hr As Long
Local hDlg As DWord
Local hdc As DWord
Local token As DWord
Local StartupInput As GdiplusStartupInput
' Initialize GDI+
StartupInput.GdiplusVersion = 1
hr = GdiplusStartup(token, StartupInput, ByVal %NULL)
If hr Then
MsgBox "Error initializing GDI+"
Exit Function
End If
Dialog New 0, "tb_gdiplus create_StringFormat",-1,-1, 420, 270, _
%WS_POPUP Or %WS_VISIBLE Or _
%WS_CLIPCHILDREN Or %WS_CAPTION Or _
%WS_SYSMENU Or %WS_MINIMIZEBOX, 0 To hDlg
Dialog Show Modal hDlg, Call dlgProc
' Shutdown GDI+
GdiplusShutdown token
End Function
' ========================================================================================
' ========================================================================================
' Main Dialog procedure
' ========================================================================================
CallBack Function DlgProc() As Long
Local cx, cy, hDc As Long
' -- Test for messages
Select Case CBMSG
Case %WM_INITDIALOG
' -- Place controls here
Dialog Pixels CBHNDL, 400, 250 To Units cx, cy
Control Add Canvas, CBHNDL, %Canvas_Gdip, "", 5, 5, cx+100, cy+100
Control Add Button, CBHNDL, %bClose, "Close", 80+cx, cy+5-84, 50, 18, Call bCloseProc
Canvas_Attach CBHNDL, %Canvas_Gdip, %TRUE
Canvas_Color Rgb(128, 255, 0), Rgb(0, 0, 0)
'Canvas_Clear(Rgb(0,0,0))
Canvas_Scale Pixels
Case %WM_PAINT
GDIP_CreateStringFormat()
Canvas_Redraw
Case %WM_COMMAND
Select Case CBCTL
Case %IDCANCEL
If CBCTLMSG = %BN_CLICKED Then Dialog End CBHNDL, 0
End Select
End Select
End Function
' -- Callback for close button
CallBack Function bCloseProc()
If CBMSG = %WM_COMMAND Then
If CBCTLMSG = %BN_CLICKED Then
' -- Closes the dialog
Dialog End CBHNDL
End If
End If
End Function
'------------------------------> with perfect solution :)
Sub GDIP_CreateStringFormat()
'------------------------------> with perfect solution :)
Local hStatus As Long
Local pGraphics As DWord
Local pPen As DWord
Local pFont As DWord
Local pFontFamily As DWord
Local pFormat As DWord
Local pBlackBrush As DWord
Local strFontName As String
Local strText As String
Local rcf As RECTF
Local fontCollection As DWord
hStatus = GdipCreateFromHDC(Canvas_GetDC, pGraphics)
' // Create the font
strFontName = Ucode$("Arial")
'hStatus = GdipCreateFontFamilyFromName(ByVal StrPtr(strFontName), %NULL, pFontFamily )
hStatus = GdipCreateFontFamilyFromName(ByVal StrPtr(strFontName), %NULL, ByVal VarPtr(pFontFamily) ) '(
If hStatus = %StatusOk And pFontFamily <> %NULL Then '
hStatus = GdipCreateFont(pFontFamily, 16, %FontStyleRegular, %UnitPoint, ByVal VarPtr(pFont ) )
GdipDeleteFontFamily(pFontFamily)
End If
' Note: You can use the wrapper function GdiPlusCreateFontFromName to create the font:
' hStatus = GdiPlusCreateFontFromName("Arial", 16, %FontStyleRegular, %UnitPoint, pFont)
' // Create a solid brush
hStatus = GdipCreateSolidFill(GDIP_ARGB(255, 0, 0, 0), ByVal VarPtr(pBlackBrush ) )
' // Draw the string
rcf.x = 30.0 : rcf.y = 30.0 : rcf.Width = 200.0 : rcf.Height = 25.0
'-------------> problemzone solved ------------------------------------------------->
hStatus = GdipCreateStringFormat(0, %LANG_NEUTRAL, ByVal VarPtr(pFormat) )
'-------------> problemzone solved ------------------------------------------------->
'hStatus = GdipSetStringFormatAlign(pFormat, %StringAlignmentCenter)
strText = Ucode$("Sample text")
hStatus = GdipDrawString(pGraphics, ByVal StrPtr(strText), Len(strText) \ 2, pFont, ByVal VarPtr(rcf), pFormat, pBlackBrush)
' // Create a Pen
hStatus = GdipCreatePen1(GDIP_ARGB(255,0, 0, 0), 3, %UnitPixel, ByVal VarPtr(pPen) )
' // Draw a rectangle
hStatus = GdipDrawRectangle(pGraphics, pPen, rcf.x, rcf.y, rcf.Width, rcf.Height)
' // Cleanup
If pFont Then GdipDeleteFont(pFont)
If pBlackBrush Then GdipDeleteBrush(pBlackBrush)
If pPen Then GdipDeletePen(pPen)
If pFormat Then GdipDeleteStringFormat(pFormat)
If pGraphics Then GdipDeleteGraphics(pGraphics)
End Sub
'-------------> END OF EXAMPLE ----------------------->
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'----------------> GDIP INCLUDE HELPERS ------------------------------------------------------>
' enum FillMode
%FillModeAlternate = 0
%FillModeWinding = 1
'---------------------------------->
%LANG_NEUTRAL = &H00??
%LANG_INVARIANT = &H7f??
'---------------------------------->
' enum StringAlignment
' // Left edge for left-to-right text,
' // right for right-to-left text,
' // and top for vertical
%StringAlignmentNear = 0
%StringAlignmentCenter = 1
%StringAlignmentFar = 2
Declare Function GdipSetStringFormatAlign Lib "GDIPLUS.DLL" Alias "GdipSetStringFormatAlign" ( _
ByVal pFormat As DWord, _
ByVal align As Long _
) As Long
Declare Function GdipCreateStringFormat Lib "GDIPLUS.DLL" Alias "GdipCreateStringFormat" ( _
ByVal formatAttributes As Long _ ' __in INT formatAttributes
, ByVal language As Word _ ' __in LANGID language
, ByRef format As DWord _ ' __out GpStringFormat **format '''[out] Pointer to a variable that receives a pointer to the new StringFormat object.
) As Long ' GpStatus
Declare Function GdipCreateFromHDC Lib "GDIPLUS.DLL" Alias "GdipCreateFromHDC" ( _
ByVal hdc As DWord _
, ByRef graphics As DWord _
) As Long
Declare Function GdipCreateFontFamilyFromName Lib "GDIPLUS.DLL" Alias "GdipCreateFontFamilyFromName" ( _
ByRef pName As String _ ' __in GDIPCONST WCHAR *name
, ByVal fontCollection As DWord _ ' __in GpFontCollection *fontCollection
, ByRef fontFamily As DWord _ ' __out GpFontFamily **fontFamily
) As Long ' GpStatus
Declare Function GdipCreateSolidFill Lib "GDIPLUS.DLL" Alias "GdipCreateSolidFill" ( _
ByVal pColor As DWord _ ' __in ARGB color
, ByRef brush As DWord _ ' __out GpSolidFill **brush
) As Long ' GpStatus
Declare Function GdipDeleteFontFamily Lib "GDIPLUS.DLL" Alias "GdipDeleteFontFamily" ( _
ByVal fontFamily As DWord _ ' __in GpFontFamily *fontFamily
) As Long ' GpStatus
Declare Function GdipCreateFont Lib "GDIPLUS.DLL" Alias "GdipCreateFont" ( _
ByVal fontFamily As DWord _ ' __in GDIPCONST GpFontFamily *fontFamily
, ByVal emSize As Single _ ' __in REAL emSize
, ByVal style As Long _ ' __in INT style
, ByVal unit As Long _ ' __in GpUnit unit
, ByRef pFont As DWord _ ' __out GpFont **font
) As Long ' GpStatus
'----------------------------------------------------------->
' -- Definitions from Josés headers
%StatusOk = 0
Type GdiplusStartupInput
GdiplusVersion As DWord
DebugEventCallback As DWord
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
If SizeOf(GdiplusStartupInput) <> 16 Then MsgBox 0, "Invalid size of GdiplusStartupInput"
Type GdiplusStartupOutput
NotificationHook As DWord
NotificationUnhook As DWord
End Type
If SizeOf(GdiplusStartupOutput) <> 8 Then MsgBox 0, "Invalid size of GdiplusStartupOutput"
Type EncoderParameter
pGuid As String * 16 ' // GUID of the parameter
NumberOfValues As DWord ' // Number of the parameter values
dwType As DWord ' // Value type, like ValueTypeLONG etc.
Value As DWord ' // A pointer to the parameter values
End Type
If SizeOf(EncoderParameter) <> 28 Then MsgBox 0, "Invalid size of EncoderParameter"
Type EncoderParameters
Count As DWord ' // Number of parameters in this structure
Parameter As EncoderParameter ' // Parameter values - variable-length array
End Type
If SizeOf(EncoderParameters) <> 32 Then MsgBox 0, "Invalid size of EncoderParameters"
Type ImageCodecInfo
Clsid As String * 16 ' CLSID
FormatID As String * 16 ' GUID
CodecName As Word Ptr ' const WCHAR*
DllName As Word Ptr ' const WCHAR*
FormatDescription As Word Ptr ' const WCHAR*
FilenameExtension As Word Ptr ' const WCHAR*
MimeType As Word Ptr ' const WCHAR*
Flags As DWord ' DWORD
Version As DWord ' DWORD
SigCount As DWord ' DWORD
SigSize As DWord ' DWORD
SigPattern As Byte Ptr ' const BYTE*
SigMask As Byte Ptr ' const BYTE*
End Type
If SizeOf(ImageCodecInfo) <> 76 Then MsgBox 0, "Invalid size of ImageCodecInfo"
Declare Function GdiplusStartup Lib "GDIPLUS.DLL" Alias "GdiplusStartup" (
ByRef token As DWord ' __out token ULONG_PTR
, ByRef input As GdiplusStartupInput ' __in input GdiplusStartupInput <record>
, ByRef output As GdiplusStartupOutput ' __out output GdiplusStartupOutput <record>
) As Long ' GpStatus
Declare Function GdipLoadImageFromFile Lib "GDIPLUS.DLL" Alias "GdipLoadImageFromFile" (
ByVal filename As DWord ' __in GDIPCONST WCHAR *filename
, ByRef pImage As DWord ' __out GpImage **image
) As Long ' GpStatus
Declare Function lstrlenw Lib "KERNEL32.DLL" Alias "lstrlenW" ( _
ByVal lpString As DWord _ ' __in LPCWSTR lpString
) As Long
Declare Function GdipGetImageEncodersSize Lib "GDIPLUS.DLL" Alias "GdipGetImageEncodersSize" (
ByRef numEncoders As DWord ' __in UINT *numEncoders
, ByRef Size As DWord ' __out UINT *size
) As Long ' Status
Declare Function GdipGetImageEncoders Lib "GDIPLUS.DLL" Alias "GdipGetImageEncoders" (
ByVal numEncoders As DWord ' __in UINT numEncoders
, ByVal Size As DWord ' __in UINT size
, ByRef encoders As Any ' __out ImageCodecInfo *encoders
) As Long ' Status
Declare Function GdipSaveImageToFile Lib "GDIPLUS.DLL" Alias "GdipSaveImageToFile" (
ByVal Image As DWord ' __in GpImage *image
, ByVal filename As DWord ' __in GDIPCONST WCHAR *filename
, ByRef clsidEncoder As Guid ' __in GDIPCONST CLSID clsidEncoder
, ByRef encoderParams As EncoderParameters ' __out GDIPCONST EncoderParameters *encoderParams
) As Long
Declare Function GdipDisposeImage Lib "GDIPLUS.DLL" Alias "GdipDisposeImage" (
ByVal Image As DWord ' __in GpImage *image
) As Long ' GpStatus
Declare Sub GdiplusShutdown Lib "GDIPLUS.DLL" Alias "GdiplusShutdown" ( _
ByVal token As DWord _ ' __in token ULONG_PTR
)
' void
Function GdiPlusGetEncoderClsid (ByVal strMimeType As String) As String
Local hr As Long
Local pImageCodecInfo As DWord
Local numEncoders As DWord
Local nSize As DWord
Local i As Long
Local wstrlen As Long
Local sMimeType As String
hr = GdipGetImageEncodersSize(numEncoders, nSize)
Dim buffer(nSize) As Byte
pImageCodecInfo = VarPtr(buffer(1))
Local myImageCodecInfo As ImageCodecInfo At pImageCodecInfo
hr = GdipGetImageEncoders(numEncoders, nSize, ByVal pImageCodecInfo)
If hr = 0 Then
For i = 1 To numEncoders
wstrlen = lstrlenW(myImageCodecInfo.MimeType)
If wstrlen Then sMimeType = Acode$(Peek$(myImageCodecInfo.MimeType, wstrlen * 2))
If InStr(Ucase$(sMimeType), Ucase$(strMimeType)) Then
Function = GuidTxt$(myImageCodecInfo.Clsid)
Exit For
End If
pImageCodecInfo += SizeOf(ImageCodecInfo) '// Increments pointer
SetAt(myImageCodecInfo, pImageCodecInfo)
Next
End If
End Function
Function GDIP_ARGB (ByVal a As Byte, ByVal r As Byte, ByVal g As Byte, ByVal b As Byte) As DWord
Local clr As GDIP_BGRA_UNION
clr.alpha = a
clr.red = r
clr.green = g
clr.blue = b
Function = clr.Colors
End Function
Declare Function GdipDrawString Lib "GDIPLUS.DLL" Alias "GdipDrawString" ( _
ByVal graphics As DWord _ ' __in GpGraphics *graphics
, ByRef Strings As String _ ' __in GDIPCONST WCHAR *string
, ByVal length As Long _ ' __in INT length
, ByVal pFont As DWord _ ' __in GDIPCONST GpFont *font
, ByRef layoutRect As RectF _ ' __in GDIPCONST GpRectF *layoutRect
, ByVal stringFormat As DWord _ ' __in GDIPCONST GpStringFormat *stringFormat
, ByVal brush As DWord _ ' __in GpBrush *brush
) As Long ' GpStatus
Declare Function GdipCreatePen1 Lib "GDIPLUS.DLL" Alias "GdipCreatePen1" ( _
ByVal pColor As DWord, _
ByVal nWidth As Single, _
ByVal unit As Long, _
ByRef pen As DWord _
) As Long
Declare Function GdipDrawRectangle Lib "GDIPLUS.DLL" Alias "GdipDrawRectangle" ( _
ByVal graphics As DWord, _
ByVal pen As DWord, _
ByVal x As Single, _
ByVal y As Single, _
ByVal nWidth As Single, _
ByVal nHeight As Single _
) As Long
Declare Function GdipDeleteBrush Lib "GDIPLUS.DLL" Alias "GdipDeleteBrush" ( _
ByVal brush As DWord _
) As Long
Declare Function GdipDeletePen Lib "GDIPLUS.DLL" Alias "GdipDeletePen" ( _
ByVal pen As DWord _
) As Long
Declare Function GdipDeleteStringFormat Lib "GDIPLUS.DLL" Alias "GdipDeleteStringFormat" ( _
ByVal pFormat As DWord _
) As Long
Declare Function GdipDeleteGraphics Lib "GDIPLUS.DLL" Alias "GdipDeleteGraphics" ( _
ByVal graphics As DWord _
) As Long
Declare Function GdipDeleteFontFamily Lib "GDIPLUS.DLL" Alias "GdipDeleteFontFamily" ( _
ByVal fontFamily As DWord _ ' __in GpFontFamily *fontFamily
) As Long ' GpStatus
Declare Function GdipDeleteFont Lib "GDIPLUS.DLL" Alias "GdipDeleteFont" ( _
ByVal Font As DWord _ ' __in GpFont *font
) As Long ' GpStatus
'------------------> GdiPlusCreateFontFromName ---------------------------------------------------------------------------------------------------------------------->
'Function GdiPlusCreateFontFromName (ByRef wszFamilyName As String, ByVal emSize As Single, ByVal lStyle As Long, ByVal unit As DWord, ByRef pFont As DWord) As Long
' Local hStatus As Long
' Local pFontFamily As DWord
' hStatus = GdipCreateFontFamilyFromName(ByVal StrPtr(wszFamilyName), %NULL, ByVal StrPtr(pFontFamily) )
' If hStatus = %StatusOk And pFontFamily <> %NULL Then
' hStatus = GdipCreateFont(pFontFamily, emSize, lStyle, unit, ByVal StrPtr(pFont))
' GdipDeleteFontFamily(pFontFamily)
' End If
' Function = hStatus
'
'End Function
' ========================================================================================
c) thanks petr for his help and patience too 
Reply With Quote
now example is running fine. I've changed all wrong strptr into varptr where needed and b) corrected Type RectF udt's into singles (that's what I didn't expected there could be a bigger problem!)
Originally Posted by José Roca
