Wer ist online?
Buchempfehlung
FreeBASIC-Chat
FreeBASIC-Nachrichten jetzt auch über Twitter erhalten. Follow us!fb:porticula NoPaste
fbImage.bi
| Uploader: |  hansholger |
| Datum/Zeit: | 25.03.2014 17:09:14 |
'------------------------------------------------------------------------------------------
' Image Laden
'------------------------------------------------------------------------------------------
#include once "win/GdiPlus.bi"
Type FBImage Extends Object
Public:
Declare Property ImgWidth() As Integer
Declare Property ImgHeight() As Integer
Declare Property ImgWidth(ByVal value As Integer )
Declare Property ImgHeight(ByVal value As Integer )
Declare Property DC() As HDC
Declare Property bkColor() As UInteger
Declare Property bkColor( ByVal x As UInteger )
Declare Sub LoadImg(s As String)
Declare Sub LoadRes(s As String)
Declare Sub ImgCopy(ByVal ZielDC As HDC, ByVal posx As Integer, ByVal posy As Integer)
Declare Sub ImgCopyRect(ByVal ZielDC As HDC, tRC As RECT, qRC As RECT, ByVal rop As UInteger)
Declare Destructor ( )
Private:
As Integer w = 0
As Integer h = 0
As HDC tdc = 0
As UInteger bkC = &hffffffff
End Type
Property FBImage.ImgWidth() As Integer
Return this.w
End Property
Property FBImage.ImgHeight() As Integer
Return this.h
End Property
Property FBImage.ImgWidth(ByVal value As Integer )
this.w = Value
End Property
Property FBImage.ImgHeight(ByVal value As Integer )
this.h = value
End Property
Property FBImage.bkColor() As UInteger
Return this.bkC
End Property
Property FBImage.bkColor( ByVal value As UInteger )
this.bkC = value
End Property
Property FBImage.DC() As HDC
Return this.tdc
End Property
DESTRUCTOR FBImage ()
If this.tdc <> 0 Then
DeleteDC(this.tdc)
End If
END Destructor
Sub FBImage.LoadImg(s As String)
Using Gdiplus
Dim As GdiplusStartupInput gdipsi
Dim As ULONG_PTR gdipToken
Dim As GpGraphics Ptr pGraph
Dim As GpImage Ptr pImg
Dim As HBITMAP bitmap
Dim As UInteger w,h
If this.tdc <> 0 Then
DeleteDC(this.tdc)
End If
gdipsi.GdiplusVersion = 1
If GdiplusStartup( @gdipToken, @gdipsi, null ) <> 0 Then
MessageBox(0,"Fehler bei der Initialisierung der GDI+","Fehler",MB_OK)
EndIf
If GdipLoadImageFromFile( WStr(s), @pImg) Then
MessageBox(0,"Datei "+s +" nicht gefunden!","Fehler",MB_OK)
EndIf
If GdipGetImageWidth (pImg, @w) = 0 Then
this.ImgWidth = w
EndIf
If GdipGetImageHeight (pImg, @h) = 0 Then
this.ImgHeight = h
Else
MessageBox(0,"Image Height konnte nicht gelesen werden","Fehler",MB_OK)
EndIf
Dim As HDC tmpDC = GetDC(GetDesktopWindow)
this.tdc = CreateCompatibleDC(tmpDC)
bitmap = CreateCompatibleBitmap(tmpDC,w,h)
SelectObject(this.tdc,bitmap)
ReleaseDC(GetDesktopWindow,tmpDc)
DeleteObject(bitmap)
GdipCreateFromHDC(this.tdc , @pGraph)
GdipGraphicsClear(pGraph,this.bkColor)
GdipDrawImageRect(pGraph, pImg, 0, 0, w, h)
'Image und Objekt freigeben
GdipDisposeImage( pImg)
GdipDeleteGraphics(pGraph)
GdiplusShutdown( gdipToken )
End Sub
Sub FBImage.LoadRes(resName As String)
Dim As HINSTANCE hInst
Dim As ZString * 128 szRes
Dim As BITMAP bm2
If this.tdc <> 0 Then
DeleteDC(this.tdc)
End If
hInst = GetModuleHandle(0)
szRes = resName
Dim As HDC hDC = GetDC(GetDesktopWindow)
this.tdc = CreateCompatibleDC(hDC)
Dim As HBITMAP hBmp = LoadBitmap(hInst , cast( LPCSTR, @szRes ))
If hBmp = 0 Then
MessageBox( null, "Fehler - Bitmap ist nicht gefunden", "Error", MB_ICONERROR )
Exit Sub
EndIf
GetObject(hBmp,SizeOf(bm2),@bm2)
this.ImgWidth = bm2.bmWidth
this.ImgHeight = bm2.bmHeight
SelectObject(this.tdc,hBmp)
DeleteObject(hBmp)
ReleaseDC(GetDesktopWindow,hDC)
End Sub
Sub FBImage.ImgCopy(ByVal ZielDC As HDC, ByVal posx As Integer, ByVal posy As Integer)
If this.tdc<>0 Then
BitBlt(ZielDC,posx,posy,this.ImgWidth,this.ImgHeight,this.tdc,0,0,SRCCOPY)
EndIf
End Sub
Sub FBImage.ImgCopyRect(ByVal ZielDC As HDC, tRC As RECT, qRC As RECT, ByVal rop As UInteger)
Dim As UInteger iRop
If rop = 0 Then
iRop = SRCCOPY
Else
iRop = rop
EndIf
If this.tdc<>0 Then
StretchBlt(ZielDC,tRC.left,tRC.top,tRC.right,tRC.bottom ,this.tdc,qRC.left,qRC.top,qRC.right,qRC.bottom ,iRop)
EndIf
End Sub