• Welcome to PlanetSquires Forums.
 

CWindow Release Candidate 29

Started by José Roca, July 01, 2017, 04:21:09 PM

Previous topic - Next topic

José Roca

I have been able to modify my graphic control to, optionally, support OpenGL. Will be created in the same way, but passing "OPENGL" in the caption:


DIM pGraphCtx AS CGraphCtx = CGraphCtx(@pWindow, IDC_GRCTX, "OPENGL", 0, 0, _
      pWindow.ClientWidth, pWindow.ClientHeight)


Then, since you can have more than one control at the same time, before using OpenGL code you have to make current the rendering context of the control where you intend to draw:


' // Make current the rendering context
pGraphCtx.MakeCurrent
' // Render the scene
RenderScene pGraphCtx.GetVirtualBufferWidth, pGraphCtx.GetVirtualBufferHeight


The OpenGL code will be as usual, but instead of calling SwapBuffers, you will call glFlush, since there are no buffers to swap.


' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB RenderScene (BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)

   ' // Specify clear values for the color buffers
   glClearColor 0.0, 0.0, 0.0, 0.0
   ' // Specify the clear value for the depth buffer
   glClearDepth 1.0
   ' // Specify the value used for depth-buffer comparisons
   glDepthFunc GL_LESS
   ' // Enable depth comparisons and update the depth buffer
   glEnable GL_DEPTH_TEST
   ' // Select smooth shading
   glShadeModel GL_SMOOTH

   ' // Prevent divide by zero making height equal one
   IF nHeight = 0 THEN nHeight = 1
   ' // Reset the current viewport
   glViewport 0, 0, nWidth, nHeight
   ' // Select the projection matrix
   glMatrixMode GL_PROJECTION
   ' // Reset the projection matrix
   glLoadIdentity
   ' // Calculate the aspect ratio of the window
   gluPerspective 45.0!, nWidth / nHeight, 0.1!, 100.0!
   ' // Select the model view matrix
   glMatrixMode GL_MODELVIEW
   ' // Reset the model view matrix
   glLoadIdentity

   ' // Clear the screen buffer
   glClear GL_COLOR_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT
   ' // Reset the view
   glLoadIdentity

   glTranslatef -1.5!, 0.0!, -6.0!       ' Move left 1.5 units and into the screen 6.0

   glBegin GL_TRIANGLES                 ' Drawing using triangles
      glColor3f   1.0!, 0.0!, 0.0!       ' Set the color to red
      glVertex3f  0.0!, 1.0!, 0.0!       ' Top
      glColor3f   0.0!, 1.0!, 0.0!       ' Set the color to green
      glVertex3f  1.0!,-1.0!, 0.0!       ' Bottom right
      glColor3f   0.0!, 0.0!, 1.0!       ' Set the color to blue
      glVertex3f -1.0!,-1.0!, 0.0!       ' Bottom left
   glEnd                                 ' Finished drawing the triangle

   glTranslatef 3.0!,0.0!,0.0!           ' Move right 3 units

   glColor3f 0.5!, 0.5!, 1.0!            ' Set the color to blue one time only
   glBegin GL_QUADS                     ' Draw a quad
      glVertex3f -1.0!, 1.0!, 0.0!       ' Top left
      glVertex3f  1.0!, 1.0!, 0.0!       ' Top right
      glVertex3f  1.0!,-1.0!, 0.0!       ' Bottom right
      glVertex3f -1.0!,-1.0!, 0.0!       ' Bottom left
   glEnd                                 ' Done drawing the quad

   ' // Required: force execution of GL commands in finite time
   glFlush

END SUB
' =======================================================================================


GDI, GDI+ and OpenGl can be used at the same time.

José Roca

#16
Quote from: TechSupport on July 04, 2017, 08:16:25 AM
Quote from: Jose Roca on July 03, 2017, 09:26:26 PM
As soon as I post a new version of the framework, new ideas come to my mind :)

You never stop thinking and coming up with new and exciting code!  :)

I have given another try to the class to manage variants, now called CVAR. I was frustrated because I want to use WMI in an easy way, using the dispatch interfaces, and for that I need variants. The class for variants seems to be working well. Later I will have to modify the CDispInvoke class to work with them.

Silly subs for testing:


#define UNICODE
#INCLUDE ONCE "Afx/CVar.inc"

SUB Foo (BYVAL pcv AS CVAR PTR)
   print pcv->ToStr
END SUB

SUB Foo1 (BYREF cv AS CVAR)
   print cv.ToStr
END SUB

SUB Foo2 (BYVAL v AS VARIANT)
   print AfxVarToStr(@v)
END SUB

SUB Foo3 (BYVAL pv AS VARIANT PTR)
   print AfxVarToStr(pv)
END SUB

SUB Foo4 (BYREF v AS VARIANT)
   print AfxVarToStr(@v)
END SUB

SUB Foo5 (BYVAL pv AS VARIANT PTR)
   pv->vt = VT_I4
   pv->lVal = 12345
END SUB


The constructors can be used to create temporary CVARs to pass to parameters without having to assign the values to variables. Yes, they will free themselves.

No matter how the parameter has been declared -- BYVAL pcv AS CVAR PTR, BYREF cv AS CVAR, BYVAL v AS VARIANT, BYVAL pv AS VARIANT PTR or BYREF v AS VARIANT --, we use the same syntax.


' --- Strings ---
Foo CVAR("Test string")
Foo1 CVAR("Test string")
Foo2 CVAR("Test string")
Foo3 CVAR("Test string")
Foo4 CVAR("Test string")
' --- Numbers ---
Foo CVAR(12345)                  ' // Defaults to LongInt (VT_I8)
Foo CVAR(12345, AFX_LONG)        ' --or-- Foo CVAR(12345, VT_I4) // VT_I4 variant (Long)
Foo CVAR(12345.12, AFX_DOUBLE)   ' --or-- Foo CVAR(12345, VT_R8) // VT_R8 variant (double)
' --------------


For OUT parameters, we can use * or vptr.
Unless the CVAR contains only numbers, we must use vptr, that clears the underlying variant with VariantClear before passing it.


DIM cv AS CVAR
'Foo5 *cv       ' // May cause a memory leak if it already has contents
Foo5 cv.vptr   ' // The correct way
print cv.ToStr


Can be used to call API variant functions


DIM cv1 AS CVAR = CVAR(1234567890)
DIM cv2 AS CVAR = CVAR(111)
DIM cvOut AS CVAR
VarAdd(cv1, cv2, cvOut)
print cvOut.ToStr
' or, to avoid memory leaks if cvOut already has contents...
VarAdd(cv1, cv2, cvOut.vptr)
print cvOut.ToStr


Can be used to store arrays of bytes in VT_UI1 arrays, e.g. to store images.
In this test, I'm using an ansi string to simulate a byte buffer...


