Gdi+

[jj2007]

Currently playing with GdiPlus - interesting, but very difficult to debug. If a parameter is, ehm, slightly off, the API throws an exception, and Win7-64 has the bad habit to "handle" them internally, meaning the debugger doesn't catch them. A typical Microsoft "feature"

[Aurel]

HI jj
did you ever try xBLite GDi+ graphics..
download and unpack to C then find XSed editor and look into gdiPlus folder

[Aurel]

for example this one called polarClock:

Code: [Select]

PROGRAM "polarclock"
VERSION "0.0001"

IMPORT "xst"
IMPORT  "xsx"
IMPORT "gdi32"
IMPORT  "user32"
IMPORT  "kernel32"
IMPORT  "gdiplus"

TYPE PDATA
XLONG .color
SINGLE .value
END TYPE

TYPE XYWH
  SINGLE .x
  SINGLE .y
  SINGLE .w
  SINGLE .h
END TYPE


DECLARE FUNCTION Entry            ()
DECLARE FUNCTION WndProc          (hwnd, msg, wParam, lParam)
DECLARE FUNCTION InitGui          ()
DECLARE FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu$)
DECLARE FUNCTION CreateWindows    ()
DECLARE FUNCTION NewWindow        (className$, titleBar$, style, x, y, w, h, exStyle)
DECLARE FUNCTION MessageLoop      ()
DECLARE FUNCTION CleanUp          ()
DECLARE FUNCTION OnPaint          (hdc)
DECLARE FUNCTION ARGB             (UBYTE alpha, UBYTE r, UBYTE g, UBYTE b)

DECLARE FUNCTION CreateScreenBuffer (hWnd, w, h)
DECLARE FUNCTION DeleteScreenBuffer (hMemDC)
DECLARE FUNCTION ClearScreenBuffer (hdcMem)

DECLARE FUNCTION DaysInMonth      (yyyy, month)
DECLARE FUNCTION LengthOfYear     (yyyy)

DECLARE FUNCTION UCODE$           (s$)
'
'
'
' ######################
' #####  Entry ()  #####
' ######################
'
FUNCTION Entry ()

STATIC entry
'
IF entry THEN RETURN ' enter once
entry =  $$TRUE ' enter occured

InitGui () ' initialize program and libraries
IF CreateWindows () THEN QUIT (0) ' create windows and other child controls
MessageLoop () ' the main message loop
CleanUp () ' unregister all window classes

END FUNCTION
'
'
' ########################
' #####  WndProc ()  #####
' ########################
'
FUNCTION WndProc (hWnd, msg, wParam, lParam)

STATIC hdcMem
RECT rc

SELECT CASE msg

CASE $$WM_CREATE :
GetClientRect (hWnd, &rc)
hdcMem = CreateScreenBuffer (hWnd, rc.right, rc.bottom)
InvalidateRect (hWnd, NULL, 1)
SetTimer (hWnd, 1, 60, 0) ' set timer id 1, 60 ms time-out

CASE $$WM_DESTROY :
DeleteScreenBuffer (hdcMem)
KillTimer (hWnd, 1)
PostQuitMessage(0)

CASE $$WM_TIMER :
hdc = GetDC (hWnd)
GetClientRect (hWnd, &rc)
ClearScreenBuffer (hdcMem)
OnPaint (hdcMem)
BitBlt (hdc, 0, 0, rc.right, rc.bottom, hdcMem, 0, 0, $$SRCCOPY)
ReleaseDC (hWnd, hdc)

CASE ELSE :
RETURN DefWindowProcA (hWnd, msg, wParam, lParam)

END SELECT

END FUNCTION
'
'
' ########################
' #####  InitGui ()  #####
' ########################
'
FUNCTION InitGui ()

SHARED hInst
SHARED gdiPlusToken
GdiplusStartupInput gsi

hInst = GetModuleHandleA (0) ' get current instance handle
IFZ hInst THEN QUIT (0)

' initialize gdiplus
gsi.GdiplusVersion = 1
err = GdiplusStartup (&gdiPlusToken, &gsi, NULL)
IF err THEN
err$ = "GdiplusStartup error: " + STRING(err)
MessageBoxA (0, &err$, &"Gdiplus error", $$MB_OK | $$MB_ICONWARNING)
QUIT (0)
END IF

END FUNCTION
'
'
' #################################
' #####  RegisterWinClass ()  #####
' #################################
'
FUNCTION RegisterWinClass (className$, addrWndProc, icon$, menu$)

SHARED hInst
WNDCLASS wc

