Incorporates some changes commented in the thread for the previous version and two new classes:
CShortcut - Class to create shortcuts
CRegExp - VB Script regular expressions
On-line help: http://www.jose.it-berater.org/CWindow/CWindowFramework.html
I think that we already have a very complete framework. If you notice bugs in the code or mistakes in the documentation (quite probably, since this is the most boring part, and there are about 3400 pages) please report them.
Update: The file CWindow_RC_29_Update.rar contains an update of AfxGdiPlus.inc, with two new proedures to load textures for OpenGL, and a new file, AfxGlut.inc, with procedures for generating 3-D geometric objects. You will need them if you intend to follow the upcoming OpenGL examples.
DL'ing it now. Just curious, will you still support offline help?
Yes, but first I have to solve an small problem.
CWindow OpenGL template.
' ########################################################################################
' Microsoft Windows
' File: CW_OGL_Template.fbtpl
' Contents: CWindow OpenGL Template
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 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 "GL/windows/glu.bi"
USING Afx
CONST WindowCaption = "OpenGL Template"
CONST GL_WINDOWWIDTH = 640 ' Window width
CONST GL_WINDOWHEIGHT = 450 ' Window height
CONST GL_BITSPERPEL = 24 ' Color resolution in bits per pixel
CONST GL_DEPTHBITS = 32 ' Depth of the depth (z-axis) buffer
DIM SHARED g_hDC AS HDC ' Device context handle
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 declarations
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE SUB SetupScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB Cleanup (BYVAL hwnd AS HWND)
DECLARE SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
DECLARE SUB ProcessMouse (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wKeyState AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG)
' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB SetupScene (BYVAL hwnd AS HWND, 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
END SUB
' =======================================================================================
' =======================================================================================
' Resize the scene
' =======================================================================================
SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
END SUB
' =======================================================================================
' =======================================================================================
' Draw the scene
' =======================================================================================
SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // Clear the screen buffer
glClear GL_COLOR_BUFFER_BIT OR GL_DEPTH_BUFFER_BIT
' // Reset the view
glLoadIdentity
' ------------------------------------------------------------------------------------
' Sample code. Replace it with your own code.
' ------------------------------------------------------------------------------------
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
END SUB
' =======================================================================================
' =======================================================================================
' Cleanup
' =======================================================================================
SUB Cleanup (BYVAL hwnd AS HWND)
' ------------------------------------------------------------------------------------
' Insert your code here
' ------------------------------------------------------------------------------------
END SUB
' =======================================================================================
' =======================================================================================
' Processes keystrokes
' Parameters:
' * hwnd = Window hande
' * vKeyCode = Virtual key code
' * bKeyDown = %TRUE if key is pressed; %FALSE if it is released
' =======================================================================================
SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
SELECT CASE vKeyCode
CASE VK_ESCAPE
' // Quit if Esc key pressed
SendMessageW hwnd, WM_CLOSE, 0, 0
END SELECT
END SUB
' =======================================================================================
' =======================================================================================
' Processes mouse clicks and movement
' Parameters:
' * hwnd = Window hande
' * uMsg = Windows message
' * wKeyState = Indicates whether various virtual keys are down.
' MK_CONTROL The CTRL key is down.
' MK_LBUTTON The left mouse button is down.
' MK_MBUTTON The middle mouse button is down.
' MK_RBUTTON The right mouse button is down.
' MK_SHIFT The SHIFT key is down.
' MK_XBUTTON1 Windows 2000/XP: The first X button is down.
' MK_XBUTTON2 Windows 2000/XP: The second X button is down.
' * x = x-coordinate of the cursor
' * y = y-coordinate of the cursor
' =======================================================================================
SUB ProcessMouse (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wKeyState AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG)
SELECT CASE uMsg
CASE WM_LBUTTONDOWN
CASE WM_LBUTTONUP
CASE WM_MOUSEMOVE
END SELECT
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
' // Creates the main window
DIM pWindow AS CWindow
' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
' // Create the window
DIM hwndMain AS HWND = pWindow.Create(NULL, WindowCaption, @WndProc)
' // Don't erase nackground
pWindow.ClassStyle = CS_DBLCLKS
' // Black brush
pWindow.Brush = CreateSolidBrush(BGR(0, 0, 0))
' // Sizes the window by setting the wanted width and height of its client area
pWindow.SetClientSize(GL_WINDOWWIDTH, GL_WINDOWHEIGHT)
' // Centers the window
pWindow.Center
' // Retrieve the coordinates of the window's client area
DIM rc AS RECT
GetClientRect hwndMain, @rc
' // Initialize the new OpenGL window
SetupScene hwndMain, rc.Right - rc.Left, rc.Bottom - rc.Top
' // Show the window
ShowWindow hwndMain, nCmdShow
UpdateWindow hwndMain
' // Optional timing code
DIM t AS DOUBLE
DIM t0 AS DOUBLE
DIM fps AS DOUBLE
DIM nFrames AS LONG
DIM wszCaption AS WSTRING * 256
' // Process Windows messages
DIM msg AS tagMSG
DIM bDone AS BOOLEAN
STATIC vKeyCode AS LONG
STATIC bKeyDown AS BOOLEAN
DO UNTIL bDone
' // Windows message pump
DO WHILE PeekMessage(@msg, NULL, 0, 0, PM_REMOVE)
IF msg.message = WM_QUIT THEN
bDone = TRUE
ELSE
IF msg.message = WM_KEYDOWN THEN
vKeyCode = msg.wParam
bKeyDown = TRUE
ELSEIF msg.message = WM_KEYUP THEN
vKeyCode = msg.wParam
bKeyDown = FALSE
END IF
TranslateMessage @msg
DispatchMessage @msg
END IF
LOOP
' // Optional timing code
' // Get time and mouse position
t = INT(TIMER)
' // Calculate and display FPS (frames per second)
IF t > t0 OR nFrames = 0 THEN
fps = nFrames \ (t - t0)
wszCaption = WindowCaption & " (" & STR(fps) & "FPS)"
SetWindowTextW hwndMain, @wszCaption
t0 = t
nFrames = 0
END IF
nFrames = nFrames + 1
' // Draw the scene
DrawScene hwndMain, GL_WINDOWWIDTH, GL_WINDOWHEIGHT
' // Exchange the front and back buffers
SwapBuffers g_hDC
' // Process the keystrokes
IF vKeyCode THEN
ProcessKeystrokes hwndMain, vKeyCode, bKeyDown
vKeyCode = 0
END IF
LOOP
FUNCTION = msg.wParam
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
DIM pf AS LONG
DIM pfd AS PIXELFORMATDESCRIPTOR
STATIC hRC AS HGLRC
SELECT CASE uMsg
CASE WM_SYSCOMMAND
' // Disable the Windows screensaver
IF (wParam AND &hFFF0) = SC_SCREENSAVE THEN EXIT FUNCTION
' // Close the window
IF (wParam AND &hFFF0) = SC_CLOSE THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE WM_CREATE
' // Retrieve the device context handle
g_hDC = GetDC(hwnd)
' // Fill the PIXELFORMATDESCRIPTOR structure
pfd.nSize = SIZEOF(PIXELFORMATDESCRIPTOR) ' Size of the structure
pfd.nVersion = 1 ' Version number
pfd.dwFlags = PFD_DRAW_TO_WINDOW _ ' Format must support window
OR PFD_SUPPORT_OPENGL _ ' Format must support OpenGL
OR PFD_DOUBLEBUFFER ' Format must support double buffering
pfd.iPixelType = PFD_TYPE_RGBA ' Request an RGBA format
pfd.cColorBits = GL_BITSPERPEL ' Number of color bitplanes in each color buffer
pfd.cRedBits = 0 ' Number of red bitplanes in each RGBA color buffer.
pfd.cRedShift = 0 ' Shift count for red bitplanes in each RGBA color buffer.
pfd.cGreenBits = 0 ' Number of green bitplanes in each RGBA color buffer.
pfd.cGreenShift = 0 ' Shift count for green bitplanes in each RGBA color buffer.
pfd.cBlueBits = 0 ' Number of blue bitplanes in each RGBA color buffer.
pfd.cBlueShift = 0 ' Shift count for blue bitplanes in each RGBA color buffer.
pfd.cAlphaBits = 0 ' Number of alpha bitplanes in each RGBA color buffer
pfd.cAlphaShift = 0 ' Shift count for alpha bitplanes in each RGBA color buffer.
pfd.cAccumBits = 0 ' Total number of bitplanes in the accumulation buffer.
pfd.cAccumRedBits = 0 ' Number of red bitplanes in the accumulation buffer.
pfd.cAccumGreenBits = 0 ' Number of gree bitplanes in the accumulation buffer.
pfd.cAccumBlueBits = 0 ' Number of blue bitplanes in the accumulation buffer.
pfd.cAccumAlphaBits = 0 ' Number of alpha bitplanes in the accumulation buffer.
pfd.cDepthBits = GL_DEPTHBITS ' Depth of the depth (z-axis) buffer.
pfd.cStencilBits = 0 ' Depth of the stencil buffer.
pfd.cAuxBuffers = 0 ' Number of auxiliary buffers.
pfd.iLayerType = 0 ' PFD_MAIN_PLANE ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.bReserved = 0 ' Number of overlay and underlay planes.
pfd.dwLayerMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.dwVisibleMask = 0 ' Transparent color or index of an underlay plane.
pfd.dwDamageMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
' // Find a matching pixel format
pf = ChoosePixelFormat(g_hDC, @pfd)
IF pf = 0 THEN
MessageBoxW hwnd, "Can't find a suitable pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Set the pixel format
IF SetPixelFormat(g_hDC, pf, @pfd) = FALSE THEN
MessageBoxW hwnd, "Can't set the pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Create a new OpenGL rendering context
hRC = wglCreateContext(g_hDC)
IF hRC = NULL THEN
MessageBoxW hwnd, "Can't create an OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Make it current
IF wglMakeCurrent(g_hDC, hRC) = FALSE THEN
MessageBoxW hwnd, "Can't activate the OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
EXIT FUNCTION
CASE WM_DESTROY
' // Clean resources
Cleanup hwnd
' // Release the device and rendering contexts
wglMakeCurrent g_hDC, NULL
' // Make the rendering context no longer current
wglDeleteContext hRC
' // Release the device context
ReleaseDC hwnd, g_hDC
' // Ends the application by sending a WM_QUIT message
PostQuitMessage(0)
EXIT FUNCTION
CASE WM_SIZE
ResizeScene hwnd, LOWORD(lParam), HIWORD(lParam)
EXIT FUNCTION
CASE WM_LBUTTONDOWN, WM_LBUTTONUP, WM_MOUSEMOVE
ProcessMouse hwnd, uMsg, wParam, LOWORD(lParam), HIWORD(lParam)
EXIT FUNCTION
END SELECT
' // Default processing of Windows messages
FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
NeHe Lesson 4.
' ########################################################################################
' Microsoft Windows
' File: CW_OGL_Nehe_04
' Contents: CWindow OpenGL - NeHe lesson 4
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 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 "GL/windows/glu.bi"
USING Afx
CONST WindowCaption = "NeHe Lesson 4"
CONST GL_WINDOWWIDTH = 640 ' Window width
CONST GL_WINDOWHEIGHT = 450 ' Window height
CONST GL_BITSPERPEL = 24 ' Color resolution in bits per pixel
CONST GL_DEPTHBITS = 32 ' Depth of the depth (z-axis) buffer
DIM SHARED g_hDC AS HDC ' Device context handle
DIM SHARED rtri AS SINGLE
DIM SHARED rquad AS SINGLE
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 declarations
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE SUB SetupScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB SetupScene (BYVAL hwnd AS HWND, 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
END SUB
' =======================================================================================
' =======================================================================================
' Resize the scene
' =======================================================================================
SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
END SUB
' =======================================================================================
' =======================================================================================
' Draw the scene
' =======================================================================================
SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
glRotatef rtri, 0.0, 1.0, 0.0 ' Rotate the triangle on the Y axis
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
glLoadIdentity ' Reset The Current Modelview Matrix
glTranslatef 1.5, 0.0, -6.0 ' Move right 1.5 units and into the screen 6.0
glRotatef rquad, 1.0, 0.0, 0.0 ' Rotate the quad on the X axis
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
rtri = rtri + 0.2 ' Increase the rotation variable for the triangle ( New )
rquad = rquad - 0.15 ' Decrease the rotation variable for the quad ( New )
END SUB
' =======================================================================================
' =======================================================================================
' Processes keystrokes
' Parameters:
' * hwnd = Window hande
' * vKeyCode = Virtual key code
' * bKeyDown = %TRUE if key is pressed; %FALSE if it is released
' =======================================================================================
SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
SELECT CASE vKeyCode
CASE VK_ESCAPE
' // Quit if Esc key pressed
SendMessageW hwnd, WM_CLOSE, 0, 0
END SELECT
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
' // Creates the main window
DIM pWindow AS CWindow
' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
' // Create the window
DIM hwndMain AS HWND = pWindow.Create(NULL, WindowCaption, @WndProc)
' // Don't erase nackground
pWindow.ClassStyle = CS_DBLCLKS
' // Black brush
pWindow.Brush = CreateSolidBrush(BGR(0, 0, 0))
' // Sizes the window by setting the wanted width and height of its client area
pWindow.SetClientSize(GL_WINDOWWIDTH, GL_WINDOWHEIGHT)
' // Centers the window
pWindow.Center
' // Retrieve the coordinates of the window's client area
DIM rc AS RECT
GetClientRect hwndMain, @rc
' // Initialize the new OpenGL window
SetupScene hwndMain, rc.Right - rc.Left, rc.Bottom - rc.Top
' // Show the window
ShowWindow hwndMain, nCmdShow
UpdateWindow hwndMain
' // Optional timing code
DIM t AS DOUBLE
DIM t0 AS DOUBLE
DIM fps AS DOUBLE
DIM nFrames AS LONG
DIM wszCaption AS WSTRING * 256
' // Process Windows messages
DIM msg AS tagMSG
DIM bDone AS BOOLEAN
STATIC vKeyCode AS LONG
STATIC bKeyDown AS BOOLEAN
DO UNTIL bDone
' // Windows message pump
DO WHILE PeekMessage(@msg, NULL, 0, 0, PM_REMOVE)
IF msg.message = WM_QUIT THEN
bDone = TRUE
ELSE
IF msg.message = WM_KEYDOWN THEN
vKeyCode = msg.wParam
bKeyDown = TRUE
ELSEIF msg.message = WM_KEYUP THEN
vKeyCode = msg.wParam
bKeyDown = FALSE
END IF
TranslateMessage @msg
DispatchMessage @msg
END IF
LOOP
' // Optional timing code
' // Get time and mouse position
t = INT(TIMER)
' // Calculate and display FPS (frames per second)
IF t > t0 OR nFrames = 0 THEN
fps = nFrames \ (t - t0)
wszCaption = WindowCaption & " (" & STR(fps) & "FPS)"
SetWindowTextW hwndMain, @wszCaption
t0 = t
nFrames = 0
END IF
nFrames = nFrames + 1
' // Draw the scene
DrawScene hwndMain, GL_WINDOWWIDTH, GL_WINDOWHEIGHT
' // Exchange the front and back buffers
SwapBuffers g_hDC
' // Process the keystrokes
IF vKeyCode THEN
ProcessKeystrokes hwndMain, vKeyCode, bKeyDown
vKeyCode = 0
END IF
LOOP
FUNCTION = msg.wParam
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
DIM pf AS LONG
DIM pfd AS PIXELFORMATDESCRIPTOR
STATIC hRC AS HGLRC
SELECT CASE uMsg
CASE WM_SYSCOMMAND
' // Disable the Windows screensaver
IF (wParam AND &hFFF0) = SC_SCREENSAVE THEN EXIT FUNCTION
' // Close the window
IF (wParam AND &hFFF0) = SC_CLOSE THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE WM_CREATE
' // Retrieve the device context handle
g_hDC = GetDC(hwnd)
' // Fill the PIXELFORMATDESCRIPTOR structure
pfd.nSize = SIZEOF(PIXELFORMATDESCRIPTOR) ' Size of the structure
pfd.nVersion = 1 ' Version number
pfd.dwFlags = PFD_DRAW_TO_WINDOW _ ' Format must support window
OR PFD_SUPPORT_OPENGL _ ' Format must support OpenGL
OR PFD_DOUBLEBUFFER ' Format must support double buffering
pfd.iPixelType = PFD_TYPE_RGBA ' Request an RGBA format
pfd.cColorBits = GL_BITSPERPEL ' Number of color bitplanes in each color buffer
pfd.cRedBits = 0 ' Number of red bitplanes in each RGBA color buffer.
pfd.cRedShift = 0 ' Shift count for red bitplanes in each RGBA color buffer.
pfd.cGreenBits = 0 ' Number of green bitplanes in each RGBA color buffer.
pfd.cGreenShift = 0 ' Shift count for green bitplanes in each RGBA color buffer.
pfd.cBlueBits = 0 ' Number of blue bitplanes in each RGBA color buffer.
pfd.cBlueShift = 0 ' Shift count for blue bitplanes in each RGBA color buffer.
pfd.cAlphaBits = 0 ' Number of alpha bitplanes in each RGBA color buffer
pfd.cAlphaShift = 0 ' Shift count for alpha bitplanes in each RGBA color buffer.
pfd.cAccumBits = 0 ' Total number of bitplanes in the accumulation buffer.
pfd.cAccumRedBits = 0 ' Number of red bitplanes in the accumulation buffer.
pfd.cAccumGreenBits = 0 ' Number of gree bitplanes in the accumulation buffer.
pfd.cAccumBlueBits = 0 ' Number of blue bitplanes in the accumulation buffer.
pfd.cAccumAlphaBits = 0 ' Number of alpha bitplanes in the accumulation buffer.
pfd.cDepthBits = GL_DEPTHBITS ' Depth of the depth (z-axis) buffer.
pfd.cStencilBits = 0 ' Depth of the stencil buffer.
pfd.cAuxBuffers = 0 ' Number of auxiliary buffers.
pfd.iLayerType = 0 ' PFD_MAIN_PLANE ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.bReserved = 0 ' Number of overlay and underlay planes.
pfd.dwLayerMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.dwVisibleMask = 0 ' Transparent color or index of an underlay plane.
pfd.dwDamageMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
' // Find a matching pixel format
pf = ChoosePixelFormat(g_hDC, @pfd)
IF pf = 0 THEN
MessageBoxW hwnd, "Can't find a suitable pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Set the pixel format
IF SetPixelFormat(g_hDC, pf, @pfd) = FALSE THEN
MessageBoxW hwnd, "Can't set the pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Create a new OpenGL rendering context
hRC = wglCreateContext(g_hDC)
IF hRC = NULL THEN
MessageBoxW hwnd, "Can't create an OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Make it current
IF wglMakeCurrent(g_hDC, hRC) = FALSE THEN
MessageBoxW hwnd, "Can't activate the OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
EXIT FUNCTION
CASE WM_DESTROY
' // Release the device and rendering contexts
wglMakeCurrent g_hDC, NULL
' // Make the rendering context no longer current
wglDeleteContext hRC
' // Release the device context
ReleaseDC hwnd, g_hDC
' // Ends the application by sending a WM_QUIT message
PostQuitMessage(0)
EXIT FUNCTION
CASE WM_SIZE
ResizeScene hwnd, LOWORD(lParam), HIWORD(lParam)
EXIT FUNCTION
END SELECT
' // Default processing of Windows messages
FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
NeHe Lesson 5.
' ########################################################################################
' Microsoft Windows
' File: CW_OGL_Nehe_04
' Contents: CWindow OpenGL - NeHe lesson 5
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 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 "GL/windows/glu.bi"
USING Afx
CONST WindowCaption = "NeHe Lesson 5"
CONST GL_WINDOWWIDTH = 640 ' Window width
CONST GL_WINDOWHEIGHT = 450 ' Window height
CONST GL_BITSPERPEL = 24 ' Color resolution in bits per pixel
CONST GL_DEPTHBITS = 32 ' Depth of the depth (z-axis) buffer
DIM SHARED g_hDC AS HDC ' Device context handle
DIM SHARED rtri AS SINGLE
DIM SHARED rquad AS SINGLE
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 declarations
DECLARE FUNCTION WndProc (BYVAL hwnd AS HWND, BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM) AS LRESULT
DECLARE SUB SetupScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB SetupScene (BYVAL hwnd AS HWND, 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
END SUB
' =======================================================================================
' =======================================================================================
' Resize the scene
' =======================================================================================
SUB ResizeScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
END SUB
' =======================================================================================
' =======================================================================================
' Draw the scene
' =======================================================================================
SUB DrawScene (BYVAL hwnd AS HWND, BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
glRotatef rtri, 0.0, 1.0, 0.0 ' Rotate the triangle on the Y axis
glBegin GL_TRIANGLES
' Front
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Front)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f -1.0, -1.0, 1.0 ' Left of triangle (Front)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f 1.0, -1.0, 1.0 ' Right of triangle (Front)
' Right
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Right)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f 1.0, -1.0, 1.0 ' Left of triangle (Right)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f 1.0, -1.0, -1.0 ' Right of triangle (Right)
' Back
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Back)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f 1.0, -1.0, -1.0 ' Left of triangle (Back)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f -1.0, -1.0, -1.0 ' Right of triangle (Back)
' Left
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Left)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f -1.0, -1.0, -1.0 ' Left of triangle (Left)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f -1.0, -1.0, 1.0 ' Right of triangle (Left)
glEnd
glLoadIdentity
glTranslatef 1.5, 0.0, -7.0 ' Move right 1.5 units and into the screen
glRotatef rquad, 1.0, 1.0, 1.0 ' Rotate the quad on the X axis
glBegin GL_QUADS
glColor3f 0.0, 1.0, 0.0 ' Set the color to green
glVertex3f 1.0, 1.0, -1.0 ' Top right of the quad (Top)
glVertex3f -1.0, 1.0, -1.0 ' Top left of the quad (Top)
glVertex3f -1.0, 1.0, 1.0 ' Bottom left of the quad (Top)
glVertex3f 1.0, 1.0, 1.0 ' Bottom right of the quad (Top)
glColor3f 1.0, 0.5, 0.0 ' Set the color to orange
glVertex3f 1.0, -1.0, 1.0 ' Top right of the quad (Bottom)
glVertex3f -1.0, -1.0, 1.0 ' Top left of the quad (Bottom)
glVertex3f -1.0, -1.0, -1.0 ' Bottom left of the quad (Bottom)
glVertex3f 1.0, -1.0, -1.0 ' Bottom right of the quad (Bottom)
glColor3f 1.0, 0.0, 0.0 ' Set the color to red
glVertex3f 1.0, 1.0, 1.0 ' Top right of the quad (Front)
glVertex3f -1.0, 1.0, 1.0 ' Top left of the quad (Front)
glVertex3f -1.0, -1.0, 1.0 ' Bottom left of the quad (Front)
glVertex3f 1.0, -1.0, 1.0 ' Bottom right of the quad (Front)
glColor3f 1.0, 1.0, 0.0 ' Set the color to yellow
glVertex3f 1.0, -1.0, -1.0 ' Top right of the quad (Back)
glVertex3f -1.0, -1.0, -1.0 ' Top left of the quad (Back)
glVertex3f -1.0, 1.0, -1.0 ' Bottom left of the quad (Back)
glVertex3f 1.0, 1.0, -1.0 ' Bottom right of the quad (Back)
glColor3f 0.0, 0.0, 1.0 ' Set the color to blue
glVertex3f -1.0, 1.0, 1.0 ' Top right of the quad (Left)
glVertex3f -1.0, 1.0, -1.0 ' Top left of the quad (Left)
glVertex3f -1.0, -1.0, -1.0 ' Bottom left of the quad (Left)
glVertex3f -1.0, -1.0, 1.0 ' Bottom right of the quad (Left)
glColor3f 1.0, 0.0, 1.0 ' Set the color to violet
glVertex3f 1.0, 1.0, -1.0 ' Top right of the quad (Right)
glVertex3f 1.0, 1.0, 1.0 ' Top left of the quad (Right)
glVertex3f 1.0, -1.0, 1.0 ' Bottom left of the quad (Right)
glVertex3f 1.0, -1.0, -1.0 ' Bottom right of the quad (Right)
glEnd
rtri = rtri + 0.2 ' Increase the rotation variable for the triangle
rquad = rquad - 0.15 ' Decrease the rotation variable for the quad
END SUB
' =======================================================================================
' =======================================================================================
' Processes keystrokes
' Parameters:
' * hwnd = Window hande
' * vKeyCode = Virtual key code
' * bKeyDown = %TRUE if key is pressed; %FALSE if it is released
' =======================================================================================
SUB ProcessKeystrokes (BYVAL hwnd AS HWND, BYVAL vKeyCode AS LONG, BYVAL bKeyDown AS LONG)
SELECT CASE vKeyCode
CASE VK_ESCAPE
' // Quit if Esc key pressed
SendMessageW hwnd, WM_CLOSE, 0, 0
END SELECT
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
' // Creates the main window
DIM pWindow AS CWindow
' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
' // Create the window
DIM hwndMain AS HWND = pWindow.Create(NULL, WindowCaption, @WndProc)
' // Don't erase nackground
pWindow.ClassStyle = CS_DBLCLKS
' // Black brush
pWindow.Brush = CreateSolidBrush(BGR(0, 0, 0))
' // Sizes the window by setting the wanted width and height of its client area
pWindow.SetClientSize(GL_WINDOWWIDTH, GL_WINDOWHEIGHT)
' // Centers the window
pWindow.Center
' // Retrieve the coordinates of the window's client area
DIM rc AS RECT
GetClientRect hwndMain, @rc
' // Initialize the new OpenGL window
SetupScene hwndMain, rc.Right - rc.Left, rc.Bottom - rc.Top
' // Show the window
ShowWindow hwndMain, nCmdShow
UpdateWindow hwndMain
' // Optional timing code
DIM t AS DOUBLE
DIM t0 AS DOUBLE
DIM fps AS DOUBLE
DIM nFrames AS LONG
DIM wszCaption AS WSTRING * 256
' // Process Windows messages
DIM msg AS tagMSG
DIM bDone AS BOOLEAN
STATIC vKeyCode AS LONG
STATIC bKeyDown AS BOOLEAN
DO UNTIL bDone
' // Windows message pump
DO WHILE PeekMessage(@msg, NULL, 0, 0, PM_REMOVE)
IF msg.message = WM_QUIT THEN
bDone = TRUE
ELSE
IF msg.message = WM_KEYDOWN THEN
vKeyCode = msg.wParam
bKeyDown = TRUE
ELSEIF msg.message = WM_KEYUP THEN
vKeyCode = msg.wParam
bKeyDown = FALSE
END IF
TranslateMessage @msg
DispatchMessage @msg
END IF
LOOP
' // Optional timing code
' // Get time and mouse position
t = INT(TIMER)
' // Calculate and display FPS (frames per second)
IF t > t0 OR nFrames = 0 THEN
fps = nFrames \ (t - t0)
wszCaption = WindowCaption & " (" & STR(fps) & "FPS)"
SetWindowTextW hwndMain, @wszCaption
t0 = t
nFrames = 0
END IF
nFrames = nFrames + 1
' // Draw the scene
DrawScene hwndMain, GL_WINDOWWIDTH, GL_WINDOWHEIGHT
' // Exchange the front and back buffers
SwapBuffers g_hDC
' // Process the keystrokes
IF vKeyCode THEN
ProcessKeystrokes hwndMain, vKeyCode, bKeyDown
vKeyCode = 0
END IF
LOOP
FUNCTION = msg.wParam
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
DIM pf AS LONG
DIM pfd AS PIXELFORMATDESCRIPTOR
STATIC hRC AS HGLRC
SELECT CASE uMsg
CASE WM_SYSCOMMAND
' // Disable the Windows screensaver
IF (wParam AND &hFFF0) = SC_SCREENSAVE THEN EXIT FUNCTION
' // Close the window
IF (wParam AND &hFFF0) = SC_CLOSE THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE WM_CREATE
' // Retrieve the device context handle
g_hDC = GetDC(hwnd)
' // Fill the PIXELFORMATDESCRIPTOR structure
pfd.nSize = SIZEOF(PIXELFORMATDESCRIPTOR) ' Size of the structure
pfd.nVersion = 1 ' Version number
pfd.dwFlags = PFD_DRAW_TO_WINDOW _ ' Format must support window
OR PFD_SUPPORT_OPENGL _ ' Format must support OpenGL
OR PFD_DOUBLEBUFFER ' Format must support double buffering
pfd.iPixelType = PFD_TYPE_RGBA ' Request an RGBA format
pfd.cColorBits = GL_BITSPERPEL ' Number of color bitplanes in each color buffer
pfd.cRedBits = 0 ' Number of red bitplanes in each RGBA color buffer.
pfd.cRedShift = 0 ' Shift count for red bitplanes in each RGBA color buffer.
pfd.cGreenBits = 0 ' Number of green bitplanes in each RGBA color buffer.
pfd.cGreenShift = 0 ' Shift count for green bitplanes in each RGBA color buffer.
pfd.cBlueBits = 0 ' Number of blue bitplanes in each RGBA color buffer.
pfd.cBlueShift = 0 ' Shift count for blue bitplanes in each RGBA color buffer.
pfd.cAlphaBits = 0 ' Number of alpha bitplanes in each RGBA color buffer
pfd.cAlphaShift = 0 ' Shift count for alpha bitplanes in each RGBA color buffer.
pfd.cAccumBits = 0 ' Total number of bitplanes in the accumulation buffer.
pfd.cAccumRedBits = 0 ' Number of red bitplanes in the accumulation buffer.
pfd.cAccumGreenBits = 0 ' Number of gree bitplanes in the accumulation buffer.
pfd.cAccumBlueBits = 0 ' Number of blue bitplanes in the accumulation buffer.
pfd.cAccumAlphaBits = 0 ' Number of alpha bitplanes in the accumulation buffer.
pfd.cDepthBits = GL_DEPTHBITS ' Depth of the depth (z-axis) buffer.
pfd.cStencilBits = 0 ' Depth of the stencil buffer.
pfd.cAuxBuffers = 0 ' Number of auxiliary buffers.
pfd.iLayerType = 0 ' PFD_MAIN_PLANE ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.bReserved = 0 ' Number of overlay and underlay planes.
pfd.dwLayerMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
pfd.dwVisibleMask = 0 ' Transparent color or index of an underlay plane.
pfd.dwDamageMask = 0 ' Ignored. Earlier implementations of OpenGL used this member, but it is no longer used.
' // Find a matching pixel format
pf = ChoosePixelFormat(g_hDC, @pfd)
IF pf = 0 THEN
MessageBoxW hwnd, "Can't find a suitable pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Set the pixel format
IF SetPixelFormat(g_hDC, pf, @pfd) = FALSE THEN
MessageBoxW hwnd, "Can't set the pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Create a new OpenGL rendering context
hRC = wglCreateContext(g_hDC)
IF hRC = NULL THEN
MessageBoxW hwnd, "Can't create an OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
' // Make it current
IF wglMakeCurrent(g_hDC, hRC) = FALSE THEN
MessageBoxW hwnd, "Can't activate the OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
EXIT FUNCTION
CASE WM_DESTROY
' // Release the device and rendering contexts
wglMakeCurrent g_hDC, NULL
' // Make the rendering context no longer current
wglDeleteContext hRC
' // Release the device context
ReleaseDC hwnd, g_hDC
' // Ends the application by sending a WM_QUIT message
PostQuitMessage(0)
EXIT FUNCTION
CASE WM_SIZE
ResizeScene hwnd, LOWORD(lParam), HIWORD(lParam)
EXIT FUNCTION
END SELECT
' // Default processing of Windows messages
FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
I'm going to add the following functions to AfxGdiPlus.inc. They allow to use textures with OpenGL and are not limited to bitmaps, but can also use .jpg, .png, etc.
' =======================================================================================
' Loads an image from disk an converts it to a texture for use with OpenGL.
' Parameters:
' * wszFileSpec = [in] The path of the image.
' * TextureWidth = [out] Width of the texture.
' * TextureHeight = [out] Height of the texture.
' * strTextureData = [out] The texture data.
' Return value:
' * ERROR_FILE_NOT_FOUND = File not found.
' * ERROR_INVALID_DATA = Bad image size.
' * A GdiPlus status value.
' =======================================================================================
PRIVATE FUNCTION AfxGdipLoadTexture OVERLOAD (BYREF wszFileName AS WSTRING, BYREF TextureWidth AS LONG, _
BYREF TextureHeight AS LONG, BYREF strTextureData AS STRING) AS LONG
DIM pImage AS GpImage PTR, pThumb AS GpImage PTR
DIM nStatus AS GpStatus, pixColor AS GDIP_BGRA
DIM pTextureData AS ANY PTR
' // Initialize Gdiplus
DIM token AS ULONG_PTR = AfxGdipInit
IF token = NULL THEN FUNCTION = 18 : EXIT FUNCTION ' // GdiplusNotInitialized
DO
' // Load the image from file
nStatus = GdipLoadImageFromFile(@wszFileName, @pImage)
IF nStatus <> 0 THEN EXIT DO
' // Get the image width and height
nStatus = GdipGetImageWidth(pImage, @TextureWidth)
IF nStatus <> 0 THEN EXIT DO
nStatus = GdipGetImageHeight(pImage, @TextureHeight)
IF nStatus <> 0 THEN EXIT DO
IF TextureWidth <> TextureHeight THEN nStatus = ERROR_INVALID_DATA : EXIT DO
' // Check if the texture if a power of 2
DIM nCount AS LONG, nPos AS LONG = 1
DO
nPos = INSTR(nPos, BIN(TextureWidth), "1")
IF nPos = 0 THEN EXIT DO
nCount += 1
nPos += 1
LOOP
IF nCount <> 1 THEN nStatus = ERROR_INVALID_DATA : EXIT DO
' // Get a thumbnail image from the Image object
nStatus = GdipGetImageThumbnail(pImage, TextureWidth, TextureHeight, @pThumb, NULL, NULL)
IF nStatus <> 0 THEN EXIT DO
' // Flip the image vertically
nStatus = GdipImageRotateFlip(pThumb, 6) ' 6 = RotateNoneFlipY
IF nStatus <> 0 THEN EXIT DO
' // Fill the strings with nulls
strTextureData = STRING(TextureWidth * TextureHeight * 4, CHR(0))
' // Get a pointer to the beginning of the string buffer
pTextureData = STRPTR(strTextureData)
' // Swap the red and blue colors
FOR y AS LONG = 0 TO TextureWidth - 1
FOR x AS LONG = 0 TO TextureHeight - 1
GdipBitmapGetPixel(cast(GpBitmap PTR, pThumb), x, y, @pixColor.color)
SWAP pixColor.red, pixColor.blue
memcpy pTextureData, @pixColor.color, 4
pTextureData += 4
NEXT
NEXT
EXIT DO
LOOP
' // Free the image
IF pImage THEN GdipDisposeImage pImage
' // Shutdown Gdiplus
GdiplusShutdown token
FUNCTION = nStatus
END FUNCTION
' =======================================================================================
' =======================================================================================
' Loads an image from a resource file an converts it to a texture for use with OpenGL.
' Parameters:
' * hInstance = [in] The instance handle.
' * wszResourceName = [in] The name of the resource
' * TextureWidth = [out] Width of the texture.
' * TextureHeight = [out] Height of the texture.
' * strTextureData = [out] The texture data.
' Return value:
' * E_POINTER = Invalid pointer.
' * ERROR_FILE_NOT_FOUND = File not found.
' * ERROR_INVALID_DATA = Bad image size.
' * A GdiPlus status value.
' =======================================================================================
PRIVATE FUNCTION AfxGdipLoadTexture OVERLOAD (BYVAL hInstance AS HINSTANCE, _
BYREF wszResourceName AS WSTRING, BYREF TextureWidth AS LONG, _
BYREF TextureHeight AS LONG, BYREF strTextureData AS STRING) AS LONG
DIM pImage AS GpImage PTR, pThumb AS GpImage PTR
DIM nStatus AS GpStatus, pixColor AS GDIP_BGRA
DIM pTextureData AS ANY PTR
DIM hResource AS HRSRC ' // Resource handle
DIM pResourceData AS ANY PTR ' // Pointer to the resoruce data
DIM hGlobal AS HGLOBAL ' // Global memory handle
DIM pGlobalBuffer AS ANY PTR ' // Pointer to global memory buffer
DIM pImageStream AS IStream PTR ' // IStream interface pointer
DIM imageSize AS DWORD ' // Image size
' // Initialize Gdiplus
DIM token AS ULONG_PTR = AfxGdipInit
IF token = NULL THEN FUNCTION = 18 : EXIT FUNCTION ' // GdiplusNotInitialized
DO
' // Find the resource and lock it
hResource = FindResourceW(cast(HMODULE, hInstance), @wszResourceName, RT_RCDATA)
IF hResource = NULL THEN nStatus = E_POINTER : EXIT DO
imageSize = SizeofResource(cast(HMODULE, hInstance), hResource)
IF imageSize = 0 THEN nStatus = ERROR_INVALID_DATA : EXIT DO
pResourceData = LockResource(LoadResource(cast(HMODULE, hInstance), hResource))
IF pResourceData = NULL THEN nStatus = E_POINTER : EXIT DO
' // Allocate memory to hold the image
hGlobal = GlobalAlloc(GMEM_MOVEABLE, imageSize)
IF hGlobal = NULL THEN nStatus = E_POINTER : EXIT DO
' // Lock the memory
pGlobalBuffer = GlobalLock(hGlobal)
IF pGlobalBuffer = NULL THEN nStatus = E_POINTER : EXIT DO
' // Copy the image from the resource file to global memory
memcpy pGlobalBuffer, pResourceData, imageSize
' // Create an stream in global memory
DIM hr AS HRESULT = CreateStreamOnHGlobal(hGlobal, FALSE, @pImageStream)
IF hr <> S_OK THEN nStatus = hr : EXIT DO
' // Create a bitmap from the data contained in the stream
nStatus = GdipCreateBitmapFromStream(pImageStream, @cast(GpBitmap PTR, pImage))
IF nStatus <> 0 THEN EXIT DO
' // Get the image width and height
nStatus = GdipGetImageWidth(pImage, @TextureWidth)
IF nStatus <> 0 THEN EXIT DO
nStatus = GdipGetImageHeight(pImage, @TextureHeight)
IF nStatus <> 0 THEN EXIT DO
IF TextureWidth <> TextureHeight THEN nStatus = ERROR_INVALID_DATA : EXIT DO
' // Check if the texture if a power of 2
DIM nCount AS LONG, nPos AS LONG = 1
DO
nPos = INSTR(nPos, BIN(TextureWidth), "1")
IF nPos = 0 THEN EXIT DO
nCount += 1
nPos += 1
LOOP
IF nCount <> 1 THEN nStatus = ERROR_INVALID_DATA : EXIT DO
' // Get a thumbnail image from the Image object
nStatus = GdipGetImageThumbnail(pImage, TextureWidth, TextureHeight, @pThumb, NULL, NULL)
IF nStatus <> 0 THEN EXIT DO
' // Flip the image vertically
nStatus = GdipImageRotateFlip(pThumb, 6) ' 6 = RotateNoneFlipY
IF nStatus <> 0 THEN EXIT DO
' // Fill the strings with nulls
strTextureData = STRING(TextureWidth * TextureHeight * 4, CHR(0))
' // Get a pointer to the beginning of the string buffer
pTextureData = STRPTR(strTextureData)
' // Swap the red and blue colors
FOR y AS LONG = 0 TO TextureWidth - 1
FOR x AS LONG = 0 TO TextureHeight - 1
GdipBitmapGetPixel(cast(GpBitmap PTR, pThumb), x, y, @pixColor.color)
SWAP pixColor.red, pixColor.blue
memcpy pTextureData, @pixColor.color, 4
pTextureData += 4
NEXT
NEXT
EXIT DO
LOOP
' // Release if IStream interface
IF pImageStream THEN pImageStream->lpvtbl->Release(pImageStream)
' // Unlock the memory
IF pGlobalBuffer THEN GlobalUnlock(pGlobalBuffer)
' // Free the global memory
IF hGlobal THEN GlobalFree(hGlobal)
' // Free the image
IF pImage THEN GdipDisposeImage pImage
' // Shutdown Gdiplus
GdiplusShutdown token
FUNCTION = nStatus
END FUNCTION
' =======================================================================================
To test it, I have translated the NeHe example 6, that uses a bitmap for the texture.
The code, the executable and the bitmap can be found in the attached .rar file. Source code not listed here because it exceeds the narrow limit of 20,000 characters of this forum.
Because I often have posted translated examples of OpenGL and other graphics technologies, some people have mistankely thought that I'm an expert in them. I know very little about OpenGL and my translations are mainly meant to test the wrappers that I wrote.
Instead of the previously posted template, I'm going to use a class. This will avoid the use of global variables.
Will also use a simple timer technique that I learned from Patrice Terrier that allows smooth repainting when resizing.
I'm also going to adapt the glut high level functions to draw teapots, cubes, spheres, etc., to Free Basic. This will free us of having to use a third party dll.
I will also write many examples. Next version will be the OpenGL one.
As soon as I post a new version of the framework, new ideas come to my mind :)
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! :)
A new template using a class. These Free Basic classes are very good to encapsulate code nd avoid the use of messing globals. This template makes very easy to use OpenGL, without the need of third party libraries like glut or SDL.
Note that a timer is used to trigger redrawing (a tip learned from Patrice Terrier). This technique keeps CPU usage very low and allows smoother rendering.
' ########################################################################################
' Microsoft Windows
' File: CW_GL_Template.fbtpl
' Contents: CWindow OpenGL Template
' Compiler: FreeBasic 32 & 64 bit
' Copyright (c) 2017 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 "GL/windows/glu.bi"
USING Afx
CONST GL_WINDOWWIDTH = 600 ' Window width
CONST GL_WINDOWHEIGHT = 400 ' Window height
CONST GL_WindowCaption = "NeHe Lesson 5" ' Window caption
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
' =======================================================================================
' OpenGL class
' =======================================================================================
TYPE COGL
Public:
m_hDC AS HDC ' // Device context handle
m_hRC AS HGLRC ' // Rendering context handle
m_hwnd AS HWND ' // Window handle
Private:
rtri AS SINGLE
rquad AS SINGLE
Public:
DECLARE CONSTRUCTOR (BYVAL hwnd AS HWND, BYVAL nBitsPerPel AS LONG = 32, BYVAL cDepthBits AS LONG = 24)
DECLARE DESTRUCTOR
DECLARE SUB SetupScene (BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB ResizeScene (BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
DECLARE SUB RenderScene
DECLARE SUB ProcessKeystrokes (BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM)
DECLARE SUB ProcessMouse (BYVAL uMsg AS UINT, BYVAL wKeyState AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG)
END TYPE
' =======================================================================================
' ========================================================================================
' COGL constructor
' ========================================================================================
CONSTRUCTOR COGL (BYVAL hwnd AS HWND, BYVAL nBitsPerPel AS LONG = 32, BYVAL cDepthBits AS LONG = 24)
DO ' // Using a fake loop to avoid the use of GOTO or nested IFs/END IFs
' // Get the device context
IF hwnd = NULL THEN EXIT DO
m_hwnd = hwnd
m_hDC = GetDC(m_hwnd)
IF m_hDC = NULL THEN EXIT DO
' // Pixel format
DIM pfd AS PIXELFORMATDESCRIPTOR
pfd.nSize = SIZEOF(PIXELFORMATDESCRIPTOR)
pfd.nVersion = 1
pfd.dwFlags = PFD_DRAW_TO_WINDOW OR PFD_SUPPORT_OPENGL OR PFD_DOUBLEBUFFER
pfd.iPixelType = PFD_TYPE_RGBA
pfd.cColorBits = nBitsPerPel
pfd.cDepthBits = cDepthBits
' // Find a matching pixel format
DIM pf AS LONG = ChoosePixelFormat(m_hDC, @pfd)
IF pf = 0 THEN
MessageBoxW hwnd, "Can't find a suitable pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
EXIT DO
END IF
' // Set the pixel format
IF SetPixelFormat(m_hDC, pf, @pfd) = FALSE THEN
MessageBoxW hwnd, "Can't set the pixel format", _
"Error", MB_OK OR MB_ICONEXCLAMATION
EXIT DO
END IF
' // Create a new OpenGL rendering context
m_hRC = wglCreateContext(m_hDC)
IF m_hRC = NULL THEN
MessageBoxW hwnd, "Can't create an OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
EXIT DO
END IF
' // Make it current
IF wglMakeCurrent(m_hDC, m_hRC) = FALSE THEN
MessageBoxW hwnd, "Can't activate the OpenGL rendering context", _
"Error", MB_OK OR MB_ICONEXCLAMATION
EXIT DO
END IF
' // Exit the fake loop
EXIT DO
LOOP
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' COGL Destructor
' ========================================================================================
DESTRUCTOR COGL
' // Release the device and rendering contexts
wglMakeCurrent m_hDC, NULL
' // Make the rendering context no longer current
wglDeleteContext m_hRC
' // Release the device context
ReleaseDC m_hwnd, m_hDC
END DESTRUCTOR
' ========================================================================================
' =======================================================================================
' All the setup goes here
' =======================================================================================
SUB COGL.SetupScene (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
END SUB
' =======================================================================================
' =======================================================================================
' Resize the scene
' =======================================================================================
SUB COGL.ResizeScene (BYVAL nWidth AS LONG, BYVAL nHeight AS LONG)
' // 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
END SUB
' =======================================================================================
' =======================================================================================
' Draw the scene
' =======================================================================================
SUB COGL.RenderScene
' // 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
glRotatef rtri, 0.0, 1.0, 0.0 ' Rotate the triangle on the Y axis
glBegin GL_TRIANGLES
' Front
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Front)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f -1.0, -1.0, 1.0 ' Left of triangle (Front)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f 1.0, -1.0, 1.0 ' Right of triangle (Front)
' Right
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Right)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f 1.0, -1.0, 1.0 ' Left of triangle (Right)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f 1.0, -1.0, -1.0 ' Right of triangle (Right)
' Back
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Back)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f 1.0, -1.0, -1.0 ' Left of triangle (Back)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f -1.0, -1.0, -1.0 ' Right of triangle (Back)
' Left
glColor3f 1.0, 0.0, 0.0 ' Red
glVertex3f 0.0, 1.0, 0.0 ' Top of triangle (Left)
glColor3f 0.0, 0.0, 1.0 ' Blue
glVertex3f -1.0, -1.0, -1.0 ' Left of triangle (Left)
glColor3f 0.0, 1.0, 0.0 ' Green
glVertex3f -1.0, -1.0, 1.0 ' Right of triangle (Left)
glEnd
glLoadIdentity
glTranslatef 1.5, 0.0, -7.0 ' Move right 1.5 units and into the screen
glRotatef rquad, 1.0, 1.0, 1.0 ' Rotate the quad on the X axis
glBegin GL_QUADS
glColor3f 0.0, 1.0, 0.0 ' Set the color to green
glVertex3f 1.0, 1.0, -1.0 ' Top right of the quad (Top)
glVertex3f -1.0, 1.0, -1.0 ' Top left of the quad (Top)
glVertex3f -1.0, 1.0, 1.0 ' Bottom left of the quad (Top)
glVertex3f 1.0, 1.0, 1.0 ' Bottom right of the quad (Top)
glColor3f 1.0, 0.5, 0.0 ' Set the color to orange
glVertex3f 1.0, -1.0, 1.0 ' Top right of the quad (Bottom)
glVertex3f -1.0, -1.0, 1.0 ' Top left of the quad (Bottom)
glVertex3f -1.0, -1.0, -1.0 ' Bottom left of the quad (Bottom)
glVertex3f 1.0, -1.0, -1.0 ' Bottom right of the quad (Bottom)
glColor3f 1.0, 0.0, 0.0 ' Set the color to red
glVertex3f 1.0, 1.0, 1.0 ' Top right of the quad (Front)
glVertex3f -1.0, 1.0, 1.0 ' Top left of the quad (Front)
glVertex3f -1.0, -1.0, 1.0 ' Bottom left of the quad (Front)
glVertex3f 1.0, -1.0, 1.0 ' Bottom right of the quad (Front)
glColor3f 1.0, 1.0, 0.0 ' Set the color to yellow
glVertex3f 1.0, -1.0, -1.0 ' Top right of the quad (Back)
glVertex3f -1.0, -1.0, -1.0 ' Top left of the quad (Back)
glVertex3f -1.0, 1.0, -1.0 ' Bottom left of the quad (Back)
glVertex3f 1.0, 1.0, -1.0 ' Bottom right of the quad (Back)
glColor3f 0.0, 0.0, 1.0 ' Set the color to blue
glVertex3f -1.0, 1.0, 1.0 ' Top right of the quad (Left)
glVertex3f -1.0, 1.0, -1.0 ' Top left of the quad (Left)
glVertex3f -1.0, -1.0, -1.0 ' Bottom left of the quad (Left)
glVertex3f -1.0, -1.0, 1.0 ' Bottom right of the quad (Left)
glColor3f 1.0, 0.0, 1.0 ' Set the color to violet
glVertex3f 1.0, 1.0, -1.0 ' Top right of the quad (Right)
glVertex3f 1.0, 1.0, 1.0 ' Top left of the quad (Right)
glVertex3f 1.0, -1.0, 1.0 ' Bottom left of the quad (Right)
glVertex3f 1.0, -1.0, -1.0 ' Bottom right of the quad (Right)
glEnd
rtri = rtri + 0.2 ' Increase the rotation variable for the triangle
rquad = rquad - 0.15 ' Decrease the rotation variable for the quad
' // Exchange the front and back buffers
SwapBuffers m_hdc
END SUB
' =======================================================================================
' =======================================================================================
' Processes keystrokes
' Parameters:
' * uMsg = The Windows message
' * wParam = Additional message information.
' * lParam = Additional message information.
' The contents of the wParam and lParam parameters depend on the value of the uMsg parameter.
' =======================================================================================
SUB COGL.ProcessKeystrokes (BYVAL uMsg AS UINT, BYVAL wParam AS WPARAM, BYVAL lParam AS LPARAM)
SELECT CASE uMsg
CASE WM_KEYDOWN ' // A nonsystem key has been pressed
SELECT CASE LOWORD(wParam)
CASE VK_ESCAPE
' // Send a message to close the application
SendMessageW m_hwnd, WM_CLOSE, 0, 0
END SELECT
END SELECT
END SUB
' =======================================================================================
' =======================================================================================
' Processes mouse clicks and movement
' Parameters:
' * wMsg = Windows message
' * wKeyState = Indicates whether various virtual keys are down.
' MK_CONTROL The CTRL key is down.
' MK_LBUTTON The left mouse button is down.
' MK_MBUTTON The middle mouse button is down.
' MK_RBUTTON The right mouse button is down.
' MK_SHIFT The SHIFT key is down.
' MK_XBUTTON1 Windows 2000/XP: The first X button is down.
' MK_XBUTTON2 Windows 2000/XP: The second X button is down.
' * x = x-coordinate of the cursor
' * y = y-coordinate of the cursor
' =======================================================================================
SUB COGL.ProcessMouse (BYVAL uMsg AS UINT, BYVAL wKeyState AS DWORD, BYVAL x AS LONG, BYVAL y AS LONG)
SELECT CASE uMsg
CASE WM_LBUTTONDOWN ' // Left mouse button pressed
' // Put your code here
CASE WM_LBUTTONUP ' // Left mouse button releases
' // Put your code here
CASE WM_MOUSEMOVE ' // Mouse has been moved
' // Put your code here
END SELECT
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
' // Creates the main window
DIM pWindow AS CWindow
' -or- DIM pWindow AS CWindow = "MyClassName" (use the name that you wish)
' // Create the window
DIM hwndMain AS HWND = pWindow.Create(NULL, GL_WindowCaption, @WndProc)
' // Don't erase the background
pWindow.ClassStyle = CS_DBLCLKS
' // Use a black brush
pWindow.Brush = CreateSolidBrush(BGR(0, 0, 0))
' // Sizes the window by setting the wanted width and height of its client area
pWindow.SetClientSize(GL_WINDOWWIDTH, GL_WINDOWHEIGHT)
' // Centers the window
pWindow.Center
' // Show the window
ShowWindow hwndMain, nCmdShow
UpdateWindow hwndMain
' // Message loop
DIM uMsg AS tagMsg
WHILE GetMessageW(@uMsg, NULL, 0, 0)
TranslateMessage @uMsg
DispatchMessageW @uMsg
WEND
FUNCTION = uMsg.wParam
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
STATIC pCOGL AS COGL PTR ' // Pointer to the COGL class
SELECT CASE uMsg
CASE WM_SYSCOMMAND
' // Disable the Windows screensaver
IF (wParam AND &hFFF0) = SC_SCREENSAVE THEN EXIT FUNCTION
' // Close the window
IF (wParam AND &hFFF0) = SC_CLOSE THEN
SendMessageW hwnd, WM_CLOSE, 0, 0
EXIT FUNCTION
END IF
CASE WM_CREATE
' // Initialize the new OpenGL window
pCOGL = NEW COGL(hwnd)
' // Retrieve the coordinates of the window's client area
DIM rc AS RECT
GetClientRect hwnd, @rc
' // Set up the scene
pCOGL->SetupScene rc.Right - rc.Left, rc.Bottom - rc.Top
' // Set the timer (using a timer to trigger redrawing allows a smoother rendering)
SetTimer(hwnd, 1, 0, NULL)
EXIT FUNCTION
CASE WM_DESTROY
' // Kill the timer
KillTimer(hwnd, 1)
' // Delete the COGL class
Delete pCOGL
' // Ends the application by sending a WM_QUIT message
PostQuitMessage(0)
EXIT FUNCTION
CASE WM_TIMER
' // Render the scene
pCOGL->RenderScene
EXIT FUNCTION
CASE WM_SIZE
pCOGL->ResizeScene LOWORD(lParam), HIWORD(lParam)
EXIT FUNCTION
CASE WM_KEYDOWN
' // Process keystrokes
pCOGL->ProcessKeystrokes uMsg, wParam, lParam
EXIT FUNCTION
CASE WM_LBUTTONDOWN, WM_LBUTTONUP, WM_MOUSEMOVE
' // Process mouse movements
pCOGL->ProcessMouse uMsg, wParam, LOWORD(lParam), HIWORD(lParam)
END SELECT
' // Default processing of Windows messages
FUNCTION = DefWindowProcW(hwnd, uMsg, wParam, lParam)
END FUNCTION
' ========================================================================================
I have begin to translate the high level glut functions. Tested the torus, cube, sphere and octahedron and got them working. See capture.
Almost finished. I have had a hard time with the teapot because Free Basic multidimensional arrays work like C, not as PowerBASIC. Makes it easier to translate C code, but I was not used to it.
I have added an update to the first post.
AfxGlut.inc contains the following procedures:
AfxGlutSolidCone / AfxGlutWireCone
AfxGlutSolidCube / AfxGlutWireCube
AfxGlutSolidCylinder / AfxGlutWireCylinder
AfxGlutSolidDodecahedron / AfxGlutWireDodecahedron
AfxGlutSolidIcosahedron / AfxGlutWireIcosahedron
AfxGlutSolidOctahedron / AfxGlutWireOctahedron
AfxGlutSolidRhombicDodecahedron / AfxGlutWireRhombicDodecahedron
AfxGlutSolidSphere / AfxGlutWireSphere
AfxGlutSolidTeapot / AfxGlutWireTeapot
AfxGlutSolidTetrahedron / AfxGlutWireTetrahedron
AfxGlutSolidTorus / AfxGlutWireTorus
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.
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.
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.
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.
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.
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.
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
' ========================================================================================
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.
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.
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:".
Thanks Jose, I will check/correct as soon as I get home from my trip. A few things needed to be done with WinFBE.
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
You should post your test using the GDI+ classes. Otherwise, I can't see if you're doing something wrong.
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)
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)
Please note that because my CWindow version is DPI aware, the graphics are rendered with better quality than yours. If you are working at 96 DPI, you won't notice the difference, but at 192 DPI it is very appreciable.
I have modified the default value for numeric variants from LongInt to Long. Long is more widely used in COM servers, whereas LongInt has some problems with some servers.
I also have adapted my CDicObj class (Dictionary object - associative arrays), to use CVAR. Seems to work fine.
Example:
'#define _CBDICOBJ_DEBUG_ 1
#define _CVAR_DEBUG_ 1
#include "Afx/CDicObj.inc"
using Afx
' // Create an instance of the CDicObj class
DIM pDic AS CDicObj
IF pDic.DispPtr = NULL THEN END
pDic.Add "a", "Athens"
pDic.Add "b", "Madrid"
pDic.Add "c", "Roma"
print pDic.Count
print pDic.Exists("a")
print pDic.Item("a").ToStr
DIM s AS STRING = pDic.Item("b").ToStr
print s, "..."
print
print "-------------"
print
DIM cvItems AS CVAR = pDic.Items
FOR i AS LONG = cvItems.GetLBound TO cvItems.GetUBound
print cvItems.GetVariantElem(i).ToStr
NEXT
print
print "-------------"
print
DIM cvKeys AS CVAR = pDic.Keys
print "---------"
print "Keys count: ", cvKeys.GetElementCount
print "Dimensions: ", cvKeys.GetDim
print "Ipper bound: ", cvKeys.GetUBound
FOR i AS LONG = cvKeys.GetLBound TO cvKeys.GetUBound
print cvKeys.GetVariantElem(i).ToStr
NEXT
print
print "-------------"
print
pDic.RemoveAll
DIM cv AS CVAR
cv = CVAR(929292929929299292, "LONGINT")
pDic.Add 1, cv
print pDic.Item(1).ToStr
pDic.Add 2, 1234567.12
print pDic.Item(2).ToStr
pDic.Add 123.12, "Roma"
print pDic.Item(123.12).ToStr
pDic.Add 1234567890123456789, "*** Roma ***"
print pDic.Item(1234567890123456789).ToStr
PRINT
PRINT "Press any key..."
SLEEP
I have finished the new CBSTR class.
For those that like to use **, I have added LeftChars, RightChars, MidChars and several Valxxx methods.
Therefore, instead of LEFT(**cbs, 3), you can use cbs.LeftChars(3). The attemps to workaround it is what messed my previous code until I said enough.
Assignment from a CBSTR to a CWSTR, or viceversa, can be done using *
DIM cws = "Test string"
DIM cbs AS CBSTR = *cws
or using cbs = cws.sptr
A new function to check if it is a BSTR:
' ========================================================================================
' // Checks if the passed pointer is a BSTR.
' // Will return FALSE if it is a null pointer.
' // If it is an OLE string it must have a descriptor; otherwise, don't.
' // Get the length in bytes looking at the descriptor and divide by 2 to get the number of
' // unicode characters, that is the value returned by the FreeBASIC LEN operator.
' // If the retrieved length if the same that the returned by LEN, then it must be an OLE string.
' ========================================================================================
FUNCTION AfxIsBstr (BYVAL pv aS ANY PTR) AS BOOLEAN
IF pv = NULL THEN RETURN FALSE
DIM res AS DWORD = PEEK(DWORD, pv - 4) \ 2
IF res = LEN(*cast(WSTRING PTR, pv)) THEN RETURN TRUE
END FUNCTION
' ========================================================================================
Now that we have variants and BSTR support, I can recover the CSafeArray and the ADO classes. Later I will start working with the WMI classes, that promise to be very powerful.
The next version will be as hot as this summer :)
Yes that goes, I thought that the initialization of GDIplus was done internally in the principal class, and same USING GDIPLUS too. Finally I did not pay attention.
A remark why the pointers CGpPen Ptr in the Drawline procedure for example that could have been simply CGpPen
> A remark why the pointers CGpPen Ptr in the Drawline procedure for example that could have been simply CGpPen
It could have been if FB had not the nasty habit of passing an address to optional BYREF parameters. In PowerASIC I can check with VARPTR if the parameter has been omitted, e.g. IF VARPTR(x) = 0 THEN..., but with FB not because VARPTR(x) will always return a value <> 0. As in many of the methods I need to know if the parameter is null, I have used the same syntax in all of them. It would have been baffling to have to use one syntax with some methods and another with others.
Years ago, there was an attempt to adopt this FB VARPTR behavior in PowerBASIC, but I strongly opposed to it and my arguments won. it is silly to pass the address of a temporary variable for an omitted optional BYREF parameter instead of passing a null pointer, only to please some programmers that complain if a program crashes because they have tried to deference a null pointer.
> I thought that the initialization of GDIplus was done internally in the principal class
There is not a principal class. They are independent. They follow as close as possible the C++ GDI+ classes.
> and same USING GDIPLUS too.
It is. They include AfxGdiPlus.inc, where you can find:
#ifdef __FB_64BIT__
#inclib "gdiplus"
#include once "win/gdiplus-c.bi"
#else
#include once "win/ddraw.bi"
#include once "win/gdiplus.bi"
using gdiplus
#endif
A prerelease of version 30.
This is a big update:
Added support for BSTR: CBSTR class in CWSTR.inc.
Added suport for variants: CVAR class in CVAR.inc.
CDispInvoke class in CDispInvoke.inc: Allows to work with COM Automation.
CSafeArray class in CSafeArray.inc: Safe arrays support.
CDicObj class in CDicObj.inc: Dictionary object (associative arrays).
ADO classes in various files: folder Afx/CADODB.
CWinHttpRequest: Modified to work with CBSTR.
CTextStream: Modified to work with CBSTR.
CFileSys: Modified to work with CBSTR.
CRegExp: Modified to work with CBSTR.
CCDOMail: Modified to worl with CBSTR.
CGraphCtx: Modified to support OPENGL.
Will have to do more tests and update the documentation before posting it as version 30.
Meanwhile, if somebody is willing to test it (you don't need a visual designer), I can post many examples. Otherwise, why bother?
If you look at the source code and find a function like this one
PRIVATE FUNCTION CFileSys.GetDriveName (BYREF cbsPathSpec AS CBSTR) AS CBSTR
IF m_pFileSys = NULL THEN RETURN ""
DIM bstrName AS AFX_BSTR
SetResult(m_pFileSys->GetDriveName(cbsPathSpec, @bstrName))
RETURN bstrName
END FUNCTION
It may lead you to think that there is a memory leak because bstrName is not being freed with SysFreeString. Nope. We must not free it because its contents aren't copied, but its handle is attached to the returning CBSTR class, that will free the BSTR when the class is destroyed.
I'm using this technique for speed, because FUNCTION = bstrXXX, followed by SysFreeString(bstrXXX) creates a temporary CBSTR that will be returned as the result of the function at the very end, when the BSTR handle is not longer valid because it has been freed. RETURN bstrXXX works correctly, BUT then SysFreeString is not executed. PROPERTY = bstrXXX works as we like, making the returned temporary CBSTR BEFORE SysFreeString is executed, BUT the number of parameters is limited to two... One workaround would be to make a temporary copy and return it, e.g. DIM cbs AS CBSTR = bstrXXX : FUNCTION = cbs : SysFreeString(bstrXXX), BUT this is slow because we copy the data twice, first when we create the temporary CBSTR, and later when we return it.
Therefore, I'm using an hack in the CBSTR constructor that receives the handle to check if the handle belongs to a BSTR or not, and if it does, it attaches the handle to the class.
PRIVATE CONSTRUCTOR CBStr (BYREF bstrHandle AS AFX_BSTR = NULL, BYVAL fAttach AS LONG = TRUE)
CBSTR_DP("--BEGIN CBSTR CONSTRUCTOR AFX_BSTR - handle: " & .WSTR(bstrHandle) & " - Attach: " & .WSTR(fAttach))
IF bstrHandle = NULL THEN
m_bstr = SysAllocString("")
CBSTR_DP("CBSTR CONSTRUCTOR SysAllocString - " & .WSTR(m_bstr))
ELSE
' Detect if the passed handle is an OLE string
' If it is an OLE string it must have a descriptor; otherwise, don't
' Get the length in bytes looking at the descriptor and divide by 2 to get the number of
' unicode characters, that is the value returned by the FreeBASIC LEN operator.
DIM Res AS INTEGER = PEEK(DWORD, CAST(ANY PTR, bstrHandle) - 4) \ 2
' If the retrieved length if the same that the returned by LEN, then it must be an OLE string
IF Res = .LEN(*bstrHandle) AND fAttach <> FALSE THEN
CBSTR_DP("CBSTR CONSTRUCTOR AFX_BSTR - Attach handle: " & .WSTR(bstrHandle))
' Attach the passed handle to the class
m_bstr = bstrHandle
ELSE
CBSTR_DP("CBSTR CONSTRUCTOR AFX_BSTR - Alloc handle: " & .WSTR(bstrHandle))
' Allocate an OLE string with the contents of the string pointer by bstrHandle
m_bstr = SysAllocString(*bstrHandle)
END IF
END IF
CBSTR_DP("--END CBSTR CONSTRUCTOR AFX_BSTR - " & .WSTR(m_bstr))
END CONSTRUCTOR
thank you Jose Roca :)
Whatever examples you post Jose, I'll run 'em.
Rick
Jose Roca
I know how disappointing it is to have no participation, it's almost like trying to have a conversation with oneself, but I hope that you won't give up.
I already have given alternatives to most of the PowerBASIC features missing in FreeBasic. TCP support is still missing, but I have some ideas and code for a lightweight class on top of WinSock.
However, the first item in my to do list are the WMI classes, because WMI is a very powerful technology. The WMI classes will allow me to develop further classes.
I already have a WMI class to get information, e.g.
#define _CVAR_DEBUG_ 1
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.DispPtr = NULL THEN END
' // Execute a query
DIM hr AS HRESULT = pServices.ExecQuery("SELECT * FROM Win32_BIOS")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : END
' // Get the number of objects retrieved
DIM nCount AS LONG = pServices.ObjectsCount
' // Parse the collection
IF nCount THEN
DIM pDispServ AS CDispInvoke = pServices.NextObject
IF pDispServ.DispPtr THEN
PRINT "BIOS version: : "; pDispServ.Get("BIOSVersion").ToStr
PRINT "BIOS characteristics:"; pDispServ.Get("BIOSCharacteristics").ToStr
PRINT "Build number: "; pDispServ.Get("BuildNumber").ToStr
PRINT "Caption: "; pDispServ.Get("Caption").ToStr
PRINT "Current language: "; pDispServ.Get("CurrentLanguage").ToStr
PRINT "Description: "; pDispServ.Get("Description").ToStr
PRINT "Identification code: "; pDispServ.Get("IdentificationCode").ToStr
PRINT "Installable languages: "; pDispServ.Get("InstallableLanguages").ToStr
PRINT "Install date: "; pDispServ.Get("InstallDate").ToStr
PRINT "Language edition: "; pDispServ.Get("LanguageEdition").ToStr
PRINT "List of languages: "; pDispServ.Get("ListOfLanguages").ToStr
PRINT "Manufacturer: "; pDispServ.Get("Manufacturer").ToStr
PRINT "Other target OS: "; pDispServ.Get("OtherTargetOS").ToStr
PRINT "Primary BIOS: "; pDispServ.Get("PrimaryBIOS").ToStr
PRINT "Release date: "; AfxWmiTimeToDateStr(pDispServ.Get("ReleaseDate"), "dd-MM-yyyy")
PRINT "Serial number: "; pDispServ.Get("SerialNumber").ToStr
PRINT "SMBIOS BIOS version: "; pDispServ.Get("SMBIOSBIOSVersion").ToStr
PRINT "SMBIOS major version: "; pDispServ.Get("SMBIOSMajorVersion").ToStr
PRINT "SMBIOS minor version: "; pDispServ.Get("SMBIOSMinorVersion").ToStr
PRINT "SMBIOS present: "; pDispServ.Get("SMBIOSPresent").ToStr
PRINT "Software element ID: "; pDispServ.Get("SoftwareElementID").ToStr
PRINT "Software element state: "; pDispServ.Get("SoftwareElementState").ToStr
PRINT "Target operating system: "; pDispServ.Get("TargetOperatingSystem").ToStr
PRINT "Version: "; pDispServ.Get("Version").ToStr
END IF
END IF
PRINT
PRINT "Press any key..."
SLEEP
Next I will write another class to set values, e.g.
' // Connect to WMI using a moniker
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
DIM pWmiObject AS CWmiObject = pServices.Get(<class name>, e.g. "Win32_Printer")
pWmiObject.Value(<property name>, e.g. "PortName") = <value>
These classes will replace the CWmiCli one, that only works with the local computer. Using a moniger apparently makes easy connecting to a remote computer, using something like "winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2" instead of "\\.\".
Another big advantage of WMI is that we only need to change the name of the class, e.g.:
DIM hr AS HRESULT = pServices.ExecQuery("SELECT * FROM Win32_CDROMDrive")
and now we can access the properties of the CDRom drive.
PRINT "Description: "; pDispServ.Get("Description").ToStr
PRINT "Manufacturer: "; pDispServ.Get("Manufacturer").ToStr
etc.
The rest of the code will be the same.
If pServices.ObjectsCount returns a value greater than 1, it means that there are several collections. We only need to change IF nCount THEN to FOR i AS LONG = 0 TO nCOunt -1.
This means that with almost identical code we can access most of the hardware without having to learn different convoluted APIs.
I don't know how so many Windows programmers can live without knowing how to work with COM when about two thirds of the technologies provided by Windows are in the form of COM servers.
jose wrote
QuoteIt could have been if FB had not the nasty habit of passing an address to optional BYREF parameters. In PowerASIC I can check with VARPTR if the parameter has been omitted, e.g. IF VARPTR(x) = 0 THEN..., but with FB not because VARPTR(x) will always return a value <> 0. As in many of the methods I need to know if the parameter is null, I have used the same syntax in all of them. It would have been baffling to have to use one syntax with some methods and another with others.
why do you need optionnal parameter where byval can do the job , for example on the drawline procedure CgPen is the class and the first parameter and can not be optionnal, if it is not assign the procedure used value initialised in the constructor of the class.
on the other hand :
I tested your classes, it is not to criticize, but for example class CVAR, although Powerbasic uses assign and others ToUbyte etc...
island seems to me that it is better to have the constructor, the operator let and cast, in this way this CVAR will be confused with the VARIANT one.
It is what DELPHI does and which also made successes of VB.
if CVAR inherits VARIANT, it is an opinion, good if you want to copy PowerBasic, it is also an option.
The first version used LET and CAST and ended being a mess because if you pass 123 the compiler can't guess if it is a BYTE, a LONG, etc. Therefore, you have to use CBYTE, CLNG, etc., for numeric types, and, worst of all, you can't assign a variable by reference to make a VT_BYREF variant because if you pass a pointer to a variable, the compiler does not know if it is a pointer to a LONG, a DOUBLE or whatever.
PowerBasic let's you to optionally specify the kind of value that it is going to be assigned, e.g. DIM v AS VARIANT = 123 AS LONG, or DIM v AS VARIANT = BYREF variable, that is what I have done in the CVAR constructor and on the Assign method. I would have liked to do it in LET and CAST, but they don't allow me to pass the variant type.
One thing is to implement it natively in the compiler and another to do it using a class. Classes have its limitations.
Visual Basic was build to use COM Automation exclusively. It loads the type libraries to know which kind of variables expects the parameters of the method and coerces them. As a downside, you can't use low-level IUnknwon interfaces with VB. Some VBer's tried to workaround this limitation writing type libraries for these IUnknwon interfaces, but the results were no perfect because of differences in the calling conventions. Being a low-level pogrammer, i soon realized that it was not a language for me since the first time that I tried it. It certainly was very popular, but I don't like it.
As it seems that FreeBasic will never support BSTR, VARIANT and SAFEARRAY as native data types, I'm doing what I can to add support for them, although not in the VB way.
Quote from: Jose Roca on July 10, 2017, 06:23:02 AM
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:".
This has now been added. I'll update GitHub before going to bed.
Using sometimes "error!:" and others "error:" is what I call lack of consistency.
I think the "error!" version is returned from the gorc resource compiler.
Quote from: aloberr on July 13, 2017, 07:35:42 PM
jose wrote
QuoteIt could have been if FB had not the nasty habit of passing an address to optional BYREF parameters. In PowerASIC I can check with VARPTR if the parameter has been omitted, e.g. IF VARPTR(x) = 0 THEN..., but with FB not because VARPTR(x) will always return a value <> 0. As in many of the methods I need to know if the parameter is null, I have used the same syntax in all of them. It would have been baffling to have to use one syntax with some methods and another with others.
why do you need optionnal parameter where byval can do the job , for example on the drawline procedure CgPen is the class and the first parameter and can not be optional, if it is not assign the procedure used value initialised in the constructor of the class.
Besides DrawLine, there are more than 600 other methods, many of which have parameters that are optional. If the parameter is declared, for example, as BYREF pImageAttributes AS CGpImageAttributes, instead of BYVAL pImageAttributes AS CGpImageAttributes PTR = NULL, how can I make it optional and how can I pass a null pointer?
jose wrote
QuotePowerBasic let's you to optionally specify the kind of value that it is going to be assigned, e.g. DIM v AS VARIANT = 123 AS LONG, or DIM v AS VARIANT = BYREF variable, that is what I have done in the CVAR constructor and on the Assign method. I would have liked to do it in LET and CAST, but they down allow me to pass the variant type.
It is done by Freebasic using;
dim v as CVAR=cast(LONG,123)
vcvar=cast(UBYTE,onevar)
because Powerbasic VARIANT is not Windows VARAINT and Powerbasic VARIANT can be compare with CVAR or OLEVARIANT
I had the same difficulties in passing the variables by referance to OLEVARIANT, I surmounted that and my class olevariant lengthened considerably, people do not like the big executables size. And yet the DELPHI which is a very powerful language and fastest of the market produces theses big exe .
Instead, I'm using
DIM cv AS CVAR = CVAR(123, "LONG")
that is not much different and not more difficult to use.
IMO there is nothing wrong in using PowerBASIC techniques. After all, I was a PB programmer and this framework is mainly targeted to PB programmers. I once posted an small example in the PB forum (the first and only time that I have done that) to help a PB programmer and I was quickly reprimanded by a certain Mr. Swiss, a self appointed guardian of the orthodoxy. Apparently I must not use .inc files because some deprecated IDEs for PB don't work well with them, and, instead, I must use modules and libraries, losing the dead code removal feature and waste my time building libraries.
Quote from: aloberr on July 14, 2017, 05:52:48 PM
I had the same difficulties in passing the variables by referance to OLEVARIANT, I surmounted that and my class olevariant lengthened considerably, people do not like the big executables size. And yet the DELPHI which is a very powerful language and fastest of the market produces theses big exe .
For VT_BYREF variants, I have this method:
' ========================================================================================
' Assigns a value by reference (a pointer to a variable).
' ========================================================================================
PRIVATE FUNCTION CVar.AssignRef (BYVAL _pvar AS ANY PTR, BYVAL _vType AS WORD) AS HRESULT
CVAR_DP("CVAR AssignRef")
VariantClear(@vd)
IF _pvar = NULL THEN RETURN E_INVALIDARG
SELECT CASE _vType
CASE VT_BOOL : vd.vt = VT_BOOL OR VT_BYREF : vd.pboolVal = _pvar
CASE VT_I1 : vd.vt = VT_I1 OR VT_BYREF : vd.pcVal = _pvar
CASE VT_UI1 : vd.vt = VT_UI1 OR VT_BYREF : vd.pbVal = _pvar
CASE VT_I2 : vd.vt = VT_I2 OR VT_BYREF : vd.piVal = _pvar
CASE VT_UI2 : vd.vt = VT_UI2 OR VT_BYREF : vd.puiVal = _pvar
CASE VT_INT : vd.vt = VT_INT OR VT_BYREF : vd.pintVal = _pvar
CASE VT_UINT : vd.vt = VT_UINT OR VT_BYREF : vd.puintVal = _pvar
CASE VT_I4 : vd.vt = VT_I4 OR VT_BYREF : vd.plVal = _pvar
CASE VT_UI4 : vd.vt = VT_UI4 OR VT_BYREF : vd.pulVal = _pvar
CASE VT_I8 : vd.vt = VT_I8 OR VT_BYREF : vd.pllVal = _pvar
CASE VT_UI8 : vd.vt = VT_UI8 OR VT_BYREF : vd.pullVal = _pvar
CASE VT_R4 : vd.vt = VT_R4 OR VT_BYREF : vd.pfltVal = _pvar
CASE VT_R8 : vd.vt = VT_R8 OR VT_BYREF : vd.pdblVal = _pvar
CASE VT_BSTR : vd.vt = VT_BSTR OR VT_BYREF : vd.pbstrVal = _pvar
CASE VT_UNKNOWN : vd.vt = VT_UNKNOWN OR VT_BYREF : vd.ppunkVal = _pvar
CASE VT_DISPATCH : vd.vt = VT_DISPATCH OR VT_BYREF : vd.ppdispVal = _pvar
CASE VT_DECIMAL : vd.vt = VT_DECIMAL OR VT_BYREF : vd.pdecVal = _pvar
CASE VT_CY : vd.vt = VT_CY OR VT_BYREF : vd.pcyVal = _pvar
CASE VT_DATE : vd.vt = VT_DATE OR VT_BYREF : vd.pdate = _pvar
CASE VT_VARIANT : vd.vt = VT_VARIANT OR VT_BYREF : vd.pvarVal = _pvar
CASE VT_SAFEARRAY : vd.vt = VT_SAFEARRAY OR VT_BYREF : vd.pvarVal = _pvar
CASE VT_ERROR : vd.vt = VT_ERROR OR VT_BYREF : vd.pparray = _pvar
CASE ELSE : RETURN E_INVALIDARG
END SELECT
END FUNCTION
' ========================================================================================
I will add another one that will use a string for the data type, easier to remember that these VT_xxx constants.
Quote
And yet the DELPHI which is a very powerful language and fastest of the market produces theses big exe.
And even a compiler such FreePascal is mainly being used with the Lazarus framework, that produces bloated executables because of its goal to imitate Delphi.
My framework produces small executables, thanks to dead code removal. Only using pure SDK will you get smaller ones, but at the cost of losing the goodies that my famework offers.
Some may object that I'm using PB techniques instead of VB or Delphi techniques, but as I said I was a PB programmer, not a VB or Delphi one. I don't even know what Delphi does because I never have used it.
And now, back to coding. I almost have finished the WMI class. Files attached to this post.
I have implemented three ways of retrieving the information.
The first one is the classic one of executing a query and retrieve the results using an enumerator.
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
' // Note: $ is used to avoid the pedantic warning of the compiler about escape characters
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.ServicesPtr = NULL THEN END
' // Execute a query
DIM hr AS HRESULT = pServices.ExecQuery("SELECT Caption, SerialNumber FROM Win32_BIOS")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Get the number of objects retrieved
DIM nCount AS LONG = pServices.ObjectsCount
print "Count: ", nCount
IF nCount = 0 THEN PRINT "No objects found" : SLEEP : END
' // Enumerate the objects using the standard IEnumVARIANT enumerator (NextObject method)
' // and retrieve the properties using the CDispInvoke class.
DIM pDispServ AS CDispInvoke = pServices.NextObject
IF pDispServ.DispPtr THEN
PRINT "Caption: "; pDispServ.Get("Caption").ToStr
PRINT "Serial number: "; pDispServ.Get("SerialNumber").ToStr
END IF
PRINT
PRINT "Press any key..."
SLEEP
If the query returns more than one object, then we will use a loop:
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
' // Note: $ is used to avoid the pedantic warning of the compiler about escape characters
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.ServicesPtr = NULL THEN END
' // Execute a query
DIM hr AS HRESULT = pServices.ExecQuery("SELECT * FROM Win32_Printer")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Get the number of objects retrieved
DIM nCount AS LONG = pServices.ObjectsCount
print "Count: ", nCount
IF nCount = 0 THEN PRINT "No objects found" : SLEEP : END
' // Enumerate the objects
FOR i AS LONG = 0 TO nCount - 1
PRINT "--- Index " & STR(i) & " ---"
DIM pDispServ AS CDispInvoke = pServices.NextObject
IF pDispServ.DispPtr THEN
PRINT "Caption: "; pDispServ.Get("Caption").ToStr
PRINT "Capabilities "; pDispServ.Get("Capabilities").ToStr
END IF
NEXT
PRINT
PRINT "Press any key..."
SLEEP
The second way is to call the GetNamedProperties method after executing the query. GetNamedProperties generates a named collection of properties. This has the advantage of not having to use CDispInvoke.
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
' // Note: $ is used to avoid the pedantic warning of the compiler about escape characters
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.ServicesPtr = NULL THEN END
' // Execute a query
DIM hr AS HRESULT = pServices.ExecQuery("SELECT Caption, SerialNumber FROM Win32_BIOS")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Get the number of objects retrieved
DIM nCount AS LONG = pServices.ObjectsCount
print "Number of objects: ", nCount
IF nCount = 0 THEN PRINT "No objects found" : SLEEP : END
' // Get a collection of named properties
IF pServices.GetNamedProperties <> S_OK THEN PRINT "Failed to get the named properties" : SLEEP : END
' // Retrieve the value of the properties
'DIM cv AS CVAR = pServices.PropValue("Caption")
'PRINT cv.ToStr
PRINT pServices.PropValue("Caption").ToStr
PRINT pServices.PropValue("SerialNumber").ToStr
PRINT
PRINT "Press any key..."
SLEEP
Using a loop
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
' // Note: $ is used to avoid the pedantic warning of the compiler about escape characters
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.ServicesPtr = NULL THEN END
' // Execute a query
DIM hr AS HRESULT = pServices.ExecQuery("SELECT * FROM Win32_Printer")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Get the number of objects retrieved
DIM nCount AS LONG = pServices.ObjectsCount
print "Number of objects: ", nCount
IF nCount = 0 THEN PRINT "No objects found" : SLEEP : END
' // Enumerate the objects
FOR i AS LONG = 0 TO nCount - 1
PRINT "--- Index " & STR(i) & " ---"
' // Get a collection of named properties
IF pServices.GetNamedProperties(i) = S_OK THEN
PRINT pServices.PropValue("Caption").ToStr
PRINT pServices.PropValue("Capabilities").ToStr
END IF
NEXT
PRINT
PRINT "Press any key..."
SLEEP
The third way is to use the Get method. It retrieves an object, that is either a class definition or an instance, based on the specified object path. Using this object, it generates a named collection of properties.
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
IF pServices.ServicesPtr = NULL THEN END
' // Get an instance of the printer "OKI B410" --> change me
DIM hr AS HRESULT = pServices.Get("Win32_Printer.DeviceID='OKI B410'")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Number of properties
PRINT "Number of properties: ", pServices.PropsCount
PRINT
' // Display some properties
PRINT "Port name: "; pServices.PropValue("PortName").ToStr
PRINT "Attributes: "; pServices.PropValue("Attributes").ToStr
PRINT "Paper sizes supported: "; pServices.PropValue("PaperSizesSupported").ToStr
PRINT
PRINT "Press any key..."
SLEEP
Another example:
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
'DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2"
' Use the constructor for server connection, just for trying...
DIM pServices AS CWmiServices = CWmiServices(".", "root\cimv2")
IF pServices.ServicesPtr = NULL THEN END
'// Get an instance of a file --> change me
DIM cbsPath AS CBSTR = ExePath & "\EX_CWMI_Get_02.bas" ' --> change me
DIM hr AS HRESULT = pServices.Get("CIM_DataFile.Name='" & cbsPath & "'")
IF hr <> S_OK THEN PRINT AfxWmiGetErrorCodeText(hr) : SLEEP : END
' // Number of properties
PRINT "Number of properties: ", pServices.PropsCount
PRINT
' // Display some properties
PRINT "Relative path: "; pServices.PropValue("Path").ToStr
PRINT "FileName: "; pServices.PropValue("FileName").ToStr
PRINT "Extension: "; pServices.PropValue("Extension").ToStr
PRINT "Size: "; pServices.PropValue("Filesize").ToStr
'PRINT pServices.PropValue("LastModified").ToStr
PRINT "Date last modified: "; pServices.WmiDateToStr(pServices.PropValue("LastModified"), "dd-MM-yyyy") ' // change the mask if needed
PRINT
PRINT "Press any key..."
SLEEP
TODO: Implement support to execute methods.
The helper function AfxWmiGetErrorCodeText returns a descriptive and localized description of WMI errors.
The methods WmiDateToStr and WmiTimeToStr convert WMI date times to formatted strings using a mask, and WmiTimeToFileTime converts it to a FILETIME structure.
Also notice that one of the constructors allow to connect to remote servers (untested because I don't have access to a server)-
' ========================================================================================
' Connects to the namespace that is specified on the cbsNamespace parameter on the computer
' that is specified in the cbsServer parameter. The target computer can be either local or
' remote, but it must have WMI installed.
' - cbsServer:
' Computer name to which you are connecting. If the remote computer is in a different domain
' than the user account under which you log in, then use the fully qualified computer name.
' If you do not provide this parameter, the call defaults to the local computer.
' Example: server1.network.fabrikam
' You also can use an IP address in this parameter. If the IP address is in IPv6 format,
' the target computer must be running IPv6. An address in IPv4 looks like 111.222.333.444
' An IP address in IPv6 format looks like 2010:836B:4179::836B:4179
' - cbsNamespace:
' String that specifies the namespace to which you log on. For example, to log on to the
' root\default namespace, use root\default. If you do not specify this parameter, it
' defaults to the namespace that is configured as the default namespace for scripting.
' Example: DIM pServices AS CWmiServices = CWmiServices(".", "root\cimv2")
' where "." is a shortcut for the local computer.
' - cbsUser [in, optional]
' User name to use to connect. The string can be in the form of either a user name or a
' Domain\Username. Leave this parameter blank to use the current security context. The
' cbsUser parameter should only be used with connections to remote WMI servers. If you
' attempt to specify strUser for a local WMI connection, the connection attempt fails.
' If Kerberos authentication is in use, then the username and password that is specified
' in cbsUser and cbsPassword cannot be intercepted on a network. You can use the UPN
' format to specify the cbsUser.
' Example: "DomainName\UserName"
' Note: If a domain is specified in cbsAuthority, then the domain must not be specified
' here. Specifying the domain in both parameters results in an Invalid Parameter error.
' - cbsPassword [in, optional]
' String that specifies the password to use when attempting to connect. Leave the
' parameter blank to use the current security context. The cbsPassword parameter should
' only be used with connections to remote WMI servers. If you attempt to specify
' cbsPassword for a local WMI connection, the connection attempt fails. If Kerberos
' authentication is in use then the username and password that is specified in cbsUser
' and cbsPassword cannot be intercepted on the network.
' - cbsLocale [in, optional]
' String that specifies the localization code. If you want to use the current locale,
' leave it blank. If not blank, this parameter must be a string that indicates the
' desired locale where information must be retrieved. For Microsoft locale identifiers,
' the format of the string is "MS_xxxx", where xxxx is a string in the hexadecimal form
' that indicates the LCID. For example, American English would appear as "MS_409".
' - cbsAuthority [in, optional]
' ""
' This parameter is optional. However, if it is specified, only Kerberos or NTLMDomain
' can be used.
' Kerberos:
' If the cbsAuthority parameter begins with the string "Kerberos:", then Kerberos
' authentication is used and this parameter should contain a Kerberos principal name.
' The Kerberos principal name is specified as Kerberos:domain, such as Kerberos:fabrikam
' where fabrikam is the server to which you are attempting to connect.
' Example: "Kerberos:DOMAIN"
' NTLMDomain:
' To use NT Lan Manager (NTLM) authentication, you must specify it as NTLMDomain:domain,
' such as NTLMDomain:fabrikam where fabrikam is the name of the domain.
' Example: "NTLMDomain:DOMAIN"
' If you leave this parameter blank, the operating system negotiates with COM to
' determine whether NTLM or Kerberos authentication is used. This parameter should
' only be used with connections to remote WMI servers. If you attempt to set the
' authority for a local WMI connection, the connection attempt fails.
' Note: If the domain is specified in cbsUser, which is the preferred location, then
' it must not be specified here. Specifying the domain in both parameters results in
' an Invalid Parameter error.
' - iSecurityFlags [in, optional]
' Used to pass flag values to ConnectServer.
' 0 (0x0)
' A value of 0 for this parameter causes the call to ConnectServer to return only
' after the connection to the server is established. This could cause your program
' to stop responding indefinitely if the connection cannot be established.
' wbemConnectFlagUseMaxWait (128 (0x80))
' The ConnectServer call is guaranteed to return in 2 minutes or less. Use this flag
' to prevent your program from ceasing to respond indefinitely if the connection
' cannot be established.
' If successful, WMI returns an SWbemServices object that is bound to the namespace that
' is specified in cbsNamespace on the computer that is specified in cbsServer.
' Usage example with the local computer:
' DIM pServices AS CWmiServices = CWmiServices(".", "root\cimv2")
' IF pServices.DispPtr = NULL THEN END
' Remarks
' The ConnectServer method is often used when connecting to an account with a different
' username and passwordâ€"credentialsâ€"on a remote computer because you cannot specify a
' different password in a moniker string.
' Using an IPv4 address to connect to a remote server may result in unexpected behavior.
' The likely cause is stale DNS entries in your environment. In these circumstances, the
' stale PTR entry for the machine will be used, with unpredictable results. To avoid
' this behavior, you can append a period (".") to the IP address before calling
' ConnectServer. This causes the reverse DNS lookup to fail, but may allow the
' ConnectServer call to succeed on the correct machine.
' ========================================================================================
PRIVATE CONSTRUCTOR CWmiServices (BYREF cbsServer AS CBSTR, BYREF cbsNamespace AS CBSTR, _
BYREF cbsUser AS CBSTR = "", BYREF cbsPassword AS CBSTR = "", BYREF cbsLocale AS CBSTR = "", _
BYREF cbsAuthority AS CBSTR = "", BYVAL iSecurityFlags AS LONG = wbemConnectFlagUseMaxWait)
' // Initialize the COM library
DIM hr AS HRESULT = CoInitialize(NULL)
IF hr = S_OK OR hr = S_FALSE THEN m_bUninitCOM = TRUE
' // Connect to the server
DIM pLocator AS Afx_ISWbemLocator PTR = AfxNewCom("WbemScripting.SWbemLocator")
IF pLocator THEN m_Result = pLocator->ConnectServer(cbsServer, cbsNamespace, cbsUser, cbsPassword, _
cbsLocale, cbsAuthority, iSecurityFlags, NULL, @m_pServices)
pLocator->Release
END CONSTRUCTOR
' ========================================================================================
Working with WMI is now very easy!
Calling a WMI method using low-level COM is very complicated, but using Dispatch.Invoke is straightfoward.
I deliberately have chosen this example because it has a VT_BYREF OUT BSTR parameter, to test the CVAR constructor designed for this purpose.
I have modified the CWmiServices class to allow to use
DIM pDispServices AS CDispInvoke = CDispInvoke(pServices.ServicesObj)
instead of
DIM pDispServices AS CDispInvoke = CDispInvoke(cast(IDispatch PTR, cast(ANY PTR, pServices.ServicesObj)))
This is why extensive testing is a must. Not only to discover bugs, but to improve the code.
#include "windows.bi"
#include "Afx/CWmiDisp.inc"
using Afx
' // Connect to WMI using a moniker
DIM pServices AS CWmiServices = $"winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv"
IF pServices.ServicesPtr = NULL THEN END
' // Assign the WMI services object pointer to CDispInvoke
' // CWmiServices.ServicesObj returns an AddRefed pointer, whereas CWmiServices.ServicesPtr not.
DIM pDispServices AS CDispInvoke = CDispInvoke(pServices.ServicesObj)
' Parameters of the GetStringValue method:
' %HKEY_LOCAL_MACHINE ("2147483650") - The value must be specified as an string and in decimal, not hexadecimal.
' vDefKey = [IN] "2147483650"
' vPath = [IN] "Software\Microsoft\Windows NT\CurrentVersion"
' vValue = [OUT] "ProductName"
DIM cbsValue AS CBSTR
DIM cvValue AS CVAR = CVAR(cbsValue.vptr, VT_BSTR)
DIM cvRes AS CVAR = pDispServices.Invoke("GetStringValue", 4, CVAR("2147483650"), _
CVAR($"Software\Microsoft\Windows NT\CurrentVersion"), CVAR("ProductName"), cvValue)
PRINT cvValue.ToStr
' --or-- PRINT cbsValue
PRINT
PRINT "Press any key..."
SLEEP
QuoteIMO there is nothing wrong in using PowerBASIC techniques.
OK!
Quote from: Jose Roca on July 04, 2017, 05:58:25 PM
I have begin to translate the high level glut functions. Tested the torus, cube, sphere and octahedron and got them working. See capture.
NeHe Lesson 5 work perfectly for me.
Rick
Quote from: Jose Roca on July 09, 2017, 09:58:03 PM
I have added some methods to the CVAR class and have implemented a news class: CDispInvoke.
Works perfectly for me.
Rick
Quote from: Jose Roca on July 10, 2017, 02:53:29 AM
This example has allowed me to test that the Invoke method works fine with OUT variant parameters.
$"Software\Microsoft\Windows NT\CurrentVersion"
Correctly shows Windows 10 Pro.
Rick
Rather than bore with the details, I ran every example you provided in the order of the threads you presented without error.
Rick
Thanks very much for testing. I'm currently updating the documentation with the new classes and will revise the ADO classes because the differences between CVAR and the old CVARIANT. After that, I will post the new version and will begin to write many small examples with the purpose of testing the framework systematically. Trying the tests in other OSes such WIndows 10 is very important because all my hardware amounts to a desktop computer with Windows 7, an internet connection and a semi-broken printer.
CBSTR, CVAR, CSafearray and CDispInvoke allow to use COM Automation. This means that now we should be able to automate Office applications, but I can't test because I don't have Office installed. Although I almost always work with COM at low-level, sometimes the use of Automation is unavoidable or convenient.
CWmiDisp allows to easily use the powerful WMI technology without having to resort to VBScript or PowerShell. I have added a constructor to allow to connect to remote servers, but I can't test it because I don't have access to a server.
Quote from: Jose Roca on July 18, 2017, 12:40:58 AM
CBSTR, CVAR, CSafearray and CDispInvoke allow to use COM Automation. This means that now we should be able to automate Office applications, but I can't test because I don't have Office installed.
I can certainly help you with that. I have access to an older version of Office (2010) and a little newer version (2013). We haven't upgraded to the very latest Office version yet. I have tried it but I didn't like it. I also use LibreOffice on my laptop but I don't think that has COM automation.
Maybe start new separate posts that specifically ask the group here to test certain code? If the posts are separate it might be easier for me and others to zero in on what you need tested. Sometimes I may miss code that is buried in long threads.
I'm using Win 10 Pro with all the latest updates on a home network behind a NetGear Nighthawk router. The router has a USB drive plugged in that appears to my PC as remote that I use for all kinds of backups. My printer is a wireless network HP Envy. I have a full copy of MS Office 2013 and can get the latest version should I want it for $10 from my employer. I have IE, EDGE, Chrome, and, Firefox browsers and am running Norton for protection. There is also a MAC, PS4, and, other windows computers on the network.
I'll run tests when you ask for 'em....
Rick
....ah yes, similarly to Rick, I am also running Windows 10 so I can run tests on that OS as well.
Quote from: TechSupport on July 18, 2017, 04:43:09 PM
....ah yes, similarly to Rick, I am also running Windows 10 so I can run tests on that OS as well.
Well Paul, in the misspent idle moments of my younger days, I ran a complete windows AD network with my own DNS, Print, NTP, Mail, Web, FTP, Domain controller, and, SQL database servers in my home. I had RJ45 outlets all over the place "homerun" wired to a patch panel. I also had a "honeypot" web server I would put on the public side of the router periodically to check on what the bad guys were trying to do to me.
Life is much simpler now and wifi is my new queen.... :o
Rick
I have added a base class to the GDI+ classes to avoid to having to initialize and shutdown GDI+ with the programs that use the classes:
DIM SHARED AFX_CGDIP_TOKEN AS ULONG_PTR ' // GDI+ token
DIM SHARED AFX_CGDIP_CREF AS LONG ' // Reference count
' ########################################################################################
' CGpBase class
' ########################################################################################
TYPE CGpBase
m_Status AS GpStatus ' // Last status code
DECLARE CONSTRUCTOR
DECLARE DESTRUCTOR
DECLARE FUNCTION GetLastStatus () AS GpStatus
DECLARE FUNCTION SetStatus (BYVAL status AS GpStatus) AS GpStatus
END TYPE
' ########################################################################################
' ========================================================================================
' Default constructor
' ========================================================================================
PRIVATE CONSTRUCTOR CGpBase
OutputDebugStringW("*** BEGIN - CONSTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
' // Initialize the GDI+ library
IF AFX_CGDIP_CREF = 0 THEN
DIM StartupInput AS GdiplusStartupInput
DIM version AS ULONG = 1
IF AfxWindowsVersion >= 600 THEN version = 2
StartupInput.GdiplusVersion = version
m_Status = GdiplusStartup(@AFX_CGDIP_TOKEN, @StartupInput, NULL)
IF m_Status <> 0 THEN
MessageBoxW(0, "GDI+ initialization failed - Error: " & STR$(m_Status), "Error", MB_OK OR MB_ICONERROR OR MB_APPLMODAL)
ELSE
AFX_CGDIP_CREF = 1
END IF
OutputDebugStringW("+++ CONSTRUCTOR CGpBase Initialize GDI+ - version = " & str$(version))
ELSE
' // Increase the reference count
AFX_CGDIP_CREF += 1
END IF
OutputDebugStringW("*** END - CONSTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' Destructor
' ========================================================================================
PRIVATE DESTRUCTOR CGpBase
OutputDebugStringW("*** BEGIN - DESTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
' // Decrease the reference count
AFX_CGDIP_CREF -= 1
IF AFX_CGDIP_CREF < 1 THEN
' // Shutdown GDI+
IF AFX_CGDIP_TOKEN THEN GdiplusShutdown(AFX_CGDIP_TOKEN)
OutputDebugStringW("--- DESTRUCTOR CGpBase Shutdown GDI+")
ELSE
END IF
OutputDebugStringW("*** END - DESTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Returns the last status code.
' ========================================================================================
PRIVATE FUNCTION CGpBase.GetLastStatus () AS GpStatus
RETURN m_Status
END FUNCTION
' ========================================================================================
' ========================================================================================
' Sets the last status code.
' ========================================================================================
PRIVATE FUNCTION CGpBase.SetStatus (BYVAL status AS GpStatus) AS GpStatus
m_Status = status
RETURN m_Status
END FUNCTION
' ========================================================================================
Have needed to use two globals, that is not something that I like, but...
UDTs can be stored in CVARs. They are stored as an array of bytes.
TYPE Foo
x AS long
y as long
b as WSTRING * 260
END type
DIM t AS Foo
t.x = 12345
t.y = 72727
t.b = "Test string"
DIM cv AS CVAR
cv.AssignBuffer(@t, SIZEOF(t))
DIM t2 as Foo
cv.ToBuffer(@t2, SIZEOF(t))
print t2.x
print t2.y
print t2.b
Quote from: Jose Roca on July 19, 2017, 03:56:59 AM
I have added a base class to the GDI+ classes to avoid to having to initialize and shutdown GDI+ with the programs that use the classes:
DIM SHARED AFX_CGDIP_TOKEN AS ULONG_PTR ' // GDI+ token
DIM SHARED AFX_CGDIP_CREF AS LONG ' // Reference count
' ########################################################################################
' CGpBase class
' ########################################################################################
TYPE CGpBase
m_Status AS GpStatus ' // Last status code
DECLARE CONSTRUCTOR
DECLARE DESTRUCTOR
DECLARE FUNCTION GetLastStatus () AS GpStatus
DECLARE FUNCTION SetStatus (BYVAL status AS GpStatus) AS GpStatus
END TYPE
' ########################################################################################
' ========================================================================================
' Default constructor
' ========================================================================================
PRIVATE CONSTRUCTOR CGpBase
OutputDebugStringW("*** BEGIN - CONSTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
' // Initialize the GDI+ library
IF AFX_CGDIP_CREF = 0 THEN
DIM StartupInput AS GdiplusStartupInput
DIM version AS ULONG = 1
IF AfxWindowsVersion >= 600 THEN version = 2
StartupInput.GdiplusVersion = version
m_Status = GdiplusStartup(@AFX_CGDIP_TOKEN, @StartupInput, NULL)
IF m_Status <> 0 THEN
MessageBoxW(0, "GDI+ initialization failed - Error: " & STR$(m_Status), "Error", MB_OK OR MB_ICONERROR OR MB_APPLMODAL)
ELSE
AFX_CGDIP_CREF = 1
END IF
OutputDebugStringW("+++ CONSTRUCTOR CGpBase Initialize GDI+ - version = " & str$(version))
ELSE
' // Increase the reference count
AFX_CGDIP_CREF += 1
END IF
OutputDebugStringW("*** END - CONSTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' Destructor
' ========================================================================================
PRIVATE DESTRUCTOR CGpBase
OutputDebugStringW("*** BEGIN - DESTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
' // Decrease the reference count
AFX_CGDIP_CREF -= 1
IF AFX_CGDIP_CREF < 1 THEN
' // Shutdown GDI+
IF AFX_CGDIP_TOKEN THEN GdiplusShutdown(AFX_CGDIP_TOKEN)
OutputDebugStringW("--- DESTRUCTOR CGpBase Shutdown GDI+")
ELSE
END IF
OutputDebugStringW("*** END - DESTRUCTOR CGpBase - cRef = " & STR$(AFX_CGDIP_CREF))
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Returns the last status code.
' ========================================================================================
PRIVATE FUNCTION CGpBase.GetLastStatus () AS GpStatus
RETURN m_Status
END FUNCTION
' ========================================================================================
' ========================================================================================
' Sets the last status code.
' ========================================================================================
PRIVATE FUNCTION CGpBase.SetStatus (BYVAL status AS GpStatus) AS GpStatus
m_Status = status
RETURN m_Status
END FUNCTION
' ========================================================================================
Have needed to use two globals, that is not something that I like, but...
I haven't tested this but....
Instead of using globals could you create the variables as STATIC member variables of the TYPE and then access them using the BASE keyword in subsequent class instances?
> Instead of using globals could you create the variables as STATIC member variables of the TYPE and then access them using the BASE keyword in subsequent class instances?
No. Each instance of a class gets its own allocation. Extending from another class you get access to its methods, but not to its data (that is, you save some coding because you don't have to reimplement the methods of the inherited class, but nothing else). Either I have to use globals or allow that each instance of any of the classes will initialize and shutdown GDI+. That works, but don't know what the speed penalty will be.
With the classes that use COM, no globals are needed because when you call CoInitialize, if the COM library has already been initialized it returns S_FALSE instead of failing, and you have to call CoUninitialize for each call to CoInitialize that returns S_OK or S_FALSE.
Therefore, on the constructor I do:
' // Initialize the COM library
DIM hr AS HRESULT = CoInitialize(NULL)
IF hr = S_OK OR hr = S_FALSE THEN m_bUninitCOM = TRUE
and in the destructor:
IF m_bUninitCOM THEN CoUninitialize
In the case of the ODBC classes, I also had to use a couple of globals:
DIM AFX_ODBC_hEnv AS SQLHANDLE ' Environment handle
DIM AFX_ODBC_numConnections AS LONG ' Number of connections
and it was unavoidable because each application can oly have an environment handle.
Anyway, given the names used for them, name conflicts are impossible.
Quote from: Jose Roca on July 19, 2017, 06:25:04 PM
> Instead of using globals could you create the variables as STATIC member variables of the TYPE and then access them using the BASE keyword in subsequent class instances?
No. Each instance of a class gets its own allocation. Extending from another class you get access to its methods, but not to its data (that is, you save some coding because you don't have to reimplement the methods of the inherited class, but nothing else). Either I have to use globals or allow that each instance of any of the classes will initialize and shutdown GDI+. That works, but don't know what the speed penalty will be.
Hmmmm... then how about this approach. Create a base class called "ReferenceCount" that has methods for increment and decrement the count, and derive your GDI classes from that class. That approach would be similar to COM's use of IUnknown that has the two functions AddRef and Release.
Same problem. Each class will get its own data. When you extend a FB type, you get a copy of its public methods and variables, but the variables are uninitialized. I think that it is normal behavior. Classes are different because you can implement different interfaces in the same class, but these FB types are not real classes and don't allow to implement interfaces.
To make it clear. If we create an instance of the CGpGraphics type, that extends the CGdipBase, it initializes GDI+ and sets the reference count to 1. Now, if we create an instance of CGpPen, that also inherits from CGpBase, the variable that keeps the count, lets say cRef, won't have a value of 1, but 0. Therefore, CGpPen will also initialize GDI+ and keep a count of 1. To access the data of the instance of CGpGraphics, we would need to have a pointer to it and get the data using this pointer.
Thanks Jose, I haven't been close to my development computer the past couple of days so I have been throwing out ideas without any actual testing whatsoever. :)
The last non-global idea I'll toss out there is this....
How about creating a STATIC member function in the TYPE that uses STATIC variables within that function to track the reference count. A STATIC member function is shared throughout all instances of the class inheritance rather than creating duplicates each time.
Something like this (off the top of my head):
STATIC Function CGdipBase.ReferenceCount( Byval IncrementValue As Long ) As Long
Static refCount As Long
refCount = refCount + IncrementValue
Select Case refCount
Case 1
' Initialize
Case 0
' Destroy/Uninitalize
End Select
Function = 0
End Function
In the Constructor
this.ReferenceCount(+1)
In the Destructor
this.ReferenceCount(-1)
Maybe I am way off base but you never know. I can actually test this tomorrow (Friday).
Jose, here is some code that should demonstrate what I was trying to convey in the previous post. It should encapsulate the reference counting situation.
type MyObject
Private:
dummy as Long
Public:
declare static Function ReferenceCount( Byval IncrementValue As Long ) As Long
declare constructor
declare destructor
END TYPE
STATIC Function MyObject.ReferenceCount( Byval IncrementValue As Long ) As Long
Static refCount As Long = 0 ' start as uninitialized
if refCount = 0 THEN
' Initialize
? "Initialize"
END IF
refCount = refCount + IncrementValue
' If after decrementing the reference count we are at zero then
' call the destroy/unitialize functions.
if refCount = 0 THEN
' Destroy/Uninitalize
? "Destroy"
End if
? "Reference Count = "; refCount
Function = 0
End Function
Constructor MyObject()
this.ReferenceCount(+1)
end constructor
Destructor MyObject()
this.ReferenceCount(-1)
end destructor
' TEST CODE
function CreateObjects() as long
dim myobj(9) as MyObject
' The DIM will create 10 instances of the object. When this function exits then
' the objects will go out scope thereby calling the destructors of each object
' and decrementing the reference count.
function = 0
end function
CreateObjects
sleep
Interesting. I didn't know that they will share the static data.
I have changed the code to:
' ========================================================================================
' Default constructor
' ========================================================================================
PRIVATE CONSTRUCTOR CGpBase
CGDIP_DP("CONSTRUCTOR CGpBase")
' // Increase the reference count
this.RefCount(TRUE)
END CONSTRUCTOR
' ========================================================================================
' ========================================================================================
' Destructor
' ========================================================================================
PRIVATE DESTRUCTOR CGpBase
CGDIP_DP("DESTRUCTOR CGpBase")
' // Decrease the reference count
this.RefCount(FALSE)
END DESTRUCTOR
' ========================================================================================
' ========================================================================================
' Increases/decreases the reference count and initializes or shutdowns GDI+ when required.
' ========================================================================================
PRIVATE FUNCTION CGpBase.RefCount (BYVAL bIncrement AS BOOLEAN) AS LONG
STATIC cRef AS LONG, token AS ULONG_PTR
' CGDIP_DP("--- BEGIN CGpBase - RefCount - cRef = " & WSTR(cRef))
IF cRef = 0 THEN
' // Initialize the GDI+ library
DIM StartupInput AS GdiplusStartupInput
DIM version AS ULONG = 1
IF AfxWindowsVersion >= 600 THEN version = 2
StartupInput.GdiplusVersion = version
m_Status = GdiplusStartup(@token, @StartupInput, NULL)
IF m_Status <> 0 THEN MessageBoxW(0, "GDI+ initialization failed - Error: " & STR$(m_Status), "Error", MB_OK OR MB_ICONERROR OR MB_APPLMODAL)
CGDIP_DP("+++ CGpBase.RefCount Initialize GDI+ - version = " & WSTR(version) & "; token = " & WSTR(token))
END IF
' // Increase or decrease the reference count
IF bIncrement THEN cRef += 1 ELSE cRef -= 1
CGDIP_DP("--- END CGpBase - RefCount - cRef = " & WSTR(cRef))
' // If the reference count reaches a value of 0, shutdown GDI+
IF cRef = 0 THEN
' // Shutdown GDI+
IF token THEN GdiplusShutdown(token)
token = 0
CGDIP_DP("+++ CGpBase.RefCount Shutdown GDI+")
END IF
RETURN cRef
END FUNCTION
' ========================================================================================
And it works fine.
Thanks very much for the idea.
Quote from: Jose Roca on July 22, 2017, 04:17:05 AM
Thanks very much for the idea.
Feels good to be able to help you for a change :) Wish i could contribute more to your efforts to create such a great code base for the FB language.