DIM s AS STRING = "Test buffer"
DIM cv AS CVAR
cv.AssignBuffer(STRPTR(s), LEN (s))
DIM cb AS LONG = cv.GetElementCount
DIM s2 AS STRING = SPACE(cb)
cv.ToBuffer STRPTR(s2), cb
print s2
' -or-
DIM s3 AS STRING = cv.ToBuffer
print s3


The method AssignRef allows to create VT_BYREF variables, e.g.:


DIM lVal AS LONG = 12345
DIM cv AS CVAR
cv.AssignRef @lVal, AFX_LONG
print cv.ToStr
' Now we change the content of the referenced variable...
lVal = 67890
print cv.ToStr


There are many methods to assign and extract values to/from the variants. I have added them as methods because the LET and CAST operators don't allow to indicate the variant type and when you pass a number such 123, it does not know if it has to assign a byte, a word, a short, a long, etc.

To extract numbers, simply use VAL(cv.ToStr). The ToStr method works also with VT_BYREF variants and arrays. If the variant contains an array, each element of the array is appended to the resulting string separated with a semicolon and a space. This string can be converted to a CWStrArray with the AfxSplit function.


' ########################################################################################
' CVar - VARIANT class
' ########################################################################################
TYPE CVar

   vd AS VARIANT         ' // Variant data

   ' // COnstructors
   DECLARE CONSTRUCTOR
   DECLARE DESTRUCTOR
   DECLARE CONSTRUCTOR (BYREF cv AS CVAR)
   DECLARE CONSTRUCTOR (BYVAL v AS VARIANT)
   DECLARE CONSTRUCTOR (BYREF wsz AS WSTRING)
   DECLARE CONSTRUCTOR (BYREF cws AS CWSTR)
   DECLARE CONSTRUCTOR (BYVAL pvar AS VARIANT PTR)
   DECLARE CONSTRUCTOR (BYVAL pdisp AS IDispatch PTR)
   DECLARE CONSTRUCTOR (BYVAL punk AS IUnknown PTR)
   DECLARE CONSTRUCTOR (BYVAL _value AS LONGINT, BYVAL _vType AS WORD = VT_I8)
   DECLARE CONSTRUCTOR (BYVAL _value AS DOUBLE, BYVAL _vType AS WORD = VT_R8)
   DECLARE CONSTRUCTOR (BYVAL _pvar AS ANY PTR, BYVAL _vType AS WORD)
   ' // Casting
