Графические средства

subroutine Draw(hdc)
  use ifwina
  integer hdc
  integer HGREEN_BRUSH, HBLUE_BRUSH
  integer HPEN, HOLD_PEN, HOLD_BRUSH, ires

    HBLUE_BRUSH =  CreateSolidBrush(RGB(0,0,255)) ! создание
    HGREEN_BRUSH = CreateSolidBrush(RGB(0,255,0))
    HPEN=CreatePen(PS_SOLID,10,RGB(230,60,150))

    HOLD_PEN = SelectObject(hdc,HPEN) ! сохранение
    HOLD_BRUSH = SelectObject(hdc,HGREEN_BRUSH)
    ires = Rectangle(hdc,100,200,400,300)
    ires = SelectObject(hdc,HOLD_PEN)  ! восстановление
    ires = SelectObject(hdc,hBLUE_BRUSH) 
    ires = Ellipse(hdc,150,150,250,250)
    ires = SelectObject(hdc,HOLD_BRUSH)
    ires = DeleteObject(HPEN)
    ires = DeleteObject(HBLUE_BRUSH)
    ires = DeleteObject(HGREEN_BRUSH)
end subroutine Draw

program DrawToMetaFile
  use ifwina
  integer hEMF, hBRUSH, hPEN, ires

  hEMF   = CreateEnhMetaFile (0,"D:\\pic.emf"C,null_rect,"А"C) 

  hBRUSH = CreateSolidBrush(RGB(0,255,0))
  hPEN   = CreatePen (PS_DASH,4,Rgb(255,0,0))
  
  ires = SelectObject(hEMF, hBRUSH) 
  ires = SelectObject(hEMF, hPEN) 

  ires = Rectangle(hEMF,100,100,300,300)

  ires = CloseEnhMetaFile(hEMF)

  ires = DeleteObject(HPEN)     
  ires = DeleteObject(HBRUSH)
end

!******************************************************************
!          Рисование треугольника Серпинского в метафайл
!******************************************************************
program FRACTAL
  use ifwina
  implicit none
  integer hEMF, hPEN, ires
  hEMF   = CreateEnhMetaFile (0,"D:\\Serpinsky.emf"C,null_rect,""C) ! --- создание метафайла, пера
  hPEN   = CreatePen (PS_SOLID,1,Rgb(0,0,255))
  ires = SelectObject(hEMF, hPEN) 

  call Serpinsky(hEMF, 50, 200, 150, 50, 250, 200, 5) ! --- вызов рекурсивной подпрограммы рисования
  
  ires=CloseEnhMetaFile(hEMF)
  ires=DeleteObject(HPEN)     
  contains
    recursive subroutine Serpinsky(hc,x1,y1,x2,y2,x3,y3,N)
      integer hc ! дескриптор метафайла
      integer x1,y1,x2,y2,x3,y3 ! координаты треугольника
      integer N                 ! число поколений
      integer xc1, yc1, xc2, yc2, xc3, yc3 ! координаты середин сторон
      integer ires

      if (N==0) return ! остановка рекурсии 

      ires=MoveToEx(hc, x1, y1, NULL)
      ires=LineTo(hc, x2, y2)
      ires=LineTo(hc, x3, y3)
      ires=LineTo(hc, x1, y1)
      xc1=(x1+x3)/2; yc1=(y1+y3)/2
      xc2=(x1+x2)/2; yc2=(y1+y2)/2
      xc3=(x2+x3)/2; yc3=(y2+y3)/2

      call Serpinsky(hc,x1,y1,xc2,yc2,xc1,yc1,N-1)
      call Serpinsky(hc,xc2,yc2,x2,y2,xc3,yc3,N-1)
      call Serpinsky(hc,xc1,yc1,xc3,yc3,x3,y3,N-1)
    end subroutine Serpinsky
end