■

総天然色の四角が枡状に乱数で表示されるスクリーンセイバーです。

起動の SUBSYSTEM は Windows で。

生成される実行ファイルの拡張子は .exe から .scr に変えておくと便利。

実行は、右クリック->TEST で可能。

MODULE ScreenSaver
USE ifwinty
CONTAINS
!--------------------------------------------------
INTEGER(BOOL) FUNCTION ScreenSaverConfigureDialog(hDlg ,message ,wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ScreenSaverConfigureDialog@16' ::ScreenSaverConfigureDialog
INTEGER, INTENT(IN) :: hDlg ,message ,wParam ,lParam
ScreenSaverConfigureDialog = 1
END FUNCTION ScreenSaverConfigureDialog
!--------------------------------------------------
INTEGER(BOOL) FUNCTION RegisterDialogClasses(hInst)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_RegisterDialogClasses@4' :: RegisterDialogClasses
INTEGER, INTENT(IN) :: hInst
RegisterDialogClasses = 1
END FUNCTION RegisterDialogClasses
!--------------------------------------------------
INTEGER(4) FUNCTION ScreenSaverProc(hWnd, uMsg, wParam, lParam)
!DEC$ ATTRIBUTES STDCALL, ALIAS : '_ScreenSaverProc@16' :: ScreenSaverProc
USE scrnsave
USE ifwina
USE iflogm
IMPLICIT NONE
INTEGER(4), INTENT(IN) :: hWnd, uMsg, wParam, lParam
INTEGER, SAVE :: ID_TIMER = 32767, iwx, iwy, nc = 0
INTEGER :: ix, iy, jc
INTEGER(1) :: ic(3)
REAL :: x(2), c(3)
TYPE (t_RECT) :: rc
TYPE (t_PaintStruct) :: ps
INTEGER(BOOL) :: iret
INTEGER(handle) :: hDC, hBrush, hPen
ScreenSaverProc = 0
SELECT CASE (uMsg)
 CASE (WM_CREATE)
  iret = GetClientRect(hWnd, rc)
  iwx = rc%right  - rc%left
  iwy = rc%bottom - rc%top
  iret = SetTimer(hWnd, ID_TIMER, 1000, NULL)
  CALL RANDOM_SEED()
 CASE (WM_TIMER)
  CALL RANDOM_NUMBER(x)
  ix = INT(x(1) * iwx / 100) * 100
  iy = INT(x(2) * iwy / 100) * 100
  hDC = GetDC(hWnd)
  IF (nc < 50) THEN
   nc = nc + 1
   CALL RANDOM_NUMBER(c)
   ic = NINT(255 * c)
   jc = RGB(ic(1), ic(2), ic(3))
   hPen   = CreatePen(PS_SOLID, 1, jc)
   hBrush = CreateSolidBrush(jc)
   iret = SelectObject(hDC, hPen)
   iret = SelectObject(hDC, hBrush)
   iret = Rectangle(hdc, ix, iy, ix + 100, iy + 100)
   iret = DeleteObject(hBrush)
   iret = DeleteObject(hPen)
  ELSE
   nc = 0
   jc = RGB(0, 0, 0)
   hPen   = CreatePen(PS_SOLID, 2, jc)
   hBrush = CreateSolidBrush(jc)
   iret = SelectObject(hDC, hPen)
   iret = SelectObject(hDC, hBrush)
   iret = Rectangle(hDC, 0, 0, iwx, iwy)
   iret = DeleteObject(hBrush)
   iret = DeleteObject(hPen)
  END IF
  iret = ReleaseDC(hWnd, hDC)
 CASE (WM_DESTROY)
  iret = KillTimer(hWnd, ID_TIMER);
  CALL PostQuitMessage(0)
 CASE DEFAULT
  ScreenSaverProc = DefScreenSaverProc(hWnd, uMsg, wParam, lParam)
END SELECT
RETURN
END FUNCTION ScreenSaverProc
!--------------------------------------------------
END MODULE ScreenSaver