'   DECLARE OPERATOR @ () AS VARIANT PTR
   DECLARE FUNCTION vptr () AS VARIANT PTR
   DECLARE FUNCTION sptr () AS VARIANT PTR
   DECLARE OPERATOR CAST () AS VARIANT
   DECLARE OPERATOR CAST () AS ANY PTR
   DECLARE FUNCTION ToStr () AS CWSTR
   DECLARE FUNCTION ToUtf8 () AS STRING
   DECLARE FUNCTION ToBuffer (BYVAL pv AS ANY PTR, BYVAL cb AS UINT) AS HRESULT
   DECLARE FUNCTION ToBuffer () AS STRING
   DECLARE FUNCTION DecToDouble () AS DOUBLE
   DECLARE FUNCTION DecToCy () AS CY
   DECLARE FUNCTION ToVbDate () AS DATE_
   DECLARE FUNCTION ToSystemTime () AS SYSTEMTIME
   DECLARE FUNCTION ToGuid () AS GUID
   DECLARE FUNCTION ToGuidStr () AS CWSTR
   DECLARE FUNCTION ToDosDateTime (BYVAL pwDate AS USHORT PTR, BYVAL pwTime AS USHORT PTR) AS HRESULT
   DECLARE FUNCTION ToFileTime (BYVAL stfOut AS AFX_PSTIME_FLAGS) AS FILETIME
   DECLARE FUNCTION ToStrRet () AS STRRET
   DECLARE FUNCTION ToBooleanArray (BYREF cv AS CVAR, BYVAL pprgf AS WINBOOL PTR PTR) AS ULONG
   DECLARE FUNCTION ToShortArray (BYVAL pprgn AS SHORT PTR PTR) AS ULONG
   DECLARE FUNCTION ToUShortArray (BYVAL pprgn AS USHORT PTR PTR) AS ULONG
   DECLARE FUNCTION ToLongArray (BYVAL pprgn AS LONG PTR PTR) AS ULONG
   DECLARE FUNCTION ToULongArray (BYVAL pprgn AS ULONG PTR PTR) AS ULONG
   DECLARE FUNCTION ToLongIntArray (BYVAL pprgn AS LONGINT PTR PTR) AS ULONG
   DECLARE FUNCTION ToULongIntArray (BYVAL pprgn AS ULONGINT PTR PTR) AS ULONG
   DECLARE FUNCTION ToDoubleArray (BYVAL pprgn AS DOUBLE PTR PTR) AS ULONG
   DECLARE FUNCTION ToStringArray (BYVAL pprgsz AS PWSTR PTR) AS ULONG
   ' // LET assignments
   DECLARE OPERATOR Let (BYREF cv AS CVAR)
   DECLARE OPERATOR Let (BYREF v AS VARIANT)
   DECLARE OPERATOR Let (BYREF wszStr AS WSTRING)
   DECLARE OPERATOR Let (BYREF cws AS CWSTR)
   DECLARE OPERATOR Let (BYVAL pvar AS VARIANT PTR)
   DECLARE OPERATOR Let (BYVAL pdisp AS IDispatch PTR)
   DECLARE OPERATOR Let (BYVAL punk AS IUnknown PTR)
   ' // Assignments
   DECLARE FUNCTION Assign (BYREF cv AS CVAR) AS HRESULT
   DECLARE FUNCTION Assign (BYREF v AS VARIANT) AS HRESULT
   DECLARE FUNCTION Assign (BYREF wszStr AS WSTRING) AS HRESULT
   DECLARE FUNCTION Assign (BYREF cws AS CWSTR) AS HRESULT
   DECLARE FUNCTION Assign (BYVAL pvar AS VARIANT PTR) AS HRESULT
   DECLARE FUNCTION Assign (BYVAL pdisp AS IDispatch PTR) AS HRESULT
   DECLARE FUNCTION Assign (BYVAL punk AS IUnknown PTR) AS HRESULT
   DECLARE FUNCTION Assign (BYVAL _value AS LONGINT, BYVAL _vType AS WORD = VT_I8) AS HRESULT
   DECLARE FUNCTION Assign (BYVAL _value AS DOUBLE, BYVAL _vType AS WORD = VT_R8) AS HRESULT
   DECLARE FUNCTION AssignULongInt (BYVAL _value AS ULONGINT) AS HRESULT
   DECLARE FUNCTION AssignBuffer(BYVAL pv AS ANY PTR, BYVAL cb AS UINT) AS HRESULT
   DECLARE FUNCTION AssignUtf8 (BYREF strUtf8 AS STRING) AS HRESULT
   DECLARE FUNCTION AssignSafeArray (BYVAL parray AS SAFEARRAY PTR, BYVAL fAttach AS BOOLEAN = FALSE) AS HRESULT
   DECLARE FUNCTION AssignResource (BYVAL hinst AS HINSTANCE, BYVAL id AS UINT) AS HRESULT
   DECLARE FUNCTION AssignRecord (BYVAL pIRecordInfo AS IRecordInfo PTR, BYVAL pRec AS ANY PTR) AS HRESULT
   DECLARE FUNCTION AssignDateString (BYVAL pwszDate AS WSTRING PTR, BYVAL lcid AS LCID = 0, BYVAL dwFlags AS ULONG = 0) AS HRESULT
   DECLARE FUNCTION AssignVbDate (BYVAL vbDate AS DATE_) AS HRESULT
   DECLARE FUNCTION AssignSystemTime (BYVAL st AS SYSTEMTIME PTR) AS BOOLEAN
   DECLARE FUNCTION AssignGuid (BYVAL guid AS IID PTR) AS HRESULT
   DEClARE FUNCTION AssignFileTime (BYVAL pft AS FILETIME PTR) AS HRESULT
   DECLARE FUNCTION AssignFileTimeArray (BYVAL prgft AS FILETIME PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignStrRet (BYVAL pstrret AS STRRET PTR, BYVAL pidl AS PCUITEMID_CHILD) AS HRESULT
   DECLARE FUNCTION AssignDec (BYVAL ppdec AS DECIMAL PTR) AS HRESULT
   DECLARE FUNCTION AssignDecFromStr (BYVAL pwszIn AS WSTRING PTR, BYVAL lcid AS LCID = 0, BYVAL dwFlags AS ULONG = 0) AS HRESULT
   DECLARE FUNCTION AssignDecFromDouble (BYVAL dbIn AS DOUBLE) AS HRESULT
   DECLARE FUNCTION AssignDecFromCy (BYVAL cyIn AS CY) AS HRESULT
   DECLARE FUNCTION AssignBooleanArray (BYVAL prgf AS WINBOOL PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignShortArray (BYVAL prgf AS SHORT PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignUShortArray (BYVAL prgf AS USHORT PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignLongArray (BYVAL prgn AS LONG PTR, BYVAL cElems AS ULONG) AS CVAR
   DECLARE FUNCTION AssignULongArray (BYVAL prgn AS ULONG PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignLongIntArray (BYVAL prgn AS LONGINT PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignULongArray (BYVAL prgn AS ULONGINT PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignDoubleArray (BYVAL prgn AS DOUBLE PTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignStringArray (BYVAL prgsz AS PCWSTR, BYVAL cElems AS ULONG) AS HRESULT
   DECLARE FUNCTION AssignPropVariant (BYVAL pPropVar AS PROPVARIANT PTR) AS HRESULT
   DECLARE FUNCTION AssignVariantArrayElem (BYVAL pvarIn AS VARIANT PTR, BYVAL iElem AS ULONG) AS CVAR
   ' // Assignments by reference
   DECLARE FUNCTION AssignRef (BYVAL _value AS ANY PTR, BYVAL _vType AS WORD = VT_I8) AS HRESULT
   ' // Safe arrays
   DECLARE FUNCTION GetDim () AS ULONG
   DECLARE FUNCTION GetLBound (BYVAL nDim AS UINT = 1) AS LONG
   DECLARE FUNCTION GetUBound (BYVAL nDim AS UINT = 1) AS LONG
   DECLARE FUNCTION GetVariantElem (BYVAL iElem AS ULONG) AS VARIANT
   ' // Arrays
   DECLARE FUNCTION GetElementCount () AS ULONG
   DECLARE FUNCTION GetBooleanElem (BYVAL iElem AS ULONG) AS BOOLEAN
   DECLARE FUNCTION GetShortElem (BYVAL iElem AS ULONG) AS SHORT
   DECLARE FUNCTION GetUShortElem (BYVAL iElem AS ULONG) AS USHORT
   DECLARE FUNCTION GetLongElem (BYVAL iElem AS ULONG) AS LONG
   DECLARE FUNCTION GetULongElem (BYVAL iElem AS ULONG) AS ULONG
   DECLARE FUNCTION GetLongIntElem (BYVAL iElem AS ULONG) AS LONGINT
   DECLARE FUNCTION GetULongIntElem (BYVAL iElem AS ULONG) AS ULONGINT
   DECLARE FUNCTION GetDoubleElem (BYVAL iElem AS ULONG) AS DOUBLE
   DECLARE FUNCTION GetStringElem (BYVAL iElem AS ULONG) AS CWSTR
   ' // Other...
   DECLARE SUB Clear
   DECLARE FUNCTION Attach (BYVAL pvar AS VARIANT PTR) AS HRESULT
   DECLARE FUNCTION Attach (BYREF v AS VARIANT) AS HRESULT
   DECLARE FUNCTION Detach (BYVAL pvar AS VARIANT PTR) AS HRESULT
   DECLARE FUNCTION Detach (BYREF v AS VARIANT) AS HRESULT
   DECLARE FUNCTION vType () AS VARTYPE
   DECLARE FUNCTION ChangeType (BYVAL vtNew AS VARTYPE, BYVAL wFlags AS USHORT = 0) AS HRESULT
   DECLARE FUNCTION ChangeTypeEx (BYVAL vtNew AS VARTYPE, BYVAL lcid AS LCID = 0, BYVAL wFlags AS USHORT = 0) AS HRESULT
   DECLARE FUNCTION FormatNumber (BYVAL iNumDig AS LONG = -1, BYVAL ilncLead AS LONG = -2, _
           BYVAL iUseParens AS LONG = -2, BYVAL iGroup AS LONG = -2, BYVAL dwFlags AS DWORD = 0) AS CWSTR

END TYPE
' ########################################################################################


I have added wrappers to call the API helper functions from propsys.dll in AfxCOM.inc.

Petrus Vorster

With the stuff you guys are doing here, would you say the Freebasic is a better compiler now than Powerbasic?
It seems to be able to do more things by the looks of your progress.

Is the developer situation at FB stable to avoid a future mess like at Powerbasic when the lead passed away?
I haven't seen any new news after the purchase of Powerbasic and there seem to be many movements at FB a well.

It would seem you are way past the Powerbasic level. It gives one a great deal of hope and joy to see how this evolves.

Great stuff.
-Regards
Peter

José Roca

#18
As MCM will say, "It's not the paintbrush, it's the artist."

It's not better than PB, not worse, it's different. The most important difference is that with FB I can write programs that compile to 32 or 64-bit without changes.

I'm revisiting the COM classes because when I wrote them I was still a newbie with FB and messed them. Now that I have mastered most parts of the language, I can do it better.

Since I never have used the outdated DDT, TCP, Graphics, etc., the only thing that I miss from PB are its COM support, that makes much easier COM programming.

The FB compiler is stable, at least the Windows version, and being 64 bit it will last for the rest of my life. Development has been halted (temporalily?) with the withdrawal of dkl, its main developer, but maybe another programmer will take the lead.

Even if there will be a new version of PB, I doubt that I will use it. After the triumph of the DDTers and the desertion of the SDK programmers, the PB forum has become a boring and uninteresting place to me.


José Roca

#19
I have added some methods to the CVAR class and have implemented a news class: CDispInvoke.

Together with CVAR, CDispInvoke allows to use COM Automation with Free Basic in a way similar to PowerBASIC.

An small example:


' ========================================================================================
' CDispInvoke test
' ========================================================================================

#include "Afx/CDispInvoke.inc"
using Afx

' // Create a instance of the RegExp object
DIM pDisp AS CDispInvoke = "VBScript.RegExp"
' // To check for success, see if the value returned by the DispPtr method is not null
IF pDisp.DispPtr = NULL THEN END

' // Set some properties
' // Use VARIANT_TRUE or CTRUE, not TRUE, because Free Basic TRUE is a BOOLEAN data type, not a LONG
pDisp.Put("Pattern", CVAR(".is"))
pDisp.Put("IgnoreCase", CVAR(VARIANT_TRUE, "BOOL"))
pDisp.Put("Global", CVAR(VARIANT_TRUE, "BOOL"))

' // Execute a search
DIM pMatches AS CDispInvoke = pDisp.Invoke("Execute", 1, CVAR("IS1 is2 IS3 is4"))
' // Parse the collection of matches
IF pMatches.DispPtr THEN
   ' // Get the number of matches
   DIM nCount AS LONG = pMatches.Get("Count").ValInt
   ' // This is equivalent to:
   ' DIM cvRes AS CVAR = pMatches.Get("Count")
   ' DIM nCount AS LONG = cvRes.ValInt
   FOR i AS LONG = 0 TO nCount -1
      ' // Get a pointer to the Match object
      ' // When using COM Automation, it's not always necessary to make sure that the
      ' // passed variant with a numeric value is of the exact type, since the standard
      ' // implementation of DispInvoke tries to coerce parameters. However, it is always
      ' // safer to use a syntax like CVAR(i, "LONG")) than CVAR(i)
      DIM pMatch AS CDIspInvoke = pMatches.Get("Item", CVAR(i))   ' // or CVAR(i, "LONG"))
      IF pMatch.DispPtr THEN
         ' // Get the value of the match and convert it to a string
         print pMatch.Get("Value").ToStr
      END IF
   NEXT
END IF

PRINT
PRINT "Press any key..."
SLEEP


DIM pDisp AS CDispInvoke = "VBScript.RegExp" is equivalent to PB's LET objvar = NEWCOM PrgID$.

pDisp.Put is equivalent to OBJECT SET, pDisp.Get to OBJEJT GET and pDisp.Invoke to OBJECT CALL.

pDisp.DispPtr is equivalent to OBJPTR(pDisp).

I think that I have found a good solution for the Invoke method, that can have a variable number of parameters. The usual way has been to use a variadic function, but as variadic functions don't work with Free Basic it was necessary to find a work around. For optional parameters, you can pass NULL or use the standard Free Basic way of omiting a parameter, e.g. ("x, , y").


' ========================================================================================
' Wrapper function to call the Invoke method to call a method or get property.
' ========================================================================================
PRIVATE FUNCTION CDispInvoke.Invoke (BYVAL pwszName AS WSTRING PTR, BYVAL cVars AS UBYTE, _
   BYVAL vArg1  AS CVAR PTR = NULL, BYVAL vArg2  AS CVAR PTR = NULL, _
   BYVAL vArg3  AS CVAR PTR = NULL, BYVAL vArg4  AS CVAR PTR = NULL, _
   BYVAL vArg5  AS CVAR PTR = NULL, BYVAL vArg6  AS CVAR PTR = NULL, _
   BYVAL vArg7  AS CVAR PTR = NULL, BYVAL vArg8  AS CVAR PTR = NULL, _
   BYVAL vArg9  AS CVAR PTR = NULL, BYVAL vArg10 AS CVAR PTR = NULL, _
   BYVAL vArg11 AS CVAR PTR = NULL, BYVAL vArg12 AS CVAR PTR = NULL, _
   BYVAL vArg13 AS CVAR PTR = NULL, BYVAL vArg14 AS CVAR PTR = NULL, _
   BYVAL vArg15 AS CVAR PTR = NULL, BYVAL vArg16 AS CVAR PTR = NULL _
   ) AS CVAR

   IF cVars > 16 THEN cVars = 16
   DIM vArgs(1 TO cVars) AS VARIANT
   ' // Default argument values to optional
   FOR i AS LONG = 1 TO cVars
      vArgs(i) = TYPE(VT_ERROR, 0, 0, 0, DISP_E_PARAMNOTFOUND)
   NEXT
   ' // Fill the arguments array with the passed values, in reverse order
   FOR i AS LONG = cVars TO 1 STEP -1
      IF i = cVars AND vArg1 <> NULL THEN vArgs(i) = *vArg1
      IF i = cVars - 1  AND vArg2  <> NULL THEN vArgs(i) = *vArg2
      IF i = cVars - 2  AND vArg3  <> NULL THEN vArgs(i) = *vArg3
      IF i = cVars - 3  AND vArg4  <> NULL THEN vArgs(i) = *vArg4
      IF i = cVars - 4  AND vArg5  <> NULL THEN vArgs(i) = *vArg5
      IF i = cVars - 5  AND vArg6  <> NULL THEN vArgs(i) = *vArg6
      IF i = cVars - 6  AND vArg7  <> NULL THEN vArgs(i) = *vArg7
      IF i = cVars - 7  AND vArg8  <> NULL THEN vArgs(i) = *vArg8
      IF i = cVars - 8  AND vArg9  <> NULL THEN vArgs(i) = *vArg9
      IF i = cVars - 9  AND vArg10 <> NULL THEN vArgs(i) = *vArg10
      IF i = cVars - 10 AND vArg11 <> NULL THEN vArgs(i) = *vArg11
      IF i = cVars - 11 AND vArg11 <> NULL THEN vArgs(i) = *vArg12
      IF i = cVars - 12 AND vArg11 <> NULL THEN vArgs(i) = *vArg13
      IF i = cVars - 13 AND vArg11 <> NULL THEN vArgs(i) = *vArg14
      IF i = cVars - 14 AND vArg11 <> NULL THEN vArgs(i) = *vArg15
      IF i = cVars - 15 AND vArg11 <> NULL THEN vArgs(i) = *vArg16
   NEXT
   ' // Call the method
   SetResult(this.DispInvoke(DISPATCH_METHOD OR DISPATCH_PROPERTYGET, pwszName, @vArgs(1), cVars, m_lcid))
   ' // Return the result
   RETURN m_varResult

END FUNCTION
' =============================================================


Notice that you have to pass the number of parameters, including the optional ones, as the second parameter.

Seems to be working fine. Usage will tell if I have to do more changes.

These new classes will allows me, among other thinds, to implement a Dictionary object, WMI classes, etc.

José Roca

#20
This example has allowed me to test that the Invoke method works fine with OUT variant parameters.


' ========================================================================================
' CDispInvoke test
' ========================================================================================

#include once "win/wbemcli.bi"
#include "Afx/CDispInvoke.inc"
using Afx

' ========================================================================================

' // We need to initialize the COM library before calling CoGetObject
OleInitialize NULL

' // Connect to WMI using a moniker
DIM pDisp AS IDispatch PTR
DIM wszDisplayName AS WSTRING * 260 = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
DIM hr AS HRESULT = CoGetObject(@wszDisplayName, NULL, @IID_IDispatch, @pDisp)
DIM pReg AS CDispInvoke = pDisp
' // To check for success, see if the value returned by the DispPtr method is not null
IF pReg.DispPtr = NULL THEN OleUninitialize : END

' %HKEY_LOCAL_MACHINE - The value must be specified as an string and in decimal, not hexadecimal.
DIM cvDefKey AS CVAR = "2147483650"
DIM cvPath AS CVAR = $"Software\Microsoft\Windows NT\CurrentVersion"
DIM cvValue AS CVAR = "ProductName"
DIM cvRes AS CVAR

' // The fourth parameter is an OUT parameter
' // We need to pass a VT_BYREF variant
DIM vResult AS VARIANT
DIM cvResult AS CVAR
cvResult.AssignRef(@vResult, VT_VARIANT)

' // Call the method - Returns 0 on success or an error code
cvRes = pReg.Invoke("GetStringValue", 4, cvDefKey, cvPath, cvValue, cvResult)
IF cvRes.ValInt = 0 THEN print cvResult.ToStr ELSE print "Error " & cvRes.ValInt

' // Uninitialize the COM library
OleUninitialize
     
PRINT
PRINT "Press any key..."
SLEEP


In general, the result value is returned as the result of the call to Invoke. However, this GetString method, returns S_OK or an error code, and expects a VT_BYREF variant where to return the result value.


José Roca

Besides NEWCOM, that creates a new instance of an object, PowerBASIC provides GETCOM and ANYCOM.

The following functions untested attempt to provide such functionality. However, as I don't have Office installed, I can't test them. If somebody has Office installed and is willing to try them, I will incorporate them to AfxCom.inc if they work fine.


' ========================================================================================
' If the requested object is in an EXE (out-of-process server), such Office applications,
' and it is running and registered in the Running Object Table (ROT), AfxGetCom will
' return a pointer to its interface. AfxAnyCom will first try to use an existing, running
' application if available, or it will create a new instance if not.
' Be aware that AfxGetCom can fail under if Office is running but not registered in the ROT.
' When an Office application starts, it does not immediately register its running objects.
' This optimizes the application's startup process. Instead of registering at startup, an
' Office application registers its running objects in the ROT once it loses focus. Therefore,
' if you attempt to use GetObject or GetActiveObject to attach to a running instance of an
' Office application before the application has lost focus, you might receive an error.
' See: https://support.microsoft.com/en-us/help/238610/getobject-or-getactiveobject-cannot-find-a-running-office-application
' ========================================================================================
PRIVATE FUNCTION AfxGetCom (BYREF wszProgID AS CONST WSTRING) AS ANY PTR
   DIM classID AS CLSID, pUnk AS ANY PTR
   CLSIDFromProgID(wszProgID, @classID)
   IF IsEqualGuid(@classID, @IID_NULL) THEN RETURN NULL
   IF GetActiveObject(@classID, NULL, @pUnk) = S_OK THEN RETURN pUnk
END FUNCTION
' ========================================================================================
' ========================================================================================
PRIVATE FUNCTION AfxAnyCom (BYREF wszProgID AS CONST WSTRING) AS ANY PTR
   DIM classID AS CLSID, pUnk AS ANY PTR
   pUnk = AfxGetCom(wszProgID)
   IF pUnk THEN RETURN pUnk
   CLSIDFromProgID(wszProgID, @classID)
   IF IsEqualGuid(@classID, @IID_NULL) THEN RETURN NULL
   CoCreateInstance(@classID, NULL, CLSCTX_INPROC_SERVER, @IID_IUnknown, @pUnk)
   RETURN pUnk
END FUNCTION
' ========================================================================================


José Roca

#22
Forgot to say that, besides of constants like AFX_LONG or VT_I4, you can also use strings to specify the variant type when creating a CVAR or assigning a value to it: "BOOL", "BYTE", "UBYTE", "SHORT", "USHORT", "INT", "UINT", "LONG" , "ULONG", "LONGINT", "ULONGINT", "NULL", "ARRAY". They should be easier to remember.

José Roca

#23
Found a strange problem with the CDispInvoke class.

See: http://www.freebasic.net/forum/viewtopic.php?f=6&p=234143#p234143

Problem solved. The file AfcCOM.inc was missing NAMESPACE Afx / END NAMESPACE.

José Roca

#24
Hi Paul,

The above compile problem is undetected by the WinFBE editor. It is checking for "ERROR!", "LINKING FAILED:", ""LINKING:" and "WARNING", but in my failed compile what can be found is "error: '_ZTSN14AFX_IDISPATCH_E' undeclared here (not in a function)" and "compiling C failed: 'C:\Users\Pepe\FreeBasic64\bin\win64\gcc.exe' terminated with exit code 1".


FreeBASIC Compiler - Version 1.05.0 (01-31-2016), built for win64 (64bit)
Copyright (C) 2004-2016 The FreeBASIC development team.
standalone
target:       win64, x86-64, 64bit
compiling:    C:\Users\Pepe\FreeBasic64\AfxTests\CDispInvoke\WMI_Test_02.bas -o C:\Users\Pepe\FreeBasic64\AfxTests\CDispInvoke\WMI_Test_02.c (main module)
compiling C:  C:\Users\Pepe\FreeBasic64\bin\win64\gcc.exe -m64 -march=x86-64 -S -nostdlib -nostdinc -Wall -Wno-unused-label -Wno-unused-function -Wno-unused-variable -Wno-unused-but-set-variable -Wno-main -Werror-implicit-function-declaration -O0 -fno-strict-aliasing -frounding-math -fno-math-errno -fno-exceptions -fno-unwind-tables -fno-asynchronous-unwind-tables -masm=intel "C:\Users\Pepe\FreeBasic64\AfxTests\CDispInvoke\WMI_Test_02.c" -o "C:\Users\Pepe\FreeBasic64\AfxTests\CDispInvoke\WMI_Test_02.asm"
C:\Users\Pepe\FreeBasic64\AfxTests\CDispInvoke\WMI_Test_02.c:2178:115: error: '_ZTSN14AFX_IDISPATCH_E' undeclared here (not in a function)
static struct $8fb_RTTI$ _ZTSN3AFX19AFX_ISWBEMDATETIME_E = { (void*)0ull, (uint8*)"N3AFX19AFX_ISWBEMDATETIME_E", &_ZTSN14AFX_IDISPATCH_E };
                                                                                                                   ^
compiling C failed: 'C:\Users\Pepe\FreeBasic64\bin\win64\gcc.exe' terminated with exit code 1


So you should also check for "ERROR:" and for "COMPILING C FAILED:".

Paul Squires

Thanks Jose, I will check/correct as soon as I get home from my trip. A few things needed to be done with WinFBE.
Paul Squires
PlanetSquires Software
WinFBE Editor and Visual Designer

aloberr

Jose I have tested your GDIPLUS classes without succees
here is an exemple without classes
#Include "windows.bi"
#Include "win/gdiplus.bi"
Using GDIPLUS

Dim Shared gdiplusToken As ULONG_PTR
Dim Shared GraphicObject As GpGraphics Ptr
Dim Shared BluePenObject  As GpPen Ptr
Dim Shared RedPenObject  As GpPen Ptr
Dim Shared GreenPenObject As GpPen Ptr


'Units
Const UnitWorld      = 0 ' -- World coordinate (non-physical unit)
Const UnitDisplay    = 1 ' -- Variable -- for PageTransform only
Const UnitPixel      = 2 ' -- Each unit is one device pixel.
Const UnitPoint      = 3 ' -- Each unit is a printer's point, or 1/72 inch.
Const UnitInch       = 4 ' -- Each unit is 1 inch.
Const UnitDocument   = 5 ' -- Each unit is 1/300 inch.
Const UnitMillimeter = 6 ' -- Each unit is 1 millimeter.



'Quality Modes
Const QualityModeInvalid   = -1
Const QualityModeDefault   =  0
Const QualityModeLow       =  1
Const QualityModeHigh      =  2


 


Function MakeColor(a As Byte,r As Byte,g As Byte,b As Byte)As Long
Return (b Or g Shl 8 Or r Shl 16 Or a Shl 24)
End Function





function InitGDIPlus() As ULONG_PTR
Dim ULONG_PTR_01 As ULONG_PTR
Dim GDIPLUSSTARTUPINPUT_01 As GDIPLUSSTARTUPINPUT
GDIPLUSSTARTUPINPUT_01.GdiplusVersion = 1
If (GdiplusStartup(@ULONG_PTR_01, @GDIPLUSSTARTUPINPUT_01, NULL) <> 0) Then
Print "FAIL"
EndIf
Return ULONG_PTR_01
End Function

Sub ExitGDIPlus(gdiplusTk  As ULONG_PTR)
  GdiplusShutdown(gdiplusTk)
End sub

Sub ExecuteGDIPlus(hdc As HDC)
  gdiplusToken = InitGDIPlus()
  If gdiplusToken Then
    'GdipCreateFromHWND(hwnd,@GraphicObject)
    GdipCreateFromHDC(hdc,@GraphicObject)
    GdipCreatePen1( MakeColor(255,0,0,255),8.0,UnitPixel,@BluePenObject)
    GdipCreatePen1( MakeColor(255,255,0,0),4.0,UnitPixel,@RedPenObject)
    GdipCreatePen1( MakeColor(255,0,255,0),2.5,UnitPixel,@GreenPenObject)
    GdipSetPenStartCap( BluePenObject,LineCapArrowAnchor)
    GdipSetPenEndCap( BluePenObject,LineCapRoundAnchor)
    GdipDrawLineI(GraphicObject,BluePenObject,40,40,500,40)
    GdipSetPenEndCap(RedPenObject,LineCapArrowAnchor)
    GdipDrawArcI(GraphicObject,RedPenObject,100,100,200,200,0.0,180.0)
     
    GdipSetSmoothingMode(GraphicObject,SmoothingModeAntiAlias)
    GdipDrawArcI(GraphicObject,RedPenObject,90,100,220,210,0.0,180.0)
   
    GdipSetSmoothingMode(GraphicObject,SmoothingModeNone)
    GdipSetPenEndCap(RedPenObject,LineCapNoAnchor)
    GdipDrawBezierI(GraphicObject,RedPenObject,200,100,300,200,400,100,500,200)
    GdipDrawRectangleI(GraphicObject,GreenPenObject,300,300,100,100)
    GdipDeletePen(BluePenObject)
    GdipDeletePen(RedPenObject)
    GdipDeletePen(GreenPenObject)
    GdipDeleteGraphics(GraphicObject)
    ExitGDIPlus(gdiplusToken)
  EndIf
End Sub



Function WndProc(hWnd As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM) As Integer
Dim ps As PAINTSTRUCT
Static As HDC compHdc,hdc
Select Case uMsg
Case WM_CLOSE
DeleteDC(compHdc)
PostQuitMessage(0)
Case WM_CREATE
hdc=GetDC(GetDesktopWindow)
compHdc=CreateCompatibleDC(hdc)
Var bitmap = CreateCompatibleBitmap(hdc,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN))
SelectObject(compHdc,bitmap)
DeleteObject(bitmap)
ReleaseDC(GetDesktopWindow,hdc)
ExecuteGDIPlus(compHdc)
InvalidateRect(hwnd,0,0)
Case WM_PAINT
BeginPaint(hWnd,@ps)
BitBlt(ps.hdc,ps.rcPaint.left,ps.rcPaint.top,ps.rcPaint.right-ps.rcPaint.left,ps.rcPaint.bottom-ps.rcPaint.top,compHdc,ps.rcPaint.left,ps.rcPaint.top,SRCCOPY)
EndPaint(hWnd,@ps)
Return 0
Case Else
Return DefWindowProc(hWnd,uMsg,wParam,lParam)
End Select
End Function


Dim wc As WNDCLASSEX
Dim  msg As MSG

With wc
.hInstance=GetModuleHandle(0)
.cbSize=SizeOf(WNDCLASSEX)
.style=CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc=@WndProc
.lpszClassName=StrPtr("classe")
.hCursor=LoadCursor(NULL,IDC_ARROW)
End With
RegisterClassEx(@wc)
CreateWindowEx(0,wc.lpszClassName,"DrawGDI+",WS_OVERLAPPEDWINDOW Or WS_VISIBLE,200,200,640,480,0,0,wc.hInstance,0)

While GetMessage(@msg,0,0,0)
TranslateMessage(@msg)
DispatchMessage(@msg)
Wend

José Roca

You should post your test using the GDI+ classes. Otherwise, I can't see if you're doing something wrong.

José Roca

#28
This is the translation using my framework:


' ########################################################################################
' Microsoft Windows
' File: PenGetEndCap.bas
' Contents: GDI+ - PenGetEndCap example
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2016 Jose Roca. Freeware. Use at your own risk.
' THIS CODE AND INFORMATION IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
' EXPRESSED OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE IMPLIED WARRANTIES OF
' MERCHANTABILITY AND/OR FITNESS FOR A PARTICULAR PURPOSE.
' ########################################################################################

#define UNICODE
#INCLUDE ONCE "Afx/CWindow.inc"
#INCLUDE ONCE "Afx/CGdiPlus/CGdiPlus.inc"
#INCLUDE ONCE "Afx/CGraphCtx.inc"
USING Afx

CONST IDC_GRCTX = 1001

DECLARE FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                          BYVAL hPrevInstance AS HINSTANCE, _
                          BYVAL szCmdLine AS ZSTRING PTR, _
                          BYVAL nCmdShow AS LONG) AS LONG

   END WinMain(GetModuleHandleW(NULL), NULL, COMMAND(), SW_NORMAL)

' // Forward declaration
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

' ========================================================================================
SUB DrawGraphics (BYVAL hdc AS HDC)

   ' // Create a graphics object from the window device context
   DIM GraphicObject AS CGpGraphics = hdc
   ' // Get the DPI scaling ratios
   DIM rxRatio AS SINGLE = GraphicObject.GetDpiX / 96
   DIM ryRatio AS SINGLE = GraphicObject.GetDpiY / 96
   ' // Set the scale transform
   GraphicObject.ScaleTransform(rxRatio, ryRatio)

   ' // Create Pen objects
   DIM BluePenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 0, 255), 8)
   DIM RedPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 255, 0, 0), 4)
   DIM GreenPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 255, 0), 2.5)

   ' // Set the end caps of the pens and draw a line and am arc
   BluePenObject.SetStartCap(LineCapArrowAnchor)
   BluePenObject.SetEndCap(LineCapRoundAnchor)
   GraphicObject.DrawLine(@BluePenObject, 40, 40, 500, 40)
   RedPenObject.SetEndCap(LineCapArrowAnchor)
   GraphicObject.DrawArc(@RedPenObject, 100, 100, 200, 200, 0, 180)
     

   ' // Draw an arc
   GraphicObject.SetSmoothingMode(SmoothingModeAntiAlias)
   GraphicObject.DrawArc(@RedPenObject, 90, 100, 220, 210, 0, 180)

   ' // Draw a Bezier curve and a rectangle
   GraphicObject.SetSmoothingMode(SmoothingModeNone)
   RedPenObject.SetEndCap(LineCapNoAnchor)
   GraphicObject.DrawBezier(@GreenPenObject, 200, 100, 300, 200, 400, 100, 500, 200)
   GraphicObject.DrawRectangle(@GreenPenObject, 300, 300, 100, 100)

