Schrift
Wiki:Tipp zum Debugging: use Data::Dumper; local $Data::Dumper::Useqq = 1; print Dumper \@var;
Start · Board · Anwendungen/Programme/Skripte in Perl · Graphische Oberflächen
[thread]11019[/thread]

Tk::Balloon mit Schatten

Leser: 2


<< >> 5 Einträge, 1 Seite
#Kein Kommentar
 2007-12-13 23:33
#103862 #103862
User since
2007-06-09
575 Artikel
HausmeisterIn
[default_avatar]
hallo,

ich hatte gerade mal ein bisschen mit Tk::Balloon herumgespielt und einen schatten für das balloon-fenster programmiert (nur dirty und quick), um Win-Look hinzukriegen.

für alle die das auch benutzen wollen (es wird das Modul CPAN:Tk::StayOnTop benötigt, ist über ppm erhältlich):

1: Füg nach dem Kopf des Moduls ein use Tk::StayOnTop; ein.


2: Füge diesen Code ganz am Ende der Subroutine '-> Popup' ein (ca. Zeile 560)
Code: (dl )
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
    $w-> stayOnTop ();

    # the shadow:
    unless ($w-> {'shadow'}){
	# create the toplevel 'shadow':
    	$w->{'shadow'}	= $w-> Toplevel (
						-height	=> $w-> height,
						-width	=> $w-> width,
					);
    	$w->{'shadow'}-> overrideredirect (1);

    	$w->{'shadow'}-> configure (-background => '#666666');
    	$w->{'shadow'}-> Label (-takefocus => 1)-> place ();

	my ($shadow_x, $shadow_y)	= ($xx+2, $y+11);
    	$w->{'shadow'}-> geometry ("+$shadow_x+$shadow_y");
    }
    else{

	my ($shadow_x, $shadow_y)	= ($xx+2, $y+11);
    	$w->{'shadow'}-> geometry ("+$shadow_x+$shadow_y");

   	$w-> {'shadow'}-> configure (-height	=> $w-> height, -width	=> $w-> width,);

	$w->{'shadow'}-> deiconify ();
    }



3: Jetzt den Inhalt von der Subroutine '-> Deactivate' mit diesem Code tauschen:

Code: (dl )
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
    my ($w) = @_;
    my $delay = delete $w->{'delay'};
    $delay->cancel if defined $delay;
    if ($w->{'popped'}) {
	    my $client = $w->{'client'};
	    my $command = $w->GetOption(-cancelcommand => $client);
	    if (defined $command) {
	        # Execute the user's command and return if it returns false:
	        return if not $command->Call($client);
	    }
	    $w->withdraw;
            $w-> {'shadow'}-> withdraw;
	    $w->ClearStatus;
	    $w->{'popped'} = 0;
	    $w->{'menu_index'} = 'none';
	    $w->{'canvas_tag'} = '';
    }
    $w->{'client'} = undef;
    $w->{'subclient'} = undef;
    $w->{'location'} = undef;


4: Ausprobieren! :)


den code hab ich jetzt nur so aus spaß gemacht, also ich habe ihn nur ein paar mal getestet und so... kommentare sind natürlich erwünscht..
Gerade weil wir alle in einem Boot sitzen, sollten wir froh sein, dass nicht alle auf unserer Seite sind
pktm
 2007-12-14 20:10
#103895 #103895
User since
2003-08-07
2921 Artikel
BenutzerIn
[Homepage]
user image
Zu 4.:

Ich habe das mal ausprobiert :)

Leider scheitere ich ein wenig bei der Vererbung.
Code: (dl )
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
package Tk::MyOwnBalloon;

use strict;
use warnings;
use Carp qw/croak/;

use Tk::widgets qw/ Balloon /;
use base qw/ Tk::Derived Tk::Balloon /;

Construct Tk::Widget 'MyOwnBalloon';


=head1 Beschreibung

Modifikation von Tk::Ballon: Zeigt einen Hintergrundschatten für das Popup an.




=head1 METHODEN

=head2 ClassInit( $mw )

=cut

sub ClassInit {
	my( $class, $mw ) = @_;
	#... e.g., class bindings here ...
	$class->SUPER::ClassInit( $mw );
} # /ClassInit




=head2 Populate( $args )

=cut

sub Populate {
	my( $self, $args ) = @_;
	$self->SUPER::Populate( $args );
} # /Populate




=head2 Popup( ??? )

=cut

