2 windows 2 message loops
2 windows 2 message loops
hi,
i have the following problem:
1 window (A), created in a module (M).
(A) should process its messages independent of all other windows created outside of (M).
outside of (M) a window is created and processes its messages. it does call functions in (M).
how can i insulate the messages of (A)?
thanks
i have the following problem:
1 window (A), created in a module (M).
(A) should process its messages independent of all other windows created outside of (M).
outside of (M) a window is created and processes its messages. it does call functions in (M).
how can i insulate the messages of (A)?
thanks
Re: 2 windows 2 message loops
A has to to handle all his stuff via BindEvents
Bernd
Bernd
Re: 2 windows 2 message loops
You should NEVER have 2 event loop in one program.
Re: 2 windows 2 message loops
thanks.
is it possible to keep (A) running when an window created outside of (M) closes?
is it possible to keep (A) running when an window created outside of (M) closes?
Re: 2 windows 2 message loops
this is possible. Use CloseWindow(), and not End
Without code nobody can help....
Without code nobody can help....
Re: 2 windows 2 message loops
here is the code, i grabed it from the bgi post: (part 1)
Code: Select all
DeclareModule CanvasBgi
EnableExplicit
;DisableDebugger
#NrVideoPages = 2
#FullScr = 0
#CustScr = 1
#ClipOn = #True
#ClipOff = #False
#EmptyFill = 0
#SolidFill = 1
#LineFill = 2
#ColFill = 3
#HatchFill = 4
#SlashFill = 5
#BkSlashFill= 6
#XHatchFill = 7
#UserFill = 8
#NoFill = 9
#SolidLn = 0
#DottedLn = 1
#DashDotLn = 2
#DashedLn = 3
#DashDotDotLn = 4
#UserBitLn = 5
#NullLn = 6
#Rad = #PI/180.0
#NormWidth = 1
#DoubleWidth = 2
#TripleWidth = 3
#QuadWidth = 4
#ThickWidth = #TripleWidth
#CopyMode = 0
#XorMode = 1
#OrMode = 2
#AndMode = 3
#NotMode = 4
#NotScrMode = 5
#NotXorMode = 6
#NotOrMode = 7
#NotAndMode = 8
#InvColAndMode = 9
#InvColOrMode = 10
#InvScrAndMode = 11
#InvScrOrMode = 12
#BlackMode = 13
#WhiteMode = 14
#EmptyMode = 15
;#TRANSPARENT = 0
;#OPAQUE = 16
#BorderFlood = 0
#SurfaceFlood = 1
#NrMaxFonts = 25
#MinCharSize = 2
#LeftText = 0
#CenterText = 1
#RightText = 2
#TopText = 0
#BottomText = 1
#BaselineText = 2
#HorizDir = 0
#VertDir = 90
#CourierNewFont = 0
#MSSansSerifFont = 1
#TimesNewRomanFont= 2
#ArialFont = 3
#DefaultFont = #CourierNewFont
#ItalicFont = $1000
#UnderlineFont = $0100
#BoldFont = $0010
; Symbols for graphs
#SYMBOLRECTANGLE = 1
#SYMBOLTRIANGLE = 2
#SYMBOLDIAMOND = 3
#SYMBOLCROSS = 4
#SYMBOLXCROSS = 5
#SYMBOLNONE = 0
#CAPTUREBLT = $40000000 ; Necessary for BitBlt to get layered windows if present on screen
#NOMIRRORBITMAP = $80000000 ; Do not Mirror the bitmap in this call
Structure WINDOW
WinMaxY.i
WinMaxX.i
windowWidth.i
windowHeight.i
winNum.i
winHwnd.i
title.s
canvasnum.i
scroller.i
EndStructure
Structure GDIMAP
Hdc.i
Bitmap.i
maxX.i
maxY.i
bitPixel.i
maxColors.i
monitorWidth.i
monitorHeight.i
Pen.i
Brush.i
PenColor.i
BrushColor.i
lineStyle.i
lineThickness.i
transparentmode.b
EndStructure
Structure MEMORYIMAGE
width.i
height.i
size.i
*bits
EndStructure
Structure ViewPortType
x1.i
y1.i
x2.i
y2.i
clip.b
EndStructure
Structure ArcCoordsType
x.i
y.i
xstart.i
ystart.i
xend.i
yend.i
EndStructure
Structure FillSettingsType
pattern.i
color.i
EndStructure
Structure LineSettingsType
linestyle.i
pattern.i
thickness.i
EndStructure
Structure TextSettingsType
font.w
direction.w
charsize.w
horiz.w
vert.w
EndStructure
Structure ThreeDPointType
x.d
y.d
z.d
EndStructure
Global.GDIMAP gdi1, gdi2
Global.WINDOW gdiwin
Declare.i CreateGdiWindow(*gdiwindow.WINDOW, *NewGdiMap.GDIMAP, custWidth.i=400, custHeight.i=400, title.s="", winnum.i=0, winsize.i = #CustScr)
Declare GetRGBComponents(color.i, *r.integer, *g.integer, *b.integer, *a.integer)
Declare.i GetMaxColor()
Declare.i GetBkColor()
Declare.i GetColor()
Declare SetWriteMode(writemode.i)
Declare ResetWriteMode()
; #PS_SOLID - A continuous solid line
; #PS_DASH - A continuous line With dashed interruptions
; #PS_DOT - A line With a dot interruption at every other pixel
; #PS_DASHDOT - A combination of alternating dashed And dotted points
; #PS_DASHDOTDOT - A combination of dash And double dotted interruptions
; #PS_NULL - No visible line
; #PS_INSIDEFRAME - A line drawn just inside of the border of a closed shape
Declare SetDrawingColor(color.i, lineStyle.i=#PS_SOLID, lineThickness.i=1)
Declare SetLineSyle(lineStyle.i)
Declare SetLinePenWidth(lineThickness.i)
Declare.i GetLinePenWidth()
Declare.i GetLinePenSyle()
Declare.i GetDrawingPenColor()
Declare.i GetFillBrushColor()
Declare SetFillBrushColor(color.i)
Declare SetBackColor(color.i)
Declare SetTextColor(color.i)
Declare SetColor(color.i)
Declare SetTransparentMode()
Declare MoveTo(x.i,y.i)
Declare Bar(x1.i,y1.i,x2.i,y2.i)
Declare SetActivePage(page.i)
Declare SetVisualPage(page.i)
Declare SetAspectRatio(xasp.i, yasp.i)
Declare GetAspectRatio(*xasp.integer, *yasp.integer)
Declare.i GetMaxX()
Declare.i GetMaxY()
Declare GetViewSettings(*viewportt.ViewPortType);
Declare GetViewPort(*viewportt.ViewPortType);
Declare.i GetXX()
Declare.i GetYY()
Declare SetFillStyle(pattern.i, color.i)
Declare SetFillPattern(Array fillpattern.b(1), color.i)
Declare ClearViewPort()
Declare SetViewPort(x1.i, y1.i, x2.i, y2.i, clip.b)
Declare ClearDevice()
Declare Ellipsee(x.i,y.i,start.i,stop.i,xradius.i,yradius.i)
Declare Arc(x.i,y.i,start.i,stop.i,radius.i)
Declare Circlee(x.i,y.i,radius.i)
Declare DrawBezier(nrpoints.i, Array polypoints.POINT(1))
Declare FillPoly(nrpoints.i, Array polypoints.POINT(1))
Declare DrawPoly(nrpoints.i, Array polypoints.POINT(1))
Declare GetArcCoords(*arccoords.ArcCoordsType)
Declare GetLineSettings(*lineinfo.LineSettingsType)
Declare PutPixel(x.i,y.i,color.i)
Declare.i GetPixel(x.i, y.i)
Declare FillRect(x1.i,y1.i,x2.i,y2.i)
Declare Bar3D(x1.i,y1.i,x2.i,y2.i, depth.i, top.i)
Declare Chord(x.i,y.i,start.i,stop.i,xradius.i,yradius.i)
Declare Rectangle(x1.l,y1.l,x2.l,y2.l)
Declare FloodFill(x.i,y.i,color.i)
Declare LineProc(x.i,y.i,param.i)
Declare LineTo(x.i,y.i)
Declare Linee(x1.i,y1.i,x2.i,y2.i)
Declare LineRel(dx.i,dy.i)
Declare MoveRel(dx.i,dy.i)
Declare FillEllipse(x.l,y.l,xradius.i,yradius.i)
Declare RotEllipse(x.i,y.i,rot.i,xradius.i,yradius.i)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotSymbol(X.d,Y.d, Symbol.i, SymSize.i, color.i=-1)
Declare CalcAnglePoint(x1.d, y1.d, distance.d, angle.d, *endX.double, *endY.double)
Declare GetFillPattern(Array *fillpatternn.byte(1))
Declare GetFillSettings(*fillinfo.FillSettingsType)
#SNone = 0
#SArrow = 1
#SBox = 2
#SCircle= 3
#SLine = 4
#SDLine = 5
#SDCross= 6
Declare LineCaped(x1.i, y1.i, x2.i, y2.i, left.i=#SNone, right.i=#SNone, filledl.i=#False, filledr.i=#False)
Declare SetLineStyle(linestyle.i,pattern.i,thickness.i)
Declare InvertRect(x1.i,y1.i,x2.i,y2.i)
Declare Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Declare PieSlice(x.i,y.i,start.i,stop.i,radius.i)
Declare RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
Declare SetFloodMode(floodmode.l)
Declare GetTextSettings(*textinfo.TextSettingsType)
Declare SetLineWidth(thickness.i)
Declare SetLinePattern(pattern.i)
Declare SetStyleLine(linestyle.i)
Declare GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer)
Declare.i EnumFontFamProc(*lpelf.LOGFONT, *lpntm.NEWTEXTMETRIC, FontType.l, param.i) ;:LPARAM
Declare.i InstallUserFont(fontname.s)
Declare InstallDefaultFonts()
Declare OutText(textstring.s)
Declare OutTextXY(x.i,y.i,textstring.s)
Declare SetTextJustify(horiz.i, vert.i)
Declare SetTextStyle(font.i,direction.l,charsize.l)
Declare SetTextFontSize(charsize.i)
Declare SetTextFont(font.i)
Declare SetTextDirection(direction.i)
Declare SetUserCharSize(nCharExtra.i,nBreakExtra.i);,dummy1.i,dummy2.i)
Declare.i TextHeightt(textstring.s)
Declare.i TextWidthh(textstring.s)
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Declare PlotSymbol1(X.d,Y.d, Symbol.i, SymSize.i, color.i=-1)
Declare DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
Declare THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Declare GetDrawingWindowRectangle(*xy.RECT, wsthickframe.b)
Declare.b PointInDrawingWindowRectangle(x.i,y.i,*xy.RECT,wsthickframe.b)
Declare BitmapToImage(bitmap.i, imagetobefilled.i)
Declare GetImage(x1.i,y1.i,x2.i,y2.i,*bmp.BITMAP)
; #CopyMode = 0
; #XorMode = 1
; #OrMode = 2
; #AndMode = 3
; #NotMode = 4
; #NotScrMode = 5
; #NotXorMode = 6
; #NotOrMode = 7
; #NotAndMode = 8
; #InvColAndMode = 9
; #InvColOrMode = 10
; #InvScrAndMode = 11
; #InvScrOrMode = 12
; #BlackMode = 13
; #WhiteMode = 14
; #EmptyMode = 15
; #TRANSPARENT_ = $00
; #OPAQUE_ = 16
Declare PutImage(x1.i,y1.i,*bmp.BITMAP,rop.i=#SRCAND)
Declare GetMemImage(x1.i,y1.i,x2.i,y2.i,*bitmap.MEMORYIMAGE)
Declare PutMemImage(x1.i,y1.i,*bitmap.MEMORYIMAGE, rop.i=#SRCAND)
Declare.i ImageSize(x1.i,y1.i,x2.i,y2.i,bitsize.i)
Declare.i MemoryImageSize(x1.i,y1.i,x2.i,y2.i,bitsize.i)
Declare UpdateBgi(winnum.i)
Declare BgiStartup(winsizex, winsizey, wintitle.s, bitsizex.i, bitsizey.i, parentwinnum.i=0)
Declare.i IsBgiWindowOpen()
EndDeclareModule
Module CanvasBgi
UseJPEGImageDecoder()
Global.i Event, Thread
Global viewPort.ViewPortType,grClip.i=#Null
Global.i viewPortWidth,viewPortHeight,origX,origY,actX,actY,aspX=10000,aspY=10000,frColor,bkColor
Global.i grDirect=#True,activePage=0,visualPage
Global.i defAspectRatio, globalTemp = 0, floodMode, grFont, old_Font
Global.i grPattern ;HBITMAP
Global.FillSettingsType fillSettings
Global.ArcCoordsType lastArcCoords
Global.LineSettingsType lineSettings
Global.TextSettingsType textSettings
Global.i grPen,old_Pen ;HPEN
Global.i grBrush,old_Brush ;HBRUSH
Global Dim fillPattern.b(8)
Global Dim instFont.s(#NrMaxFonts-1)
Global.GDIMAP grMemory
Procedure.b LOBYTE(w.w)
ProcedureReturn w & $0FF
EndProcedure
Procedure.b HIBYTE(w.w)
ProcedureReturn (w >> 8) & $0FF
EndProcedure
Procedure.w LOWORD(l.l)
ProcedureReturn l & $0FFFF
EndProcedure
Procedure.w HIWORD(l.l)
ProcedureReturn (l >> 16) & $0FFFF
EndProcedure
Procedure CreateBitmaps(*NewGdiMap.GDIMAP, xsize.i, ysize.i, bitPixel.i = 32, backGroundColor.i=#White)
Protected *pvBits, bmi.BITMAPINFO, dc.i, hBrush.i
dc = CreateDC_("DISPLAY",0,0,0)
*NewGdiMap\Hdc = CreateCompatibleDC_(0)
bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
bmi\bmiHeader\biWidth = xsize
bmi\bmiHeader\biHeight = ysize
bmi\bmiHeader\biPlanes = 1
bmi\bmiHeader\biBitCount = bitPixel
bmi\bmiHeader\biCompression = #BI_RGB
*NewGdiMap\Bitmap = CreateDIBSection_(*NewGdiMap\Hdc, bmi, #DIB_RGB_COLORS, @*pvBits, 0, 0)
SelectObject_(*NewGdiMap\Hdc, *NewGdiMap\Bitmap)
DeleteDC_(dc)
hBrush = CreateSolidBrush_(backGroundColor)
SelectObject_(*NewGdiMap\Hdc, hBrush)
Rectangle_(*NewGdiMap\Hdc, 0, 0, xsize, ysize)
DeleteObject_(hBrush)
*NewGdiMap\maxX = xsize
*NewGdiMap\maxY = ysize
*NewGdiMap\bitPixel = bitPixel
*NewGdiMap\maxColors = 1 << bitPixel
*NewGdiMap\monitorWidth = GetSystemMetrics_(#SM_CXSCREEN)
*NewGdiMap\monitorHeight = GetSystemMetrics_(#SM_CYSCREEN)
*NewGdiMap\transparentmode = #False
floodMode=#BorderFlood
FillMemory(@fillPattern(0), 8, $FF, #PB_Byte)
EndProcedure
Procedure BitmapToImage(bitmap.i, imagetobefilled.i)
StartDrawing(ImageOutput(imagetobefilled))
DrawImage(bitmap,0,0)
StopDrawing()
EndProcedure
Procedure GetRGBComponents(color.i, *r.integer, *g.integer, *b.integer, *a.integer)
*r\i=Red(color)
*g\i=Green(color)
*b\i=Blue(color)
*a\i=Alpha(color)
EndProcedure
Procedure.i GetMaxColor()
ProcedureReturn gdi1\maxColors
EndProcedure
Procedure.i GetBkColor()
ProcedureReturn bkColor
EndProcedure
Procedure.i GetColor()
ProcedureReturn frColor
EndProcedure
Procedure SetWriteMode(writemode.i)
Protected.i fnDrawMode,iBkMode
fnDrawMode=writemode % $10
iBkMode=(writemode / $10) << 4
Select fnDrawMode
Case #CopyMode : fnDrawMode = #R2_COPYPEN
Case #XorMode : fnDrawMode = #R2_XORPEN
Case #OrMode : fnDrawMode = #R2_MERGEPEN
Case #AndMode : fnDrawMode = #R2_MASKPEN
Case #NotMode : fnDrawMode = #R2_NOTCOPYPEN
Case #NotScrMode : fnDrawMode = #R2_NOT
Case #NotXorMode : fnDrawMode = #R2_NOTXORPEN
Case #NotOrMode : fnDrawMode = #R2_NOTMERGEPEN
Case #NotAndMode : fnDrawMode = #R2_NOTMASKPEN
Case #InvColAndMode: fnDrawMode = #R2_MASKNOTPEN
Case #InvColOrMode : fnDrawMode = #R2_MERGENOTPEN
Case #InvScrAndMode: fnDrawMode = #R2_MASKPENNOT
Case #InvScrOrMode : fnDrawMode = #R2_MERGEPENNOT
Case #BlackMode : fnDrawMode = #R2_BLACK
Case #WhiteMode : fnDrawMode = #R2_WHITE
Case #EmptyMode : fnDrawMode = #R2_NOP
Default
ProcedureReturn
EndSelect
Select iBkMode
Case #TRANSPARENT: iBkMode=#TRANSPARENT
Case #OPAQUE : iBkMode=#OPAQUE
Default
ProcedureReturn
EndSelect
SetROP2_(gdi1\Hdc,fnDrawMode)
SetBkMode_(gdi1\Hdc,iBkMode)
SetROP2_(gdi2\Hdc,fnDrawMode)
SetBkMode_(gdi2\Hdc,iBkMode)
GdiFlush_()
EndProcedure
Procedure ResetWriteMode()
SetWriteMode(#CopyMode | #TRANSPARENT)
EndProcedure
; #PS_SOLID - A continuous solid line
; #PS_DASH - A continuous line With dashed interruptions
; #PS_DOT - A line With a dot interruption at every other pixel
; #PS_DASHDOT - A combination of alternating dashed And dotted points
; #PS_DASHDOTDOT - A combination of dash And double dotted interruptions
; #PS_NULL - No visible line
; #PS_INSIDEFRAME - A line drawn just inside of the border of a closed shape
Procedure SetDrawingColor(color.i, lineStyle.i=#PS_SOLID, lineThickness.i=1)
;SetDCPenColor_(gdi1\Hdc, color)
DeleteObject_(gdi1\Pen)
gdi1\Pen = CreatePen_(lineStyle, lineThickness, color)
SelectObject_(gdi1\Hdc, gdi1\Pen)
gdi1\PenColor = color
gdi1\lineStyle = lineStyle
gdi1\lineThickness = lineThickness
DeleteObject_(gdi2\Pen)
gdi2\Pen = CreatePen_(lineStyle, lineThickness, color)
SelectObject_(gdi2\Hdc, gdi2\Pen)
gdi2\PenColor = color
gdi2\lineStyle = lineStyle
gdi2\lineThickness = lineThickness
EndProcedure
Procedure SetLineSyle(lineStyle.i)
DeleteObject_(gdi1\Pen)
gdi1\Pen = CreatePen_(lineStyle, gdi1\lineThickness, gdi1\PenColor)
SelectObject_(gdi1\Hdc, gdi1\Pen)
gdi1\lineStyle = lineStyle
DeleteObject_(gdi2\Pen)
gdi2\Pen = CreatePen_(lineStyle, gdi1\lineThickness, gdi2\PenColor)
SelectObject_(gdi2\Hdc, gdi2\Pen)
gdi2\lineStyle = lineStyle
EndProcedure
Procedure SetLinePenWidth(lineThickness.i)
DeleteObject_(gdi1\Pen)
gdi1\Pen = CreatePen_(gdi1\lineStyle, lineThickness, gdi1\PenColor)
SelectObject_(gdi1\Hdc, gdi1\Pen)
gdi1\lineThickness = lineThickness
DeleteObject_(gdi2\Pen)
gdi2\Pen = CreatePen_(gdi1\lineStyle, lineThickness, gdi2\PenColor)
SelectObject_(gdi2\Hdc, gdi2\Pen)
gdi2\lineThickness = lineThickness
EndProcedure
Procedure.i GetLinePenWidth()
ProcedureReturn gdi1\lineThickness
EndProcedure
Procedure.i GetLinePenSyle()
ProcedureReturn gdi1\lineStyle
EndProcedure
Procedure.i GetDrawingPenColor()
ProcedureReturn gdi1\PenColor
EndProcedure
Procedure.i GetFillBrushColor()
ProcedureReturn gdi1\BrushColor
EndProcedure
Procedure SetFillBrushColor(color.i)
DeleteObject_(gdi1\Brush)
gdi1\Brush = CreateSolidBrush_(color)
SelectObject_(gdi1\Hdc, gdi1\Brush)
gdi1\BrushColor = color
DeleteObject_(gdi2\Brush)
gdi2\Brush = CreateSolidBrush_(color)
SelectObject_(gdi2\Hdc, gdi2\Brush)
gdi2\BrushColor = color
EndProcedure
Procedure SetBackColor(color.i)
SetBkColor_(gdi1\Hdc,color)
SetBkColor_(gdi2\Hdc,color)
bkColor=color
EndProcedure
Procedure SetTextColor(color.i)
SetTextColor_(gdi1\Hdc, color)
SetTextColor_(gdi2\Hdc, color)
frColor = color
EndProcedure
Procedure SetColor(color.i)
SetTextColor_(gdi1\Hdc, color)
SetTextColor_(gdi2\Hdc, color)
frColor = color
EndProcedure
Procedure SetTransparentMode()
If gdi1\transparentmode
SetBkMode_(gdi1\Hdc, #OPAQUE)
SetBkMode_(gdi2\Hdc, #OPAQUE)
Else
SetBkMode_(gdi1\Hdc, #TRANSPARENT)
SetBkMode_(gdi2\Hdc, #TRANSPARENT)
EndIf
EndProcedure
Procedure MoveTo(x.i,y.i)
;Protected d.POINT
actX=x
actY=y
x+origX
y+origY
MoveToEx_(gdi1\Hdc,x,y,#Null)
MoveToEx_(gdi2\Hdc,x,y,#Null)
GdiFlush_()
EndProcedure
Re: 2 windows 2 message loops
part 2:
little test
Code: Select all
Procedure Bar(x1.i,y1.i,x2.i,y2.i)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
x1 + origX
y1 + origY
x2 + origX
y2 + origY
SetRect_(rc,x1,y1,x2+1,y2+1)
If grDirect
FillRect_(gdi1\Hdc,rc,grBrush)
EndIf
FillRect_(gdi2\Hdc,rc,grBrush)
GdiFlush_()
EndProcedure
Procedure SetActivePage(page.i)
If (page >= 2)
page=0
EndIf
activePage = page
;SelectObject(grMemory,grBitmap[activePage]:HGDIOBJ);
If activepage = 0
grMemory = gdi1
;CopyMemory(@gdi1, @grMemory, SizeOf(GDIMAP))
Else
grMemory = gdi2
EndIf
grDirect = Bool(activePage = visualPage)
ResizeWindow(gdiwin\winNum, #PB_Ignore,#PB_Ignore,#PB_Ignore,#PB_Ignore)
EndProcedure
Procedure SetVisualPage(page.i)
Protected *lpRect.RECT = #Null
If (page >= #NrVideoPages)
page=0
EndIf
visualPage = page
grDirect= Bool(activePage = visualPage)
InvalidateRect_(gdiwin\winHwnd,*lpRect,#False)
EndProcedure
Procedure SetAspectRatio(xasp.i, yasp.i)
aspX=xasp
aspY=yasp
defAspectRatio = Bool(Bool(xasp = 10000) And Bool(yasp = 10000))
EndProcedure
Procedure GetAspectRatio(*xasp.integer, *yasp.integer)
*xasp\i=aspX
*yasp\i=aspY
EndProcedure
Procedure.i GetMaxX()
ProcedureReturn gdi1\maxX
EndProcedure
Procedure.i GetMaxY()
ProcedureReturn gdi1\maxY
EndProcedure
Procedure GetViewSettings(*viewportt.ViewPortType);
*viewportt = viewPort
EndProcedure
Procedure GetViewPort(*viewportt.ViewPortType);
*viewportt = viewPort
EndProcedure
Procedure.i GetXX()
ProcedureReturn actX
EndProcedure
Procedure.i GetYY()
ProcedureReturn actY
EndProcedure
Procedure SetFillStyle(pattern.i, color.i)
Protected lplb.LOGBRUSH
Protected old.i
With lplb
\lbStyle=#BS_HATCHED;
\lbHatch=0;
Select pattern
Case #SolidFill : \lbStyle=#BS_SOLID
Case #EmptyFill : \lbStyle=#BS_SOLID
color=bkColor
Case #LineFill : \lbHatch=#HS_HORIZONTAL
Case #ColFill : \lbHatch=#HS_VERTICAL
Case #HatchFill : \lbHatch=#HS_CROSS
Case #SlashFill : \lbHatch=#HS_BDIAGONAL
Case #BkSlashFill: \lbHatch=#HS_FDIAGONAL
Case #XHatchFill : \lbHatch=#HS_DIAGCROSS
Case #UserFill : \lbStyle=#BS_PATTERN
\lbHatch=(grPattern)
Case #NoFill : \lbStyle=#BS_NULL
Default
ProcedureReturn
EndSelect
\lbColor=color
EndWith
fillSettings\pattern=pattern
fillSettings\color=color
grBrush=CreateBrushIndirect_(lplb)
old=SelectObject_(gdi1\Hdc,grBrush)
SelectObject_(gdi2\Hdc,grBrush)
If (old <> old_Brush)
DeleteObject_(old)
EndIf
GdiFlush_()
EndProcedure
Procedure SetFillPattern(Array fillpattern.b(1), color.i)
Protected.i i,j
Protected.i col0,col1
Protected.b b
col1 = color
col0 = bkcolor
If grPattern <> #Null
DeleteObject_(grPattern)
EndIf
grPattern = CreateCompatibleBitmap_(gdi1\Hdc,8,8)
SelectObject_(gdi1\Hdc, grPattern)
For i = 0 To 7
b = fillpattern(i+1)
For j = 7 To 0 Step -1
If (b & $01) <> 0
SetPixelV_(gdi1\Hdc,j,i,col1)
Else
SetPixelV_(gdi1\Hdc,j,i,col0)
EndIf
b = b >> 1
Next
Next
SetFillStyle(#UserFill, color)
EndProcedure
Procedure ClearViewPort()
Protected old_FillSettings.FillSettingsType;
MoveTo(0,0)
old_FillSettings=fillSettings
SetFillStyle(#SolidFill,bkColor)
Bar(0,0,viewPortWidth,viewPortHeight)
With old_FillSettings
SetFillStyle(\pattern, \color)
EndWith
GdiFlush_()
EndProcedure
Procedure IsClipping()
If grClip <> #Null
ProcedureReturn #True
EndIf
ProcedureReturn #False
EndProcedure
Procedure SetViewPort(x1.i, y1.i, x2.i, y2.i, clip.b)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
viewPort\x1=x1
viewPort\y1=y1
viewPort\x2=x2
viewPort\y2=y2
viewPort\clip=clip
viewPortWidth=x2-x1;
viewPortHeight=y2-y1;
origX=x1
origY=y1
MoveTo(0,0)
If (grClip <> #Null)
SelectClipRgn_(gdi1\Hdc,#Null)
SelectClipRgn_(gdi2\Hdc,#Null)
DeleteObject_(grClip)
grClip=#Null
EndIf
If clip
grClip=CreateRectRgn_(x1,y1,x2+1,y2+1)
SelectClipRgn_(gdi1\Hdc,grClip)
SelectClipRgn_(gdi2\Hdc,grClip)
EndIf
GdiFlush_()
EndProcedure
Procedure ClearDevice()
Protected old_ViewPort.ViewPortType
old_ViewPort = viewPort
SetViewPort(0,0, gdi1\maxX, gdi1\maxY, #ClipOff)
ClearViewPort()
With old_ViewPort
SetViewPort(\x1,\y1,\x2,\y2,\clip)
EndWith
GdiFlush_()
EndProcedure
Procedure Ellipsee(x.i,y.i,start.i,stop.i,xradius.i,yradius.i)
Protected.i nXStartArc,nYStartArc,nXEndArc,nYEndArc
lastArcCoords\x=x
lastArcCoords\y=y
x + origX
y + origY
nXStartArc=(((xradius)*Cos((start)*#Rad)))
nXEndArc=(((xradius)*Cos((stop)*#Rad)))
nYStartArc=(((yradius)*Sin((start)*#Rad)))
nYEndArc=(((yradius)*Sin((stop)*#Rad)))
If Not(defAspectRatio)
xradius=Int(10000*xradius) / aspX
yradius=Int(10000*yradius) / aspY
EndIf
If grDirect
Arc_(gdi1\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc)
EndIf
Arc_(gdi2\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXStartArc,y-nYStartArc,x+nXEndArc,y-nYEndArc)
GdiFlush_()
With lastArcCoords
\xstart=\x+nXStartArc
\ystart=\y-nYStartArc
\xend=\x+nXEndArc
\yend=\y-nYEndArc
EndWith
EndProcedure
Procedure Arc(x.i,y.i,start.i,stop.i,radius.i)
Ellipsee(x,y,start,stop,radius,radius)
EndProcedure
Procedure Circlee(x.i,y.i,radius.i)
Ellipsee(x,y,0,360,radius,radius)
EndProcedure
Procedure DrawBezier(nrpoints.i, Array polypoints.POINT(1))
If (nrpoints >= 4)
If grDirect
PolyBezier_(gdi1\Hdc,polypoints(),nrpoints)
EndIf
PolyBezier_(gdi2\Hdc,polypoints(),nrpoints);
GdiFlush_()
EndIf
EndProcedure
Procedure FillPoly(nrpoints.i, Array polypoints.POINT(1))
; If Not(grEnabled)
; ProcedureReturn
; EndIf
If (nrpoints >= 2)
If grDirect
Polygon_(gdi1\Hdc,polypoints(),nrpoints)
EndIf
Polygon_(gdi2\Hdc,polypoints(),nrpoints)
GdiFlush_()
EndIf
EndProcedure
Procedure DrawPoly(nrpoints.i, Array polypoints.POINT(1))
; If Not(grEnabled)
; ProcedureReturn
; EndIf
If nrpoints >= 2
If grDirect
Polyline_(gdi1\Hdc,polypoints(),nrpoints)
EndIf
Polyline_(gdi2\Hdc,polypoints(),nrpoints)
GdiFlush_()
EndIf
EndProcedure
Procedure GetArcCoords(*arccoords.ArcCoordsType)
*arccoords=lastArcCoords
EndProcedure
Procedure GetLineSettings(*lineinfo.LineSettingsType)
*lineinfo=lineSettings
EndProcedure
Procedure PutPixel(x.i,y.i,color.i)
x+origX
y+origY
If grDirect
SetPixelV_(gdi1\Hdc,x,y,color)
EndIf
SetPixelV_(gdi2\Hdc,x,y,color)
GdiFlush_()
EndProcedure
Procedure.i GetPixel(x.i, y.i)
ProcedureReturn GetPixel_(gdi1\Hdc,x+origX,y+origY);
EndProcedure
Procedure FillRect(x1.i,y1.i,x2.i,y2.i)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
x1+origX
y1+origY
x2+origX+1
y2+origY+1
If grDirect
Rectangle_(gdi1\Hdc,x1,y1,x2,y2)
EndIf
Rectangle_(gdi2\Hdc,x1,y1,x2,y2)
GdiFlush_()
EndProcedure
Procedure Bar3D(x1.i,y1.i,x2.i,y2.i, depth.i, top.i)
Protected Dim pt.POINT(4)
FillRect(x1,y1,x2,y2)
x1 + origX
y1 + origY
x2 + origX
y2 + origY
If top <> 0
pt(0)\x = x1: pt(0)\y = y1
pt(1)\x = x1+Int(depth): pt(1)\y = y1-Int(depth)
pt(2)\x = x2+Int(depth): pt(2)\y = y1-Int(depth)
pt(3)\x = x2: pt(3)\y = y1
If grDirect
Polyline_(gdi1\Hdc,@pt(),4)
EndIf
Polyline_(gdi2\Hdc,@pt(),4)
EndIf
If depth <> 0
pt(0)\x = x2+Int(depth): pt(0)\y = y1-Int(depth)
pt(1)\x = x2+Int(depth): pt(1)\y = y2-Int(depth)
pt(2)\x = x2: pt(2)\y = y2
If grDirect
Polyline_(gdi1\Hdc,@pt(),3)
EndIf
Polyline_(gdi2\Hdc,@pt(),3)
EndIf
GdiFlush_()
EndProcedure
Procedure Chord(x.i,y.i,start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
x + origX
y + origY
nXRadial1=(((xradius)*Cos((start)*#Rad)))
nXRadial2=(((xradius)*Cos((stop)*#Rad)))
nYRadial1=(((yradius)*Sin((start)*#Rad)))
nYRadial2=(((yradius)*Sin((stop)*#Rad)))
If Not(defAspectRatio)
xradius=10000*Int(xradius) / aspX
yradius=10000*Int(yradius) / aspY
EndIf
If grDirect
Chord_(gdi1\Hdc,x-xradius,y-yradius,x+xradius+1,y+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndIf
Chord_(gdi2\Hdc,x-xradius,y-yradius,x+xradius+1,y+yradius+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
GdiFlush_()
EndProcedure
Procedure Rectangle(x1.l,y1.l,x2.l,y2.l)
Protected Dim pt.POINT(5)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
x1 + origX
y1 + origY
x2 + origX
y2 + origY
If (x1 <> x2) Or (y1 <> y2)
pt(0)\x = x1: pt(0)\y = y1
pt(1)\x = x2: pt(1)\y = y1
pt(2)\x = x2: pt(2)\y = y2
pt(3)\x = x1: pt(3)\y = y2
pt(4)\x = x1: pt(4)\y = y1
If grDirect
Polyline_(gdi1\Hdc,@pt(),5)
EndIf
Polyline_(gdi2\Hdc,@pt(),5)
Else
PutPixel(x1,y1,frcolor)
EndIf
GdiFlush_()
EndProcedure
Procedure FloodFill(x.i,y.i,color.i)
x+origX
y+origY
If grDirect
ExtFloodFill_(gdi1\Hdc,x,y,color,floodMode)
EndIf
ExtFloodFill_(gdi2\Hdc,x,y,color,floodMode)
GdiFlush_()
EndProcedure
Procedure LineProc(x.i,y.i,param.i)
param = param >> globalTemp
If (param.i & $0001) <> 0
PutPixel(x,y,frColor)
EndIf
globalTemp = (globalTemp+1) % 16
EndProcedure
Procedure LineTo(x.i,y.i)
Protected x0.i,y0.i
x0=x
y0=y
x + origX
y + origY
With lineSettings
If (\linestyle <> #UserFill)
If grDirect
LineTo_(gdi1\Hdc,x,y)
EndIf
LineTo_(gdi2\Hdc,x,y)
If (\thickness = #NormWidth)
PutPixel(x0,y0,frColor)
EndIf
Else
globalTemp=0
LineDDA_(actX,actY,x0,y0,@LineProc(),\pattern)
EndIf
MoveTo(x0,y0)
EndWith
GdiFlush_()
EndProcedure
Procedure Linee(x1.i,y1.i,x2.i,y2.i)
MoveTo(x1,y1)
LineTo(x2,y2)
EndProcedure
Procedure LineRel(dx.i,dy.i)
LineTo(actX+dx,actY+dy)
EndProcedure
Procedure MoveRel(dx.i,dy.i)
actX+dx
actY+dy
MoveTo(actX,actY)
EndProcedure
Procedure FillEllipse(x.l,y.l,xradius.i,yradius.i)
Protected fillinfo.FillSettingsType
x + origX
y + origY
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX
yradius = Int(10000*yradius) / aspY
EndIf
If grDirect
Ellipse_(gdi1\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1)
EndIf
Ellipse_(gdi2\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1)
GdiFlush_()
EndProcedure
Procedure RotEllipse(x.i,y.i,rot.i,xradius.i,yradius.i)
Protected Dim pt.POINT(7)
Protected.d cosrot,sinrot
Protected.i x1,y1,i
xradius = Round(1.3333*xradius, #PB_Round_Nearest)
cosrot = Cos(rot*#Rad): sinrot = Sin(rot*#Rad)
pt(0)\x = 0: pt(0)\y = -Int(yradius)
pt(1)\x = xradius: pt(1)\y = -Int(yradius)
pt(2)\x = xradius: pt(2)\y = (yradius)
pt(3)\x = 0: pt(3)\y = (yradius)
pt(4)\x = -Int(xradius): pt(4)\y = (yradius)
pt(5)\x = -Int(xradius): pt(5)\y = -Int(yradius)
pt(6)\x = 0: pt(6)\y = -Int(yradius)
For i = 0 To 6
x1 = pt(i)\x: y1 = pt(i)\y ; perform rotation
pt(i)\x = x+Round( x1*cosrot+y1*sinrot, #PB_Round_Nearest)
pt(i)\y = y+Round(-x1*sinrot+y1*cosrot, #PB_Round_Nearest)
Next
DrawBezier(7, pt())
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotSymbol(X.d,Y.d, Symbol.i, SymSize.i, color.i=-1)
Protected.i del = 1
Protected.i xs,ys,delta,x1,y1
Protected.i curcol
x1 = GetXX()
y1 = GetYY()
curcol = GetColor()
If color <> -1
SetColor(color)
EndIf
xs=X : ys=Y
delta = del*SymSize;
Select Symbol
Case 1 ; plus
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
MoveRel(-delta,-delta)
LineRel(0,2*delta)
Case 2 ; box
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,0)
LineRel(0,2*delta)
LineRel(-2*delta,0)
LineRel(0,-2*delta)
Case 3 ; cross
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,2*delta)
MoveRel(-2*delta,0)
LineRel(2*delta,-2*delta)
Case 4: ; triangle
MoveTo(xs,Int(ys-delta-delta / 3))
LineRel(-delta,2*delta)
LineRel(2*delta,0)
LineRel(-delta,-2*delta)
Case 5 ; inverted triangle
MoveTo(xs,Int(ys+delta+delta / 3))
LineRel(-delta,-2*delta)
LineRel(2*delta,0)
LineRel(-delta,2*delta)
Case 6
Circlee(xs,ys,delta) ; open circle
Case 7
FillEllipse(xs,ys,delta,delta) ; closed circle
Case 8
PutPixel(xs,ys,GetMaxColor()) ; unscaled point
Default
EndSelect
MoveTo(x1,y1)
SetColor(curcol)
GdiFlush_()
EndProcedure
Procedure CalcAnglePoint(x1.d, y1.d, distance.d, angle.d, *endX.double, *endY.double)
*endX\d = x1 + distance * Sin(angle)
*endY\d = y1 + distance * Cos(angle)
EndProcedure
Procedure GetFillPattern(Array *fillpatternn.byte(1))
CopyArray(*fillPatternn(), fillpattern())
EndProcedure
Procedure GetFillSettings(*fillinfo.FillSettingsType)
CopyStructure(@fillSettings, *fillinfo, FillSettingsType)
EndProcedure
#SNone = 0
#SArrow = 1
#SBox = 2
#SCircle= 3
#SLine = 4
#SDLine = 5
#SDCross= 6
Procedure LineCaped(x1.i, y1.i, x2.i, y2.i, left.i=#SNone, right.i=#SNone, filledl.i=#False, filledr.i=#False)
Protected Dim polypoints.POINT(6)
Protected fillinfo.FillSettingsType
Protected.d rx, ry, dist
Protected.d angle, xx, yy
Protected.d xx1, yy1, xx2, yy2
Protected.d xx3, yy3, xx4, yy4
Protected.d xx5, yy5, xx6, yy6
If (x1=x2) And (y1=y2)
ProcedureReturn
EndIf
MoveTo(x1,y1)
LineTo(x2,y2)
rx=((x1-x2)*50) / (x1 + (x2 - x1))
ry=((y1-y2)*50) / (y1 + (y2 - y1))
dist = Pow(((x2+(rx-(ry * 0.5))*(1/3)) - (x2+(rx+(ry * 0.5))*(1/3))), 2)
dist + Pow((y2+((rx * 0.5)+ry)*(1/3)) - (y2+(-(rx * 0.5)+ry)*(1/3)), 2)
dist = Round(Sqr(dist), #PB_Round_Nearest) / 2
angle=ATan2(y2 - y1, x2 - x1) ; * (180 / 3.14) ;4 = pi
If (x1=x2) And (y1=y2)
ProcedureReturn
EndIf
If right <> #SNone
Select right
Case #SArrow
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2, -dist, angle, @xx, @yy)
CalcAnglePoint(x2, y2-dist, -dist, angle, @xx1, @yy1)
CalcAnglePoint(x2-1, y2+dist, -dist, angle, @xx2, @yy2)
polypoints(0)\x = xx1
polypoints(0)\y = yy1
polypoints(1)\x = xx2
polypoints(1)\y = yy2
polypoints(2)\x = x2
polypoints(2)\y = y2
polypoints(3)\x = xx1
polypoints(3)\y = yy1
SetFillStyle(#SolidFill, frColor)
If filledr
FillPoly(4, polypoints())
Else
DrawPoly(4, polypoints())
EndIf
Case #SBox
CalcAnglePoint(x2, y2, -dist, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx4, @yy4)
polypoints(0)\x = xx1
polypoints(0)\y = yy1
polypoints(1)\x = xx2
polypoints(1)\y = yy2
polypoints(2)\x = xx2
polypoints(2)\y = yy2
polypoints(3)\x = xx4
polypoints(3)\y = yy4
polypoints(4)\x = xx3
polypoints(4)\y = yy3
polypoints(5)\x = xx1
polypoints(5)\y = yy1
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, frColor)
If filledr
FillPoly(6, polypoints())
Else
DrawPoly(6, polypoints())
EndIf
Case #SCircle
CalcAnglePoint(x2, y2, -dist, angle, @xx, @yy)
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, frColor)
If filledr
FillPoly(6, polypoints())
FillEllipse(xx,yy,dist,dist)
Else
PlotSymbol(xx, yy, 6, dist)
EndIf
Case #SLine
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
MoveTo(xx1, yy1)
LineTo(xx2, yy2)
Case #SDLine
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2, -1, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx4, @yy4)
MoveTo(xx1, yy1)
LineTo(xx2, yy2)
MoveTo(xx3, yy3)
LineTo(xx4, yy4)
Case #SDCross
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2, -1, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx4, @yy4)
MoveTo(x2-dist,y2-dist)
LineRel(2*dist,2*dist)
MoveRel(-2*dist,0)
LineRel(2*dist,-2*dist)
EndSelect
EndIf
If left <> #SNone
Swap x1,x2 : Swap y1,y2
Select left
Case #SArrow
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2, dist, angle, @xx, @yy)
CalcAnglePoint(x2, y2-dist, dist, angle, @xx1, @yy1)
CalcAnglePoint(x2-1, y2+dist, dist, angle, @xx2, @yy2)
polypoints(0)\x = xx1
polypoints(0)\y = yy1
polypoints(1)\x = xx2
polypoints(1)\y = yy2
polypoints(2)\x = x2
polypoints(2)\y = y2
polypoints(3)\x = xx1
polypoints(3)\y = yy1
SetFillStyle(#SolidFill, frColor)
If filledl
FillPoly(4, polypoints())
Else
DrawPoly(4, polypoints())
EndIf
Case #SBox
CalcAnglePoint(x2, y2, dist, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx4, @yy4)
polypoints(0)\x = xx1
polypoints(0)\y = yy1
polypoints(1)\x = xx2
polypoints(1)\y = yy2
polypoints(2)\x = xx2
polypoints(2)\y = yy2
polypoints(3)\x = xx4
polypoints(3)\y = yy4
polypoints(4)\x = xx3
polypoints(4)\y = yy3
polypoints(5)\x = xx1
polypoints(5)\y = yy1
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, frColor)
If filledl
FillPoly(6, polypoints())
Else
DrawPoly(6, polypoints())
EndIf
Case #SCircle
CalcAnglePoint(x2, y2, dist, angle, @xx, @yy)
GetFillSettings(@fillinfo)
SetFillStyle(#SolidFill, frColor)
If filledl
FillPoly(6, polypoints())
FillEllipse(xx,yy,dist,dist)
Else
PlotSymbol(xx, yy, 6, dist)
EndIf
Case #SLine
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
MoveTo(xx1, yy1)
LineTo(xx2, yy2)
Case #SDLine
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2, 1, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx4, @yy4)
MoveTo(xx1, yy1)
LineTo(xx2, yy2)
MoveTo(xx3, yy3)
LineTo(xx4, yy4)
Case #SDCross
GetFillSettings(@fillinfo)
CalcAnglePoint(x2, y2-dist, 0, angle, @xx1, @yy1)
CalcAnglePoint(x2, y2+dist, 0, angle, @xx2, @yy2)
CalcAnglePoint(x2, y2, 1, angle, @xx, @yy)
CalcAnglePoint(xx, yy-dist, 0, angle, @xx3, @yy3)
CalcAnglePoint(xx, yy+dist, 0, angle, @xx4, @yy4)
MoveTo(x2-dist,y2-dist)
LineRel(2*dist,2*dist)
MoveRel(-2*dist,0)
LineRel(2*dist,-2*dist)
EndSelect
EndIf
SetFillStyle(fillinfo\pattern, fillinfo\color)
GdiFlush_()
EndProcedure
Procedure SetLineStyle(linestyle.i,pattern.i,thickness.i)
Protected lgpn.LOGPEN
Protected lstyle.i
Protected old.i ;HGDIOBJ
Select linestyle
Case #SolidLn : lstyle=#PS_SOLID
Case #DashedLn : lstyle=#PS_DASH
Case #DottedLn : lstyle=#PS_DOT
Case #DashDotLn : lstyle=#PS_DASHDOT
Case #DashDotDotLn : lstyle=#PS_DASHDOTDOT
Case #UserBitLn,#NullLn: lstyle=#PS_NULL
Default
ProcedureReturn
EndSelect
lineSettings\linestyle=linestyle
lineSettings\pattern=pattern
lineSettings\thickness=thickness
With lgpn
\lopnStyle=lstyle
\lopnWidth\x=thickness
\lopnColor=frColor
EndWith
grPen=CreatePenIndirect_(lgpn)
old=SelectObject_(gdi1\Hdc,grPen)
SelectObject_(gdi2\Hdc,grPen)
If (old <> old_Pen)
DeleteObject_(old)
EndIf
GdiFlush_()
EndProcedure
Procedure InvertRect(x1.i,y1.i,x2.i,y2.i)
Protected rc.RECT
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
x1+origX
y1+origY
x2+origX
y2+origY
SetRect_(rc,x1,y1,x2+1,y2+1)
If grDirect
InvertRect_(gdi1\Hdc,rc)
EndIf
InvertRect_(gdi2\Hdc,rc)
GdiFlush_()
EndProcedure
Procedure Sector(x.l,y.l, start.i,stop.i,xradius.i,yradius.i)
Protected.i nXRadial1,nYRadial1,nXRadial2,nYRadial2
x + origX
y + origY
nXRadial1 = Round(xradius*Cos(start*#Rad), #PB_Round_Nearest)
nXRadial2 = Round(xradius*Cos(stop*#Rad), #PB_Round_Nearest)
nYRadial1 = Round(yradius*Sin(start*#Rad), #PB_Round_Nearest)
nYRadial2 = Round(yradius*Sin(stop*#Rad), #PB_Round_Nearest)
If defAspectRatio <> 0
xradius = Int(10000*xradius) / aspX : yradius = Int(10000*yradius) / aspY
EndIf
If grDirect
Pie_(gdi1\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
EndIf
Pie_(gdi2\Hdc,x-Int(xradius),y-Int(yradius),x+Int(xradius)+1,y+Int(yradius)+1,x+nXRadial1,y-nYRadial1,x+nXRadial2,y-nYRadial2)
GdiFlush_()
EndProcedure
Procedure PieSlice(x.i,y.i,start.i,stop.i,radius.i)
Sector(x,y,start,stop,radius,radius)
EndProcedure
Procedure RoundRect(x1.l,y1.l,x2.l,y2.l,r.l)
If (x1 > x2) Or (y1 > y2)
ProcedureReturn
EndIf
x1 + origX
y1 + origY
x2 + origX
y2 + origY
If grDirect
RoundRect_(gdi1\Hdc,x1,y1,x2+1,y2+1,r,r)
EndIf
RoundRect_(gdi2\Hdc,x1,y1,x2+1,y2+1,r,r)
GdiFlush_()
EndProcedure
Procedure SetFloodMode(floodmode.l)
Select floodmode
Case #BorderFlood : floodMode = #FLOODFILLBORDER
Case #SurfaceFlood: floodMode = #FLOODFILLSURFACE
EndSelect
EndProcedure
Procedure GetTextSettings(*textinfo.TextSettingsType)
*textinfo = textSettings
EndProcedure
Procedure SetLineWidth(thickness.i)
Protected lineinfo.LineSettingsType
GetLineSettings(lineinfo)
SetLineStyle(lineinfo\linestyle,lineinfo\pattern,thickness)
EndProcedure
Procedure SetLinePattern(pattern.i)
Protected lineinfo.LineSettingsType
GetLineSettings(lineinfo)
SetLineStyle(lineinfo\linestyle,pattern,lineinfo\thickness)
EndProcedure
Procedure SetStyleLine(linestyle.i)
Protected lineinfo.LineSettingsType;
GetLineSettings(lineinfo)
SetLineStyle(linestyle,lineinfo\pattern,lineinfo\thickness)
EndProcedure
Procedure GetFontSettings(fontname.s, *width.integer, *height.integer, *ttfont.integer)
Protected *lptm.TEXTMETRIC
Protected len.i
Protected x.s = Space(255), tt.s = ""
len = GetTextFace_(gdi1\Hdc,255, @x)
tt = Chr(len-1) + Space(255)
GetTextFace_(gdi1\Hdc,255, @tt)
GetTextMetrics_(gdi1\Hdc, *lptm)
With *lptm
*width = \tmMaxCharWidth
*height = \tmHeight
*ttfont = Bool((\tmPitchAndFamily & #TMPF_TRUETYPE) <> 0)
EndWith
GdiFlush_()
EndProcedure
Procedure.i EnumFontFamProc(*lpelf.LOGFONT, *lpntm.NEWTEXTMETRIC, FontType.l, param.i) ;:LPARAM
globalTemp = 1 ; we got here IF at least one font from the family font exists
ProcedureReturn 0
EndProcedure
Procedure.i InstallUserFont(fontname.s)
Protected.i i, Result=-1
Protected famName.s = ""
famName = fontname
globalTemp = 0
EnumFontFamilies_(gdi1\Hdc,@famName,@EnumFontFamProc(),0)
If globalTemp = 1
For i = 0 To #NrMaxFonts-1
If instFont(i) = ""
instFont(i) = fontname
Result = i
Break
EndIf
Next
EndIf
ProcedureReturn Result
EndProcedure
#NrDefFonts = 4
Procedure InstallDefaultFonts()
Protected Dim DefaultFont.s(#NrDefFonts-1)
Protected i.i
DefaultFont(0) = "Courier New"
DefaultFont(1) = "MS Sans Serif"
DefaultFont(2) = "Times New Roman"
DefaultFont(3) = "Arial"
For i = 0 To #NrMaxFonts-1
instFont(i) = ""
Next
For i=0 To #NrDefFonts-1
InstallUserFont(DefaultFont(i))
Next
EndProcedure
Procedure OutText(textstring.s)
Protected lpPoint.POINT
Protected len.i
len = Len(textstring)
If grDirect
TextOut_(gdi1\Hdc,0,0,textstring,len)
EndIf
TextOut_(gdi2\Hdc,0,0,textstring,len)
GetCurrentPositionEx_(gdi2\Hdc,lpPoint)
MoveTo(lpPoint\x-origX,lpPoint\y-origY)
GdiFlush_()
EndProcedure
Procedure OutTextXY(x.i,y.i,textstring.s)
Protected lpPoint.POINT
Protected len.i
len = Len(textstring)
If grDirect
TextOut_(gdi1\Hdc,x,y,textstring,len)
EndIf
TextOut_(gdi2\Hdc,x,y,textstring,len)
GetCurrentPositionEx_(gdi2\Hdc, @lpPoint)
MoveTo(lpPoint\x-origX,lpPoint\y-origY)
GdiFlush_()
EndProcedure
Procedure SetTextJustify(horiz.i, vert.i)
Protected.i htext,vtext
Select horiz
Case #LeftText : htext = #TA_LEFT
Case #CenterText: htext = #TA_CENTER
Case #RightText : htext = #TA_RIGHT
Default
ProcedureReturn
EndSelect
Select vert
Case #TopText : vtext = #TA_TOP
Case #BottomText : vtext = #TA_BOTTOM
Case #BaselineText: vtext = #TA_BASELINE
Default
ProcedureReturn
EndSelect
textSettings\horiz = horiz
textSettings\vert = vert
SetTextAlign_(gdi1\Hdc,htext | vtext | #TA_UPDATECP)
SetTextAlign_(gdi2\Hdc,htext | vtext | #TA_UPDATECP)
GdiFlush_()
EndProcedure
Procedure SetTextStyle(font.i,direction.l,charsize.l)
Protected.b loByte,hiByte
Protected.b nrfont
Protected fontname.s = ""
Protected lplf.LOGFONT
Protected old.i
loByte = LOBYTE(LOWORD(font))
hiByte = HIBYTE(HIWORD(font))
nrfont = loByte % $10
If (nrfont>=0) And (nrfont <= #NrMaxFonts-1)
fontname = instFont(nrfont)
Else
fontname = ""
EndIf
If fontname <> ""
textSettings\font = font
textSettings\direction = direction
textSettings\charsize = charsize
If charsize <= #MinCharSize
charsize = charsize + #MinCharSize
EndIf
lplf\lfHeight = charsize
lplf\lfWidth = 0
lplf\lfEscapement = 10 * direction
lplf\lfOrientation = 10 * direction
lplf\lfItalic = #False
lplf\lfWeight = (#FW_BOLD - #FW_NORMAL) * (loByte / $10) + #FW_NORMAL
If (hiByte / $10) > 0
lplf\lfItalic = 1
EndIf
lplf\lfUnderline = 0
If (hiByte / $10) > 0
lplf\lfUnderline = 1
EndIf
lplf\lfStrikeOut = 0
lplf\lfCharSet = #DEFAULT_CHARSET
lplf\lfOutPrecision = #OUT_DEFAULT_PRECIS
lplf\lfClipPrecision = #CLIP_DEFAULT_PRECIS
lplf\lfQuality = #DEFAULT_QUALITY
lplf\lfPitchAndFamily = #DEFAULT_PITCH | #FF_DONTCARE
PokeS(@lplf\lfFaceName[0], fontname)
grFont = CreateFontIndirect_(@lplf)
old=SelectObject_(gdi1\Hdc, grFont)
SelectObject_(gdi2\Hdc, grFont)
If (old <> old_Font)
DeleteObject_(old)
EndIf
GdiFlush_()
EndIf
EndProcedure
Procedure SetTextFontSize(charsize.i)
Protected textinfo.TextSettingsType
GetTextSettings(textinfo)
SetTextStyle(textinfo\font,textinfo\direction,charsize)
EndProcedure
Procedure SetTextFont(font.i)
Protected textinfo.TextSettingsType
GetTextSettings(textinfo)
SetTextStyle(font,textinfo\direction,textinfo\charsize)
EndProcedure
Procedure SetTextDirection(direction.i)
Protected textinfo.TextSettingsType
GetTextSettings(textinfo)
SetTextStyle(textinfo\font,direction,textinfo\charsize)
EndProcedure
Procedure SetUserCharSize(nCharExtra.i,nBreakExtra.i);,dummy1.i,dummy2.i)
SetTextCharacterExtra_(gdi1\Hdc,nCharExtra)
SetTextCharacterExtra_(gdi2\Hdc,nCharExtra)
SetTextJustification_(gdi1\Hdc,nBreakExtra,1)
SetTextJustification_(gdi2\Hdc,nBreakExtra,1)
GdiFlush_()
EndProcedure
Procedure.i TextHeightt(textstring.s)
Protected lpSize.SIZE
Protected len.i
len=Len(textstring)
GetTextExtentPoint32_(gdi1\Hdc,textstring,len,lpSize);
GdiFlush_()
ProcedureReturn lpSize\cy
EndProcedure
Procedure.i TextWidthh(textstring.s)
Protected lpSize.SIZE
Protected len.i
len=Len(textstring)
GetTextExtentPoint32_(gdi1\Hdc,textstring,len,lpSize)
GdiFlush_()
ProcedureReturn lpSize\cx
EndProcedure
; Plots a Symbol, scaled by SymSize, centered at world coordinates
; X,Y; available Symbols are:
; 1 - plus
; 2 - box
; 3 - cross (x-like)
; 4 - triangle
; 5 - inverted triangle
; 6 - open circle
; 7 - filled circle
; 8 - dot
Procedure PlotSymbol1(X.d,Y.d, Symbol.i, SymSize.i, color.i=-1)
Protected.i del = 1
Protected.i xs,ys,delta,x1,y1
Protected.i curcol
x1 = GetXX()
y1 = GetYY()
curcol = GetColor()
If color <> -1
SetColor(color)
EndIf
xs=X : ys=Y
delta = del*SymSize;
Select Symbol
Case 1 ; plus
MoveTo(xs-delta,ys)
LineRel(2*delta,0)
MoveRel(-delta,-delta)
LineRel(0,2*delta)
Case 2 ; box
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,0)
LineRel(0,2*delta)
LineRel(-2*delta,0)
LineRel(0,-2*delta)
Case 3 ; cross
MoveTo(xs-delta,ys-delta)
LineRel(2*delta,2*delta)
MoveRel(-2*delta,0)
LineRel(2*delta,-2*delta)
Case 4: ; triangle
MoveTo(xs,Int(ys-delta-delta / 3))
LineRel(-delta,2*delta)
LineRel(2*delta,0)
LineRel(-delta,-2*delta)
Case 5 ; inverted triangle
MoveTo(xs,Int(ys+delta+delta / 3))
LineRel(-delta,-2*delta)
LineRel(2*delta,0)
LineRel(-delta,2*delta)
Case 6
Circlee(xs,ys,delta) ; open circle
Case 7
FillEllipse(xs,ys,delta,delta) ; closed circle
Case 8
PutPixel(xs,ys,GetMaxColor()) ; unscaled point
Default
EndSelect
MoveTo(x1,y1)
SetColor(curcol)
GdiFlush_()
EndProcedure
Procedure DrawSymbol(x.l, y.l, color.l, symbol.l, width.l, height.l)
Protected currfcol.l = GetColor()
SetColor(color)
Select symbol
Case #SYMBOLRECTANGLE:
Linee(x - width/2, y - height/2, x + width/2, y - height/2)
Linee(x + width/2, y - height/2, x + width/2, y + height/2)
Linee(x + width/2, y + height/2, x - width/2, y + height/2)
Linee(x - width/2, y + height/2, x - width/2, y - height/2)
Case #SYMBOLTRIANGLE:
Linee(x - width/2, y + height/2, x, y - height/2)
Linee(x, y - height/2, x + width/2, y + height/2)
Linee(x + width/2, y + height/2, x - width/2, y + height/2)
Case #SYMBOLDIAMOND:
Linee(x - width/2, y, x, y - height/2)
Linee(x, y - height/2, x + width/2, y)
Linee(x + width/2, y, x, y + height/2)
Linee(x, y + height/2, x - width/2, y)
Case #SYMBOLCROSS:
Linee(x - width/2, y, x + width/2, y)
Linee(x, y - height/2, x, y + height/2)
Case #SYMBOLXCROSS:
Linee(x - width/2, y + height/2, x + width/2, y - height/2)
Linee(x - width/2, y - height/2, x + width/2, y + height/2)
Default
EndSelect
SetColor(currfcol)
GdiFlush_()
EndProcedure
Procedure THREEDto2DAll(*coords.ThreeDPointType, *pan.ThreeDPointType, *centre.ThreeDPointType, *position.ThreeDPointType, zoom.d, *sx.double, *sy.double)
Protected new.ThreeDPointType
*coords\x + *position\x
*coords\y + *position\y
*coords\z + *position\z
new\x = *coords\x*Cos(*pan\x) - *coords\z*Sin(*pan\x)
new\z = *coords\x*Sin(*pan\x) + *coords\z*Cos(*pan\x)
new\y = *coords\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\z = new\y*Cos(*pan\y) - new\z*Sin(*pan\y)
*coords\x = new\x*Cos(*pan\z) - new\y*Sin(*pan\z)
*coords\y = new\x*Sin(*pan\z) + new\y*Cos(*pan\z)
If *coords\z > 0.0
*sx = *coords\x / *coords\z * zoom + *centre\x
*sy = *coords\y / *coords\z * zoom + *centre\y
Else
*sx = *coords\x * zoom + *centre\x
*sy = *coords\y * zoom + *centre\y
EndIf
EndProcedure
Procedure THREEDto2D(*coords.ThreeDPointType, zoom.d, *sx.double, *sy.double)
*sx = *coords\x / *coords\z * zoom
*sy = *coords\y / *coords\z * zoom
EndProcedure
Procedure GetDrawingWindowRectangle(*xy.RECT, wsthickframe.b)
Protected.i cxFrame, cyFrame, cyCaption
Protected.WINDOWPLACEMENT info
GetWindowPlacement_(gdi1\Hdc, @info)
cxFrame = GetSystemMetrics_(#SM_CXFIXEDFRAME) * 2
cyFrame = GetSystemMetrics_(#SM_CYFIXEDFRAME) * 2
cyCaption= GetSystemMetrics_(#SM_CYCAPTION)
If wsthickframe
cxFrame = GetSystemMetrics_(#SM_CXFRAME) * 2
cyFrame = GetSystemMetrics_(#SM_CYFRAME) * 2
EndIf
With info\rcNormalPosition
*xy\left = \left
*xy\top = \top
*xy\right = \right-\left-cxFrame
*xy\bottom= \bottom-\top-cyFrame-cyCaption
EndWith
EndProcedure
Procedure.b PointInDrawingWindowRectangle(x.i,y.i,*xy.RECT,wsthickframe.b)
Protected.POINT iRec
GetDrawingWindowRectangle(*xy, wsthickframe)
ProcedureReturn Bool((x >= *xy\left) And (x <= *xy\right) And (y >= *xy\top) And (y <= *xy\bottom))
EndProcedure
Procedure GetImage(x1.i,y1.i,x2.i,y2.i,*bmp.BITMAP)
Protected.i hdcMemDC, hbmScreen
Protected bih.BITMAPINFOHEADER
hdcMemDC = CreateCompatibleDC_(gdi1\Hdc)
hbmScreen = CreateCompatibleBitmap_(gdi1\Hdc, x2-x1+1, y2-y1+1)
SelectObject_(hdcMemDC, hbmScreen)
BitBlt_(hdcMemDC, 0, 0, x2-x1+1, y2-y1+1, gdi1\Hdc, x1, y1, #SRCCOPY|#CAPTUREBLT)
GetObject_(hbmScreen, SizeOf(BITMAP), *bmp)
bih\biSize = SizeOf(BITMAPINFOHEADER)
bih\biHeight = *bmp\bmHeight
bih\biWidth = *bmp\bmWidth
bih\biPlanes = 1
bih\biBitCount = *bmp\bmBitsPixel
bih\biCompression = #BI_RGB
bih\biSizeImage = 0
bih\biXPelsPerMeter = 0
bih\biYPelsPerMeter = 0
bih\biClrUsed = 0
bih\biClrImportant = 0
*bmp\bmBits = AllocateMemory(*bmp\bmWidth * *bmp\bmHeight * ((*bmp\bmBitsPixel + 7) / 8))
GetDIBits_(gdi1\Hdc, hbmScreen, 0, *bmp\bmHeight, *bmp\bmBits, @bih, #DIB_RGB_COLORS)
GdiFlush_()
DeleteObject_(hbmScreen)
DeleteObject_(hdcMemDC)
EndProcedure
; #CopyMode = 0
; #XorMode = 1
; #OrMode = 2
; #AndMode = 3
; #NotMode = 4
; #NotScrMode = 5
; #NotXorMode = 6
; #NotOrMode = 7
; #NotAndMode = 8
; #InvColAndMode = 9
; #InvColOrMode = 10
; #InvScrAndMode = 11
; #InvScrOrMode = 12
; #BlackMode = 13
; #WhiteMode = 14
; #EmptyMode = 15
; #TRANSPARENT_ = $00
; #OPAQUE_ = 16
Procedure PutImage(x1.i,y1.i,*bmp.BITMAP,rop.i=#SRCAND)
Protected.i hdcMemDC,rop1
Protected bih.BITMAPINFOHEADER
Protected *hBitMap.BITMAP
Protected *ppvBits
Select rop
Case #CopyMode : rop1 = #SRCCOPY
Case #XorMode : rop1 = #SRCPAINT
Case #OrMode : rop1 = #SRCAND
Case #AndMode : rop1 = #SRCINVERT
Case #NotMode : rop1 = #SRCERASE
Case #NotScrMode : rop1 = #NOTSRCCOPY
Case #NotXorMode : rop1 = #NOTSRCERASE
Case #NotOrMode : rop1 = #MERGECOPY
Case #NotAndMode : rop1 = #MERGEPAINT
Case #InvColAndMode : rop1 = #PATCOPY
Case #InvColOrMode : rop1 = #PATPAINT
Case #InvScrAndMode : rop1 = #PATINVERT
Case #InvScrOrMode : rop1 = #DSTINVERT
Case #BlackMode : rop1 = #BLACKNESS
Case #WhiteMode : rop1 = #WHITENESS
Case #EmptyMode : rop1 = #NOMIRRORBITMAP
Default
ProcedureReturn
EndSelect
hdcMemDC = CreateCompatibleDC_(gdi1\Hdc)
bih\biSize = SizeOf(BITMAPINFOHEADER)
bih\biHeight = *bmp\bmHeight
bih\biWidth = *bmp\bmWidth
bih\biPlanes = 1
bih\biBitCount = *bmp\bmBitsPixel
bih\biCompression = #BI_RGB
bih\biSizeImage = 0
bih\biXPelsPerMeter = 0
bih\biYPelsPerMeter = 0
bih\biClrUsed = 0
bih\biClrImportant = 0
*hBitMap = CreateDIBSection_(hdcMemDC, @bih, #DIB_RGB_COLORS, @*ppvBits, #Null, 0)
CopyMemory(*bmp\bmBits, *ppvBits, MemorySize(*bmp\bmBits))
SelectObject_(hdcMemDC, *hBitMap)
BitBlt_(gdi1\Hdc, x1, y1, *bmp\bmWidth, *bmp\bmHeight, hdcMemDC, 0, 0, rop1|#CAPTUREBLT)
GdiFlush_()
DeleteObject_(*hBitMap)
DeleteObject_(hdcMemDC)
EndProcedure
Procedure.i ImageSize(x1.i,y1.i,x2.i,y2.i,bitsize.i)
ProcedureReturn (((y2-y1) * (x2-x1) * bitsize) / 8)
EndProcedure
Procedure.i MemoryImageSize(x1.i,y1.i,x2.i,y2.i,bitsize.i)
ProcedureReturn (((y2-y1) * (x2-x1) * bitsize) / 8) + SizeOf(MEMORYIMAGE)
EndProcedure
Procedure GetMemImage(x1.i,y1.i,x2.i,y2.i,*bitmap.MEMORYIMAGE)
Protected.i targetDC = CreateCompatibleDC_(gdi1\Hdc)
*bitmap\width = x2-x1+1
*bitmap\height = (y2-y1+1) ; Otherwise colors in the buffer will be backwards, "bottom-up" which we don't want
*bitmap\bits = CreateCompatibleBitmap_(gdi1\Hdc, x2-x1+1, (y2-y1+1))
SelectObject_(targetDC, *bitmap\bits)
BitBlt_(targetDC, x1, y1, x2-x1+1, (y2-y1+1), gdi1\Hdc, x1, y1, #SRCCOPY|#CAPTUREBLT)
GdiFlush_()
DeleteDC_(targetDC)
ReleaseDC_(*bitmap\bits, gdi1\Hdc)
EndProcedure
Procedure PutMemImage(x1.i,y1.i,*bitmap.MEMORYIMAGE, rop.i=#SRCAND)
Protected.i tempDC
tempDC = CreateCompatibleDC_(gdi1\Hdc)
SelectObject_(tempDC, @*bitmap\bits)
BitBlt_(gdi1\Hdc, x1, y1, *bitmap\width, *bitmap\height, tempDC, 0, 0, rop|#CAPTUREBLT)
GdiFlush_()
DeleteDC_(tempDC)
EndProcedure
Procedure UpdateBgi(winnum.i)
ResizeWindow(gdiwin\winNum, #PB_Ignore, #PB_Ignore, #PB_Ignore, #PB_Ignore)
SetActiveWindow(winnum)
EndProcedure
Procedure Track()
Protected.i x = WindowWidth(gdiwin\winNum), y = WindowHeight(gdiwin\winNum)
If x > gdi1\maxX
x = gdi1\maxX
EndIf
If y > gdi1\maxY
y = gdi1\maxY
EndIf
ResizeGadget(gdiwin\scroller, #PB_Ignore, #PB_Ignore, x, y)
ResizeWindow(gdiwin\winNum, #PB_Ignore, #PB_Ignore, x, y)
ResizeGadget(gdiwin\canvasnum, #PB_Ignore,#PB_Ignore, #PB_Ignore, #PB_Ignore)
EndProcedure
Procedure closeevent()
If EventWindow() = gdiwin\winNum
CloseWindow(gdiwin\winNum)
gdiwin\winNum = -1
If IsThread(Thread)
KillThread(Thread)
EndIf
PostEvent(#PB_Event_CloseWindow,gdiwin\winNum,-1)
EndIf
EndProcedure
Procedure.i IsBgiWindowOpen()
ProcedureReturn Bool(gdiwin\winNum > 0)
EndProcedure
Procedure canvasrefresh()
Select EventGadget()
Case gdiwin\canvasnum
If StartDrawing(CanvasOutput(gdiwin\canvasnum))
DrawImage(grMemory\Bitmap, 0, 0)
StopDrawing()
EndIf
EndSelect
ResizeGadget(gdiwin\canvasnum, #PB_Ignore,#PB_Ignore, #PB_Ignore, #PB_Ignore)
EndProcedure
Global parentwinnum.i=0
Procedure.i CreateGdiWindow(*gdiwindow.WINDOW, *NewGdiMap.GDIMAP, custWidth.i=400, custHeight.i=400, title.s="", winnum.i=0, winsize.i = #CustScr)
Protected.i x
*gdiwindow\windowWidth = custWidth
*gdiwindow\windowHeight= custHeight
*gdiwindow\title = title
If *gdiwindow\windowWidth > *NewGdiMap\maxX
*gdiwindow\windowWidth = *NewGdiMap\maxX+1
EndIf
If *gdiwindow\windowHeight > *NewGdiMap\maxY
*gdiwindow\windowHeight = *NewGdiMap\maxY+1
EndIf
If winnum <> 0
*gdiwindow\winNum = OpenWindow(#PB_Any, 0, 0, *gdiwindow\windowWidth, *gdiwindow\windowHeight, *gdiwindow\title, #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget | #PB_Window_TitleBar | #PB_Window_SizeGadget, WindowID(winnum))
parentwinnum = winnum
Else
*gdiwindow\winNum = OpenWindow(#PB_Any, 0, 0, *gdiwindow\windowWidth, *gdiwindow\windowHeight, *gdiwindow\title, #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget | #PB_Window_TitleBar | #PB_Window_SizeGadget)
EndIf
If *gdiwindow\winNum = 0: ProcedureReturn -1 : EndIf
*gdiwindow\scroller = ScrollAreaGadget(#PB_Any, 0, 0, *gdiwindow\windowWidth, *gdiwindow\windowHeight, *NewGdiMap\maxX, *NewGdiMap\maxY, 1, #PB_ScrollArea_BorderLess)
*gdiwindow\winHwnd = WindowID(*gdiwindow\winNum)
*gdiwindow\canvasnum = CanvasGadget(#PB_Any, 0, 0, *NewGdiMap\maxX, *NewGdiMap\maxY, #PB_Canvas_Border | #PB_Canvas_Keyboard)
CloseGadgetList()
BindEvent(#PB_Event_SizeWindow, @Track(),gdiwin\winNum)
BindEvent(#PB_Event_CloseWindow, @closeevent(),gdiwin\winNum)
BindEvent(#PB_Event_Gadget, @canvasrefresh(),gdiwin\winNum)
SetActiveGadget(*gdiwindow\canvasnum)
ResizeWindow(gdiwin\winNum, #PB_Ignore, #PB_Ignore, custWidth, custHeight)
PostEvent(#PB_Event_Repaint, gdiwin\winNum, gdiwin\winNum,#PB_EventType_Focus)
EndProcedure
Procedure BgiStartup(winsizex, winsizey, wintitle.s, bitsizex.i, bitsizey.i, parentwinnum.i=0)
CreateBitmaps(gdi1, bitsizex, bitsizey)
CreateBitmaps(gdi2, bitsizex, bitsizey)
grMemory = gdi1
CreateGdiWindow(gdiwin, gdi1, winsizex, winsizey, wintitle,parentwinnum)
InstallDefaultFonts()
SetFillStyle(#SolidFill,#Black)
SetTextStyle(#DefaultFont,#HorizDir,10)
SetTextJustify(#LeftText,#TopText)
SetUserCharSize(0,0)
SetViewPort(0,0,GetMaxX(),GetMaxY(),#ClipOff)
SetWriteMode(#CopyMode | #TRANSPARENT)
SetAspectRatio(10000,10000)
SetActivePage(0)
SetActiveGadget(gdiwin\canvasnum)
;;; simulate click to redraw window
Protected Cursor.Point
BlockInput_(#True)
GetCursorPos_(@Cursor)
SetCursorPos_(WindowX(gdiwin\winNum),WindowY(gdiwin\winNum))
mouse_event_(#MOUSEEVENTF_LEFTDOWN,0,0,0,0)
mouse_event_(#MOUSEEVENTF_LEFTUP,0,0,0,0)
SetCursorPos_(Cursor\x,Cursor\y)
BlockInput_(#False)
EndProcedure
EndModule
little test
Code: Select all
EnableExplicit
XIncludeFile "bgi3Module.pb"
UseModule CanvasBgi
Global tEvent,tQuit,twinnum
twinnum = OpenWindow(#PB_Any, 0, 0, 200, 400, "PureBasic Window", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget|#PB_Window_WindowCentered)
If twinnum
BgiStartup(400, 400, "bgiwindow", 1200, 900)
SetActiveWindow(gdiwin\winNum)
ResizeWindow(gdiwin\winNum, #PB_Ignore,#PB_Ignore,#PB_Ignore,#PB_Ignore)
SetDrawingColor(#Blue, #PS_DOT,2)
RoundRect(100,100,300,600,30)
SetBackColor(#Green)
SetTextColor(#Red)
SetTextFontSize(30)
OutTextXY(200,200,"Hello World")
SetBackColor(#White)
Circlee(200,200,20)
Linee(400,400,700,700)
LineCaped(200,200,700,700,#SArrow,#SArrow, #True, #True)
Rectangle(100,100,600,600)
SetTextColor_(gdi1\Hdc, #Green)
MoveTo(600, 600)
Lineto(500,300)
MoveTo(600, 600)
SetTextFontSize(25)
SetTextColor_(gdi1\Hdc, #Blue)
OutTextXY(600, 600, "test1")
RotEllipse(300,300, 85, 90, 50)
Repeat
tEvent = WaitWindowEvent()
If tEvent = #PB_Event_CloseWindow ; If the user has pressed on the close button
tQuit = 1
EndIf
Until tQuit = 1
EndIf
Re: 2 windows 2 message loops
Don't use #PB_Window_WindowCentered
And
Makes no sense. When the window is closed, you can not send events to it.
So I had to modify your Main loop:
Bernd
Code: Select all
twinnum = OpenWindow(#PB_Any, 0, 0, 200, 400, "PureBasic Window", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget|#PB_Window_ScreenCentered)
Code: Select all
Procedure closeevent()
If EventWindow() = gdiwin\winNum
CloseWindow(gdiwin\winNum)
gdiwin\winNum = -1
If IsThread(Thread)
KillThread(Thread)
EndIf
PostEvent(#PB_Event_CloseWindow,gdiwin\winNum,-1)
EndIf
EndProcedure
So I had to modify your Main loop:
Code: Select all
Repeat
tEvent = WaitWindowEvent()
If EventWindow() = twinnum
If tEvent = #PB_Event_CloseWindow ; If the user has pressed on the close button
tQuit = 1
EndIf
EndIf
Until tQuit = 1
Re: 2 windows 2 message loops
great - thanks for all the info and corrections.
is it possible to start the module window and keep it open even if the test program closes?
is it possible to start the module window and keep it open even if the test program closes?
Re: 2 windows 2 message loops
No.
But you can close the window without stopping the program
Bernd
But you can close the window without stopping the program
Code: Select all
Repeat
If IsBgiWindowOpen()
tEvent = WaitWindowEvent()
If EventWindow() = twinnum
If tEvent = #PB_Event_CloseWindow ; If the user has pressed on the close button
If IsBgiWindowOpen()
CloseWindow(twinnum)
Else
tQuit = 1
EndIf
EndIf
EndIf
Else
Delay(10)
EndIf
Until tQuit = 1 Or Not IsBgiWindowOpen()
Re: 2 windows 2 message loops
thank very much for your help and insides.
i was thinking, that maybe one could somehow start an thread with the bgi window and thus keep it independent.
many thanks
i was thinking, that maybe one could somehow start an thread with the bgi window and thus keep it independent.
many thanks