END SUB
' ========================================================================================

' ========================================================================================
' Main
' ========================================================================================
FUNCTION WinMain (BYVAL hInstance AS HINSTANCE, _
                  BYVAL hPrevInstance AS HINSTANCE, _
                  BYVAL szCmdLine AS ZSTRING PTR, _
                  BYVAL nCmdShow AS LONG) AS LONG

   ' // Set process DPI aware
   ' // The recommended way is to use a manifest file
   AfxSetProcessDPIAware

   ' // Initialize GDI+
   DIM token AS ULONG_PTR = AfxGdipInit

   ' // Create the main window
   DIM pWindow AS CWindow
   ' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
   pWindow.Create(NULL, "GDI+ PenGetEndCap", @WndProc)
   ' // Chante the window style
   pWindow.WindowStyle = WS_OVERLAPPED OR WS_CAPTION OR WS_SYSMENU
   ' // Size it by setting the wanted width and height of its client area
   pWindow.SetClientSize(640, 480)
   ' // Center the window
   pWindow.Center

   ' // Add a graphic control
   DIM pGraphCtx AS CGraphCtx = CGraphCtx(@pWindow, IDC_GRCTX, "", 0, 0, pWindow.ClientWidth, pWindow.ClientHeight)
   pGraphCtx.Clear BGR(0, 0, 0)
   ' // Get the memory device context of the graphic control
   DIM hdc AS HDC = pGraphCtx.GetMemDc
   ' // Draw the graphics
   DrawGraphics(hdc)

   ' // Displays the window and dispatches the Windows messages
   FUNCTION = pWindow.DoEvents(nCmdShow)

   ' // Shutdown GDI+
   AfxGdipShutdown(token)

