#Include "crt.bi"
#Include "windows.bi"
#Include "win/gdiplus.bi"
#Include "window9.bi"
#Include "win/ole2.bi"

Using GDIPLUS

Dim Shared GDIPLUSSTARTUPINPUT As GDIPLUSSTARTUPINPUT
Dim Shared As ULONG_PTR gdiplusToken

Type S_info
  gpim As PVOID
  g As PVOID
  fg As PVOID
  BrushText As PVOID
  FontFam As PVOID
  font As PVOID
  Brush1 As PVOID
  hWnd As HWND
End Type

Dim Shared S1B As S_info
Dim Shared As RECTF SR1 = Type(0,0,1000,100)
Dim Shared S1_cc As Double

Dim Shared hwnd0 As HWND
Dim Shared As String sIm

Type boxinfo
  hWnd As HWND
End Type

Dim Shared mbox As boxinfo

Sub _OnPaint(g As Any Ptr)
  SR1 = Type(S1_cc, 0, 1000,100)
  S1_cc -= 0.5
  If S1_cc <= - 1000 Then
   S1_cc = 1000
  EndIf
  GdipSetSmoothingMode(S1B.fg, 5)
  GdipGraphicsClear(S1B.fg,&hFF000000)
  GdipFillRectangle(S1B.fg, S1B.Brush1, 0, 0, 1000,100)  
  GdipDrawString(S1B.fg, WSTR("FreeBasic FreeBasic FreeBasic FreeBasic FreeBasic FreeBasic"), LEN("FreeBasic FreeBasic FreeBasic FreeBasic FreeBasic FreeBasic"), S1B.font, @SR1, NULL, S1B.BrushText)
  GdipDrawImage(S1B.g,S1B.gpim, 0, 0)   
End Sub

Function WndProc(hWnd As HWND,uMsg As UINT,wParam As WPARAM,lParam As LPARAM) As Integer
  Select Case uMsg
   Case WM_CLOSE
    KillTimer(hwnd,1)
    GdipDeleteGraphics(S1B.g)
    GdipDeleteGraphics(S1B.fg)
    GdipDisposeImage(S1B.gpim)
    GdipDeleteBrush(S1B.BrushText)
    GdipDeleteBrush(S1B.Brush1)    
    GdiplusShutdown gdiplusToken
    PostQuitMessage(0)
   Case WM_CREATE    
    GDIPLUSSTARTUPINPUT.GdiplusVersion = 1
    GdiplusStartup(@gdiplusToken, @GDIPLUSSTARTUPINPUT, NULL)
    GdipCreateFromHWND(hWnd,@S1B.g)
    GdipCreateBitmapFromScan0(1000,100, NULL, PixelFormat32bppARGB, NULL, @S1B.gpim)
    GdipGetImageGraphicsContext(S1B.gpim,@S1B.fg)
    GdipCreateSolidFill(&hFFFF0000,@S1B.BrushText)
    GdipCreateFontFamilyFromName("Tahoma",NULL,@S1B.FontFam)
    GdipCreateFont(S1B.FontFam, 35, NULL, NULL, @S1B.font)    
    GdipCreateSolidFill(&hFF000000,@S1B.Brush1)   
    SetTimer(hWnd, 1, 10, 0)
   Case WM_TIMER
    _OnPaint(S1B.g)
   Case Else
    Return DefWindowProc(hWnd,uMsg,wParam,lParam)
  End Select
End Function

Sub _Create(mPtr As S_info Ptr)  
  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("Class")
   .hCursor=LoadCursor(NULL,IDC_ARROW)
  End With
  RegisterClassEx(@wc)
  CreateWindowEx(0,wc.lpszClassName,"Str",WS_OVERLAPPEDWINDOW Or WS_VISIBLE,0,100,1000,100,0,0,wc.hInstance,0)
  _OnPaint(S1B.g)
  While GetMessage(@msg,0,0,0)
   TranslateMessage(@msg)
   DispatchMessage(@msg)
  Wend
End Sub

Sub _tImBox (mPtr As boxinfo Ptr)
  Dim info As boxinfo = *mPtr  
  Dim As Integer event
  hwnd0 = OpenWindow("Image",100,200,500,500, WS_OVERLAPPEDWINDOW Or WS_VISIBLE)  
  ShowWindow(hwnd0,SW_SHOWNORMAL)
  ImageGadget(1,0,0,500,500)    '
  Do
   event=WaitEvent()
   If event=EventClose Then End
  Loop
End Sub

Sub Im(patch As String)  
  Var hbitmap=Load_image(sIm)  
  hbitmap=Resize_image(hbitmap,500,500)
  SetImageGadget(1,hbitmap)
  Free_Image(hBitmap)  
End Sub

' функции, вызываемые внешней программой
Extern "windows-ms"  

Function _RunImage(ByVal TextP As String) As String Export ' загрузка картинки
  sIm = TextP  
  ThreadCreate(@Im, @TextP)
  Function = TextP
End Function

Function _ImageInit(ByVal hWndC As HWND) As HWND Export ' запуск ImageGadget
  mbox.hWnd = hWndC
  ThreadCreate(Cast(Any Ptr, @_tImBox), @mbox)
  Function = mbox.hWnd  
End Function

Function _StrInit(ByVal hWnd As HWND) As HWND Export ' запуск движущегося текста
  S1B.hWnd = hWnd
  ThreadCreate(Cast(Any Ptr, @_Create), @S1B)  
  Function = S1B.hWnd
End Function

End Extern