XProfan

Source wurde am 15.07.2007 aus der MMJ-Quellcodesammlung (Dietmar Horn) in die Babyklappe auf XProfan.Com abgelegt:
Animierte Cursor laufen lassen (Hunde), oder Buttons zuweisen
Lauffähig ab Profan-Version 5.0
#############################################################
Animierte Cursor laufen lassen
oder Buttons zuweisen
oder Icons aus Dlls oder eigener Instanz laden und zuweisen
für Profan² 32-bit
#############################################################
Andreas Miethe * Bielefeld * August 1998
Quellcode ist frei nutzbar
#############################################################
Beschreibung für DrawIconEx
***************************
DrawExIcon (Device-Context-Handle{HDC},X-Position,Y-Position,ICON-Handle,Icon-Breite,Icon-Hoehe,
Icon-Index{Bild-Nummer bei Animation},Hintergrundfarbe,Flags)
bei animierten Cursorn sollte die Anzahl der Bilder und die Verzoegerung bekannt sein !
Flags :
#######
DI_MASK = 1
DI_IMAGE = 2
DI_NORMAL = 3
DI_COMPAT = 4
DI_DEFAULTSIZE = 8
#################################################################################################
Def ADrawIconEx(9) ! User32,DrawIconEx
Def LoadIcon(2) !USER32,LoadIconA
Def APILoadCursorFromFile(1) ! USER32,LoadCursorFromFileA
Def ASleep(1) !Kernel32,Sleep
Def APICreateSolidBrush(1) ! GDI32,CreateSolidBrush
Def APIGetDC(1) ! USER32,GetDC,%,%
DEF @AGetSysColor(1) !USER32,GetSysColor
DEF AExtractIcon(3) !SHELL32,ExtractIconA
Declare hdll&,DllIcon&,InstIcon&,sysicon&,Ico&,B1&,st#,Datei#
Declare Button%,BDC&,IDC&
Declare yy%,x%,x1%,ende%,y%,b&,farbe&,g%
Declare hcur#,hc&,hc1&
Settruecolor 1

Proc Lade_Hund

    Den  Hund  laden
    Parameters name$
    Dim hcur#,len (name$) + 1
    String hcur#,0=name$
    Let hc&=APILoadCursorFromFile(hcur#)
    Dispose hcur#

Endproc

Proc Lade_Globus

    Den  Globus  laden
    Parameters name$
    Dim hcur#,len(name$) + 1
    String hcur#,0=name$
    Let hc1&=APILoadCursorFromFile(hcur#)
    Dispose hcur#

Endproc

Proc Male_Icon_1

    Ein Icon aus der eigenen Instanz
    ################################
    Dim st#,50
    String st#,0 = A
    Let InstIcon&=LoadIcon(%hinstance,st#) Icon A aus HINSTANCE
    ADrawIconEx(%HDC,100,100,InstIcon&,32,32,0,b&,3)  In das Fenster
    Dispose st#

Endproc

Proc Male_Icon_2

    Ein Icon aus einer DLL
    ######################
    Dim Datei#,120
    String Datei#,0=Moricons.dll
    Let dllIcon& = AExtractIcon(%Hinstance,Datei#,49)
    ADrawIconEx(%HDC,100,200,dllIcon&,64,64,0,b&,3) ein bißchen groeßer - In das Fenster
    Dispose Datei#

Endproc

Ein System-Icon
###############
Let SysIcon& = LoadIcon(0,32513)  SYSTEMICON - {von 32512 - 32517}

Proc Male_ani

    Das Systemicon
    ADrawIconEx(BDC&,4,4,SysIcon&,16,16,x1%,b&,3)  Auf den Button
    Der erste Globus
    ADrawIconEx(BDC&,76,4,Hc1&,16,16,x1%,b&,3)  Auf den Button
    Der zweite Globus
    ADrawIconEx(IDC&,3,3,Hc1&,32,32,x1%,b1&,3)  In ein Control
    Der erste Hund
    ADrawIconEx(%hdc,y%,yy%,hc&,g%,g%,x%,b&,3)
    Rectangle add(y%,g%),yy%-add(y%,add(g%,g%)),add(yy%,g%)
    Der zweite Hund
    ADrawIconEx(%hdc,sub(y%,64),yy%,hc&,g%,g%,x%,b&,3)
    Rectangle add(sub(y%,64),g%),yy%-add(sub(y%,64),add(g%,g%)),add(yy%,g%)
    Der dritte Hund
    ADrawIconEx(%hdc,sub(y%,128),yy%,hc&,g%,g%,x%,b&,3)
    Rectangle add(sub(y%,128),g%),yy%-add(sub(y%,128),add(g%,g%)),add(yy%,g%)

Endproc

Proc Fensteraufbau

    Let Button% = @CreateButton(%hwnd,Ende,10,10,100,24)
    Let BDC& = APIGetDC(Button%)              Device-Context-Handle für den Button
    Let ico& = @Control(Static,,$50001004,580,0,40,40,%hwnd,1000,%Hinstance)
    Let IDC& = APIGetDC(Ico&)                Device-Context-Handle für das Control
    Let B1&=rgb(0,0,0)                       Hintergrundfarbe für Control

Endproc

Hauptprogramm
#############
Lade_Hund Dog.ani                      Animierter Cursor Nr.1
Lade_Globus Globe2.ani                 Animierter Cursor Nr.2
Let Farbe& = @AGetSysColor(15)           Buttonface - Hintergrundfarbe für animierten Cursor
window add(%maxx,1),0-640,480            erstmal neben den Bildschirm
UseFont Arial,15,0,0,0,0
SetDialogFont 1
CLS Farbe&
Let b& = APICreateSolidBrush(Farbe&)     Hier wird die Hintergrundfarbe gesetzt
für die transparente Darstellung
UseBrush 1,Farbe&  wird benötigt für Rechteck
UsePen 0,0,Farbe&  wird benötigt für Rechteck
Wird das Rechteck nicht gezeichnet, zieht ein animierter
Cusor Streifen - probier es aus !
Voreinstellungen für den Hund
#############################
Let y%=830      Anfangsposition
Let g%=32       Groesse des Curors
Let yy%=300     Y-Position
Fensteraufbau
setwindowpos %hwnd = 0,0-640,480         jetzt auf den Bilschirm
Male_Icon_1
Male_Icon_2
Male_ani

whilenot ende%

    case equ(x%,6):let x%=0

    if lt (y%,sub(g%,mul(g%,3)))

        let y%=830

    endif

    Case Getfocus(Button%):let ende%=1
    case equ(x1%,16):let x1%=0
    Male_ani
    inc x%
    inc x1%
    sub y%,10
    ASleep(60)

wend

end