END FUNCTION
' ========================================================================================

' ========================================================================================
' Main window procedure
' ========================================================================================
FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT

   SELECT CASE uMsg

      CASE WM_COMMAND
         SELECT CASE GET_WM_COMMAND_ID(wParam, lParam)
            CASE IDCANCEL
               ' // If ESC key pressed, close the application by sending an WM_CLOSE message
               IF GET_WM_COMMAND_CMD(wParam, lParam) = BN_CLICKED THEN
                  SendMessageW hwnd, WM_CLOSE, 0, 0
                  EXIT FUNCTION
               END IF
         END SELECT

    CASE WM_DESTROY
         ' // Ends the application by sending a WM_QUIT message
         PostQuitMessage(0)
         EXIT FUNCTION

   END SELECT

   ' // Default processing of Windows messages
   FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)

END FUNCTION
' ========================================================================================


The relevant code (the one that draws with GDI+) is:


' ========================================================================================
SUB DrawGraphics (BYVAL hdc AS HDC)

   ' // Create a graphics object from the window device context
   DIM GraphicObject AS CGpGraphics = hdc
   ' // Get the DPI scaling ratios
   DIM rxRatio AS SINGLE = GraphicObject.GetDpiX / 96
   DIM ryRatio AS SINGLE = GraphicObject.GetDpiY / 96
   ' // Set the scale transform
   GraphicObject.ScaleTransform(rxRatio, ryRatio)

   ' // Create Pen objects
   DIM BluePenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 0, 255), 8)
   DIM RedPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 255, 0, 0), 4)
   DIM GreenPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 255, 0), 2.5)

   ' // Set the end caps of the pens and draw a line and am arc
   BluePenObject.SetStartCap(LineCapArrowAnchor)
   BluePenObject.SetEndCap(LineCapRoundAnchor)
   GraphicObject.DrawLine(@BluePenObject, 40, 40, 500, 40)
   RedPenObject.SetEndCap(LineCapArrowAnchor)
   GraphicObject.DrawArc(@RedPenObject, 100, 100, 200, 200, 0, 180)
     

   ' // Draw an arc
   GraphicObject.SetSmoothingMode(SmoothingModeAntiAlias)
   GraphicObject.DrawArc(@RedPenObject, 90, 100, 220, 210, 0, 180)

   ' // Draw a Bezier curve and a rectangle
   GraphicObject.SetSmoothingMode(SmoothingModeNone)
   RedPenObject.SetEndCap(LineCapNoAnchor)
   GraphicObject.DrawBezier(@GreenPenObject, 200, 100, 300, 200, 400, 100, 500, 200)
   GraphicObject.DrawRectangle(@GreenPenObject, 300, 300, 100, 100)