wc.style           = $$CS_HREDRAW | $$CS_VREDRAW | $$CS_OWNDC
wc.lpfnWndProc     = addrWndProc
wc.cbClsExtra      = 0
wc.cbWndExtra      = 0
wc.hInstance       = hInst
wc.hIcon           = LoadIconA (hInst, &icon$)
wc.hCursor         = LoadCursorA (0, $$IDC_ARROW)
wc.hbrBackground   = GetStockObject ($$BLACK_BRUSH)
wc.lpszMenuName    = &menu$
wc.lpszClassName   = &className$

IFZ RegisterClassA (&wc) THEN RETURN ($$TRUE)

END FUNCTION
'
'
' ##############################
' #####  CreateWindows ()  #####
' ##############################
'
FUNCTION CreateWindows ()

' register window class
className$  = "PolarClock"
addrWndProc = &WndProc()
icon$ = "scrabble"
menu$ = ""
IF RegisterWinClass (@className$, addrWndProc, @icon$, @menu$) THEN RETURN ($$TRUE)

' create main window
titleBar$ = "Polar Clock Demo"
style = $$WS_OVERLAPPEDWINDOW
w = 480
h = 480
exStyle = 0
#winMain = NewWindow (@className$, @titleBar$, style, x, y, w, h, exStyle)
IFZ #winMain THEN RETURN ($$TRUE)

XstCenterWindow (#winMain) ' center window position
ShowWindow (#winMain, $$SW_SHOWNORMAL) ' show window

END FUNCTION
'
'
' ##########################
' #####  NewWindow ()  #####
' ##########################
'
FUNCTION NewWindow (className$, titleBar$, style, x, y, w, h, exStyle)

SHARED hInst

RETURN CreateWindowExA (exStyle, &className$, &titleBar$, style, x, y, w, h, 0, 0, hInst, 0)

END FUNCTION

'
' ############################
' #####  MessageLoop ()  #####
' ############################
'
FUNCTION MessageLoop ()

MSG msg

' main message loop

IF LIBRARY(0) THEN RETURN ' main program executes message loop

DO ' the message loop
ret = GetMessageA (&msg, NULL, 0, 0) ' retrieve next message from queue

SELECT CASE ret
CASE  0 : RETURN msg.wParam ' WM_QUIT message
CASE -1 : RETURN $$TRUE ' error
CASE ELSE:
hwnd = GetActiveWindow ()
IF (!IsWindow (hwnd)) || (!IsDialogMessageA (hwnd, &msg)) THEN ' send only non-dialog messages
  TranslateMessage (&msg) ' translate virtual-key messages into character messages
  DispatchMessageA (&msg) ' send message to window callback function WndProc()
END IF
END SELECT
LOOP

END FUNCTION
'
'
' ########################
' #####  CleanUp ()  #####
' ########################
'
FUNCTION CleanUp ()

SHARED hInst, className$
SHARED gdiPlusToken

UnregisterClassA (&className$, hInst)
GdiplusShutdown (gdiplusToken)

END FUNCTION
'
' #####################
' #####  OnPaint  #####
' #####################
'
' Paint window
'
FUNCTION OnPaint (hdc)

PDATA pd[]
RECT rc
SINGLE sec, min, hr, wd, date, mo
XYWH r

DIM pd[5]

GdipCreateFromHDC (hdc, &GraphicObject)

' set anti-alias graphics
  GdipSetSmoothingMode (GraphicObject, $$SmoothingModeAntiAlias)

w = 300
h = 300
x = 75
y = 75
offset = 24

XstGetLocalDateAndTime (@year, @month, @day, @weekDay, @hour, @minute, @second, @nanos)
' ? month, day, weekDay, hour, minute, second, nanos/1000000000.0
sec = (second + (nanos/1000000000.0))/60.0
min = (minute + sec)/60.0
hr  = (hour + min)/24.0

wd   = (weekDay + hr)/7.0
date = (day - 1 + hr)/SINGLE(DaysInMonth(year, month))
mo   = (month - 1 + date)/12.0

pd[0].value = sec
pd[1].value = min
pd[2].value = hr
pd[3].value = wd
pd[4].value = date
pd[5].value = mo

pd[0].color = ARGB (255, 255, 0, 0)
pd[1].color = ARGB (255, 255, 255, 255)
pd[2].color = ARGB (255, 255, 0, 0)
pd[3].color = ARGB (255, 255, 255, 255)
pd[4].color = ARGB (255, 255, 0, 0)
pd[5].color = ARGB (255, 255, 255, 255)

' draw arcs
FOR i = 0 TO 5
GdipCreatePen1 (pd[i].color, 20.0, $$UnitPixel, &p1)
GdipSetPenEndCap (p1, $$LineCapTriangle)
GdipSetPenStartCap (p1, $$LineCapFlat)
GdipDrawArcI (GraphicObject, p1, x, y, w, h, 270.0, pd[i].value * 360.0)
GdipDeletePen (p1)
x = x + offset
y = y + offset
w = w - offset - offset
h = h - offset - offset
NEXT i

' create font family object
  fontname$ = UCODE$ ("ARIAL")
  GdipCreateFontFamilyFromName (&fontname$, NULL, &FontFamily)

' create font object
  GdipCreateFont (FontFamily, 14.0, $$FontStyleBold, $$UnitPixel, &Fontobject)

' create string format object
hStatus = GdipCreateStringFormat (0, $$LANG_NEUTRAL, &pFormat)
hStatus = GdipSetStringFormatAlign (pFormat, $$StringAlignmentCenter)

' create brush object
  GdipCreateSolidFill (ARGB (255, 255, 255, 255), &BrushObject)
GdipCreateSolidFill (ARGB (255, 255, 0, 0), &BrushObject1)

' set rectangle to draw text
  r.x = 178.0
  r.y = 67.0
  r.w = 100.0
  r.h = 100.0

' second label
  text$ = UCODE$ (RIGHT$("0" + STRING$(second), 2) + " sec")
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject)

r.y = r.y + offset

' minute label
  text$ = UCODE$ (RIGHT$("0" + STRING$(minute), 2) + " min")
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject1)