sub Popup {
    # -- Inhalt der Tk::Balloon::Popup-Funktion, aus technischen Gründen gekürzt....
	
	# -- Modifikation ab hier
	
    $w->stayOnTop ();

    # the shadow:
    unless ( $w->{'shadow'} ) {
		
		# create the toplevel 'shadow':
        $w->{'shadow'} = $w->Toplevel(
            -height	=> $w->height(),
            -width 	=> $w->width(),
		);
        $w->{'shadow'}->overrideredirect(1);

        $w->{'shadow'}->configure(-background => '#666666');
        $w->{'shadow'}->Label(-takefocus => 1)->place();

		my ($shadow_x, $shadow_y) = ($xx+2, $y+11);
        $w->{'shadow'}->geometry("+$shadow_x+$shadow_y");
		
    }else {

		my ($shadow_x, $shadow_y) = ($xx+2, $y+11);
        $w->{'shadow'}-> geometry ("+$shadow_x+$shadow_y");

		$w->{'shadow'}->configure(
			-height	=> $w->height(),
			-width	=> $w->width(),
		);

		$w->{'shadow'}->deiconify();
    }
	
} # /Popup



=head2 Deactivate( ??? )

=cut

sub Deactivate {
    my ($w) = @_;
    my $delay = delete $w->{'delay'};
    $delay->cancel if defined $delay;
    if ($w->{'popped'}) {
        my $client = $w->{'client'};
        my $command = $w->GetOption(-cancelcommand => $client);
        if (defined $command) {
            # Execute the user's command and return if it returns false:
            return if not $command->Call($client);
        }
        $w->withdraw;
            $w-> {'shadow'}-> withdraw;
        $w->ClearStatus;
        $w->{'popped'} = 0;
        $w->{'menu_index'} = 'none';
        $w->{'canvas_tag'} = '';
    }
    $w->{'client'} = undef;
    $w->{'subclient'} = undef;
    $w->{'location'} = undef;
} # /Deactivate


1;


Das bringt den Fehler:
Quote
Can't locate Tk/MyOwnBalloon.pm in @INC ...


Das Modul liegt im Verzeichnis des aufrufenden Skripts im Verzeichnis Tk und nennt sich MyOwnBalloon.pm.

Edit: hier noch schnell die INstanz:
Code: (dl )
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
#!/Perl/bin/perl

use strict;
use warnings;
use Data::Dumper qw/Dumper/;
use Perl6::Say;
use FindBin qw/$Bin/;
use lib $Bin;
use Tk;
use Tk::Balloon;
use Tk::PNG;
use Tk::MyOwnBalloon;

my $mw = Tk::MainWindow->new();
$mw->packPropagate(0);

# -- Tk::Baloon (Original)

my $widget = $mw->Button(
    -text       => 'press me...',
    -command    => sub{ say "push!"; },
)->pack();

my $b = $mw->Balloon();

$b->attach($widget,
    -position => 'widget',
    -balloonmsg => "Balloon help message",
);


# -- Baloon mit Schatten (modifiziert)

my $widget2 = $mw->Button(
    -text       => 'press me...',
    -command    => sub{ say "push (2)!"; },
)->pack();

my $b2 = $mw->MyOwnBalloon();

$b2->attach($widget2,
    -position => 'widget',
    -balloonmsg => "Balloon (mod.) help message",
);



$mw->MainLoop();


Hat wer Rat?

Grüße, pktm
http://www.intergastro-service.de (mein erstes CMS :) )
ptk
 2007-12-14 22:23
#103898 #103898
User since
2003-11-28
3645 Artikel
ModeratorIn
[default_avatar]
Hier (FreeBSD) funktioniert es mit ein paar Tweaks (use Tk::StayOnTop; und use Tk qw(Exists) fehlt).

Aber leider gibt es ein Problem, wenn der Schatten-Balloon verschwindet. Dann erscheint wenig später der einfache Balloon wieder auf.
pktm
 2007-12-17 02:04
#103962 #103962
User since
2003-08-07
2921 Artikel
BenutzerIn
[Homepage]
user image
Hat niemand eine Idee zu meinem Problem?

Grüße, pktm
http://www.intergastro-service.de (mein erstes CMS :) )
ptk
 2007-12-17 08:48
#103964 #103964
User since
2003-11-28
3645 Artikel
ModeratorIn
[default_avatar]
pktm+2007-12-17 01:04:25--
Hat niemand eine Idee zu meinem Problem?

Wenn du Linux/Unix zur Verfügung hast, solltest du mal mit strace, truss oder ktrace debuggen.
<< >> 5 Einträge, 1 Seite



View all threads created 2007-12-13 23:33.