END SUB
' ========================================================================================


This part is to make it DPI aware. You don't need it if your application is not dpi ware.


   ' // Get the DPI scaling ratios
   DIM rxRatio AS SINGLE = GraphicObject.GetDpiX / 96
   DIM ryRatio AS SINGLE = GraphicObject.GetDpiY / 96
   ' // Set the scale transform
   GraphicObject.ScaleTransform(rxRatio, ryRatio)


José Roca

And this is your program modified to work with my classes:


#Include "windows.bi"
'#Include "win/gdiplus.bi"
'Using GDIPLUS
#INCLUDE ONCE "Afx/CGdiPlus/CGdiPlus.inc"
USING Afx

Dim Shared gdiplusToken As ULONG_PTR
'Dim Shared GraphicObject As GpGraphics Ptr
'Dim Shared BluePenObject  As GpPen Ptr
'Dim Shared RedPenObject  As GpPen Ptr
'Dim Shared GreenPenObject As GpPen Ptr


'Units
'Const UnitWorld      = 0 ' -- World coordinate (non-physical unit)
'Const UnitDisplay    = 1 ' -- Variable -- for PageTransform only
'Const UnitPixel      = 2 ' -- Each unit is one device pixel.
'Const UnitPoint      = 3 ' -- Each unit is a printer's point, or 1/72 inch.
'Const UnitInch       = 4 ' -- Each unit is 1 inch.
'Const UnitDocument   = 5 ' -- Each unit is 1/300 inch.
'Const UnitMillimeter = 6 ' -- Each unit is 1 millimeter.