r.y = r.y + offset

' hour label
  text$ = UCODE$ (RIGHT$("0" + STRING$(hour), 2) + " hrs")
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject)

r.y = r.y + offset
r.x = 190

' weekday label
SELECT CASE weekDay
CASE 0 : text$ = "sun"
CASE 1 : text$ = "mon"
CASE 2 : text$ = "tue"
CASE 3 : text$ = "wed"
CASE 4 : text$ = "thu"
CASE 5 : text$ = "fri"
CASE 6 : text$ = "sat"
END SELECT

text$ = UCODE$ (text$ + "   ")
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject1)

r.y = r.y + offset
r.x = 178

' day of month label
  text$ = UCODE$ (RIGHT$("0" + STRING$(day), 2) + " day")
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject)

r.y = r.y + offset
r.x = 190

' month label
SELECT CASE month
CASE 1 : text$ = "jan"
CASE 2 : text$ = "feb"
CASE 3 : text$ = "mar"
CASE 4 : text$ = "apr"
CASE 5 : text$ = "may"
CASE 6 : text$ = "jun"
CASE 7 : text$ = "jul"
CASE 8 : text$ = "aug"
CASE 9 : text$ = "sep"
CASE 10 : text$ = "oct"
CASE 11 : text$ = "nov"
CASE 12 : text$ = "dec"
END SELECT

  text$ = UCODE$ (text$)
  GdipDrawString (GraphicObject, &text$, -1, Fontobject, &r, pFormat, BrushObject1)

  GdipDeleteFontFamily (FontFamily)
  GdipDeleteFont (Fontobject)
  GdipDeleteBrush (BrushObject)
GdipDeleteBrush (BrushObject1)
GdipDeleteStringFormat(pFormat)

  GdipDeleteGraphics (GraphicObject)

END FUNCTION
'
' ##################
' #####  ARGB  #####
' ##################
'
' Return 32-bit color value form argb values
'
FUNCTION ARGB (UBYTE alpha, UBYTE r, UBYTE g, UBYTE b)

RETURN alpha << 24 + r << 16 + g << 8 + b

END FUNCTION

FUNCTION DaysInMonth (yyyy, month)
' return the length of the month

SELECT CASE month
CASE 1 : RETURN 31
CASE 2 : IF LengthOfYear (yyyy) == 365 THEN RETURN 28 ELSE RETURN 29
CASE 3 : RETURN 31
CASE 4 : RETURN 30
CASE 5 : RETURN 31
CASE 6 : RETURN 30
CASE 7 : RETURN 31
CASE 8 : RETURN 31
CASE 9 : RETURN 30
CASE 10: RETURN 31
CASE 11: RETURN 30
CASE 12: RETURN 31

END SELECT
END FUNCTION

FUNCTION LengthOfYear (yyyy)

' Takes into account 1900 not being leap year and 2000 being leap year
IF (((yyyy) MOD 400 == 0 || ((yyyy) MOD 100 != 0 && (yyyy) MOD 4 == 0))) THEN
RETURN 366
ELSE
RETURN 365
END IF

END FUNCTION

'
'
' ###################################
' #####  CreateScreenBuffer ()  #####
' ###################################
'
FUNCTION  CreateScreenBuffer (hWnd, w, h)