'Quality Modes
'Const QualityModeInvalid   = -1
'Const QualityModeDefault   =  0
'Const QualityModeLow       =  1
'Const QualityModeHigh      =  2


'Function MakeColor(a As Byte,r As Byte,g As Byte,b As Byte)As Long
' Return (b Or g Shl 8 Or r Shl 16 Or a Shl 24)
'End Function

function InitGDIPlus() As ULONG_PTR
Dim ULONG_PTR_01 As ULONG_PTR
Dim GDIPLUSSTARTUPINPUT_01 As GDIPLUSSTARTUPINPUT
GDIPLUSSTARTUPINPUT_01.GdiplusVersion = 1
If (GdiplusStartup(@ULONG_PTR_01, @GDIPLUSSTARTUPINPUT_01, NULL) <> 0) Then
Print "FAIL"
EndIf
Return ULONG_PTR_01
End Function

Sub ExitGDIPlus(BYVAL gdiplusTk As ULONG_PTR)
  GdiplusShutdown(gdiplusTk)
End sub

Sub ExecuteGDIPlus(hdc As HDC)
'  gdiplusToken = InitGDIPlus()
'  If gdiplusToken Then
   ' // Create a graphics object from the window device context
   DIM GraphicObject AS CGpGraphics = hdc
   ' // Get the DPI scaling ratios
   DIM rxRatio AS SINGLE = GraphicObject.GetDpiX / 96
   DIM ryRatio AS SINGLE = GraphicObject.GetDpiY / 96
   ' // Set the scale transform
   GraphicObject.ScaleTransform(rxRatio, ryRatio)

   ' // Create Pen objects
   DIM BluePenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 0, 255), 8)
   DIM RedPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 255, 0, 0), 4)
   DIM GreenPenObject AS CGpPen = CGpPen(GDIP_ARGB(255, 0, 255, 0), 2.5)

   ' // Set the end caps of the pens and draw a line and am arc
   BluePenObject.SetStartCap(LineCapArrowAnchor)
   BluePenObject.SetEndCap(LineCapRoundAnchor)
   GraphicObject.DrawLine(@BluePenObject, 40, 40, 500, 40)
   RedPenObject.SetEndCap(LineCapArrowAnchor)
   GraphicObject.DrawArc(@RedPenObject, 100, 100, 200, 200, 0, 180)
     

   ' // Draw an arc
   GraphicObject.SetSmoothingMode(SmoothingModeAntiAlias)
   GraphicObject.DrawArc(@RedPenObject, 90, 100, 220, 210, 0, 180)

   ' // Draw a Bezier curve and a rectangle
   GraphicObject.SetSmoothingMode(SmoothingModeNone)
   RedPenObject.SetEndCap(LineCapNoAnchor)
   GraphicObject.DrawBezier(@GreenPenObject, 200, 100, 300, 200, 400, 100, 500, 200)
   GraphicObject.DrawRectangle(@GreenPenObject, 300, 300, 100, 100)
'    ExitGDIPlus(gdiplusToken)
'  EndIf
End Sub



Function WndProc(hWnd As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM) As Integer
Dim ps As PAINTSTRUCT
Static As HDC compHdc,hdc
Select Case uMsg
Case WM_CLOSE
DeleteDC(compHdc)
PostQuitMessage(0)
Case WM_CREATE
hdc=GetDC(GetDesktopWindow)
compHdc=CreateCompatibleDC(hdc)
Var bitmap = CreateCompatibleBitmap(hdc,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN))
SelectObject(compHdc,bitmap)
DeleteObject(bitmap)
ReleaseDC(GetDesktopWindow,hdc)
ExecuteGDIPlus(compHdc)
InvalidateRect(hwnd,0,0)
Case WM_PAINT
BeginPaint(hWnd,@ps)
BitBlt(ps.hdc,ps.rcPaint.left,ps.rcPaint.top,ps.rcPaint.right-ps.rcPaint.left,ps.rcPaint.bottom-ps.rcPaint.top,compHdc,ps.rcPaint.left,ps.rcPaint.top,SRCCOPY)
EndPaint(hWnd,@ps)
Return 0
Case Else
Return DefWindowProc(hWnd,uMsg,wParam,lParam)
End Select
End Function

gdiplusToken = InitGDIPlus()

Dim wc As WNDCLASSEX
Dim  msg As MSG

With wc
.hInstance=GetModuleHandle(0)
.cbSize=SizeOf(WNDCLASSEX)
.style=CS_HREDRAW Or CS_VREDRAW
.lpfnWndProc=@WndProc
.lpszClassName=StrPtr("classe")
.hCursor=LoadCursor(NULL,IDC_ARROW)
End With
RegisterClassEx(@wc)
CreateWindowEx(0,wc.lpszClassName,"DrawGDI+",WS_OVERLAPPEDWINDOW Or WS_VISIBLE,200,200,640,480,0,0,wc.hInstance,0)

While GetMessage(@msg,0,0,0)
TranslateMessage(@msg)
DispatchMessage(@msg)
Wend

ExitGDIPlus(gdiplusToken)