hDC = GetDC (hWnd)
memDC = CreateCompatibleDC (hDC)
hBit = CreateCompatibleBitmap (hDC, w, h)
SelectObject (memDC, hBit)
hBrush = GetStockObject ($$BLACK_BRUSH)
SelectObject (memDC, hBrush)
PatBlt (memDC, 0, 0, w, h, $$PATCOPY)
ReleaseDC (hWnd, hDC)
RETURN memDC

END FUNCTION
'
'
' ###################################
' #####  DeleteScreenBuffer ()  #####
' ###################################
'
FUNCTION  DeleteScreenBuffer (hMemDC)

hBmp = GetCurrentObject (hMemDC, $$OBJ_BITMAP)
DeleteObject (hBmp)
DeleteDC (hMemDC)

END FUNCTION
'
'
' ##################################
' #####  ClearScreenBuffer ()  #####
' ##################################
'
FUNCTION  ClearScreenBuffer (hdcMem)

BITMAP bm

IFZ hdcMem THEN RETURN ($$TRUE)
hImage = GetCurrentObject (hdcMem, $$OBJ_BITMAP)
IFZ hImage THEN RETURN ($$TRUE)

GetObjectA (hImage, SIZE(bm), &bm)
w = bm.width
h = bm.height

hBrush = GetStockObject ($$BLACK_BRUSH)
lastBrush = SelectObject (hdcMem, hBrush)
PatBlt (hdcMem, 0, 0, w, h, $$PATCOPY)
SelectObject (hdcMem, lastBrush)

END FUNCTION

FUNCTION UCODE$ (s$)

  textSizeW = LEN(s$)*2 + 2
  sw$ = NULL$(textSizeW)
  MultiByteToWideChar ($$CP_ACP, 0, &s$, -1, &sw$, textSizeW)

RETURN sw$
END FUNCTION
END PROGRAM


[jj2007]

Looks nice, Aurel, but not very "BASIC" ;-)

I will have to find out about GdipDrawArc. That is still lacking in my interface.

[Aurel]

Well xBlite is not stated as BASIC dialect but have elements of basic becuase is based on XBasic.

is this basic:
DO                                                         ' the message loop
      ret = GetMessageA (&msg, NULL, 0, 0)   ' retrieve next message from queue

      SELECT CASE ret
         CASE  0 : RETURN msg.wParam               ' WM_QUIT message
         CASE -1 : RETURN $$TRUE                     ' error
         CASE ELSE:
            hwnd = GetActiveWindow ()
            IF (!IsWindow (hwnd)) || (!IsDialogMessageA (hwnd, &msg)) THEN      ' send only non-dialog messages
              TranslateMessage (&msg)               ' translate virtual-key messages into character messages
              DispatchMessageA (&msg)               ' send message to window callback function WndProc()
            END IF
      END SELECT
   LOOP

[Cosmo]

Currently playing with GdiPlus

Hi jj2007

stretching doesn't correctly work. is it an own procedure?

[Cosmo]

is this basic:

sure.

[jj2007]

Currently playing with GdiPlus

Hi jj2007

stretching doesn't correctly work. is it an own procedure?

What exactly is going wrong? Which Windows version? Can you post a screenshot of the problem?

[Cosmo]

What exactly is going wrong? Which Windows version? Can you post a screenshot of the problem?

jj2007,

of course, I drive Window7
the left side is incorrect.

[Cosmo]

I will have to find out about GdipDrawArc. That is still lacking in my interface.

Hi jj2007

you mean this ARC!

Code: [Select]

include "gdip.inc"
window 640,480,1
graphics = GetBufferDC

! GdipDrawArcI   Lib "gdiplus" (sys graphics, pen, x, y, width, height, single startAngle, sweepAngle) As sys
! GdipCreatePen1 Lib "gdiplus" (sys color, single width, sys unit, pen) As sys
! GdipDeletePen  Lib "gdiplus" (sys pen) As sys
   
Antialiasing 4

int iPen
int x = 200
int y = 100
int width  = 100
int height = 200
single startAngle = 0.0
single sweepAngle = 180.0

GdipCreatePen1 ARGB(255,255,0,0), 1.0, 2, &iPen
GdipDrawArcI graphics, iPen, x, y, width, height, startAngle, sweepAngle
GdipDeletePen  iPen

waitkey 
winEnd


[jj2007]

Hi jj2007

you mean this ARC!

Yes, more or less. I have used GdipAddPathArc, but it does the same.

> the left side is incorrect.

Not really. I see the same on my Windows 7-64. It is just a test of all the functions, and when you maximise the window, the fungus moves out to the left.

[jj2007]

Here is a new version.

[Cosmo]

Here is a new version.

Cool 

jerking a bit, but isn't that bad!