diff options
Diffstat (limited to 'src')
67 files changed, 8066 insertions, 593 deletions
diff --git a/src/3rdparty/README.txt b/src/3rdparty/README.txt new file mode 100644 index 00000000..406a8a6c --- /dev/null +++ b/src/3rdparty/README.txt @@ -0,0 +1,5 @@ +The code found here is optional extras. When using them, they will add +extra dependencies to your project, but that is a choice for you to +make. + +For further details please see the README file in each sub-directory.
\ No newline at end of file diff --git a/src/3rdparty/libvlc/README.txt b/src/3rdparty/libvlc/README.txt new file mode 100644 index 00000000..0b1f1147 --- /dev/null +++ b/src/3rdparty/libvlc/README.txt @@ -0,0 +1,11 @@ + +VLC Library 2.x + +This directory contains header translations of the VLC library v2.x, as well +as unit containing a non-gui Media Player class. There is also a fpGUI Media +Player descendant class added, which allows you to embed the video output +inside a fpGUI widget. + +This code was commissioned by Master Maths [http://www.mastermaths.co.za] +(my employer), and kindly donated to the Free Pascal and fpGUI Toolkit +projects. diff --git a/src/3rdparty/libvlc/fpg_vlc.pas b/src/3rdparty/libvlc/fpg_vlc.pas new file mode 100644 index 00000000..0eb8daba --- /dev/null +++ b/src/3rdparty/libvlc/fpg_vlc.pas @@ -0,0 +1,81 @@ +unit fpg_vlc; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, libvlc, vlc, fpg_main; + +Type + + { TFpgVLCPlayer } + + TFpgVLCPlayer = Class(TVLCMediaPlayer) + private + FParentWindow: TfpgWindow; + procedure SetParentWindowControl(AValue: TfpgWindow); + Protected + Procedure SetParentWindow; override; + Procedure SetParentWindowSize(AWidth,AHeight : Cardinal); override; + procedure Notification(AComponent: TComponent; Operation: TOperation); override; + Published + Property ParentWindow : TfpgWindow Read FParentWindow Write SetParentWindowControl; + end; + +implementation + +{ TFpgVLCPlayer } + +procedure TFpgVLCPlayer.SetParentWindowControl(AValue: TfpgWindow); +begin + if FParentWindow=AValue then Exit; + If Assigned(FParentWindow) then + FParentWindow.RemoveFreeNotification(Self); + FParentWindow:=AValue; + If Assigned(FParentWindow) then + FParentWindow.FreeNotification(Self); +end; + +procedure TFpgVLCPlayer.SetParentWindow; + +begin + if Assigned(ParentWindow) then + begin + {$IFDEF UNIX} + libvlc_media_player_set_xwindow(Instance, ParentWindow.WinHandle); + {$ENDIF} + {$IFDEF MSWINDOWS} + libvlc_media_player_set_hwnd(Instance, Pointer(ParentWindow.WinHandle)); + {$ENDIF} + end + else if HaveInstance then + begin + {$IFDEF UNIX} + libvlc_media_player_set_xwindow(Instance, 0); + {$ENDIF} + {$IFDEF MSWINDOWS} + libvlc_media_player_set_hwnd(Instance, Nil); + {$ENDIF} + end +end; + +procedure TFpgVLCPlayer.SetParentWindowSize(AWidth, AHeight: Cardinal); +begin + If Assigned(ParentWindow) then + begin + ParentWindow.Width:=AWidth; + ParentWindow.Height:=AHeight; + end; +end; + +procedure TFpgVLCPlayer.Notification(AComponent: TComponent; + Operation: TOperation); +begin + Inherited; + if (Operation=opRemove) and (AComponent=FParentWindow) then + FParentWindow:=Nil; +end; + +end. + diff --git a/src/3rdparty/libvlc/libvlc.pas b/src/3rdparty/libvlc/libvlc.pas new file mode 100644 index 00000000..cfdc1e52 --- /dev/null +++ b/src/3rdparty/libvlc/libvlc.pas @@ -0,0 +1,1156 @@ + +{$mode objfpc} +unit libvlc; +interface + +uses + ctypes; + +{$IFDEF FPC} +{$PACKRECORDS C} +{$ENDIF} + +Const + +{$ifdef unix} + libname = 'libvlc.so'; +{$else} +{$ifdef windows} + DefaultlibPath = 'C:\Program files\Videolan\VLC\'; + corelibname = 'libvlccore.dll'; + libname = 'libvlc.dll'; +{$endif} +{$endif} + + Type + _bool = cint; + Ppcchar = ^Pcchar; + + // Opaque types. + libvlc_event_manager_t = record end; + Libvlc_instance_t = record end; + Libvlc_log_iterator_t = record end; + Libvlc_log_t = record end; + Libvlc_media_discoverer_t = record end; + Libvlc_media_library_t = record end; + Libvlc_media_list_player_t = record end; + Libvlc_media_list_t = record end; + Libvlc_media_player_t = record end; + Libvlc_media_t = record end; + + Plibvlc_audio_output_t = ^libvlc_audio_output_t; + Plibvlc_event_manager_t = ^libvlc_event_manager_t; + Plibvlc_event_t = ^libvlc_event_t; + Plibvlc_instance_t = ^libvlc_instance_t; + Plibvlc_log_iterator_t = ^libvlc_log_iterator_t; + Plibvlc_log_message_t = ^libvlc_log_message_t; + Plibvlc_log_t = ^libvlc_log_t; + Plibvlc_media_discoverer_t = ^libvlc_media_discoverer_t; + Plibvlc_media_library_t = ^libvlc_media_library_t; + Plibvlc_media_list_player_t = ^libvlc_media_list_player_t; + Plibvlc_media_list_t = ^libvlc_media_list_t; + Plibvlc_media_player_t = ^libvlc_media_player_t; + Plibvlc_media_stats_t = ^libvlc_media_stats_t; + Plibvlc_media_t = ^libvlc_media_t; + Plibvlc_media_track_info_t = ^libvlc_media_track_info_t; + Plibvlc_module_description_t = ^libvlc_module_description_t; + Plibvlc_track_description_t = ^libvlc_track_description_t; + + int8_t = cschar; + int16_t = csint; + int32_t = cint; + int64_t = clong; + uint8_t = cuchar; + uint16_t = csint; + uint32_t = cuint; + uint64_t = culong; + int_least8_t = cschar; + int_least16_t = csint; + int_least32_t = cint; + int_least64_t = clong; + uint_least8_t = cuchar; + uint_least16_t = csint; + uint_least32_t = cuint; + uint_least64_t = culong; + int_fast8_t = cschar; + int_fast16_t = clong; + int_fast32_t = clong; + int_fast64_t = clong; + uint_fast8_t = cuchar; + uint_fast16_t = culong; + uint_fast32_t = culong; + uint_fast64_t = culong; + intptr_t = clong; + uintptr_t = culong; + intmax_t = clong; + uintmax_t = culong; + + libvlc_time_t = int64_t; + libvlc_log_message_t = record + i_severity : cint; + psz_type : ^cchar; + psz_name : ^cchar; + psz_header : ^cchar; + psz_message : ^cchar; + end; + + libvlc_event_type_t = cint; + libvlc_callback_t = procedure (_para1:Plibvlc_event_t; _para2:pointer);cdecl; + + libvlc_module_description_t = record + psz_name : ^cchar; + psz_shortname : ^cchar; + psz_longname : ^cchar; + psz_help : ^cchar; + p_next : ^libvlc_module_description_t; + end; + +{ +static inline int64_t libvlc_delay(int64_t pts) + + return pts - libvlc_clock(); + + } + + + libvlc_meta_t = (libvlc_meta_Title,libvlc_meta_Artist, + libvlc_meta_Genre,libvlc_meta_Copyright, + libvlc_meta_Album,libvlc_meta_TrackNumber, + libvlc_meta_Description,libvlc_meta_Rating, + libvlc_meta_Date,libvlc_meta_Setting, + libvlc_meta_URL,libvlc_meta_Language, + libvlc_meta_NowPlaying,libvlc_meta_Publisher, + libvlc_meta_EncodedBy,libvlc_meta_ArtworkURL, + libvlc_meta_TrackID); + + libvlc_state_t = (libvlc_NothingSpecial := 0,libvlc_Opening, + libvlc_Buffering,libvlc_Playing,libvlc_Paused, + libvlc_Stopped,libvlc_Ended,libvlc_Error + ); + + libvlc_media_option_t = (libvlc_media_option_trusted := $2,libvlc_media_option_unique := $100 + ); + + libvlc_track_type_t = (libvlc_track_unknown := -(1),libvlc_track_audio := 0, + libvlc_track_video := 1,libvlc_track_text := 2 + ); + + libvlc_media_stats_t = record + i_read_bytes : cint; + f_input_bitrate : cfloat; + i_demux_read_bytes : cint; + f_demux_bitrate : cfloat; + i_demux_corrupted : cint; + i_demux_discontinuity : cint; + i_decoded_video : cint; + i_decoded_audio : cint; + i_displayed_pictures : cint; + i_lost_pictures : cint; + i_played_abuffers : cint; + i_lost_abuffers : cint; + i_sent_packets : cint; + i_sent_bytes : cint; + f_send_bitrate : cfloat; + end; + + libvlc_media_track_info_t = record + i_codec : uint32_t; + i_id : cint; + i_type : libvlc_track_type_t; + i_profile : cint; + i_level : cint; + u : record + case longint of + 0 : ( audio : record + i_channels : cunsigned; + i_rate : cunsigned; + end ); + 1 : ( video : record + i_height : cunsigned; + i_width : cunsigned; + end ); + end; + end; + + + libvlc_track_description_t = record + i_id : cint; + psz_name : ^cchar; + p_next : ^libvlc_track_description_t; + end; + + libvlc_audio_output_t = record + psz_name : ^cchar; + psz_description : ^cchar; + p_next : ^libvlc_audio_output_t; + end; + + libvlc_rectangle_t = record + top : cint; + left : cint; + bottom : cint; + right : cint; + end; + + libvlc_video_marquee_option_t = (libvlc_marquee_Enable := 0,libvlc_marquee_Text, + libvlc_marquee_Color,libvlc_marquee_Opacity, + libvlc_marquee_Position,libvlc_marquee_Refresh, + libvlc_marquee_Size,libvlc_marquee_Timeout, + libvlc_marquee_X,libvlc_marquee_Y); + + libvlc_navigate_mode_t = (libvlc_navigate_activate := 0,libvlc_navigate_up, + libvlc_navigate_down,libvlc_navigate_left, + libvlc_navigate_right); + + + libvlc_video_lock_cb = function (opaque:pointer; planes:Ppointer):pointer;cdecl; + libvlc_video_unlock_cb = procedure (opaque:pointer; picture:pointer; planes:Ppointer);cdecl; + libvlc_video_display_cb = procedure (opaque:pointer; picture:pointer);cdecl; + libvlc_video_format_cb = function (opaque:Ppointer; chroma:pcchar; width:pcunsigned; height:pcunsigned; pitches:pcunsigned; + lines:pcunsigned):cunsigned;cdecl; + libvlc_video_cleanup_cb = procedure (opaque:pointer);cdecl; + libvlc_audio_play_cb = procedure (data:pointer; samples:pointer; count:cunsigned; pts:int64_t);cdecl; + libvlc_audio_pause_cb = procedure (data:pointer; pts:int64_t);cdecl; + libvlc_audio_resume_cb = procedure (data:pointer; pts:int64_t);cdecl; + libvlc_audio_flush_cb = procedure (data:pointer; pts:int64_t);cdecl; + libvlc_audio_drain_cb = procedure (data:pointer);cdecl; + libvlc_audio_set_volume_cb = procedure (data:pointer; volume:cfloat; mute:_Bool);cdecl; + libvlc_audio_setup_cb = function (data:Ppointer; format:pcchar; rate:pcunsigned; channels:pcunsigned):cint;cdecl; + libvlc_audio_cleanup_cb = procedure (data:pointer);cdecl; + libvlc_video_logo_option_t = (libvlc_logo_enable,libvlc_logo_file,libvlc_logo_x, + libvlc_logo_y,libvlc_logo_delay,libvlc_logo_repeat, + libvlc_logo_opacity,libvlc_logo_position + ); + libvlc_video_adjust_option_t = (libvlc_adjust_Enable := 0,libvlc_adjust_Contrast, + libvlc_adjust_Brightness,libvlc_adjust_Hue, + libvlc_adjust_Saturation,libvlc_adjust_Gamma + ); + libvlc_audio_output_device_types_t = (libvlc_AudioOutputDevice_Error := -(1), + libvlc_AudioOutputDevice_Mono := 1, + libvlc_AudioOutputDevice_Stereo := 2, + libvlc_AudioOutputDevice_2F2R := 4, + libvlc_AudioOutputDevice_3F2R := 5, + libvlc_AudioOutputDevice_5_1 := 6,libvlc_AudioOutputDevice_6_1 := 7, + libvlc_AudioOutputDevice_7_1 := 8,libvlc_AudioOutputDevice_SPDIF := 10 + ); + + libvlc_audio_output_channel_t = (libvlc_AudioChannel_Error := -(1),libvlc_AudioChannel_Stereo := 1, + libvlc_AudioChannel_RStereo := 2,libvlc_AudioChannel_Left := 3, + libvlc_AudioChannel_Right := 4,libvlc_AudioChannel_Dolbys := 5 + ); + libvlc_playback_mode_t = (libvlc_playback_mode_default,libvlc_playback_mode_loop, + libvlc_playback_mode_repeat); + + libvlc_event_e = (libvlc_MediaMetaChanged := 0, + libvlc_MediaSubItemAdded, + libvlc_MediaDurationChanged,libvlc_MediaParsedChanged, + libvlc_MediaFreed,libvlc_MediaStateChanged, + libvlc_MediaPlayerMediaChanged := $100, + libvlc_MediaPlayerNothingSpecial,libvlc_MediaPlayerOpening, + libvlc_MediaPlayerBuffering,libvlc_MediaPlayerPlaying, + libvlc_MediaPlayerPaused,libvlc_MediaPlayerStopped, + libvlc_MediaPlayerForward,libvlc_MediaPlayerBackward, + libvlc_MediaPlayerEndReached,libvlc_MediaPlayerEncounteredError, + libvlc_MediaPlayerTimeChanged,libvlc_MediaPlayerPositionChanged, + libvlc_MediaPlayerSeekableChanged,libvlc_MediaPlayerPausableChanged, + libvlc_MediaPlayerTitleChanged,libvlc_MediaPlayerSnapshotTaken, + libvlc_MediaPlayerLengthChanged,libvlc_MediaPlayerVout, + libvlc_MediaListItemAdded := $200,libvlc_MediaListWillAddItem, + libvlc_MediaListItemDeleted,libvlc_MediaListWillDeleteItem, + libvlc_MediaListViewItemAdded := $300, + libvlc_MediaListViewWillAddItem,libvlc_MediaListViewItemDeleted, + libvlc_MediaListViewWillDeleteItem,libvlc_MediaListPlayerPlayed := $400, + libvlc_MediaListPlayerNextItemSet,libvlc_MediaListPlayerStopped, + libvlc_MediaDiscovererStarted := $500, + libvlc_MediaDiscovererEnded,libvlc_VlmMediaAdded := $600, + libvlc_VlmMediaRemoved,libvlc_VlmMediaChanged, + libvlc_VlmMediaInstanceStarted,libvlc_VlmMediaInstanceStopped, + libvlc_VlmMediaInstanceStatusInit,libvlc_VlmMediaInstanceStatusOpening, + libvlc_VlmMediaInstanceStatusPlaying, + libvlc_VlmMediaInstanceStatusPause,libvlc_VlmMediaInstanceStatusEnd, + libvlc_VlmMediaInstanceStatusError); + + + libvlc_event_t = record + _type : cint; + p_obj : pointer; + case longint of + 0 : ( media_meta_changed : record + meta_type : libvlc_meta_t; + end ); + 1 : ( media_subitem_added : record + new_child : ^libvlc_media_t; + end ); + 2 : ( media_duration_changed : record + new_duration : int64_t; + end ); + 3 : ( media_parsed_changed : record + new_status : cint; + end ); + 4 : ( media_freed : record + md : ^libvlc_media_t; + end ); + 5 : ( media_state_changed : record + new_state : libvlc_state_t; + end ); + 6 : ( media_player_buffering : record + new_cache : cfloat; + end ); + 7 : ( media_player_position_changed : record + new_position : cfloat; + end ); + 8 : ( media_player_time_changed : record + new_time : libvlc_time_t; + end ); + 9 : ( media_player_title_changed : record + new_title : cint; + end ); + 10 : ( media_player_seekable_changed : record + new_seekable : cint; + end ); + 11 : ( media_player_pausable_changed : record + new_pausable : cint; + end ); + 12 : ( media_player_vout : record + new_count : cint; + end ); + 13 : ( media_list_item_added : record + item : ^libvlc_media_t; + index : cint; + end ); + 14 : ( media_list_will_add_item : record + item : ^libvlc_media_t; + index : cint; + end ); + 15 : ( media_list_item_deleted : record + item : ^libvlc_media_t; + index : cint; + end ); + 16 : ( media_list_will_delete_item : record + item : ^libvlc_media_t; + index : cint; + end ); + 17 : ( media_list_player_next_item_set : record + item : ^libvlc_media_t; + end ); + 18 : ( media_player_snapshot_taken : record + psz_filename : ^cchar; + end ); + 19 : ( media_player_length_changed : record + new_length : libvlc_time_t; + end ); + 20 : ( vlm_media_event : record + psz_media_name : ^cchar; + psz_instance_name : ^cchar; + end ); + 21 : ( media_player_media_changed : record + new_media : ^libvlc_media_t; + end ); + end; + + PPlibvlc_media_track_info_t = ^Plibvlc_media_track_info_t; + cbtype1 = procedure (_para1:pointer); cdecl; + +Var + libvlc_media_player_new : function(p_libvlc_instance:Plibvlc_instance_t):plibvlc_media_player_t; cdecl; + libvlc_media_player_new_from_media : function(p_md:Plibvlc_media_t):plibvlc_media_player_t; cdecl; + libvlc_media_player_release : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_retain : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_set_media : procedure(p_mi:Plibvlc_media_player_t; p_md:Plibvlc_media_t); cdecl; + libvlc_media_player_get_media : function(p_mi:Plibvlc_media_player_t):plibvlc_media_t; cdecl; + libvlc_media_player_event_manager : function(p_mi:Plibvlc_media_player_t):plibvlc_event_manager_t; cdecl; + libvlc_media_player_is_playing : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_play : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_set_pause : procedure(mp:Plibvlc_media_player_t; do_pause:cint); cdecl; + libvlc_media_player_pause : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_stop : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_new_location : function(p_instance:Plibvlc_instance_t; psz_mrl:pcchar):plibvlc_media_t; cdecl; + libvlc_media_new_path : function(p_instance:Plibvlc_instance_t; path:pcchar):plibvlc_media_t; cdecl; + libvlc_media_new_fd : function(p_instance:Plibvlc_instance_t; fd:cint):plibvlc_media_t; cdecl; + libvlc_media_new_as_node : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):plibvlc_media_t; cdecl; + libvlc_media_add_option : procedure(p_md:Plibvlc_media_t; ppsz_options:pcchar); cdecl; + libvlc_media_add_option_flag : procedure(p_md:Plibvlc_media_t; ppsz_options:pcchar; i_flags:cunsigned); cdecl; + libvlc_media_retain : procedure(p_md:Plibvlc_media_t); cdecl; + libvlc_media_release : procedure(p_md:Plibvlc_media_t); cdecl; + libvlc_media_get_mrl : function(p_md:Plibvlc_media_t):pcchar; cdecl; + libvlc_media_duplicate : function(p_md:Plibvlc_media_t):plibvlc_media_t; cdecl; + libvlc_media_get_meta : function(p_md:Plibvlc_media_t; e_meta:libvlc_meta_t):pcchar; cdecl; + libvlc_media_set_meta : procedure(p_md:Plibvlc_media_t; e_meta:libvlc_meta_t; psz_value:pcchar); cdecl; + libvlc_media_save_meta : function(p_md:Plibvlc_media_t):cint; cdecl; + libvlc_media_get_state : function(p_md:Plibvlc_media_t):libvlc_state_t; cdecl; + libvlc_media_get_stats : function(p_md:Plibvlc_media_t; p_stats:Plibvlc_media_stats_t):cint; cdecl; + libvlc_media_subitems : function(p_md:Plibvlc_media_t):plibvlc_media_list_t; cdecl; + libvlc_media_event_manager : function(p_md:Plibvlc_media_t):plibvlc_event_manager_t; cdecl; + libvlc_media_get_duration : function(p_md:Plibvlc_media_t):libvlc_time_t; cdecl; + libvlc_media_parse : procedure(p_md:Plibvlc_media_t); cdecl; + libvlc_media_parse_async : procedure(p_md:Plibvlc_media_t); cdecl; + libvlc_media_is_parsed : function(p_md:Plibvlc_media_t):cint; cdecl; + libvlc_media_set_user_data : procedure(p_md:Plibvlc_media_t; p_new_user_data:pointer); cdecl; + libvlc_media_get_user_data : function(p_md:Plibvlc_media_t):pointer; cdecl; + libvlc_media_get_tracks_info : function(p_md:Plibvlc_media_t; tracks:PPlibvlc_media_track_info_t):cint; cdecl; + libvlc_module_description_list_release : procedure(p_list:Plibvlc_module_description_t); cdecl; + libvlc_audio_filter_list_get : function(p_instance:Plibvlc_instance_t):plibvlc_module_description_t; cdecl; + libvlc_video_filter_list_get : function(p_instance:Plibvlc_instance_t):plibvlc_module_description_t; cdecl; + libvlc_clock : function:int64_t; cdecl; + + libvlc_errmsg : function:pcchar; cdecl; + libvlc_clearerr : procedure; cdecl; + libvlc_printerr : function(fmt:pcchar):pcchar;varargs; cdecl; + + libvlc_new : function(argc:cint; argv:Ppcchar):plibvlc_instance_t; cdecl; + libvlc_release : procedure(p_instance:Plibvlc_instance_t); cdecl; + libvlc_retain : procedure(p_instance:Plibvlc_instance_t); cdecl; + libvlc_add_intf : function(p_instance:Plibvlc_instance_t; name:pcchar):cint; cdecl; + libvlc_set_exit_handler : procedure(p_instance:Plibvlc_instance_t; cb:cbtype1; opaque:pointer); cdecl; + libvlc_wait : procedure(p_instance:Plibvlc_instance_t); cdecl; + libvlc_set_user_agent : procedure(p_instance:Plibvlc_instance_t; name:pcchar; http:pcchar); cdecl; + libvlc_get_version : function:pcchar; cdecl; + libvlc_get_compiler : function:pcchar; cdecl; + libvlc_get_changeset : function:pcchar; cdecl; + libvlc_free : procedure(ptr:pointer); cdecl; + libvlc_event_attach : function(p_event_manager:Plibvlc_event_manager_t; i_event_type:libvlc_event_type_t; f_callback:libvlc_callback_t; user_data:pointer):cint; cdecl; + libvlc_event_detach : procedure(p_event_manager:Plibvlc_event_manager_t; i_event_type:libvlc_event_type_t; f_callback:libvlc_callback_t; p_user_data:pointer); cdecl; + libvlc_event_type_name : function(event_type:libvlc_event_type_t):pcchar; cdecl; + libvlc_get_log_verbosity : function(p_instance:Plibvlc_instance_t):cunsigned; cdecl; + libvlc_set_log_verbosity : procedure(p_instance:Plibvlc_instance_t; level:cunsigned); cdecl; + libvlc_log_open : function(p_instance:Plibvlc_instance_t):plibvlc_log_t; cdecl; + libvlc_log_close : procedure(p_log:Plibvlc_log_t); cdecl; + libvlc_log_count : function(p_log:Plibvlc_log_t):cunsigned; cdecl; + libvlc_log_clear : procedure(p_log:Plibvlc_log_t); cdecl; + libvlc_log_get_iterator : function(p_log:Plibvlc_log_t):plibvlc_log_iterator_t; cdecl; + libvlc_log_iterator_free : procedure(p_iter:Plibvlc_log_iterator_t); cdecl; + libvlc_log_iterator_has_next : function(p_iter:Plibvlc_log_iterator_t):cint; cdecl; + libvlc_log_iterator_next : function(p_iter:Plibvlc_log_iterator_t; p_buffer:Plibvlc_log_message_t):plibvlc_log_message_t; cdecl; + libvlc_audio_output_list_get : function(p_instance:Plibvlc_instance_t):plibvlc_audio_output_t; cdecl; + libvlc_audio_output_list_release : procedure(p_list:Plibvlc_audio_output_t); cdecl; + libvlc_audio_output_set : function(p_mi:Plibvlc_media_player_t; psz_name:pcchar):cint; cdecl; + libvlc_audio_output_device_count : function(p_instance:Plibvlc_instance_t; psz_audio_output:pcchar):cint; cdecl; + libvlc_audio_output_device_longname : function(p_instance:Plibvlc_instance_t; psz_audio_output:pcchar; i_device:cint):pcchar; cdecl; + libvlc_audio_output_device_id : function(p_instance:Plibvlc_instance_t; psz_audio_output:pcchar; i_device:cint):pcchar; cdecl; + libvlc_audio_output_device_set : procedure(p_mi:Plibvlc_media_player_t; psz_audio_output:pcchar; psz_device_id:pcchar); cdecl; + libvlc_audio_output_get_device_type : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_output_set_device_type : procedure(p_mi:Plibvlc_media_player_t; device_type:cint); cdecl; + libvlc_audio_toggle_mute : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_audio_get_mute : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_set_mute : procedure(p_mi:Plibvlc_media_player_t; status:cint); cdecl; + libvlc_audio_get_volume : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_set_volume : function(p_mi:Plibvlc_media_player_t; i_volume:cint):cint; cdecl; + libvlc_audio_get_track_count : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_get_track_description : function(p_mi:Plibvlc_media_player_t):plibvlc_track_description_t; cdecl; + libvlc_audio_get_track : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_set_track : function(p_mi:Plibvlc_media_player_t; i_track:cint):cint; cdecl; + libvlc_audio_get_channel : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_audio_set_channel : function(p_mi:Plibvlc_media_player_t; channel:cint):cint; cdecl; + libvlc_audio_get_delay : function(p_mi:Plibvlc_media_player_t):int64_t; cdecl; + libvlc_audio_set_delay : function(p_mi:Plibvlc_media_player_t; i_delay:int64_t):cint; cdecl; + libvlc_media_list_new : function(p_instance:Plibvlc_instance_t):plibvlc_media_list_t; cdecl; + libvlc_media_list_release : procedure(p_ml:Plibvlc_media_list_t); cdecl; + libvlc_media_list_retain : procedure(p_ml:Plibvlc_media_list_t); cdecl; + + libvlc_media_list_add_file_content : function(p_ml:Plibvlc_media_list_t; psz_uri:pcchar):cint; cdecl; + libvlc_media_list_set_media : procedure(p_ml:Plibvlc_media_list_t; p_md:Plibvlc_media_t); cdecl; + libvlc_media_list_media : function(p_ml:Plibvlc_media_list_t):plibvlc_media_t; cdecl; + libvlc_media_list_add_media : function(p_ml:Plibvlc_media_list_t; p_md:Plibvlc_media_t):cint; cdecl; + libvlc_media_list_insert_media : function(p_ml:Plibvlc_media_list_t; p_md:Plibvlc_media_t; i_pos:cint):cint; cdecl; + libvlc_media_list_remove_index : function(p_ml:Plibvlc_media_list_t; i_pos:cint):cint; cdecl; + libvlc_media_list_count : function(p_ml:Plibvlc_media_list_t):cint; cdecl; + libvlc_media_list_item_at_index : function(p_ml:Plibvlc_media_list_t; i_pos:cint):plibvlc_media_t; cdecl; + libvlc_media_list_index_of_item : function(p_ml:Plibvlc_media_list_t; p_md:Plibvlc_media_t):cint; cdecl; + libvlc_media_list_is_readonly : function(p_ml:Plibvlc_media_list_t):cint; cdecl; + libvlc_media_list_lock : procedure(p_ml:Plibvlc_media_list_t); cdecl; + libvlc_media_list_unlock : procedure(p_ml:Plibvlc_media_list_t); cdecl; + libvlc_media_list_event_manager : function(p_ml:Plibvlc_media_list_t):plibvlc_event_manager_t; cdecl; + libvlc_media_list_player_new : function(p_instance:Plibvlc_instance_t):plibvlc_media_list_player_t; cdecl; + libvlc_media_list_player_release : procedure(p_mlp:Plibvlc_media_list_player_t); cdecl; + libvlc_media_list_player_retain : procedure(p_mlp:Plibvlc_media_list_player_t); cdecl; + libvlc_media_list_player_event_manager : function(p_mlp:Plibvlc_media_list_player_t):plibvlc_event_manager_t; cdecl; + libvlc_media_list_player_set_media_player : procedure(p_mlp:Plibvlc_media_list_player_t; p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_list_player_set_media_list : procedure(p_mlp:Plibvlc_media_list_player_t; p_mlist:Plibvlc_media_list_t); cdecl; + libvlc_media_list_player_play : procedure(p_mlp:Plibvlc_media_list_player_t); cdecl; + libvlc_media_list_player_pause : procedure(p_mlp:Plibvlc_media_list_player_t); cdecl; + libvlc_media_list_player_is_playing : function(p_mlp:Plibvlc_media_list_player_t):cint; cdecl; + libvlc_media_list_player_get_state : function(p_mlp:Plibvlc_media_list_player_t):libvlc_state_t; cdecl; + libvlc_media_list_player_play_item_at_index : function(p_mlp:Plibvlc_media_list_player_t; i_index:cint):cint; cdecl; + libvlc_media_list_player_play_item : function(p_mlp:Plibvlc_media_list_player_t; p_md:Plibvlc_media_t):cint; cdecl; + libvlc_media_list_player_stop : procedure(p_mlp:Plibvlc_media_list_player_t); cdecl; + libvlc_media_list_player_next : function(p_mlp:Plibvlc_media_list_player_t):cint; cdecl; + libvlc_media_list_player_previous : function(p_mlp:Plibvlc_media_list_player_t):cint; cdecl; + libvlc_media_list_player_set_playback_mode : procedure(p_mlp:Plibvlc_media_list_player_t; e_mode:libvlc_playback_mode_t); cdecl; + libvlc_media_library_new : function(p_instance:Plibvlc_instance_t):plibvlc_media_library_t; cdecl; + libvlc_media_library_release : procedure(p_mlib:Plibvlc_media_library_t); cdecl; + libvlc_media_library_retain : procedure(p_mlib:Plibvlc_media_library_t); cdecl; + libvlc_media_library_load : function(p_mlib:Plibvlc_media_library_t):cint; cdecl; + libvlc_media_library_media_list : function(p_mlib:Plibvlc_media_library_t):plibvlc_media_list_t; cdecl; + libvlc_video_get_adjust_int : function(p_mi:Plibvlc_media_player_t; option:cunsigned):cint; cdecl; + libvlc_video_set_adjust_int : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; value:cint); cdecl; + libvlc_video_get_adjust_float : function(p_mi:Plibvlc_media_player_t; option:cunsigned):cfloat; cdecl; + libvlc_video_set_adjust_float : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; value:cfloat); cdecl; + libvlc_video_get_logo_int : function(p_mi:Plibvlc_media_player_t; option:cunsigned):cint; cdecl; + libvlc_video_set_logo_int : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; value:cint); cdecl; + libvlc_video_set_logo_string : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; psz_value:pcchar); cdecl; + libvlc_audio_set_format_callbacks : procedure(mp:Plibvlc_media_player_t; setup:libvlc_audio_setup_cb; cleanup:libvlc_audio_cleanup_cb); cdecl; + libvlc_audio_set_format : procedure(mp:Plibvlc_media_player_t; format:pcchar; rate:cunsigned; channels:cunsigned); cdecl; + libvlc_media_player_get_length : function(p_mi:Plibvlc_media_player_t):libvlc_time_t; cdecl; + libvlc_media_player_get_time : function(p_mi:Plibvlc_media_player_t):libvlc_time_t; cdecl; + libvlc_media_player_set_time : procedure(p_mi:Plibvlc_media_player_t; i_time:libvlc_time_t); cdecl; + libvlc_media_player_get_position : function(p_mi:Plibvlc_media_player_t):cfloat; cdecl; + libvlc_media_player_set_position : procedure(p_mi:Plibvlc_media_player_t; f_pos:cfloat); cdecl; + libvlc_media_player_set_chapter : procedure(p_mi:Plibvlc_media_player_t; i_chapter:cint); cdecl; + libvlc_media_player_get_chapter : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_get_chapter_count : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_will_play : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_get_chapter_count_for_title : function(p_mi:Plibvlc_media_player_t; i_title:cint):cint; cdecl; + libvlc_media_player_set_title : procedure(p_mi:Plibvlc_media_player_t; i_title:cint); cdecl; + libvlc_media_player_get_title : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_get_title_count : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_previous_chapter : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_next_chapter : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_get_rate : function(p_mi:Plibvlc_media_player_t):cfloat; cdecl; + libvlc_media_player_set_rate : function(p_mi:Plibvlc_media_player_t; rate:cfloat):cint; cdecl; + libvlc_media_player_get_state : function(p_mi:Plibvlc_media_player_t):libvlc_state_t; cdecl; + libvlc_media_player_get_fps : function(p_mi:Plibvlc_media_player_t):cfloat; cdecl; + libvlc_media_player_has_vout : function(p_mi:Plibvlc_media_player_t):cunsigned; cdecl; + libvlc_media_player_is_seekable : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_can_pause : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_media_player_next_frame : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_media_player_navigate : procedure(p_mi:Plibvlc_media_player_t; navigate:cunsigned); cdecl; + libvlc_track_description_list_release : procedure(p_track_description:Plibvlc_track_description_t); cdecl; + libvlc_track_description_release : procedure(p_track_description:Plibvlc_track_description_t); cdecl; + libvlc_toggle_fullscreen : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_set_fullscreen : procedure(p_mi:Plibvlc_media_player_t; b_fullscreen:cint); cdecl; + libvlc_get_fullscreen : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_set_key_input : procedure(p_mi:Plibvlc_media_player_t; on:cunsigned); cdecl; + libvlc_video_set_mouse_input : procedure(p_mi:Plibvlc_media_player_t; on:cunsigned); cdecl; + libvlc_video_get_size : function(p_mi:Plibvlc_media_player_t; num:cunsigned; px:pcunsigned; py:pcunsigned):cint; cdecl; + libvlc_video_get_height : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_get_width : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_get_cursor : function(p_mi:Plibvlc_media_player_t; num:cunsigned; px:pcint; py:pcint):cint; cdecl; + libvlc_video_get_scale : function(p_mi:Plibvlc_media_player_t):cfloat; cdecl; + libvlc_video_set_scale : procedure(p_mi:Plibvlc_media_player_t; f_factor:cfloat); cdecl; + libvlc_video_get_aspect_ratio : function(p_mi:Plibvlc_media_player_t):pcchar; cdecl; + libvlc_video_set_aspect_ratio : procedure(p_mi:Plibvlc_media_player_t; psz_aspect:pcchar); cdecl; + libvlc_video_get_spu : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_get_spu_count : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_get_spu_description : function(p_mi:Plibvlc_media_player_t):plibvlc_track_description_t; cdecl; + libvlc_video_set_spu : function(p_mi:Plibvlc_media_player_t; i_spu:cunsigned):cint; cdecl; + libvlc_video_set_subtitle_file : function(p_mi:Plibvlc_media_player_t; psz_subtitle:pcchar):cint; cdecl; + libvlc_video_get_spu_delay : function(p_mi:Plibvlc_media_player_t):int64_t; cdecl; + libvlc_video_set_spu_delay : function(p_mi:Plibvlc_media_player_t; i_delay:int64_t):cint; cdecl; + libvlc_video_get_title_description : function(p_mi:Plibvlc_media_player_t):plibvlc_track_description_t; cdecl; + libvlc_video_get_chapter_description : function(p_mi:Plibvlc_media_player_t; i_title:cint):plibvlc_track_description_t; cdecl; + libvlc_video_get_crop_geometry : function(p_mi:Plibvlc_media_player_t):pcchar; cdecl; + libvlc_video_set_crop_geometry : procedure(p_mi:Plibvlc_media_player_t; psz_geometry:pcchar); cdecl; + libvlc_video_get_teletext : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_set_teletext : procedure(p_mi:Plibvlc_media_player_t; i_page:cint); cdecl; + libvlc_toggle_teletext : procedure(p_mi:Plibvlc_media_player_t); cdecl; + libvlc_video_get_track_count : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_get_track_description : function(p_mi:Plibvlc_media_player_t):plibvlc_track_description_t; cdecl; + libvlc_video_get_track : function(p_mi:Plibvlc_media_player_t):cint; cdecl; + libvlc_video_set_track : function(p_mi:Plibvlc_media_player_t; i_track:cint):cint; cdecl; + libvlc_video_take_snapshot : function(p_mi:Plibvlc_media_player_t; num:cunsigned; psz_filepath:pcchar; i_width:cuint; i_height:cuint):cint; cdecl; + libvlc_video_set_deinterlace : procedure(p_mi:Plibvlc_media_player_t; psz_mode:pcchar); cdecl; + libvlc_video_get_marquee_int : function(p_mi:Plibvlc_media_player_t; option:cunsigned):cint; cdecl; + libvlc_video_get_marquee_string : function(p_mi:Plibvlc_media_player_t; option:cunsigned):pcchar; cdecl; + libvlc_video_set_marquee_int : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; i_val:cint); cdecl; + libvlc_video_set_marquee_string : procedure(p_mi:Plibvlc_media_player_t; option:cunsigned; psz_text:pcchar); cdecl; + libvlc_audio_set_callbacks : procedure(mp:Plibvlc_media_player_t; play:libvlc_audio_play_cb; pause:libvlc_audio_pause_cb; resume:libvlc_audio_resume_cb; flush:libvlc_audio_flush_cb; + drain:libvlc_audio_drain_cb; opaque:pointer); cdecl; + libvlc_audio_set_volume_callback : procedure(mp:Plibvlc_media_player_t; set_volume:libvlc_audio_set_volume_cb); cdecl; + libvlc_video_set_callbacks : procedure(mp:Plibvlc_media_player_t; lock:libvlc_video_lock_cb; unlock:libvlc_video_unlock_cb; display:libvlc_video_display_cb; opaque:pointer); cdecl; + libvlc_video_set_format : procedure(mp:Plibvlc_media_player_t; chroma:pcchar; width:cunsigned; height:cunsigned; pitch:cunsigned); cdecl; + libvlc_video_set_format_callbacks : procedure(mp:Plibvlc_media_player_t; setup:libvlc_video_format_cb; cleanup:libvlc_video_cleanup_cb); cdecl; + libvlc_media_player_set_nsobject : procedure(p_mi:Plibvlc_media_player_t; drawable:pointer); cdecl; + libvlc_media_player_get_nsobject : function(p_mi:Plibvlc_media_player_t):pointer; cdecl; + libvlc_media_player_set_agl : procedure(p_mi:Plibvlc_media_player_t; drawable:uint32_t); cdecl; + libvlc_media_player_get_agl : function(p_mi:Plibvlc_media_player_t):uint32_t; cdecl; + libvlc_media_player_set_xwindow : procedure(p_mi:Plibvlc_media_player_t; drawable:uint32_t); cdecl; + libvlc_media_player_get_xwindow : function(p_mi:Plibvlc_media_player_t):uint32_t; cdecl; + libvlc_media_player_set_hwnd : procedure(p_mi:Plibvlc_media_player_t; drawable:pointer); cdecl; + libvlc_media_player_get_hwnd : function(p_mi:Plibvlc_media_player_t):pointer; cdecl; + libvlc_media_discoverer_new_from_name : function(p_inst:Plibvlc_instance_t; psz_name:pcchar):plibvlc_media_discoverer_t; cdecl; + libvlc_media_discoverer_release : procedure(p_mdis:Plibvlc_media_discoverer_t); cdecl; + libvlc_media_discoverer_localized_name : function(p_mdis:Plibvlc_media_discoverer_t):pcchar; cdecl; + libvlc_media_discoverer_media_list : function(p_mdis:Plibvlc_media_discoverer_t):plibvlc_media_list_t; cdecl; + libvlc_media_discoverer_event_manager : function(p_mdis:Plibvlc_media_discoverer_t):plibvlc_event_manager_t; cdecl; + libvlc_media_discoverer_is_running : function(p_mdis:Plibvlc_media_discoverer_t):cint; cdecl; + libvlc_vlm_release : procedure(p_instance:Plibvlc_instance_t); cdecl; + libvlc_vlm_add_broadcast : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_input:pcchar; psz_output:pcchar; i_options:cint; + ppsz_options:Ppcchar; b_enabled:cint; b_loop:cint):cint; cdecl; + libvlc_vlm_add_vod : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_input:pcchar; i_options:cint; ppsz_options:Ppcchar; + b_enabled:cint; psz_mux:pcchar):cint; cdecl; + libvlc_vlm_del_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):cint; cdecl; + libvlc_vlm_set_enabled : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; b_enabled:cint):cint; cdecl; + libvlc_vlm_set_output : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_output:pcchar):cint; cdecl; + libvlc_vlm_set_input : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_input:pcchar):cint; cdecl; + libvlc_vlm_add_input : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_input:pcchar):cint; cdecl; + libvlc_vlm_set_loop : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; b_loop:cint):cint; cdecl; + libvlc_vlm_set_mux : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_mux:pcchar):cint; cdecl; + libvlc_vlm_change_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; psz_input:pcchar; psz_output:pcchar; i_options:cint; + ppsz_options:Ppcchar; b_enabled:cint; b_loop:cint):cint; cdecl; + libvlc_vlm_play_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):cint; cdecl; + libvlc_vlm_stop_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):cint; cdecl; + libvlc_vlm_pause_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):cint; cdecl; + libvlc_vlm_seek_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; f_percentage:cfloat):cint; cdecl; + libvlc_vlm_show_media : function(p_instance:Plibvlc_instance_t; psz_name:pcchar):pcchar; cdecl; + libvlc_vlm_get_media_instance_position : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; i_instance:cint):cfloat; cdecl; + libvlc_vlm_get_media_instance_time : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; i_instance:cint):cint; cdecl; + libvlc_vlm_get_media_instance_length : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; i_instance:cint):cint; cdecl; + libvlc_vlm_get_media_instance_rate : function(p_instance:Plibvlc_instance_t; psz_name:pcchar; i_instance:cint):cint; cdecl; + libvlc_vlm_get_event_manager : function(p_instance:Plibvlc_instance_t):plibvlc_event_manager_t; cdecl; + libvlc_playlist_play : procedure(p_instance:Plibvlc_instance_t; i_id:cint; i_options:cint; ppsz_options:Ppcchar); cdecl; + +Procedure Freelibvlc; +Procedure Loadlibvlc(lib : AnsiString; CheckProcNames : Boolean = False); + +implementation + +uses + SysUtils, dynlibs; + +var + hlib : tlibhandle; + LibRefCount : Integer; + +procedure Freelibvlc; + +begin + if (LibRefCount>0) then + Dec(LibRefCount); + if LibRefCount>0 then + exit; + FreeLibrary(hlib); + libvlc_errmsg:=nil; + libvlc_clearerr:=nil; + libvlc_printerr:=nil; + libvlc_new:=nil; + libvlc_release:=nil; + libvlc_retain:=nil; + libvlc_add_intf:=nil; + libvlc_set_exit_handler:=nil; + libvlc_wait:=nil; + libvlc_set_user_agent:=nil; + libvlc_get_version:=nil; + libvlc_get_compiler:=nil; + libvlc_get_changeset:=nil; + libvlc_free:=nil; + libvlc_event_attach:=nil; + libvlc_event_detach:=nil; + libvlc_event_type_name:=nil; + libvlc_get_log_verbosity:=nil; + libvlc_set_log_verbosity:=nil; + libvlc_log_open:=nil; + libvlc_log_close:=nil; + libvlc_log_count:=nil; + libvlc_log_clear:=nil; + libvlc_log_get_iterator:=nil; + libvlc_log_iterator_free:=nil; + libvlc_log_iterator_has_next:=nil; + libvlc_log_iterator_next:=nil; + libvlc_module_description_list_release:=nil; + libvlc_audio_filter_list_get:=nil; + libvlc_video_filter_list_get:=nil; + libvlc_clock:=nil; + libvlc_media_new_location:=nil; + libvlc_media_new_path:=nil; + libvlc_media_new_fd:=nil; + libvlc_media_new_as_node:=nil; + libvlc_media_add_option:=nil; + libvlc_media_add_option_flag:=nil; + libvlc_media_retain:=nil; + libvlc_media_release:=nil; + libvlc_media_get_mrl:=nil; + libvlc_media_duplicate:=nil; + libvlc_media_get_meta:=nil; + libvlc_media_set_meta:=nil; + libvlc_media_save_meta:=nil; + libvlc_media_get_state:=nil; + libvlc_media_get_stats:=nil; + libvlc_media_subitems:=nil; + libvlc_media_event_manager:=nil; + libvlc_media_get_duration:=nil; + libvlc_media_parse:=nil; + libvlc_media_parse_async:=nil; + libvlc_media_is_parsed:=nil; + libvlc_media_set_user_data:=nil; + libvlc_media_get_user_data:=nil; + libvlc_media_get_tracks_info:=nil; + libvlc_media_player_new:=nil; + libvlc_media_player_new_from_media:=nil; + libvlc_media_player_release:=nil; + libvlc_media_player_retain:=nil; + libvlc_media_player_set_media:=nil; + libvlc_media_player_get_media:=nil; + libvlc_media_player_event_manager:=nil; + libvlc_media_player_is_playing:=nil; + libvlc_media_player_play:=nil; + libvlc_media_player_set_pause:=nil; + libvlc_media_player_pause:=nil; + libvlc_media_player_stop:=nil; + libvlc_video_set_callbacks:=nil; + libvlc_video_set_format:=nil; + libvlc_video_set_format_callbacks:=nil; + libvlc_media_player_set_nsobject:=nil; + libvlc_media_player_get_nsobject:=nil; + libvlc_media_player_set_agl:=nil; + libvlc_media_player_get_agl:=nil; + libvlc_media_player_set_xwindow:=nil; + libvlc_media_player_get_xwindow:=nil; + libvlc_media_player_set_hwnd:=nil; + libvlc_media_player_get_hwnd:=nil; + libvlc_audio_set_callbacks:=nil; + libvlc_audio_set_volume_callback:=nil; + libvlc_audio_set_format_callbacks:=nil; + libvlc_audio_set_format:=nil; + libvlc_media_player_get_length:=nil; + libvlc_media_player_get_time:=nil; + libvlc_media_player_set_time:=nil; + libvlc_media_player_get_position:=nil; + libvlc_media_player_set_position:=nil; + libvlc_media_player_set_chapter:=nil; + libvlc_media_player_get_chapter:=nil; + libvlc_media_player_get_chapter_count:=nil; + libvlc_media_player_will_play:=nil; + libvlc_media_player_get_chapter_count_for_title:=nil; + libvlc_media_player_set_title:=nil; + libvlc_media_player_get_title:=nil; + libvlc_media_player_get_title_count:=nil; + libvlc_media_player_previous_chapter:=nil; + libvlc_media_player_next_chapter:=nil; + libvlc_media_player_get_rate:=nil; + libvlc_media_player_set_rate:=nil; + libvlc_media_player_get_state:=nil; + libvlc_media_player_get_fps:=nil; + libvlc_media_player_has_vout:=nil; + libvlc_media_player_is_seekable:=nil; + libvlc_media_player_can_pause:=nil; + libvlc_media_player_next_frame:=nil; + libvlc_media_player_navigate:=nil; + libvlc_track_description_list_release:=nil; + libvlc_track_description_release:=nil; + libvlc_toggle_fullscreen:=nil; + libvlc_set_fullscreen:=nil; + libvlc_get_fullscreen:=nil; + libvlc_video_set_key_input:=nil; + libvlc_video_set_mouse_input:=nil; + libvlc_video_get_size:=nil; + libvlc_video_get_height:=nil; + libvlc_video_get_width:=nil; + libvlc_video_get_cursor:=nil; + libvlc_video_get_scale:=nil; + libvlc_video_set_scale:=nil; + libvlc_video_get_aspect_ratio:=nil; + libvlc_video_set_aspect_ratio:=nil; + libvlc_video_get_spu:=nil; + libvlc_video_get_spu_count:=nil; + libvlc_video_get_spu_description:=nil; + libvlc_video_set_spu:=nil; + libvlc_video_set_subtitle_file:=nil; + libvlc_video_get_spu_delay:=nil; + libvlc_video_set_spu_delay:=nil; + libvlc_video_get_title_description:=nil; + libvlc_video_get_chapter_description:=nil; + libvlc_video_get_crop_geometry:=nil; + libvlc_video_set_crop_geometry:=nil; + libvlc_video_get_teletext:=nil; + libvlc_video_set_teletext:=nil; + libvlc_toggle_teletext:=nil; + libvlc_video_get_track_count:=nil; + libvlc_video_get_track_description:=nil; + libvlc_video_get_track:=nil; + libvlc_video_set_track:=nil; + libvlc_video_take_snapshot:=nil; + libvlc_video_set_deinterlace:=nil; + libvlc_video_get_marquee_int:=nil; + libvlc_video_get_marquee_string:=nil; + libvlc_video_set_marquee_int:=nil; + libvlc_video_set_marquee_string:=nil; + libvlc_video_get_logo_int:=nil; + libvlc_video_set_logo_int:=nil; + libvlc_video_set_logo_string:=nil; + libvlc_video_get_adjust_int:=nil; + libvlc_video_set_adjust_int:=nil; + libvlc_video_get_adjust_float:=nil; + libvlc_video_set_adjust_float:=nil; + libvlc_audio_output_list_get:=nil; + libvlc_audio_output_list_release:=nil; + libvlc_audio_output_set:=nil; + libvlc_audio_output_device_count:=nil; + libvlc_audio_output_device_longname:=nil; + libvlc_audio_output_device_id:=nil; + libvlc_audio_output_device_set:=nil; + libvlc_audio_output_get_device_type:=nil; + libvlc_audio_output_set_device_type:=nil; + libvlc_audio_toggle_mute:=nil; + libvlc_audio_get_mute:=nil; + libvlc_audio_set_mute:=nil; + libvlc_audio_get_volume:=nil; + libvlc_audio_set_volume:=nil; + libvlc_audio_get_track_count:=nil; + libvlc_audio_get_track_description:=nil; + libvlc_audio_get_track:=nil; + libvlc_audio_set_track:=nil; + libvlc_audio_get_channel:=nil; + libvlc_audio_set_channel:=nil; + libvlc_audio_get_delay:=nil; + libvlc_audio_set_delay:=nil; + libvlc_media_list_new:=nil; + libvlc_media_list_release:=nil; + libvlc_media_list_retain:=nil; + libvlc_media_list_add_file_content:=nil; + libvlc_media_list_set_media:=nil; + libvlc_media_list_media:=nil; + libvlc_media_list_add_media:=nil; + libvlc_media_list_insert_media:=nil; + libvlc_media_list_remove_index:=nil; + libvlc_media_list_count:=nil; + libvlc_media_list_item_at_index:=nil; + libvlc_media_list_index_of_item:=nil; + libvlc_media_list_is_readonly:=nil; + libvlc_media_list_lock:=nil; + libvlc_media_list_unlock:=nil; + libvlc_media_list_event_manager:=nil; + libvlc_media_list_player_new:=nil; + libvlc_media_list_player_release:=nil; + libvlc_media_list_player_retain:=nil; + libvlc_media_list_player_event_manager:=nil; + libvlc_media_list_player_set_media_player:=nil; + libvlc_media_list_player_set_media_list:=nil; + libvlc_media_list_player_play:=nil; + libvlc_media_list_player_pause:=nil; + libvlc_media_list_player_is_playing:=nil; + libvlc_media_list_player_get_state:=nil; + libvlc_media_list_player_play_item_at_index:=nil; + libvlc_media_list_player_play_item:=nil; + libvlc_media_list_player_stop:=nil; + libvlc_media_list_player_next:=nil; + libvlc_media_list_player_previous:=nil; + libvlc_media_list_player_set_playback_mode:=nil; + libvlc_media_library_new:=nil; + libvlc_media_library_release:=nil; + libvlc_media_library_retain:=nil; + libvlc_media_library_load:=nil; + libvlc_media_library_media_list:=nil; + libvlc_media_discoverer_new_from_name:=nil; + libvlc_media_discoverer_release:=nil; + libvlc_media_discoverer_localized_name:=nil; + libvlc_media_discoverer_media_list:=nil; + libvlc_media_discoverer_event_manager:=nil; + libvlc_media_discoverer_is_running:=nil; + libvlc_vlm_release:=nil; + libvlc_vlm_add_broadcast:=nil; + libvlc_vlm_add_vod:=nil; + libvlc_vlm_del_media:=nil; + libvlc_vlm_set_enabled:=nil; + libvlc_vlm_set_output:=nil; + libvlc_vlm_set_input:=nil; + libvlc_vlm_add_input:=nil; + libvlc_vlm_set_loop:=nil; + libvlc_vlm_set_mux:=nil; + libvlc_vlm_change_media:=nil; + libvlc_vlm_play_media:=nil; + libvlc_vlm_stop_media:=nil; + libvlc_vlm_pause_media:=nil; + libvlc_vlm_seek_media:=nil; + libvlc_vlm_show_media:=nil; + libvlc_vlm_get_media_instance_position:=nil; + libvlc_vlm_get_media_instance_time:=nil; + libvlc_vlm_get_media_instance_length:=nil; + libvlc_vlm_get_media_instance_rate:=nil; + libvlc_vlm_get_event_manager:=nil; + libvlc_playlist_play:=nil; +end; + + +Procedure Loadlibvlc(lib : AnsiString; CheckProcNames : Boolean = False); + + Function GetProcAddress(h : TLibHandle; Name : AnsiString) : Pointer; + + begin + Result:=dynlibs.GetProcAddress(h,Name); + If (Result=Nil) and CheckProcNames then + raise Exception.CreateFmt('Could not find procedure address: %s ',[Name]); + end; + + Procedure EM(FN : String); + + begin + {$ifndef VER2_6} + Raise Exception.CreateFmt('Could not load library "%s": %s',[FN,GetLoadErrorStr]); + {$else} + raise Exception.CreateFmt('Could not load library "%s"',[FN]); + {$endif} + end; + + + +Var + D : String; + +begin + if (hLib<>NilHandle) then + begin + Inc(LibRefCount); + Exit; + end; + D:=ExtractFilePath(lib); + {$ifdef windows} + if (LoadLibrary(d+corelibname)=NilHandle) then + if (d='') and (LoadLibrary(DefaultlibPath+corelibname)=NilHandle) then + EM(DefaultlibPath+corelibname); + {$endif} + hlib:=LoadLibrary(lib); + if (hlib=NilHandle) then +{$ifndef windows} + EM(Lib); +{$else} + if (d='') then + begin + hlib:=LoadLibrary(DefaultlibPath+ExtractFileName(Lib)); + if (hlib=NilHandle) then + EM(Lib); + end; +{$endif} + Inc(LibRefCount); + pointer(libvlc_errmsg):=GetProcAddress(hlib,'libvlc_errmsg'); + pointer(libvlc_clearerr):=GetProcAddress(hlib,'libvlc_clearerr'); + pointer(libvlc_printerr):=GetProcAddress(hlib,'libvlc_printerr'); + pointer(libvlc_new):=GetProcAddress(hlib,'libvlc_new'); + pointer(libvlc_release):=GetProcAddress(hlib,'libvlc_release'); + pointer(libvlc_retain):=GetProcAddress(hlib,'libvlc_retain'); + pointer(libvlc_add_intf):=GetProcAddress(hlib,'libvlc_add_intf'); + pointer(libvlc_set_exit_handler):=GetProcAddress(hlib,'libvlc_set_exit_handler'); + pointer(libvlc_wait):=GetProcAddress(hlib,'libvlc_wait'); + pointer(libvlc_set_user_agent):=GetProcAddress(hlib,'libvlc_set_user_agent'); + pointer(libvlc_get_version):=GetProcAddress(hlib,'libvlc_get_version'); + pointer(libvlc_get_compiler):=GetProcAddress(hlib,'libvlc_get_compiler'); + pointer(libvlc_get_changeset):=GetProcAddress(hlib,'libvlc_get_changeset'); + pointer(libvlc_free):=GetProcAddress(hlib,'libvlc_free'); + pointer(libvlc_event_attach):=GetProcAddress(hlib,'libvlc_event_attach'); + pointer(libvlc_event_detach):=GetProcAddress(hlib,'libvlc_event_detach'); + pointer(libvlc_event_type_name):=GetProcAddress(hlib,'libvlc_event_type_name'); + pointer(libvlc_get_log_verbosity):=GetProcAddress(hlib,'libvlc_get_log_verbosity'); + pointer(libvlc_set_log_verbosity):=GetProcAddress(hlib,'libvlc_set_log_verbosity'); + pointer(libvlc_log_open):=GetProcAddress(hlib,'libvlc_log_open'); + pointer(libvlc_log_close):=GetProcAddress(hlib,'libvlc_log_close'); + pointer(libvlc_log_count):=GetProcAddress(hlib,'libvlc_log_count'); + pointer(libvlc_log_clear):=GetProcAddress(hlib,'libvlc_log_clear'); + pointer(libvlc_log_get_iterator):=GetProcAddress(hlib,'libvlc_log_get_iterator'); + pointer(libvlc_log_iterator_free):=GetProcAddress(hlib,'libvlc_log_iterator_free'); + pointer(libvlc_log_iterator_has_next):=GetProcAddress(hlib,'libvlc_log_iterator_has_next'); + pointer(libvlc_log_iterator_next):=GetProcAddress(hlib,'libvlc_log_iterator_next'); + pointer(libvlc_module_description_list_release):=GetProcAddress(hlib,'libvlc_module_description_list_release'); + pointer(libvlc_audio_filter_list_get):=GetProcAddress(hlib,'libvlc_audio_filter_list_get'); + pointer(libvlc_video_filter_list_get):=GetProcAddress(hlib,'libvlc_video_filter_list_get'); + pointer(libvlc_clock):=GetProcAddress(hlib,'libvlc_clock'); + pointer(libvlc_media_new_location):=GetProcAddress(hlib,'libvlc_media_new_location'); + pointer(libvlc_media_new_path):=GetProcAddress(hlib,'libvlc_media_new_path'); + pointer(libvlc_media_new_fd):=GetProcAddress(hlib,'libvlc_media_new_fd'); + pointer(libvlc_media_new_as_node):=GetProcAddress(hlib,'libvlc_media_new_as_node'); + pointer(libvlc_media_add_option):=GetProcAddress(hlib,'libvlc_media_add_option'); + pointer(libvlc_media_add_option_flag):=GetProcAddress(hlib,'libvlc_media_add_option_flag'); + pointer(libvlc_media_retain):=GetProcAddress(hlib,'libvlc_media_retain'); + pointer(libvlc_media_release):=GetProcAddress(hlib,'libvlc_media_release'); + pointer(libvlc_media_get_mrl):=GetProcAddress(hlib,'libvlc_media_get_mrl'); + pointer(libvlc_media_duplicate):=GetProcAddress(hlib,'libvlc_media_duplicate'); + pointer(libvlc_media_get_meta):=GetProcAddress(hlib,'libvlc_media_get_meta'); + pointer(libvlc_media_set_meta):=GetProcAddress(hlib,'libvlc_media_set_meta'); + pointer(libvlc_media_save_meta):=GetProcAddress(hlib,'libvlc_media_save_meta'); + pointer(libvlc_media_get_state):=GetProcAddress(hlib,'libvlc_media_get_state'); + pointer(libvlc_media_get_stats):=GetProcAddress(hlib,'libvlc_media_get_stats'); + pointer(libvlc_media_subitems):=GetProcAddress(hlib,'libvlc_media_subitems'); + pointer(libvlc_media_event_manager):=GetProcAddress(hlib,'libvlc_media_event_manager'); + pointer(libvlc_media_get_duration):=GetProcAddress(hlib,'libvlc_media_get_duration'); + pointer(libvlc_media_parse):=GetProcAddress(hlib,'libvlc_media_parse'); + pointer(libvlc_media_parse_async):=GetProcAddress(hlib,'libvlc_media_parse_async'); + pointer(libvlc_media_is_parsed):=GetProcAddress(hlib,'libvlc_media_is_parsed'); + pointer(libvlc_media_set_user_data):=GetProcAddress(hlib,'libvlc_media_set_user_data'); + pointer(libvlc_media_get_user_data):=GetProcAddress(hlib,'libvlc_media_get_user_data'); + pointer(libvlc_media_get_tracks_info):=GetProcAddress(hlib,'libvlc_media_get_tracks_info'); + pointer(libvlc_media_player_new):=GetProcAddress(hlib,'libvlc_media_player_new'); + pointer(libvlc_media_player_new_from_media):=GetProcAddress(hlib,'libvlc_media_player_new_from_media'); + pointer(libvlc_media_player_release):=GetProcAddress(hlib,'libvlc_media_player_release'); + pointer(libvlc_media_player_retain):=GetProcAddress(hlib,'libvlc_media_player_retain'); + pointer(libvlc_media_player_set_media):=GetProcAddress(hlib,'libvlc_media_player_set_media'); + pointer(libvlc_media_player_get_media):=GetProcAddress(hlib,'libvlc_media_player_get_media'); + pointer(libvlc_media_player_event_manager):=GetProcAddress(hlib,'libvlc_media_player_event_manager'); + pointer(libvlc_media_player_is_playing):=GetProcAddress(hlib,'libvlc_media_player_is_playing'); + pointer(libvlc_media_player_play):=GetProcAddress(hlib,'libvlc_media_player_play'); + pointer(libvlc_media_player_set_pause):=GetProcAddress(hlib,'libvlc_media_player_set_pause'); + pointer(libvlc_media_player_pause):=GetProcAddress(hlib,'libvlc_media_player_pause'); + pointer(libvlc_media_player_stop):=GetProcAddress(hlib,'libvlc_media_player_stop'); + pointer(libvlc_video_set_callbacks):=GetProcAddress(hlib,'libvlc_video_set_callbacks'); + pointer(libvlc_video_set_format):=GetProcAddress(hlib,'libvlc_video_set_format'); + pointer(libvlc_video_set_format_callbacks):=GetProcAddress(hlib,'libvlc_video_set_format_callbacks'); + pointer(libvlc_media_player_set_nsobject):=GetProcAddress(hlib,'libvlc_media_player_set_nsobject'); + pointer(libvlc_media_player_get_nsobject):=GetProcAddress(hlib,'libvlc_media_player_get_nsobject'); + pointer(libvlc_media_player_set_agl):=GetProcAddress(hlib,'libvlc_media_player_set_agl'); + pointer(libvlc_media_player_get_agl):=GetProcAddress(hlib,'libvlc_media_player_get_agl'); + pointer(libvlc_media_player_set_xwindow):=GetProcAddress(hlib,'libvlc_media_player_set_xwindow'); + pointer(libvlc_media_player_get_xwindow):=GetProcAddress(hlib,'libvlc_media_player_get_xwindow'); + pointer(libvlc_media_player_set_hwnd):=GetProcAddress(hlib,'libvlc_media_player_set_hwnd'); + pointer(libvlc_media_player_get_hwnd):=GetProcAddress(hlib,'libvlc_media_player_get_hwnd'); + pointer(libvlc_audio_set_callbacks):=GetProcAddress(hlib,'libvlc_audio_set_callbacks'); + pointer(libvlc_audio_set_volume_callback):=GetProcAddress(hlib,'libvlc_audio_set_volume_callback'); + pointer(libvlc_audio_set_format_callbacks):=GetProcAddress(hlib,'libvlc_audio_set_format_callbacks'); + pointer(libvlc_audio_set_format):=GetProcAddress(hlib,'libvlc_audio_set_format'); + pointer(libvlc_media_player_get_length):=GetProcAddress(hlib,'libvlc_media_player_get_length'); + pointer(libvlc_media_player_get_time):=GetProcAddress(hlib,'libvlc_media_player_get_time'); + pointer(libvlc_media_player_set_time):=GetProcAddress(hlib,'libvlc_media_player_set_time'); + pointer(libvlc_media_player_get_position):=GetProcAddress(hlib,'libvlc_media_player_get_position'); + pointer(libvlc_media_player_set_position):=GetProcAddress(hlib,'libvlc_media_player_set_position'); + pointer(libvlc_media_player_set_chapter):=GetProcAddress(hlib,'libvlc_media_player_set_chapter'); + pointer(libvlc_media_player_get_chapter):=GetProcAddress(hlib,'libvlc_media_player_get_chapter'); + pointer(libvlc_media_player_get_chapter_count):=GetProcAddress(hlib,'libvlc_media_player_get_chapter_count'); + pointer(libvlc_media_player_will_play):=GetProcAddress(hlib,'libvlc_media_player_will_play'); + pointer(libvlc_media_player_get_chapter_count_for_title):=GetProcAddress(hlib,'libvlc_media_player_get_chapter_count_for_title'); + pointer(libvlc_media_player_set_title):=GetProcAddress(hlib,'libvlc_media_player_set_title'); + pointer(libvlc_media_player_get_title):=GetProcAddress(hlib,'libvlc_media_player_get_title'); + pointer(libvlc_media_player_get_title_count):=GetProcAddress(hlib,'libvlc_media_player_get_title_count'); + pointer(libvlc_media_player_previous_chapter):=GetProcAddress(hlib,'libvlc_media_player_previous_chapter'); + pointer(libvlc_media_player_next_chapter):=GetProcAddress(hlib,'libvlc_media_player_next_chapter'); + pointer(libvlc_media_player_get_rate):=GetProcAddress(hlib,'libvlc_media_player_get_rate'); + pointer(libvlc_media_player_set_rate):=GetProcAddress(hlib,'libvlc_media_player_set_rate'); + pointer(libvlc_media_player_get_state):=GetProcAddress(hlib,'libvlc_media_player_get_state'); + pointer(libvlc_media_player_get_fps):=GetProcAddress(hlib,'libvlc_media_player_get_fps'); + pointer(libvlc_media_player_has_vout):=GetProcAddress(hlib,'libvlc_media_player_has_vout'); + pointer(libvlc_media_player_is_seekable):=GetProcAddress(hlib,'libvlc_media_player_is_seekable'); + pointer(libvlc_media_player_can_pause):=GetProcAddress(hlib,'libvlc_media_player_can_pause'); + pointer(libvlc_media_player_next_frame):=GetProcAddress(hlib,'libvlc_media_player_next_frame'); + pointer(libvlc_media_player_navigate):=GetProcAddress(hlib,'libvlc_media_player_navigate'); + pointer(libvlc_track_description_list_release):=GetProcAddress(hlib,'libvlc_track_description_list_release'); + pointer(libvlc_track_description_release):=GetProcAddress(hlib,'libvlc_track_description_release'); + pointer(libvlc_toggle_fullscreen):=GetProcAddress(hlib,'libvlc_toggle_fullscreen'); + pointer(libvlc_set_fullscreen):=GetProcAddress(hlib,'libvlc_set_fullscreen'); + pointer(libvlc_get_fullscreen):=GetProcAddress(hlib,'libvlc_get_fullscreen'); + pointer(libvlc_video_set_key_input):=GetProcAddress(hlib,'libvlc_video_set_key_input'); + pointer(libvlc_video_set_mouse_input):=GetProcAddress(hlib,'libvlc_video_set_mouse_input'); + pointer(libvlc_video_get_size):=GetProcAddress(hlib,'libvlc_video_get_size'); + pointer(libvlc_video_get_height):=GetProcAddress(hlib,'libvlc_video_get_height'); + pointer(libvlc_video_get_width):=GetProcAddress(hlib,'libvlc_video_get_width'); + pointer(libvlc_video_get_cursor):=GetProcAddress(hlib,'libvlc_video_get_cursor'); + pointer(libvlc_video_get_scale):=GetProcAddress(hlib,'libvlc_video_get_scale'); + pointer(libvlc_video_set_scale):=GetProcAddress(hlib,'libvlc_video_set_scale'); + pointer(libvlc_video_get_aspect_ratio):=GetProcAddress(hlib,'libvlc_video_get_aspect_ratio'); + pointer(libvlc_video_set_aspect_ratio):=GetProcAddress(hlib,'libvlc_video_set_aspect_ratio'); + pointer(libvlc_video_get_spu):=GetProcAddress(hlib,'libvlc_video_get_spu'); + pointer(libvlc_video_get_spu_count):=GetProcAddress(hlib,'libvlc_video_get_spu_count'); + pointer(libvlc_video_get_spu_description):=GetProcAddress(hlib,'libvlc_video_get_spu_description'); + pointer(libvlc_video_set_spu):=GetProcAddress(hlib,'libvlc_video_set_spu'); + pointer(libvlc_video_set_subtitle_file):=GetProcAddress(hlib,'libvlc_video_set_subtitle_file'); + pointer(libvlc_video_get_spu_delay):=GetProcAddress(hlib,'libvlc_video_get_spu_delay'); + pointer(libvlc_video_set_spu_delay):=GetProcAddress(hlib,'libvlc_video_set_spu_delay'); + pointer(libvlc_video_get_title_description):=GetProcAddress(hlib,'libvlc_video_get_title_description'); + pointer(libvlc_video_get_chapter_description):=GetProcAddress(hlib,'libvlc_video_get_chapter_description'); + pointer(libvlc_video_get_crop_geometry):=GetProcAddress(hlib,'libvlc_video_get_crop_geometry'); + pointer(libvlc_video_set_crop_geometry):=GetProcAddress(hlib,'libvlc_video_set_crop_geometry'); + pointer(libvlc_video_get_teletext):=GetProcAddress(hlib,'libvlc_video_get_teletext'); + pointer(libvlc_video_set_teletext):=GetProcAddress(hlib,'libvlc_video_set_teletext'); + pointer(libvlc_toggle_teletext):=GetProcAddress(hlib,'libvlc_toggle_teletext'); + pointer(libvlc_video_get_track_count):=GetProcAddress(hlib,'libvlc_video_get_track_count'); + pointer(libvlc_video_get_track_description):=GetProcAddress(hlib,'libvlc_video_get_track_description'); + pointer(libvlc_video_get_track):=GetProcAddress(hlib,'libvlc_video_get_track'); + pointer(libvlc_video_set_track):=GetProcAddress(hlib,'libvlc_video_set_track'); + pointer(libvlc_video_take_snapshot):=GetProcAddress(hlib,'libvlc_video_take_snapshot'); + pointer(libvlc_video_set_deinterlace):=GetProcAddress(hlib,'libvlc_video_set_deinterlace'); + pointer(libvlc_video_get_marquee_int):=GetProcAddress(hlib,'libvlc_video_get_marquee_int'); + pointer(libvlc_video_get_marquee_string):=GetProcAddress(hlib,'libvlc_video_get_marquee_string'); + pointer(libvlc_video_set_marquee_int):=GetProcAddress(hlib,'libvlc_video_set_marquee_int'); + pointer(libvlc_video_set_marquee_string):=GetProcAddress(hlib,'libvlc_video_set_marquee_string'); + pointer(libvlc_video_get_logo_int):=GetProcAddress(hlib,'libvlc_video_get_logo_int'); + pointer(libvlc_video_set_logo_int):=GetProcAddress(hlib,'libvlc_video_set_logo_int'); + pointer(libvlc_video_set_logo_string):=GetProcAddress(hlib,'libvlc_video_set_logo_string'); + pointer(libvlc_video_get_adjust_int):=GetProcAddress(hlib,'libvlc_video_get_adjust_int'); + pointer(libvlc_video_set_adjust_int):=GetProcAddress(hlib,'libvlc_video_set_adjust_int'); + pointer(libvlc_video_get_adjust_float):=GetProcAddress(hlib,'libvlc_video_get_adjust_float'); + pointer(libvlc_video_set_adjust_float):=GetProcAddress(hlib,'libvlc_video_set_adjust_float'); + pointer(libvlc_audio_output_list_get):=GetProcAddress(hlib,'libvlc_audio_output_list_get'); + pointer(libvlc_audio_output_list_release):=GetProcAddress(hlib,'libvlc_audio_output_list_release'); + pointer(libvlc_audio_output_set):=GetProcAddress(hlib,'libvlc_audio_output_set'); + pointer(libvlc_audio_output_device_count):=GetProcAddress(hlib,'libvlc_audio_output_device_count'); + pointer(libvlc_audio_output_device_longname):=GetProcAddress(hlib,'libvlc_audio_output_device_longname'); + pointer(libvlc_audio_output_device_id):=GetProcAddress(hlib,'libvlc_audio_output_device_id'); + pointer(libvlc_audio_output_device_set):=GetProcAddress(hlib,'libvlc_audio_output_device_set'); + pointer(libvlc_audio_output_get_device_type):=GetProcAddress(hlib,'libvlc_audio_output_get_device_type'); + pointer(libvlc_audio_output_set_device_type):=GetProcAddress(hlib,'libvlc_audio_output_set_device_type'); + pointer(libvlc_audio_toggle_mute):=GetProcAddress(hlib,'libvlc_audio_toggle_mute'); + pointer(libvlc_audio_get_mute):=GetProcAddress(hlib,'libvlc_audio_get_mute'); + pointer(libvlc_audio_set_mute):=GetProcAddress(hlib,'libvlc_audio_set_mute'); + pointer(libvlc_audio_get_volume):=GetProcAddress(hlib,'libvlc_audio_get_volume'); + pointer(libvlc_audio_set_volume):=GetProcAddress(hlib,'libvlc_audio_set_volume'); + pointer(libvlc_audio_get_track_count):=GetProcAddress(hlib,'libvlc_audio_get_track_count'); + pointer(libvlc_audio_get_track_description):=GetProcAddress(hlib,'libvlc_audio_get_track_description'); + pointer(libvlc_audio_get_track):=GetProcAddress(hlib,'libvlc_audio_get_track'); + pointer(libvlc_audio_set_track):=GetProcAddress(hlib,'libvlc_audio_set_track'); + pointer(libvlc_audio_get_channel):=GetProcAddress(hlib,'libvlc_audio_get_channel'); + pointer(libvlc_audio_set_channel):=GetProcAddress(hlib,'libvlc_audio_set_channel'); + pointer(libvlc_audio_get_delay):=GetProcAddress(hlib,'libvlc_audio_get_delay'); + pointer(libvlc_audio_set_delay):=GetProcAddress(hlib,'libvlc_audio_set_delay'); + pointer(libvlc_media_list_new):=GetProcAddress(hlib,'libvlc_media_list_new'); + pointer(libvlc_media_list_release):=GetProcAddress(hlib,'libvlc_media_list_release'); + pointer(libvlc_media_list_retain):=GetProcAddress(hlib,'libvlc_media_list_retain'); + pointer(libvlc_media_list_add_file_content):=GetProcAddress(hlib,'libvlc_media_list_add_file_content'); + pointer(libvlc_media_list_set_media):=GetProcAddress(hlib,'libvlc_media_list_set_media'); + pointer(libvlc_media_list_media):=GetProcAddress(hlib,'libvlc_media_list_media'); + pointer(libvlc_media_list_add_media):=GetProcAddress(hlib,'libvlc_media_list_add_media'); + pointer(libvlc_media_list_insert_media):=GetProcAddress(hlib,'libvlc_media_list_insert_media'); + pointer(libvlc_media_list_remove_index):=GetProcAddress(hlib,'libvlc_media_list_remove_index'); + pointer(libvlc_media_list_count):=GetProcAddress(hlib,'libvlc_media_list_count'); + pointer(libvlc_media_list_item_at_index):=GetProcAddress(hlib,'libvlc_media_list_item_at_index'); + pointer(libvlc_media_list_index_of_item):=GetProcAddress(hlib,'libvlc_media_list_index_of_item'); + pointer(libvlc_media_list_is_readonly):=GetProcAddress(hlib,'libvlc_media_list_is_readonly'); + pointer(libvlc_media_list_lock):=GetProcAddress(hlib,'libvlc_media_list_lock'); + pointer(libvlc_media_list_unlock):=GetProcAddress(hlib,'libvlc_media_list_unlock'); + pointer(libvlc_media_list_event_manager):=GetProcAddress(hlib,'libvlc_media_list_event_manager'); + pointer(libvlc_media_list_player_new):=GetProcAddress(hlib,'libvlc_media_list_player_new'); + pointer(libvlc_media_list_player_release):=GetProcAddress(hlib,'libvlc_media_list_player_release'); + pointer(libvlc_media_list_player_retain):=GetProcAddress(hlib,'libvlc_media_list_player_retain'); + pointer(libvlc_media_list_player_event_manager):=GetProcAddress(hlib,'libvlc_media_list_player_event_manager'); + pointer(libvlc_media_list_player_set_media_player):=GetProcAddress(hlib,'libvlc_media_list_player_set_media_player'); + pointer(libvlc_media_list_player_set_media_list):=GetProcAddress(hlib,'libvlc_media_list_player_set_media_list'); + pointer(libvlc_media_list_player_play):=GetProcAddress(hlib,'libvlc_media_list_player_play'); + pointer(libvlc_media_list_player_pause):=GetProcAddress(hlib,'libvlc_media_list_player_pause'); + pointer(libvlc_media_list_player_is_playing):=GetProcAddress(hlib,'libvlc_media_list_player_is_playing'); + pointer(libvlc_media_list_player_get_state):=GetProcAddress(hlib,'libvlc_media_list_player_get_state'); + pointer(libvlc_media_list_player_play_item_at_index):=GetProcAddress(hlib,'libvlc_media_list_player_play_item_at_index'); + pointer(libvlc_media_list_player_play_item):=GetProcAddress(hlib,'libvlc_media_list_player_play_item'); + pointer(libvlc_media_list_player_stop):=GetProcAddress(hlib,'libvlc_media_list_player_stop'); + pointer(libvlc_media_list_player_next):=GetProcAddress(hlib,'libvlc_media_list_player_next'); + pointer(libvlc_media_list_player_previous):=GetProcAddress(hlib,'libvlc_media_list_player_previous'); + pointer(libvlc_media_list_player_set_playback_mode):=GetProcAddress(hlib,'libvlc_media_list_player_set_playback_mode'); + pointer(libvlc_media_library_new):=GetProcAddress(hlib,'libvlc_media_library_new'); + pointer(libvlc_media_library_release):=GetProcAddress(hlib,'libvlc_media_library_release'); + pointer(libvlc_media_library_retain):=GetProcAddress(hlib,'libvlc_media_library_retain'); + pointer(libvlc_media_library_load):=GetProcAddress(hlib,'libvlc_media_library_load'); + pointer(libvlc_media_library_media_list):=GetProcAddress(hlib,'libvlc_media_library_media_list'); + pointer(libvlc_media_discoverer_new_from_name):=GetProcAddress(hlib,'libvlc_media_discoverer_new_from_name'); + pointer(libvlc_media_discoverer_release):=GetProcAddress(hlib,'libvlc_media_discoverer_release'); + pointer(libvlc_media_discoverer_localized_name):=GetProcAddress(hlib,'libvlc_media_discoverer_localized_name'); + pointer(libvlc_media_discoverer_media_list):=GetProcAddress(hlib,'libvlc_media_discoverer_media_list'); + pointer(libvlc_media_discoverer_event_manager):=GetProcAddress(hlib,'libvlc_media_discoverer_event_manager'); + pointer(libvlc_media_discoverer_is_running):=GetProcAddress(hlib,'libvlc_media_discoverer_is_running'); + pointer(libvlc_vlm_release):=GetProcAddress(hlib,'libvlc_vlm_release'); + pointer(libvlc_vlm_add_broadcast):=GetProcAddress(hlib,'libvlc_vlm_add_broadcast'); + pointer(libvlc_vlm_add_vod):=GetProcAddress(hlib,'libvlc_vlm_add_vod'); + pointer(libvlc_vlm_del_media):=GetProcAddress(hlib,'libvlc_vlm_del_media'); + pointer(libvlc_vlm_set_enabled):=GetProcAddress(hlib,'libvlc_vlm_set_enabled'); + pointer(libvlc_vlm_set_output):=GetProcAddress(hlib,'libvlc_vlm_set_output'); + pointer(libvlc_vlm_set_input):=GetProcAddress(hlib,'libvlc_vlm_set_input'); + pointer(libvlc_vlm_add_input):=GetProcAddress(hlib,'libvlc_vlm_add_input'); + pointer(libvlc_vlm_set_loop):=GetProcAddress(hlib,'libvlc_vlm_set_loop'); + pointer(libvlc_vlm_set_mux):=GetProcAddress(hlib,'libvlc_vlm_set_mux'); + pointer(libvlc_vlm_change_media):=GetProcAddress(hlib,'libvlc_vlm_change_media'); + pointer(libvlc_vlm_play_media):=GetProcAddress(hlib,'libvlc_vlm_play_media'); + pointer(libvlc_vlm_stop_media):=GetProcAddress(hlib,'libvlc_vlm_stop_media'); + pointer(libvlc_vlm_pause_media):=GetProcAddress(hlib,'libvlc_vlm_pause_media'); + pointer(libvlc_vlm_seek_media):=GetProcAddress(hlib,'libvlc_vlm_seek_media'); + pointer(libvlc_vlm_show_media):=GetProcAddress(hlib,'libvlc_vlm_show_media'); + pointer(libvlc_vlm_get_media_instance_position):=GetProcAddress(hlib,'libvlc_vlm_get_media_instance_position'); + pointer(libvlc_vlm_get_media_instance_time):=GetProcAddress(hlib,'libvlc_vlm_get_media_instance_time'); + pointer(libvlc_vlm_get_media_instance_length):=GetProcAddress(hlib,'libvlc_vlm_get_media_instance_length'); + pointer(libvlc_vlm_get_media_instance_rate):=GetProcAddress(hlib,'libvlc_vlm_get_media_instance_rate'); + pointer(libvlc_vlm_get_event_manager):=GetProcAddress(hlib,'libvlc_vlm_get_event_manager'); + pointer(libvlc_playlist_play):=GetProcAddress(hlib,'libvlc_playlist_play'); +end; + + +end. diff --git a/src/3rdparty/libvlc/vlc.pas b/src/3rdparty/libvlc/vlc.pas new file mode 100644 index 00000000..0f82b9c0 --- /dev/null +++ b/src/3rdparty/libvlc/vlc.pas @@ -0,0 +1,1746 @@ +unit vlc; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, ctypes, libvlc, syncobjs; + +Type + + { TVLCLibrary } + + TVLCLibrary = class(TComponent) + private + FInstance : plibvlc_instance_t; + FLibraryArgs: TStrings; + FLibraryPath : String; + function GetI: Boolean; + function GetLastError: String; + Function GetVersion : String; + Function GetCompiler : String; + Function GetChangeSet : String; + Procedure SetLibraryPath(Const AValue : String); + Protected + Function GetInstance : plibvlc_instance_t; virtual; + property Instance : plibvlc_instance_t read GetInstance; + public + constructor Create (AOwner : TComponent); override; + destructor Destroy; override; + Procedure Initialize; + Procedure Release; + property LastError : String read GetLastError; + property Version : String read GetVersion; + property Compiler : String read GetCompiler; + property ChangeSer : String read GetChangeSet; + property LibraryPath : String read FLibraryPath write SetLibraryPath; + Property LibraryArgs : TStrings read FLibraryArgs Write FLibraryArgs; + Property Initialized : Boolean Read GetI; + end; + + TVLCLibraryClass = Class of TVLCLibrary; + + TCustomVLCMediaPlayer = Class; + TVLCMediaItems = Class; + + { TVLCMediaItem } + TSnapShotFormat = (ssfPNG,ssfJPG); + TDeinterlaceMode = (dmBlend, dmDiscard, dmBob, dmLinear, dmMean, dmX, dmYadif, dmYadif2x); + + TVLCMediaItem = Class(TCollectionItem) + private + FDIM: TDeinterlaceMode; + FInstance : plibvlc_media_t; + FOpts : Array [0..3] of Boolean; // Keep in sync with property indexes + FPath: String; + FSS: TSNapshotFormat; + FFD: Integer; + function GetInstance: plibvlc_media_t; + function GetM(AIndex: Integer): Boolean; + function GetMD(AMeta : libvlc_meta_t): String; + function GetMRL: String; + function GetParsed: Boolean; + function GetUD: Pointer; + procedure SetDIM(AValue: TDeinterlaceMode); + procedure SetFSS(AValue: TSNapshotFormat); + procedure SetM(AIndex: Integer; AValue: Boolean); + Function GetBoolOpt(AIndex : Integer; AValue : Boolean) : String; + procedure SetMD(AMeta : libvlc_meta_t; AValue: String); + procedure SetUD(AValue: Pointer); + function GetState : libvlc_state_t; + function GetDuration : TDateTime; + Protected + Procedure RegisterInstance; + Procedure UnRegisterInstance; + procedure SetMRL(AValue: String); virtual; + procedure SetPath(AValue: String); virtual; + procedure SetFD(AValue: Integer); virtual; + Function GetVLC : TVLCLibrary; virtual; + function GetEventManager : plibvlc_event_manager_t; + Procedure SetInstance( Avalue : plibvlc_media_t); + Property Instance : plibvlc_media_t Read GetInstance; + Public + Destructor Destroy; override; + Procedure AddOption(Const AValue : String); + procedure Parse; + procedure ParseAsync; + Procedure SaveMetaData; + Function GetStats(Var AStats : libvlc_media_stats_t) : Boolean; + Function Duplicate : TVLCMediaItem; + Property Parsed : Boolean Read GetParsed; + Property ShowTitle : Boolean Index 0 Read GetM Write SetM; + Property VideoOnTop : Boolean Index 1 Read GetM Write SetM; + Property UseOverlay : Boolean Index 2 Read GetM Write SetM; + Property FullScreen : Boolean Index 3 Read GetM Write SetM; + Property DeinterlaceFilter : Boolean Index 4 Read GetM Write SetM; + Property DeInterlaceMode : TDeinterlaceMode Read FDIM Write SetDIM; + Property SnapShotFormat : TSNapshotFormat Read FSS Write SetFSS; + Property UserData : Pointer Read GetUD Write SetUD; + Property State : libvlc_state_t Read GetState; + Property Duration : TDateTime Read GetDuration; + Property MetaData[AMeta : libvlc_meta_t] : String Read GetMD Write SetMD; + // These must be set prior to using any of the above. + Property MRL : String Read GetMRL Write SetMRL; + Property Path : String Read FPath Write SetPath; + property FileDescriptor : Integer Read FFD Write SetFD; + end; + + TVLCMediaItemClass = Class of TVLCMediaItem; + + { TVLCMediaItems } + TVLCPlayMode = (pmNormal,pmLoop,pmRepeat); + + TVLCMediaItems = Class(TCollection) + Private + FPlayer: TCustomVLCMediaPlayer; + FPlayMode: TVLCPlayMode; + FVLC : TVLCLibrary; + FInstance : Plibvlc_media_list_t; + function GetI(AIndex : Integer): TVLCMediaItem; + function GetInstance: Plibvlc_media_list_t; + function GetIsReadOnly: Boolean; + procedure SetI(AIndex : Integer; AValue: TVLCMediaItem); + Protected + Function GetVLC : TVLCLibrary; virtual; + Public + Constructor Create(ALibrary : TVLCLibrary;AItemClass: TVLCMediaItemClass = Nil); overload; + Constructor Create(AInstance : Plibvlc_media_list_t;AItemClass: TVLCMediaItemClass = Nil); overload; + Procedure Lock; + Procedure Unlock; + Property Instance : Plibvlc_media_list_t read GetInstance; + Property VLC : TVLCLibrary Read GetVLC Write FVLC; + Property MediaItems[AIndex : Integer] : TVLCMediaItem Read GetI Write SetI; default; + Property ReadOnly : Boolean Read GetIsReadOnly; + end; + + { TCustomVLCMediaPlayer } + TBooleanEvent = procedure(Sender : TObject; Const AValue : Boolean) of object; + TTitleEvent = procedure(Sender : TObject; Const ATitle : Integer) of object; + TSnapshotEvent = procedure(Sender : TObject; Const AfileName : string) of object; + TErrorEvent = procedure(Sender : TObject; Const AError : string) of object; + TTimeEvent = procedure(Sender : TObject; Const time : TDateTime) of object; + TPositionEvent = procedure(Sender : TObject; Const APos : Double) of object; + + TCustomVLCMediaPlayer = Class(TComponent) + private + FFitWindow: Boolean; + FOnBackward: TNotifyEvent; + FOnBuffering: TNotifyEvent; + FOnEOF: TNotifyEvent; + FOnError: TErrorEvent; + FOnForward: TNotifyEvent; + FOnLengthChanged: TTimeEvent; + FOnMediaChanged: TNotifyEvent; + FOnNothingSpecial: TNotifyEvent; + FOnOpening: TNotifyEvent; + FOnPausableChanged: TBooleanEvent; + FOnPause: TNotifyEvent; + FOnPlaying: TNotifyEvent; + FOnPositionChanged: TPositionEvent; + FOnSeekableChanged: TBooleanEvent; + FOnSnapShot: TSnapShotEvent; + FOnStop: TNotifyEvent; + FOnTimeChanged: TTimeEvent; + FOnTitleChanged: TTitleEvent; + FUseEvents: Boolean; + Finstance : Plibvlc_media_player_t; + FVLC: TVLCLibrary; + FECS : TCriticalSection; + function GetAspectRatio: String; + function GetAudioMuted: Boolean; + function GetAudioTrack: Integer; + function GetHaveInstance: Boolean; + function GetState: libvlc_state_t; + function GetVideoDuration: TDateTime; + function GetVideoFPS: Double; + function GetVideoFractional: Double; + function GetVideoHeight: Cardinal; + function GetVideoLength: Int64; + function GetVideoPos: Int64; + function GetVideoScale: Double; + function GetVideoWidth: Cardinal; + function GetVLC: TVLCLibrary; + procedure SetAspectRatio(AValue: String); + procedure SetAudioMuted(AValue: Boolean); + procedure SetFitWindow(AValue: Boolean); + procedure SetUseEVents(AValue: Boolean); + function GetAudioTrackCount : Integer; + procedure SetAudioTrack(AValue: Integer); + function GetAudioTrackDescriptions(AIndex : Integer) : String; + function GetChannel: Integer; + procedure SetChannel(AValue : Integer); + function GetAudioDelay : Int64; + procedure SetAudioDelay (AValue: Int64); + function GetPlaying : Boolean; + function GetChapter : Integer; + procedure SetChapter(AValue : Integer); + function GetChapterCount: Integer; + Function GetPlayable : Boolean; + Function GetPausable : Boolean; + Function GetSeekable : Boolean; + function GetAudioVolume : Integer; + function GetPlayRate: Integer; + procedure SetAudioVolume(AValue : Integer); + procedure SetPlayRate(AValue: Integer); + procedure SetFullScreenMode(AValue: Boolean); + function GetFullScreenMode: Boolean; + procedure SetVideoFractional(AValue: Double); + procedure SetVideoPos(AValue: Int64); + procedure SetVideoScale(AValue: Double); + Protected + function GetInstance: Plibvlc_media_player_t; virtual; + // Called to set parent window. Descendents must override this. + Procedure SetParentWindow; virtual; + // Called when FitWindow is true. + Procedure SetParentWindowSize(AWidth,AHeight : Cardinal); Virtual; + procedure DoMediaChanged; virtual; + procedure DoNothingSpecial; virtual; + procedure DoOnBackward; virtual; + procedure DoOnBuffering;virtual; + procedure DoOnEOF;virtual; + procedure DoOnError;virtual; + procedure DoOnForward;virtual; + procedure DoOnOpening;virtual; + procedure DoOnPause;virtual; + procedure DoOnPlaying;virtual; + procedure DoOnStop;virtual; + procedure DoOnLengthChanged(const ATime: libvlc_time_t); virtual; + procedure DoOnPausableChanged(const APausable: Boolean); virtual; + procedure DoOnPositionChanged(const Aposition: Double); virtual; + procedure DoOnSeekableChanged(const ASeekable: Boolean); virtual; + procedure DoOnTimeChanged(const ATime: libvlc_time_t); virtual; + procedure DoOnTitleChanged(const ATitle: cint); virtual; + procedure DoOnSnapshot(const AFileName: PCChar); virtual; + procedure HookupEvents; virtual; + procedure UnHookEvents; virtual; + procedure HandleVLCEvent(e: Plibvlc_event_t); virtual; + Property VLC : TVLCLibrary Read GetVLC Write FVLC; + Property Instance : Plibvlc_media_player_t Read GetInstance; + Property HaveInstance : Boolean Read GetHaveInstance; + Public + Destructor Destroy; override; + procedure Play; + procedure SetMedia(M: TVLCMediaItem); + Procedure Play(M : TVLCMediaItem); + Procedure PlayFile(Const AFileName : String); + Procedure Stop; + procedure Pause; + procedure Resume; + procedure NextFrame; + function Snapshot(Const AFileName: String): Boolean; + function Snapshot(Const AFileName: String; AWidth, AHeight: Cardinal): Boolean; + function GetVideoSize(Var AWidth, AHeight: Cardinal): Boolean; + // These can be made public/published in descendents + Protected + Property Playable : Boolean Read GetPlayable; + Property Pausable : Boolean Read GetPausable; + Property Seekable : Boolean Read GetSeekable; + Property Playing : Boolean Read GetPlaying; + Property State : libvlc_state_t Read GetState; + Property AudioTrackDescriptions [AIndex : Integer] : String Read GetAudioTrackDescriptions; + Property ChapterCount : Integer Read GetChapterCount; + Property AudioTrackCount : Integer Read GetAudioTrackCount; + Property AudioTrack : Integer Read GetAudioTrack Write SetAudioTrack; + Property AudioDelay : Int64 Read GetAudioDelay Write SetAudioDelay; + Property AudioVolume : Integer Read GetAudioVolume Write SetAudioVolume; + Property AudioMuted : Boolean Read GetAudioMuted Write SetAudioMuted; + Property FitWindow : Boolean Read FFitWindow Write SetFitWindow; + Property VideoWidth : Cardinal Read GetVideoWidth; + Property VideoHeight : Cardinal Read GetVideoHeight; + // In MS. + Property VideoLength : Int64 Read GetVideoLength; + Property VideoDuration : TDateTime Read GetVideoDuration; + // In MS + Property VideoPosition : Int64 Read GetVideoPos Write SetVideoPos; + Property VideoFractionalPosition : Double Read GetVideoFractional Write SetVideoFractional; + Property VideoFramesPerSecond : Double Read GetVideoFPS; + Property VideoScale : Double Read GetVideoScale Write SetVideoScale; + Property AspectRatio : String Read GetAspectRatio Write SetAspectRatio; + Property Channel : Integer Read GetChannel Write SetChannel; + Property Chapter : Integer Read GetChapter Write SetChapter; + Property FullScreenMode : Boolean Read GetFullScreenMode Write SetFullScreenMode; + Property UseEvents : Boolean Read FUseEvents Write SetUseEVents; + // Events from VLC player + Property OnMediaChanged : TNotifyEvent Read FOnMediaChanged Write FOnMediaChanged; + Property OnNothingSpecial : TNotifyEvent Read FOnNothingSpecial Write FOnNothingSpecial; + Property OnBackward : TNotifyEvent Read FOnBackward Write FOnBackward; + Property OnBuffering : TNotifyEvent Read FOnBuffering Write FOnBuffering; + Property OnEOF : TNotifyEvent Read FOnEOF Write FOnEOF; + Property OnError : TErrorEvent Read FOnError Write FOnError; + Property OnForward : TNotifyEvent Read FOnForward Write FOnForward; + Property OnOpening : TNotifyEvent Read FOnOpening Write FOnOpening; + Property OnPause : TNotifyEvent Read FOnPause Write FOnPause; + Property OnPlaying : TNotifyEvent Read FOnPlaying Write FOnPlaying; + Property OnStop : TNotifyEvent Read FOnStop Write FOnStop; + Property OnLengthChanged : TTimeEvent Read FOnLengthChanged Write FOnLengthChanged; + Property OnTimeChanged : TTimeEvent Read FOnTimeChanged Write FOnTimeChanged; + Property OnPausableChanged : TBooleanEvent Read FOnPausableChanged Write FOnPausableChanged; + Property OnPositionChanged : TPositionEvent Read FOnPositionChanged Write FOnPositionChanged; + Property OnSeekableChanged : TBooleanEvent Read FOnSeekableChanged Write FOnSeekableChanged; + Property OnTitleChanged : TTitleEvent Read FOnTitleChanged Write FOnTitleChanged; + Property OnSnapshot : TSnapShotEvent Read FOnSnapShot Write FOnSnapShot; + end; + + EVLC = Class(Exception); + + TVLCMediaPlayer = Class(TCustomVLCMediaPlayer) + Public + Property Playable ; + Property Pausable ; + Property Seekable ; + Property PLaying ; + Property State ; + Property AudioTrackDescriptions; + Property ChapterCount ; + Property AudioTrackCount ; + Property AudioTrack ; + Property VideoWidth ; + Property VideoHeight; + Property VideoLength; + Property VideoDuration ; + Property VideoPosition ; + Property VideoFractionalPosition ; + Property VideoFramesPerSecond; + Property VideoScale : Double; + Property AspectRatio : String; + Published + Property AudioDelay ; + Property AudioVolume ; + Property AudioMuted ; + Property Channel ; + Property Chapter ; + Property FitWindow; + Property FullScreenMode ; + Property UseEvents ; + Property OnMediaChanged ; + Property OnNothingSpecial ; + Property OnBackward ; + Property OnBuffering ; + Property OnEOF ; + Property OnError ; + Property OnForward ; + Property OnOpening ; + Property OnPause ; + Property OnPlaying ; + Property OnStop ; + Property OnLengthChanged ; + Property OnTimeChanged ; + Property OnPausableChanged ; + Property OnPositionChanged ; + Property OnSeekableChanged ; + Property OnTitleChanged ; + Property OnSnapshot ; + end; + + { TCustomVLCMediaListPlayer } + + TCustomVLCMediaListPlayer = Class(TComponent) + Private + FMediaItems: TVLCMediaItems; + FPlayer: TCustomVLCMediaPlayer; + FPlayMode: TVLCPlayMode; + FInstance : plibvlc_media_list_player_t; + FVLC: TVLCLibrary; + function GetInstance: plibvlc_media_list_player_t; + function GetPlaying : Boolean; + function GetState: libvlc_state_t; + function GetVLC: TVLCLibrary; + procedure SetMediaItems(AValue: TVLCMediaItems); + procedure SetPlayer(AValue: TCustomVLCMediaPlayer); virtual; + procedure SetPlayMode(AValue: TVLCPlayMode); + Protected + Function CreateMediaItems : TVLCMediaItems; virtual; + Property Instance : plibvlc_media_list_player_t Read GetInstance; + Property Player : TCustomVLCMediaPlayer Read FPlayer write SetPlayer; + Property PlayMode : TVLCPlayMode read FPlayMode write SetPlayMode; + Property Playing : Boolean Read GetPLaying; + Property State : libvlc_state_t Read GetState; + Property MediaItems : TVLCMediaItems Read FMediaItems Write SetMediaItems; + Property VLC : TVLCLibrary Read GetVLC Write FVLC; + Public + Constructor Create(AOwner : TComponent); override; + Destructor Destroy; override; + procedure Play(Item : TVLCMediaItem); + procedure Play; + procedure Pause; + procedure Stop; + procedure Next; + procedure Prev; + end; + + TVLCMediaListPlayer = Class(TCustomVLCMediaListPlayer) + Public + Property VLC : TVLCLibrary; + Published + Property Player; + Property PlayMode; + Property Playing; + Property State; + Property MediaItems; + end; + +Function VLCLibrary : TVLCLibrary; + +Var + VLCLibraryClass : TVLCLibraryClass = TVLCLibrary; + +Function VLCTimeToDateTime (T : libvlc_time_t) : TDateTime; + +implementation + +{ TVLCLibrary } +Var + LVLC : TVLCLibrary; + +Function VLCLibrary : TVLCLibrary; + +begin + If LVLC=Nil then + LVLC:=VLCLibraryClass.Create(Nil); + Result:=LVLC; +end; + +Procedure DoneVLC; + +begin + If Assigned(LVLC) then + FreeAndNil(LVLC); +end; + +Function VLCTimeToDateTime (T : libvlc_time_t) : TDateTime; + + Function MD(Var MS : libvlc_time_t; D : Integer) : Word; inline; + + begin + Result:=MS Mod D; + MS:=MS div D; + end; + +var + d,h,m,s,ms: word; + +begin + ms:=MD(T,1000); + s:=MD(T,60); + m:=MD(T,60); + h:=MD(T,24); + d:=T; + Result:=D+EncodeTime(h,m,s,ms); +end; + +procedure PlayerEventHelper(event: Plibvlc_event_t; data: Pointer); cdecl; + +begin + if Not Assigned(data) then + exit; + TCustomVLCMediaPlayer(data).HandleVLCEvent(event); +end; + +{ TCustomVLCMediaListPlayer } + +function TCustomVLCMediaListPlayer.GetPlaying: Boolean; +begin + Result:=libvlc_media_list_player_is_playing(Instance)<>0; +end; + +function TCustomVLCMediaListPlayer.GetInstance: plibvlc_media_list_player_t; +begin + if (FInstance=Nil) then + begin + Finstance:=libvlc_media_list_player_new(VLC.Instance); + if Assigned(MediaItems) then + begin + libvlc_media_list_player_set_media_list(FInstance,MediaItems.Instance); + end; + If Assigned(FPlayer) then + begin + libvlc_media_list_player_set_media_player(FInstance, FPlayer.Instance); + end; + end; + Result:=FInstance; +end; + +function TCustomVLCMediaListPlayer.GetState: libvlc_state_t; +begin + Result:=libvlc_media_list_player_get_state(Instance) +end; + +function TCustomVLCMediaListPlayer.GetVLC: TVLCLibrary; +begin + Result:=FVLC; + If Result=Nil then + Result:=VLCLibrary; +end; + +procedure TCustomVLCMediaListPlayer.Play(Item: TVLCMediaItem); +begin + libvlc_media_list_player_play_item(Instance, item.Instance); +end; + +procedure TCustomVLCMediaListPlayer.SetMediaItems(AValue: TVLCMediaItems); +begin + if FMediaItems=AValue then Exit; + FMediaItems.Assign(AValue); +end; + +procedure TCustomVLCMediaListPlayer.SetPlayer(AValue: TCustomVLCMediaPlayer); +begin + if FPlayer=AValue then Exit; + FPlayer:=AValue; + If Assigned(FInstance) then + begin + libvlc_media_list_player_set_media_player(FInstance, FPlayer.Instance); + end; +end; + +procedure TCustomVLCMediaListPlayer.SetPlayMode(AValue: TVLCPlayMode); +Const + M : Array [TVLCPlayMode] of libvlc_playback_mode_t + = (libvlc_playback_mode_default, + libvlc_playback_mode_loop, + libvlc_playback_mode_repeat); + +begin + if FPlayMode=AValue then Exit; + FPlayMode:=AValue; + libvlc_media_list_player_set_playback_mode(FInstance, M[AValue]); +end; + +function TCustomVLCMediaListPlayer.CreateMediaItems: TVLCMediaItems; +begin + Result:=TVLCMediaItems.Create(TVLCMediaItem); +end; + +constructor TCustomVLCMediaListPlayer.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + FMediaItems:=CreateMediaItems; +end; + +destructor TCustomVLCMediaListPlayer.Destroy; +begin + If Assigned(Finstance) then + libvlc_media_list_player_release(FInstance); + FreeAndNil(FMediaItems); + inherited Destroy; +end; + +procedure TCustomVLCMediaListPlayer.Play; +begin + libvlc_media_list_player_play(Instance); +end; + +procedure TCustomVLCMediaListPlayer.Pause; +begin + libvlc_media_list_player_pause(Instance); +end; + +procedure TCustomVLCMediaListPlayer.Stop; +begin + libvlc_media_list_player_stop(Instance); +end; + +procedure TCustomVLCMediaListPlayer.Next; +begin + libvlc_media_list_player_next(Instance); +end; + +procedure TCustomVLCMediaListPlayer.Prev; +begin + libvlc_media_list_player_previous(Instance); +end; + + +{ TCustomVLCMediaPlayer } + +function TCustomVLCMediaPlayer.GetVLC: TVLCLibrary; +begin + Result:=FVLC; + if Result=Nil then + Result:=VLCLibrary; +end; + +procedure TCustomVLCMediaPlayer.SetAspectRatio(AValue: String); + +begin + libvlc_video_set_aspect_ratio(Instance,Pcchar(PChar(AValue))); +end; + +function TCustomVLCMediaPlayer.GetAudioMuted: Boolean; +begin + if Assigned(Finstance) then + Result:=libvlc_audio_get_mute(instance)<>0 + else + Result:=False; +end; + +function TCustomVLCMediaPlayer.GetAspectRatio: String; + +Var + P : Pcchar; + +begin + P:=libvlc_video_get_aspect_ratio(Instance); + if (P<>Nil) then + Result:=StrPas(PChar(P)) + else + Result:=''; +end; + +function TCustomVLCMediaPlayer.GetAudioTrack: Integer; +begin + if Assigned(FInstance) then + Result := libvlc_audio_get_track(FINstance) + else + Result:=-1; +end; + +function TCustomVLCMediaPlayer.GetHaveInstance: Boolean; +begin + Result:=(FInstance<>Nil); +end; + +function TCustomVLCMediaPlayer.GetState: libvlc_state_t; +begin + If Assigned(FInstance) then + Result:=libvlc_media_player_get_state(FInstance) + else + Result:=libvlc_NothingSpecial; +end; + +function TCustomVLCMediaPlayer.GetVideoDuration: TDateTime; +begin + Result:=VLCTimeToDateTime(GetVideoLength); +end; + +function TCustomVLCMediaPlayer.GetVideoFPS: Double; +begin + Result:=libvlc_media_player_get_fps(FInstance); +end; + +function TCustomVLCMediaPlayer.GetVideoFractional: Double; +begin + Result:=libvlc_media_player_get_Position(FInstance); +end; + +function TCustomVLCMediaPlayer.GetVideoHeight: Cardinal; +begin + Result:=libvlc_video_get_height(FInstance); +end; + +function TCustomVLCMediaPlayer.GetVideoLength: Int64; +begin + Result:=libvlc_media_player_get_length(Finstance); +end; + +function TCustomVLCMediaPlayer.GetVideoPos: Int64; +begin + Result:=libvlc_media_player_get_time(FInstance); +end; + +function TCustomVLCMediaPlayer.GetVideoScale: Double; +begin + Result:=libvlc_video_get_scale(Finstance); +end; + +function TCustomVLCMediaPlayer.GetVideoWidth: Cardinal; +begin + Result:=libvlc_video_get_width(FInstance); +end; + + +procedure TCustomVLCMediaPlayer.SetAudioMuted(AValue: Boolean); +begin + libvlc_audio_set_mute(instance, ord(AValue)); +end; + +procedure TCustomVLCMediaPlayer.SetFitWindow(AValue: Boolean); + +Var + W,H : Cardinal; + +begin + if FFitWindow=AValue then Exit; + FFitWindow:=AValue; + If FFitWindow and Playing then + begin + if GetVideoSize(W,H) then + SetParentWindowSize(W,H); + end; +end; + +procedure TCustomVLCMediaPlayer.SetUseEVents(AValue: Boolean); +begin + if FUseEvents=AValue then Exit; + FUseEvents:=AValue; + If Assigned(Finstance) then + If AValue then + HookupEvents + else + UnhookEvents; +end; + +function TCustomVLCMediaPlayer.GetAudioTrackCount: Integer; +begin + if Assigned(FInstance) then + Result := libvlc_audio_get_track_count(FINstance) + else + Result:=-1; +end; + + +procedure TCustomVLCMediaPlayer.SetAudioTrack(AValue: Integer); +begin + if Assigned(FInstance) then + begin + if (AValue<0) then + AValue:=0; + libvlc_audio_set_track(FInstance,AValue); + end; +end; + +function TCustomVLCMediaPlayer.GetAudioTrackDescriptions(AIndex: Integer): String; + +var + t : plibvlc_track_description_t; + +begin + Result := ''; + If (AIndex>=0) And Assigned(FInstance) then + begin + T:=libvlc_audio_get_track_description(Finstance); + while (AIndex>0) and Assigned(t) do + begin + Dec(Aindex); + t:=t^.p_next; + end; + If Assigned(t) and Assigned(t^.psz_name) then + Result:=StrPas(PChar(t^.psz_name)); + end; +end; + +function TCustomVLCMediaPlayer.GetChannel: Integer; +begin + If Assigned(Finstance) then + Result:=libvlc_audio_get_channel(FInstance) + else + Result:=-1; +end; + +procedure TCustomVLCMediaPlayer.SetChannel(AValue: Integer); +begin + If Assigned(Finstance) then + libvlc_audio_set_channel(Finstance,AValue) +end; + +function TCustomVLCMediaPlayer.GetAudioDelay: Int64; +begin + if Assigned(FInstance) then + Result:=libvlc_audio_get_delay(FInstance) + else + Result:=-1; +end; + +procedure TCustomVLCMediaPlayer.SetAudioDelay(AValue: Int64); +begin + if Assigned(FInstance) then + libvlc_audio_set_delay(FInstance,AValue) +end; + +function TCustomVLCMediaPlayer.GetPlaying: Boolean; +begin + Result:=(State=libvlc_Playing); +end; + +function TCustomVLCMediaPlayer.GetChapter: Integer; +begin + if Assigned(FInstance) then + Result:=libvlc_media_player_get_chapter(FInstance) + else + Result:=-1; +end; + +procedure TCustomVLCMediaPlayer.SetChapter(AValue: Integer); +begin + if Assigned(FInstance) then + libvlc_media_player_set_chapter(FInstance,AValue); +end; + +function TCustomVLCMediaPlayer.GetChapterCount: Integer; +begin + if Assigned(FInstance) then + Result:=libvlc_media_player_get_chapter_count(FInstance) + else + Result:=-1; +end; + +function TCustomVLCMediaPlayer.GetPlayable: Boolean; +begin + if Assigned(FInstance) then + Result:=(libvlc_media_player_will_play(FInstance)<>0) + else + Result:=False +end; + +function TCustomVLCMediaPlayer.GetPausable: Boolean; +begin + if Assigned(FInstance) then + Result:=(libvlc_media_player_can_pause(FInstance)<>0) + else + Result:=False +end; + +function TCustomVLCMediaPlayer.GetSeekable: Boolean; +begin + if Assigned(FInstance) then + Result:=(libvlc_media_player_is_seekable(FInstance)<>0) + else + Result:=False +end; + +function TCustomVLCMediaPlayer.GetAudioVolume: Integer; +begin + if Assigned(FInstance) then + Result:=libvlc_audio_get_volume(FInstance) + else + Result:=-1 +end; + +procedure TCustomVLCMediaPlayer.SetAudioVolume(AValue: Integer); +begin + if Assigned(FInstance) then + begin + if (AValue<0) then + AValue:=0 + else if (AValue>200) then + AValue:=200; + libvlc_audio_set_volume(Finstance,AValue); + end; +end; + +procedure TCustomVLCMediaPlayer.SetPlayRate(Avalue : Integer); +begin + if Assigned(FInstance) then + begin + if (Avalue< 1) then + AValue:=1 + else if (AValue>1000) then + AValue:=1000; + libvlc_media_player_set_rate(FInstance,AValue/100); + end; +end; + +function TCustomVLCMediaPlayer.GetPlayRate: Integer; +begin + if Assigned(FInstance) then + Result:=Round(libvlc_media_player_get_rate(FInstance)*100) + else + Result:=-1; +end; + +procedure TCustomVLCMediaPlayer.SetFullScreenMode(AValue: Boolean); +begin + if Assigned(FInstance) then + libvlc_set_fullscreen(Finstance,Ord(AValue)); +end; + +function TCustomVLCMediaPlayer.GetFullScreenMode: Boolean; +begin + If Assigned(FInstance) then + Result:=libvlc_get_fullscreen(Finstance)<>0 + else + Result:=False; +end; + +procedure TCustomVLCMediaPlayer.SetVideoFractional(AValue: Double); +begin + libvlc_media_player_set_position(FInstance,AValue); +end; + +procedure TCustomVLCMediaPlayer.SetVideoPos(AValue: Int64); +begin + libvlc_media_player_set_time(FInstance,AVAlue); +end; + +procedure TCustomVLCMediaPlayer.SetVideoScale(AValue: Double); +begin + libvlc_video_set_scale(Finstance,AVAlue); +end; + +function TCustomVLCMediaPlayer.GetInstance: Plibvlc_media_player_t; +begin + Result:=FInstance; + if (FInstance=Nil) then + begin + FInstance:=libvlc_media_player_new(VLC.Instance); + libvlc_video_set_mouse_input(FInstance,1); + libvlc_video_set_key_input(FInstance,1); + if FUseEvents then + HookupEvents; + end; + Result:=FInstance; +end; + +procedure TCustomVLCMediaPlayer.SetParentWindow; +begin + // Do nothing +end; + +procedure TCustomVLCMediaPlayer.SetParentWindowSize(AWidth, AHeight: Cardinal); +begin + // Do nothing +end; + +Procedure TCustomVLCMediaPlayer.UnHookEvents; + + + Procedure ClearEvent(M : plibvlc_event_manager_t;t : libvlc_event_e); + + begin + libvlc_event_detach(M,ord(t),@PlayerEventHelper,Self); + end; + +Var + M : plibvlc_event_manager_t; + +begin + M:=libvlc_media_player_event_manager(Instance); + if (M<>Nil) then + begin + ClearEvent(M,libvlc_MediaPlayerMediaChanged); + ClearEvent(M,libvlc_MediaPlayerNothingSpecial); + ClearEvent(M,libvlc_MediaPlayerOpening); + ClearEvent(M,libvlc_MediaPlayerBuffering); + ClearEvent(M,libvlc_MediaPlayerPlaying); + ClearEvent(M,libvlc_MediaPlayerPaused); + ClearEvent(M,libvlc_MediaPlayerStopped); + ClearEvent(M,libvlc_MediaPlayerForward); + ClearEvent(M,libvlc_MediaPlayerBackward); + ClearEvent(M,libvlc_MediaPlayerEndReached); + ClearEvent(M,libvlc_MediaPlayerEncounteredError); + ClearEvent(M,libvlc_MediaPlayerTimeChanged); + ClearEvent(M,libvlc_MediaPlayerPositionChanged); + ClearEvent(M,libvlc_MediaPlayerSeekableChanged); + ClearEvent(M,libvlc_MediaPlayerPausableChanged); + ClearEvent(M,libvlc_MediaPlayerTitleChanged); + ClearEvent(M,libvlc_MediaPlayerSnapshotTaken); + ClearEvent(M,libvlc_MediaPlayerLengthChanged); + FreeAndNil(FECS); + end; +end; + +Procedure TCustomVLCMediaPlayer.HookupEvents; + + Procedure AttachEvent( M : plibvlc_event_manager_t;t : libvlc_event_e); + + begin + libvlc_event_attach(M,ord(t),@PlayerEventHelper,Self); + end; + +Var + M : plibvlc_event_manager_t; + +begin + M:=libvlc_media_player_event_manager(Instance); + if (M<>Nil) then + begin + FECS:=TCriticalSection.Create; + AttachEvent(M,libvlc_MediaPlayerMediaChanged); + AttachEvent(M,libvlc_MediaPlayerNothingSpecial); + AttachEvent(M,libvlc_MediaPlayerOpening); + AttachEvent(M,libvlc_MediaPlayerBuffering); + AttachEvent(M,libvlc_MediaPlayerPlaying); + AttachEvent(M,libvlc_MediaPlayerPaused); + AttachEvent(M,libvlc_MediaPlayerStopped); + AttachEvent(M,libvlc_MediaPlayerForward); + AttachEvent(M,libvlc_MediaPlayerBackward); + AttachEvent(M,libvlc_MediaPlayerEndReached); + AttachEvent(M,libvlc_MediaPlayerEncounteredError); + AttachEvent(M,libvlc_MediaPlayerTimeChanged); + AttachEvent(M,libvlc_MediaPlayerPositionChanged); + AttachEvent(M,libvlc_MediaPlayerSeekableChanged); + AttachEvent(M,libvlc_MediaPlayerPausableChanged); + AttachEvent(M,libvlc_MediaPlayerTitleChanged); + AttachEvent(M,libvlc_MediaPlayerSnapshotTaken); + AttachEvent(M,libvlc_MediaPlayerLengthChanged); + end; +end; + +procedure TCustomVLCMediaPlayer.DoMediaChanged; + +begin + If Assigned(FOnMediaChanged) then + FOnMediaChanged(Self); +end; + +procedure TCustomVLCMediaPlayer.DoNothingSpecial; + +begin + If Assigned(FOnNothingSpecial) then + FOnNothingSpecial(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnOpening; + +begin + If Assigned(FOnOpening) then + FOnOpening(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnPlaying; + +begin + If Assigned(FOnPlaying) then + FOnPlaying(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnPause; + +begin + If Assigned(FOnPause) then + FOnPause(Self); +end; + + +procedure TCustomVLCMediaPlayer.DoOnStop; + +begin + If Assigned(FOnStop) then + FOnStop(Self); +end; + + +procedure TCustomVLCMediaPlayer.DoOnForward; + +begin + If Assigned(FOnForward) then + FOnForward(Self); +end; + + +procedure TCustomVLCMediaPlayer.DoOnBackward; + +begin + If Assigned(FOnBackward) then + FOnBackward(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnEOF; + +begin + If Assigned(FOnEOF) then + FOnEOF(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnBuffering; + +begin + If Assigned(FOnBuffering) then + FOnBuffering(Self); +end; + +procedure TCustomVLCMediaPlayer.DoOnError; + +Var + P : pcchar; + E : String; +begin + p:=libvlc_errmsg(); + if p<>Nil then + E:=StrPas(PChar(P)) + else + E:=''; + If Assigned(FOnError) then + FOnError(Self,E); +end; + +procedure TCustomVLCMediaPlayer.DoOnTimeChanged(Const ATime: libvlc_time_t); + +begin + If Assigned(FOnTimeChanged) then + FOnTimeChanged(Self,VLCTimeToDateTime(ATime)); +end; + +procedure TCustomVLCMediaPlayer.DoOnPositionChanged(Const Aposition: Double); + +begin + If Assigned(FOnPositionChanged) then + FOnPositionChanged(Self,APosition); +end; + + +procedure TCustomVLCMediaPlayer.DoOnSeekableChanged(Const ASeekable : Boolean); + +begin + If Assigned(FOnSeekableChanged) then + FOnSeekableChanged(Self,ASeekable); +end; + +procedure TCustomVLCMediaPlayer.DoOnPausableChanged(Const APausable : Boolean); + +begin + If Assigned(FOnPausableChanged) then + FOnPausableChanged(Self,APausable); +end; + +procedure TCustomVLCMediaPlayer.DoOnTitleChanged(Const ATitle: cint); + +begin + If Assigned(FOnTitleChanged) then + FOnTitleChanged(Self,ATitle); +end; + +procedure TCustomVLCMediaPlayer.DoOnSnapshot(Const AFileName : PCChar); + +Var + S :String; + +begin + If Assigned(FOnSnapshot) then + begin + if Assigned(AFileName) then + S:=StrPas(PChar(AFileName)) + else + S:=''; + FOnSnapShot(Self,S); + end; +end; + +procedure TCustomVLCMediaPlayer.DoOnLengthChanged(Const ATime: libvlc_time_t); + +begin + If Assigned(FOnLengtHChanged) then + FOnLengtHChanged(Self,VLCTimeToDateTime(ATime)); +end; + + + +procedure TCustomVLCMediaPlayer.HandleVLCEvent(e: Plibvlc_event_t); + +begin + FECS.Enter; + try + case libvlc_event_e(e^._type) of + libvlc_MediaPlayerMediaChanged : DoMediaChanged; + libvlc_MediaPlayerNothingSpecial : DoNothingSpecial; + libvlc_MediaPlayerOpening : DoOnOpening; + libvlc_MediaPlayerBuffering : DoOnBuffering; + libvlc_MediaPlayerPlaying : DoOnPlaying; + libvlc_MediaPlayerPaused : DoOnPause; + libvlc_MediaPlayerStopped : DoOnStop; + libvlc_MediaPlayerForward : DoOnForward; + libvlc_MediaPlayerBackward : DoOnBackward; + libvlc_MediaPlayerEndReached : DoOnEOF; + libvlc_MediaPlayerEncounteredError : DoOnError; + libvlc_MediaPlayerTimeChanged : begin + DoOnTimeChanged(e^.media_player_time_changed.new_time); + end; + libvlc_MediaPlayerPositionChanged : begin + DoOnPositionChanged(e^.media_player_position_changed.new_position); + end; + libvlc_MediaPlayerSeekableChanged : begin + DoOnSeekableChanged(e^.media_player_seekable_changed.new_seekable<>0); + end; + libvlc_MediaPlayerPausableChanged : begin + DoOnPausableChanged(e^.media_player_pausable_changed.new_pausable<>0) ; + end; + libvlc_MediaPlayerTitleChanged : begin + DoOnTitleChanged(e^.media_player_title_changed.new_title); + end; + libvlc_MediaPlayerSnapshotTaken : begin + DoOnSnapShot(e^.media_player_snapshot_taken.psz_filename); + end; + libvlc_MediaPlayerLengthChanged : begin + DoOnLengthChanged(e^.media_player_length_changed.new_length); + end; + else + // Writeln('Unknown event type ',e^._type); + end; + finally + FECS.Leave; + end; +end; + +destructor TCustomVLCMediaPlayer.Destroy; +begin + If Assigned(FInstance) then + begin + libvlc_media_player_release(FInstance); + FInstance:=Nil; + end; + FreeAndNil(FECS); + inherited Destroy; +end; + +procedure TCustomVLCMediaPlayer.SetMedia(M: TVLCMediaItem); + +begin + libvlc_media_player_set_media(Instance,M.Instance); +end; + +procedure TCustomVLCMediaPlayer.Play; + +Var + W,H : Cardinal; + +begin + SetParentWindow; + libvlc_media_player_play(Instance); + If FitWindow then + begin + VideoScale:=1.0; + if GetVideoSize(W,H) then + SetParentWindowSize(W,H); + end; +end; + +procedure TCustomVLCMediaPlayer.Play(M: TVLCMediaItem); + +begin + if Playing then + begin + Stop; + While Playing do + Sleep(100); + end; + SetMedia(M); + Play; +end; + +procedure TCustomVLCMediaPlayer.PlayFile(const AFileName: String); + +Var + M : TVLCMediaItem; +begin + M:=TVLCMediaItem.Create(Nil); + try + M.Path:=AFileName; + Play(M); + finally + M.Free; + end; +end; + +procedure TCustomVLCMediaPlayer.Stop; +begin + if Assigned(FInstance) then + libvlc_media_player_stop(FInstance); +end; + +procedure TCustomVLCMediaPlayer.Pause; +begin + if Assigned(FInstance) then + libvlc_media_player_pause(FInstance); +end; + +procedure TCustomVLCMediaPlayer.Resume; +begin + if (GetState()=libvlc_Paused) then + if Assigned(FInstance) then + libvlc_media_player_play(FInstance); +end; + +procedure TCustomVLCMediaPlayer.NextFrame; +begin + if Assigned(FInstance) then + libvlc_media_player_next_frame(Finstance); +end; + +function TCustomVLCMediaPlayer.Snapshot(const AFileName: String): Boolean; + +var + w,h : Cardinal; +begin + Result:=Assigned(FInstance); + if Result then + begin + w:=0; + h:=0; + Result:=libvlc_video_get_size(FInstance,0,@W,@H)=0; + if Result then + Result:=SnapShot(AFileName,W,H); + end; +end; + +function TCustomVLCMediaPlayer.Snapshot(const AFileName: String; AWidth, + AHeight: Cardinal): Boolean; +begin + Result:=Assigned(FInstance); + If Result then + Result:=libvlc_video_take_snapshot(FInstance,0,PCChar(PChar(AFileName)),AWidth,AHeight)=0; +end; + +function TCustomVLCMediaPlayer.GetVideoSize(var AWidth, AHeight: Cardinal + ): Boolean; +begin + Result:=libvlc_video_get_size(FInstance,0,@AWidth,@AHeight)=0; +end; + +{ TVLCMediaItems } + +constructor TVLCMediaItems.Create(ALibrary: TVLCLibrary;AItemClass: TVLCMediaItemClass = Nil); +begin + Inherited Create(AItemClass); + FVLC:=ALibrary; +end; + +constructor TVLCMediaItems.Create(AInstance: Plibvlc_media_list_t; + AItemClass: TVLCMediaItemClass); + + +Var + I : Integer; + P : plibvlc_media_t; + +begin + Inherited Create(AItemClass); + FInstance:=AInstance; + For I:=0 to libvlc_media_list_count(FInstance)-1 do + begin + P:=libvlc_media_list_item_at_index(FInstance,I); + (Add as TVLCMediaItem).SetInstance(P); + end; +end; + +procedure TVLCMediaItems.Lock; +begin + libvlc_media_list_lock(FInstance); +end; + +procedure TVLCMediaItems.Unlock; +begin + libvlc_media_list_lock(FInstance); +end; + +function TVLCMediaItems.GetInstance: Plibvlc_media_list_t; +Var + I :integer; +begin + if FInstance=Nil then + begin + FInstance:=libvlc_media_list_new(VLC.Instance); + For I:=0 to Count-1 do + GetI(I).RegisterInstance; + end; + Result:=Finstance; +end; + +function TVLCMediaItems.GetIsReadOnly: Boolean; +begin + Result:=libvlc_media_list_is_readonly(FInstance)<>0; +end; + +function TVLCMediaItems.GetI(AIndex : Integer): TVLCMediaItem; +begin + Result:=Items[AIndex] as TVLCMediaItem; +end; + +procedure TVLCMediaItems.SetI(AIndex : Integer; AValue: TVLCMediaItem); +begin + Items[AIndex]:=AValue; +end; + + +function TVLCMediaItems.GetVLC: TVLCLibrary; +begin + Result:=VLCLibrary; +end; + +{ TVLCMediaItem } + +function TVLCMediaItem.GetInstance: plibvlc_media_t; +begin + Result:=Finstance; + If (Result=Nil) then + Raise EVLC.Create('No instance available at this time. Set MRL, Path or FileDescriptor first'); +end; + +function TVLCMediaItem.GetM(AIndex: Integer): Boolean; +begin + Result:=FOpts[AIndex]; +end; + +function TVLCMediaItem.GetMD(AMeta : libvlc_meta_t): String; + +Var + P : PCChar; + +begin + P:=libvlc_media_get_meta(Instance,AMeta); + if (P<>Nil) then + Result:=StrPas(PChar(p)) + else + Result:=''; +end; + +function TVLCMediaItem.GetMRL: String; +Var + P : PCChar; + +begin + P:=libvlc_media_get_mrl(Instance); + if (P<>Nil) then + Result:=StrPas(PChar(p)) + else + Result:=''; +end; + +function TVLCMediaItem.GetParsed: Boolean; +begin + Result:=libvlc_media_is_parsed(Instance)<>0; +end; + +function TVLCMediaItem.GetUD: Pointer; +begin + Result:=libvlc_media_get_user_data(Instance); +end; + +procedure TVLCMediaItem.SetDIM(AValue: TDeinterlaceMode); + +Const + DMS : Array[TDeinterlaceMode] of string + = ('blend', 'discard', 'bob', 'linear', 'mean', 'x', 'yadif', 'yadif2x'); +begin + if (FDIM=AValue) then Exit; + FDIM:=AValue; + libvlc_media_add_option(Instance, PCChar(PChar('deinterlace-mode='+DMS[AValue]))); +end; + +procedure TVLCMediaItem.SetFD(AValue: Integer); +begin + FFD:=AValue; + Finstance:=libvlc_media_new_fd(GetVLC.Instance,AValue); + If (FInstance=Nil) then + Raise EVLC.CreateFmt('Failed to create media item from file descriptor "%d"',[AValue]); + RegisterInstance; +end; + +procedure TVLCMediaItem.SetFSS(AValue: TSNapshotFormat); + +Const + ssfs : Array[TSnapShotFormat] of string = ('png','jpg'); + +begin + if FSS=AValue then Exit; + FSS:=AValue; + libvlc_media_add_option(Instance, PCChar(PChar('no-snapshot-preview'))); + libvlc_media_add_option(instance, PCChar(PChar('snapshot-format=' + SSFS[aValue]))); +end; + +procedure TVLCMediaItem.SetM(AIndex: Integer; AValue: Boolean); + +begin + FOpts[AIndex]:=AValue; + libvlc_media_add_option(FInstance,PcChar(PChar(GetBoolOpt(AIndex,AValue)))); +end; + +function TVLCMediaItem.GetBoolOpt(AIndex: Integer; AValue: Boolean): String; +begin + Case AINdex of + 0 : Result:='video-title-show'; + 1 : Result:='video-on-top'; + 2 : Result:='overlay'; + 3 : Result:='fullscreen'; + 4 : Result:='deinterlace='+IntToStr(Ord(AValue)); + end; + if (AIndex < 4) and Not AValue then + Result:='no-'+Result; +end; + +procedure TVLCMediaItem.SetMD(AMeta : libvlc_meta_t; AValue: String); +begin + libvlc_media_set_meta(Instance,AMeta,Pcchar(PChar(AValue))); +end; + +procedure TVLCMediaItem.SetMRL(AValue: String); +begin + Finstance:=libvlc_media_new_location(GetVLC.Instance,PCChar(AValue)); + If (FInstance=Nil) then + Raise EVLC.CreateFmt('Failed to create media item from MRL : "%s"',[AValue]); + RegisterInstance; +end; + +procedure TVLCMediaItem.SetPath(AValue: String); +begin + if FPath=AValue then Exit; + FPath:=AValue; + FInstance:=libvlc_media_new_path(GetVLC.Instance,PCChar(AValue)); + if (FInstance=Nil) then + Raise EVLC.CreateFmt('Failed to create media item from path : "%s"',[AValue]); + RegisterInstance; +end; + +procedure TVLCMediaItem.SetUD(AValue: Pointer); +begin + libvlc_media_set_user_data(Instance,AValue); +end; + +function TVLCMediaItem.GetState: libvlc_state_t; +begin + Result:=libvlc_media_get_state(instance); +end; + +function TVLCMediaItem.GetDuration: TDateTime; + +Var + d : libvlc_time_t; + +begin + d:=libvlc_media_get_duration(Instance); + Result:=D +end; + +procedure TVLCMediaItem.RegisterInstance; + +Var + L : Plibvlc_media_list_t; + +begin + If Assigned(Collection) and (Collection is TVLCMediaItems) then + begin + L:=TVLCMediaItems(Collection).FInstance; + if (L<>Nil) then + begin + libvlc_media_list_lock(L); + libvlc_media_list_add_media(L, FInstance); + libvlc_media_list_unlock(L); + end; + end; +end; + +procedure TVLCMediaItem.UnRegisterInstance; +Var + L : Plibvlc_media_list_t; + i : integer; + +begin + If Assigned(Collection) and (Collection is TVLCMediaItems) then + begin + L:=TVLCMediaItems(Collection).FInstance; + if L<>Nil then + begin + libvlc_media_list_lock(L); + I:=libvlc_media_list_index_of_item(L,Finstance); + if (i>=0) then + libvlc_media_list_remove_index(L,i); + libvlc_media_list_unlock(L); + end; + end; +end; + +function TVLCMediaItem.GetVLC: TVLCLibrary; +begin + If Assigned(Collection) and (Collection is TVLCMediaItems) then + Result:=TVLCMediaItems(Collection).GetVLC + else + Result:=VLCLibrary; + if not Result.Initialized then + Result.Initialize; +end; + +function TVLCMediaItem.GetEventManager: plibvlc_event_manager_t; +begin + Result:=libvlc_media_event_manager(Instance); +end; + +procedure TVLCMediaItem.SetInstance(Avalue: plibvlc_media_t); +begin + FInstance:=AValue; +end; + +destructor TVLCMediaItem.Destroy; +begin + inherited Destroy; + if Assigned(FInstance) then + begin + UnregisterInstance; + libvlc_media_release(FInstance); + FInstance:=Nil; + end; +end; + +procedure TVLCMediaItem.AddOption(const AValue: String); +begin + libvlc_media_add_option(Instance,PCChar(PChar(AValue))); +end; + +procedure TVLCMediaItem.Parse; +begin + libvlc_media_parse(Instance); +end; + +procedure TVLCMediaItem.ParseAsync; +begin + libvlc_media_parse_async(Instance); +end; + +procedure TVLCMediaItem.SaveMetaData; +begin + libvlc_media_save_meta(Instance); +end; + +function TVLCMediaItem.GetStats(var AStats: libvlc_media_stats_t): Boolean; +begin + Result:=libvlc_media_get_stats(Instance,@AStats)<>0; +end; + +function TVLCMediaItem.Duplicate: TVLCMediaItem; +begin + If Assigned(Collection) and (Collection is TVLCMediaItems) then + Result:=TVLCMediaItems(Collection).Add as TVLCMediaItem + else + Result:=TVLCMediaItem.Create(Nil); + Result.SetInstance(libvlc_media_duplicate(Instance)); +end; + + +function TVLCLibrary.GetLastError: String; + +Var + P : PCChar; + +begin + P:=libvlc_errmsg(); + if Assigned(P) then + Result := StrPas(PChar(P)) + else + Result:=''; +end; + +function TVLCLibrary.GetI: Boolean; +begin + Result:=FInstance<>Nil; +end; + +function TVLCLibrary.GetVersion: String; +Var + P : PCChar; + +begin + P:=libvlc_get_version(); + if Assigned(P) then + Result := StrPas(PChar(P)) + else + Result:=''; +end; + +function TVLCLibrary.GetCompiler: String; +Var + P : PCChar; + +begin + P:=libvlc_get_compiler(); + if Assigned(P) then + Result := StrPas(PChar(P)) + else + Result:=''; +end; + +function TVLCLibrary.GetChangeSet: String; + +Var + P : PCChar; + +begin + P:=libvlc_get_changeset(); + if Assigned(P) then + Result := StrPas(PChar(P)) + else + Result:=''; +end; + +procedure TVLCLibrary.SetLibraryPath(const AValue: String); +begin + If AValue=FLibraryPath then exit; + If Assigned(FInstance) then + Raise EVLC.Create('VLC already initialized, cannot set librarypath'); + FLibraryPath:=AVAlue; +end; + +function TVLCLibrary.GetInstance: plibvlc_instance_t; + +var + args: Array of AnsiString; + cargs : array of PAnsiChar; + argc, + I : integer; + +begin + If (FInstance=Nil) then + begin + LibraryArgs.add('--no-video-title-show'); + SetLength(cArgs,LibraryArgs.Count+2); + SetLength(Args,LibraryArgs.Count+1); + cargs[0] := PChar(FLibraryPath); + For I:=0 to LibraryArgs.Count-1 do + begin + Args[i]:=LibraryArgs[i]; + CArgs[i+1]:=PChar(Args[i]); + end; + argc:=Length(CArgs); + cargs[argc-1] := NIL; + FInstance := libvlc_new(argc-1, PPcchar(cargs)); + if (FInstance=Nil) then + Raise EVLC.Create('Could not create instance of libvlc'); + end; + Result:=FInstance; +end; + +constructor TVLCLibrary.Create(AOwner: TComponent); +begin + Inherited; + FInstance:=Nil; + FLibraryPath:=LibName; + FLibraryArgs:=TStringList.Create; +end; + +destructor TVLCLibrary.Destroy; +begin + FreeAndNil(FLibraryArgs); + Release; + inherited Destroy; +end; + +procedure TVLCLibrary.Initialize; +begin + LoadLibVLC(LibraryPath,False); + GetInstance; +end; + +procedure TVLCLibrary.Release; +begin + If (FInstance<>Nil) then + begin + libvlc_release(FInstance); + FreeLibVLC; + end; + FInstance:=Nil; +end; + +Initialization + +Finalization + DoneVLC; +end. + diff --git a/src/VERSION_FILE.inc b/src/VERSION_FILE.inc index 212d4aea..b0593919 100644 --- a/src/VERSION_FILE.inc +++ b/src/VERSION_FILE.inc @@ -1 +1 @@ -FPGUI_VERSION = '1.0'; +FPGUI_VERSION = '1.2'; diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas index f3e8f6db..96332d5d 100644 --- a/src/corelib/fpg_base.pas +++ b/src/corelib/fpg_base.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -90,6 +90,8 @@ type // For providing user feedback. No need to display backtrace information EfpGUIUserFeedbackException = class(EfpGUIException); + TfpgTextEncoding = (encUTF8, encCP437, encCP850, encCP866, encCP1250, encIBMGraph); + const @@ -119,6 +121,7 @@ const FPGM_FREEME = 19; FPGM_DROPENTER = 20; FPGM_DROPEXIT = 21; + FPGM_HSCROLL = 22; FPGM_USER = 50000; FPGM_KILLME = MaxInt; @@ -213,6 +216,13 @@ type PfpgMessageRec = ^TfpgMessageRec; + TfpgMoveEventRec = record + Sender: TObject; + x: TfpgCoord; + y: TfpgCoord; + end; + + TfpgLineStyle = (lsSolid, lsDash, lsDot, lsDashDot, lsDashDotDot); @@ -380,7 +390,7 @@ type procedure DrawPolygon(Points: PPoint; NumPts: Integer; Winding: boolean = False); virtual; procedure DrawPolygon(const Points: array of TPoint); procedure StretchDraw (x, y, w, h: TfpgCoord; ASource: TfpgImageBase); - procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); virtual; // x,y is the top/left corner of where the text output will start. procedure DrawString(x, y: TfpgCoord; const txt: string); procedure FillRectangle(x, y, w, h: TfpgCoord); overload; @@ -602,6 +612,7 @@ type TFileEntryType = (etFile, etDir); TFileListSortOrder = (soNone, soFileName, soCSFileName, soFileExt, soSize, soTime); TFileModeString = string[9]; + TfpgSearchMode = (smAny, smFiles, smDirs); // A simple data object @@ -641,6 +652,7 @@ type FEntries: TList; FDirectoryName: TfpgString; FFileMask: TfpgString; + FSearchMode: TfpgSearchMode; FShowHidden: boolean; FCurrentSpecialDir: integer; procedure AddEntry(sr: TSearchRec); @@ -663,6 +675,7 @@ type property Entry[i: integer]: TFileEntry read GetEntry; property FileMask: TfpgString read FFileMask write FFileMask; property HasFileMode: boolean read FHasFileMode; + property SearchMode: TfpgSearchMode read FSearchMode write FSearchMode; property ShowHidden: boolean read FShowHidden write FShowHidden; property SpecialDirs: TStringList read FSpecialDirs; end; @@ -765,7 +778,6 @@ function fpgLighter(const AColor: TfpgColor; APercent: Byte = 50): TfpgColor; { Points } -function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; procedure SortRect(var ARect: TRect); procedure SortRect(var ARect: TfpgRect); procedure SortRect(var left, top, right, bottom: integer); @@ -782,7 +794,7 @@ uses typinfo, process, {$IFDEF GDEBUG} - dbugintf, + fpg_dbugintf, {$ENDIF} dateutils; @@ -1090,14 +1102,6 @@ begin Result := RGBTripleTofpgColor(lColor); end; -function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; -begin - Result := (APoint.x >= ARect.Left) and - (APoint.y >= ARect.Top) and - (APoint.x <= ARect.Right) and - (APoint.y <= ARect.Bottom); -end; - procedure SortRect(var ARect: TRect); begin with ARect do @@ -1737,9 +1741,9 @@ begin RGBStop := fpgColorToRGBTriple(AStop); if ADirection = gdVertical then - count := ARect.Bottom - ARect.Top + count := ARect.Height else - count := ARect.Right - ARect.Left; + count := ARect.Width; RDiff := RGBStop.Red - RGBStart.Red; GDiff := RGBStop.Green - RGBStart.Green; @@ -2101,7 +2105,7 @@ end; procedure TfpgBaseInterpolation.Execute(x, y, w, h: integer); begin - tempimage := TfpgImageBase.Create; + tempimage := TfpgImage.Create; tempimage.AllocateImage(image.ColorDepth, w, image.Height); xfactor := image.Width / w; @@ -2242,7 +2246,7 @@ begin FMasked := False; FWidth := 0; FHeight := 0; -// DoFreeImage; + DoFreeImage; end; procedure TfpgImageBase.AllocateImage(acolordepth, awidth, aheight: integer); @@ -2549,7 +2553,11 @@ var p: TProcess; begin Result := False; - if not fpgFileExists(GetHelpViewer) then + if fpgExtractFilePath(GetHelpViewer) = '' then + begin + // do nothing - we are hoping docview is in the system PATH + end + else if not fpgFileExists(GetHelpViewer) then raise EfpGUIUserFeedbackException.Create(rsfailedtofindhelpviewer); p := TProcess.Create(nil); try @@ -2577,7 +2585,11 @@ var p: TProcess; begin Result := False; - if not fpgFileExists(GetHelpViewer) then + if fpgExtractFilePath(GetHelpViewer) = '' then + begin + // do nothing - we are hoping docview is in the system PATH + end + else if not fpgFileExists(GetHelpViewer) then raise EfpGUIUserFeedbackException.Create(rsfailedtofindhelpviewer); p := TProcess.Create(nil); try @@ -2720,7 +2732,7 @@ var e: TFileEntry; begin e := TFileEntry.Create; - e.Name := fpgFromOSEncoding(sr.Name); + e.Name := sr.Name; e.Extension := fpgExtractFileExt(e.Name); e.Size := sr.Size; // e.Attributes := sr.Attr; // this is incorrect and needs to improve! @@ -2790,6 +2802,7 @@ begin FFileMask := '*'; FDirectoryName := ''; FSpecialDirs := TStringList.Create; + FSearchMode := smAny; end; destructor TfpgFileListBase.Destroy; @@ -2836,11 +2849,13 @@ begin // Reported to FPC as bug 9440 in Mantis. if fpgFindFirst(FDirectoryName + AllFilesMask, faAnyFile or $00000080, SearchRec) = 0 then begin - AddEntry(SearchRec); - while fpgFindNext(SearchRec) = 0 do - begin - AddEntry(SearchRec); - end; + repeat + if (FSearchMode=smAny) or + ((FSearchMode=smFiles) and (not HasAttrib(SearchRec.Attr, faDirectory))) or + ((FSearchMode=smDirs) and HasAttrib(SearchRec.Attr, faDirectory)) + then + AddEntry(SearchRec); + until fpgFindNext(SearchRec) <> 0; end; Result:=True; finally @@ -3087,7 +3102,6 @@ end; function TfpgMimeDataBase.Formats: TStrings; var i: integer; - r: TfpgMimeDataItem; s: string; begin if Count = 0 then diff --git a/src/corelib/fpg_constants.pas b/src/corelib/fpg_constants.pas index 37b3f135..60bd18e7 100644 --- a/src/corelib/fpg_constants.pas +++ b/src/corelib/fpg_constants.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, diff --git a/src/corelib/fpg_dbugintf.pas b/src/corelib/fpg_dbugintf.pas new file mode 100644 index 00000000..8e9d9874 --- /dev/null +++ b/src/corelib/fpg_dbugintf.pas @@ -0,0 +1,337 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. + + This is the Client Interface for the debug server, which is + based on SimpleIPC. +} +unit fpg_dbugintf; + +{$mode objfpc}{$h+} + +interface + +uses + Classes, + fpg_base; + +Type + TDebugLevel = (dlStop, dlInformation, dlWarning, dlError, dlIdentify, dlLive); + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel = dlLive); +procedure SendPointer(const Identifier: string; const Value: Pointer); +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel = dlInformation); +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +procedure SendDebug(const Msg: string); +procedure SendMethodEnter(const MethodName: string); +procedure SendMethodExit(const MethodName: string); +procedure SendSeparator; +procedure SendDebugFmt(const Msg: string; const Args: array of const); +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string = ''); + +procedure SetDebuggingEnabled(const AValue : boolean); +function GetDebuggingEnabled : Boolean; + +{ low-level routines } + +Function StartDebugServer : integer; +Function InitDebugClient : Boolean; +Function DebugMessageName(msgType: TDebugLevel) : String; + +Const + SendError : String = ''; + +ResourceString + SProcessID = 'Process %s'; + SEntering = '> Entering '; + SExiting = '< Exiting '; + SSeparator = '>-=-=-=-=-=-=-=-=-=-=-=-=-=-=-<'; + SServerStartFailed = 'Failed to start debugserver. (%s)'; + +implementation + +Uses + SysUtils, + process, + simpleipc, + fpg_dbugmsg; + +const + IndentChars = 2; + +var + DebugClient : TSimpleIPCClient = nil; + MsgBuffer : TMemoryStream = Nil; + ServerID : Integer; + DebugDisabled : Boolean = False; + Indent : Integer = 0; + +function RectToStr(const ARect: TRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Right: %d; Bottom: %d)', [Left, Top, Right, Bottom]); +end; + +function fpgRectToStr(const ARect: TfpgRect): String; +begin + with ARect do + Result := Format('(Left: %d; Top: %d; Width: %d; Height: %d)', [Left, Top, Width, Height]); +end; + +function PointToStr(const APoint: TPoint): String; +begin + with APoint do + Result := Format('(X: %d; Y: %d)', [X, Y]); +end; + +procedure WriteMessage(Const Msg : TDebugMessage); +begin + MsgBuffer.Seek(0, soFromBeginning); + WriteDebugMessageToStream(MsgBuffer, Msg); + DebugClient.SendMessage(mtUnknown, MsgBuffer); +end; + +procedure SendDebugMessage(Var Msg : TDebugMessage); +begin + if DebugDisabled then exit; + try + If (DebugClient=Nil) then + if InitDebugClient = false then exit; + if (Indent > 0) then + Msg.Msg := StringOfChar(' ', Indent) + Msg.Msg; + WriteMessage(Msg); + except + On E: Exception do + SendError := E.Message; + end; +end; + +procedure SendBoolean(const Identifier: string; const Value: Boolean); +const + Booleans : Array[Boolean] of string = ('False','True'); +begin + SendDebugFmt('%s = %s',[Identifier,Booleans[value]]); +end; + +procedure SendDateTime(const Identifier: string; const Value: TDateTime); +begin + SendDebugFmt('%s = %s',[Identifier,DateTimeToStr(Value)]); +end; + +procedure SendInteger(const Identifier: string; const Value: Integer; HexNotation: Boolean = False); +const + Msgs : Array[Boolean] of string = ('%s = %d','%s = %x'); +begin + SendDebugFmt(Msgs[HexNotation],[Identifier,Value]); +end; + +procedure SendPoint(const Identifier: string; const Value: TPoint; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s = %s',[Identifier, PointToStr(Value)], ADbgLevel); +end; + +procedure SendPointer(const Identifier: string; const Value: Pointer); +begin + SendDebugFmt('%s = %p',[Identifier,Value]); +end; + +procedure SendRect(const Identifier: string; const Value: TRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[RectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendRect(const Identifier: string; const Value: TfpgRect; const ADbgLevel: TDebugLevel); +begin + SendDebugFmtEx('%s',[fpgRectToStr(Value)], ADbgLevel, Identifier); +end; + +procedure SendDebugEx(const Msg: string; MType: TDebugLevel); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(MTYpe); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendDebug(const Msg: string); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:=Ord(dlInformation); + Mesg.Msg:=Msg; + SendDebugMessage(Mesg); +end; + +procedure SendMethodEnter(const MethodName: string); +begin + SendDebug(SEntering+MethodName); + inc(Indent,IndentChars); +end; + +procedure SendMethodExit(const MethodName: string); +begin + Dec(Indent,IndentChars); + If (Indent<0) then + Indent:=0; + SendDebug(SExiting+MethodName); +end; + +procedure SendSeparator; +begin + SendDebug(SSeparator); +end; + +procedure SendDebugFmt(const Msg: string; const Args: array of const); +var + Mesg : TDebugMessage; +begin + Mesg.MsgTimeStamp:=Now; + Mesg.MsgType:= Ord(dlInformation); + Mesg.Msg:=Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SendDebugFmtEx(const Msg: string; const Args: array of const; MType: TDebugLevel; const ATitle: string); +var + Mesg: TDebugMessage; +begin + Mesg.MsgTimeStamp := Now; + Mesg.MsgType := Ord(mType); + if MType = dlLive then + Mesg.MsgTitle := ATitle + else + Mesg.MsgTitle := ' '; + Mesg.Msg := Format(Msg,Args); + SendDebugMessage(Mesg); +end; + +procedure SetDebuggingEnabled(const AValue: boolean); +begin + DebugDisabled := not AValue; +end; + +function GetDebuggingEnabled: Boolean; +begin + Result := not DebugDisabled; +end; + +function StartDebugServer : Integer; +begin + With TProcess.Create(Nil) do + begin + Try + CommandLine:='dbugsrv'; + Execute; + Result:=ProcessID; + Except On E: Exception do + begin + SendError := Format(SServerStartFailed,[E.Message]); + Result := 0; + end; + end; + Free; + end; +end; + +procedure FreeDebugClient; +var + msg : TDebugMessage; +begin + try + If (DebugClient<>Nil) and + (DebugClient.ServerRunning) then + begin + Msg.MsgType := Ord(dlStop); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + end; + if assigned(MsgBuffer) then + FreeAndNil(MsgBuffer); + if assigned(DebugClient) then + FreeAndNil(DebugClient); + except + end; +end; + +function InitDebugClient : Boolean; +var + msg : TDebugMessage; + I : Integer; +begin + Result := False; + DebugClient:=TSimpleIPCClient.Create(Nil); + DebugClient.ServerID:=DebugServerID; + If not DebugClient.ServerRunning then + begin + ServerID:=StartDebugServer; + if ServerID = 0 then + begin + DebugDisabled := True; + FreeAndNil(DebugClient); + Exit; + end + else + DebugDisabled := False; + I:=0; + While (I<10) and not DebugClient.ServerRunning do + begin + Inc(I); + Sleep(100); + end; + end; + try + DebugClient.Connect; + except + FreeAndNil(DebugClient); + DebugDisabled:=True; + Raise; + end; + MsgBuffer := TMemoryStream.Create; + Msg.MsgType := Ord(dlIdentify); + Msg.MsgTimeStamp := Now; + Msg.Msg := Format(SProcessID,[ApplicationName]); + WriteMessage(Msg); + Result := True; +end; + +Function DebugMessageName(msgType : TDebugLevel) : String; +begin + Case MsgType of + dlStop : Result := 'Stop'; + dlInformation : Result := 'Information'; + dlWarning : Result := 'Warning'; + dlError : Result := 'Error'; + dlIdentify : Result := 'Identify'; + dlLive : Result := 'LiveView'; + else + Result := 'Unknown'; + end; +end; + + +finalization + FreeDebugClient; + +end. diff --git a/src/corelib/fpg_dbugmsg.pas b/src/corelib/fpg_dbugmsg.pas new file mode 100644 index 00000000..502b697e --- /dev/null +++ b/src/corelib/fpg_dbugmsg.pas @@ -0,0 +1,95 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2005 by Michael Van Canneyt, member of + the Free Pascal development team + Copyright (C) 2013 by Graeme Geldenhuys + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Originally from the Free Pascal FCL. Since then the code has + diverged and was customised for fpGUI usage. +} +unit fpg_dbugmsg; + +{$mode objfpc}{$h+} + +interface + +uses Classes; + +Const + DebugServerID : String = 'fpgDebugServer'; + +Type + TDebugMessage = record + MsgType : Integer; + MsgTimeStamp : TDateTime; + MsgTitle : string; + Msg : string; + end; + +Procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +Procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); + + +implementation + + +procedure ReadDebugMessageFromStream(AStream : TStream; Var Msg : TDebugMessage); +var + MsgSize: Integer; +begin + MsgSize := 0; + with AStream do + begin + ReadBuffer(Msg.MsgType, SizeOf(Integer)); + ReadBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.MsgTitle, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.MsgTitle[1], MsgSize); + + ReadBuffer(MsgSize, SizeOf(Integer)); + SetLength(Msg.Msg, MsgSize); + if (MsgSize<>0) then + ReadBuffer(Msg.Msg[1], MsgSize); + end; +end; + +procedure WriteDebugMessageToStream(AStream : TStream; Const Msg : TDebugMessage); +var + MsgSize : Integer; + lTitle: string; +begin + with AStream do + begin + WriteBuffer(Msg.MsgType, SizeOf(Integer)); + WriteBuffer(Msg.MsgTimeStamp, SizeOf(TDateTime)); + + MsgSize := Length(Msg.MsgTitle); + if MsgSize = 0 then // fake a title + begin + MsgSize := 1; + lTitle := ' '; + end + else + lTitle := Msg.MsgTitle; + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(lTitle[1], MsgSize); + + MsgSize := Length(Msg.Msg); + WriteBuffer(MsgSize, SizeOf(Integer)); + WriteBuffer(Msg.Msg[1], MsgSize); + end; +end; + + +end. diff --git a/src/corelib/fpg_imgfmt_bmp.pas b/src/corelib/fpg_imgfmt_bmp.pas index 00637f3b..fe827405 100644 --- a/src/corelib/fpg_imgfmt_bmp.pas +++ b/src/corelib/fpg_imgfmt_bmp.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -64,7 +64,7 @@ begin if not fpgFileExists(AFileName) then Exit; //==> - AssignFile(AFile, AFileName); + AssignFile(AFile, fpgToOSEncoding(AFileName)); FileMode := fmOpenRead; // read-only Reset(AFile); AImageDataSize := FileSize(AFile); diff --git a/src/corelib/fpg_imgfmt_jpg.pas b/src/corelib/fpg_imgfmt_jpg.pas index 33704643..4fe67692 100644 --- a/src/corelib/fpg_imgfmt_jpg.pas +++ b/src/corelib/fpg_imgfmt_jpg.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -34,10 +34,11 @@ type EJPEG = class(Exception); procedure ReadImage_JPG(img: TfpgImage; bmp: TStream; const AScale: integer = 1); -function LoadImage_JPG(const AFileName: String; const AScale: integer = 1): TfpgImage; +function LoadImage_JPG(const AFileName: TfpgString; const AScale: integer = 1): TfpgImage; implementation uses + fpg_utils, {PASJPG10 library} jmorecfg, jpeglib, @@ -360,21 +361,21 @@ begin img.UpdateImage; end; -function LoadImage_JPG(const AFileName: String; const AScale: integer): TfpgImage; +function LoadImage_JPG(const AFileName: TfpgString; const AScale: integer): TfpgImage; var inFile: TStream; begin Result := nil; - if not FileExists(AFileName) then + if not fpgFileExists(AFileName) then Exit; //==> - inFile:=TFileStream.Create(AFileName,fmOpenRead); - try - Result:=TfpgImage.Create; - ReadImage_JPG(Result, inFile, AScale); - finally - inFile.Free; - end; + inFile := TFileStream.Create(fpgToOSEncoding(AFileName), fmOpenRead); + try + Result := TfpgImage.Create; + ReadImage_JPG(Result, inFile, AScale); + finally + inFile.Free; + end; end; diff --git a/src/corelib/fpg_imgfmt_png.pas b/src/corelib/fpg_imgfmt_png.pas index c95150e4..3148a5b4 100644 --- a/src/corelib/fpg_imgfmt_png.pas +++ b/src/corelib/fpg_imgfmt_png.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -68,6 +68,7 @@ end; function LoadImage_PNG(const AFileName: TfpgString): TfpgImage; var imga: TFPCustomImage; + PNGReader: TFPReaderPNG; begin Result := nil; if not fpgFileExists(AFileName) then @@ -75,7 +76,12 @@ begin imga := TFPMemoryImage.Create(0, 0); try - imga.LoadFromFile(AFileName, TFPReaderPNG.Create); // auto size image + PNGReader := TFPReaderPNG.Create; + try + imga.LoadFromFile(fpgToOSEncoding(AFileName), PNGReader); // auto size image + finally + PNGReader.Free; + end; except imga := nil; end; @@ -159,7 +165,7 @@ begin // Calculated to fit the image within required size: xlocal, ylocal imga := TFPMemoryImage.Create(0, 0); try - imga.LoadFromFile(AFileName, TFPReaderPNG.Create); // auto size image + imga.LoadFromFile(fpgToOSEncoding(AFileName), TFPReaderPNG.Create); // auto size image except imga := nil; imgb := nil; diff --git a/src/corelib/fpg_main.pas b/src/corelib/fpg_main.pas index 44ab6a82..c7275b14 100644 --- a/src/corelib/fpg_main.pas +++ b/src/corelib/fpg_main.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -47,7 +47,7 @@ type TAnchors = set of TAnchor; TfpgButtonFlags = set of (btfIsEmbedded, btfIsDefault, btfIsPressed, - btfIsSelected, btfHasFocus, btfHasParentColor, btfFlat, btfHover); + btfIsSelected, btfHasFocus, btfHasParentColor, btfFlat, btfHover, btfDisabled); TfpgMenuItemFlags = set of (mifSelected, mifHasFocus, mifSeparator, mifEnabled, mifChecked, mifSubMenu); @@ -78,8 +78,7 @@ type Public event properties: Event Types *******************************************} { Keyboard } - TKeyEvent = procedure(Sender: TObject; AKey: Word; AShift: TShiftState) of object; - TKeyCharEvent = procedure(Sender: TObject; AKeyChar: Char) of object; + TfpgKeyCharEvent = procedure(Sender: TObject; AChar: TfpgChar; var Consumed: boolean) of object; TKeyPressEvent = procedure(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean) of object; { Mouse } TMouseButtonEvent = procedure(Sender: TObject; AButton: TMouseButton; AShift: TShiftState; const AMousePos: TPoint) of object; @@ -176,8 +175,6 @@ type // As soon as TfpgStyle has moved out of CoreLib, these must go! procedure DrawButtonFace(x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); overload; procedure DrawButtonFace(r: TfpgRect; AFlags: TfpgButtonFlags); overload; - procedure DrawControlFrame(x, y, w, h: TfpgCoord); overload; - procedure DrawControlFrame(r: TfpgRect); overload; procedure DrawBevel(x, y, w, h: TfpgCoord; ARaised: Boolean = True); overload; procedure DrawBevel(r: TfpgRect; ARaised: Boolean = True); overload; procedure DrawDirectionArrow(x, y, w, h: TfpgCoord; direction: TArrowDirection); overload; @@ -224,6 +221,12 @@ type function GetSeparatorSize: integer; virtual; { Editbox } procedure DrawEditBox(ACanvas: TfpgCanvas; const r: TfpgRect; const IsEnabled: Boolean; const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor); virtual; + { Combobox } + procedure DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; const IsEnabled: Boolean; const IsFocused: Boolean; const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor; const AInternalBtnRect: TfpgRect; const ABtnPressed: Boolean); virtual; + procedure DrawInternalComboBoxButton(ACanvas: TfpgCanvas; r: TfpgRect; const IsEnabled: Boolean; const IsPressed: Boolean); virtual; + { Checkbox } + function GetCheckBoxSize: integer; virtual; + procedure DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); virtual; end; @@ -395,10 +398,15 @@ function fpgGetTickCount: DWord; procedure fpgPause(MilliSeconds: Cardinal); // Rectangle, Point & Size routines +function CopyRect(out Dest: TfpgRect; const Src: TfpgRect): Boolean; function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; function InflateRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; +function IntersectRect(out ARect: TfpgRect; const r1, r2: TfpgRect): Boolean; +function IsRectEmpty(const ARect: TfpgRect): Boolean; function OffsetRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; function OffsetRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; +function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; +function UniongRect(out ARect: TfpgRect; const R1, R2: TfpgRect): Boolean; function CenterPoint(const Rect: TRect): TPoint; function CenterPoint(const Rect: TfpgRect): TPoint; function fpgRect(ALeft, ATop, AWidth, AHeight: integer): TfpgRect; @@ -422,11 +430,12 @@ procedure DebugLn(const s1, s2: TfpgString); procedure DebugLn(const s1, s2, s3: TfpgString); procedure DebugLn(const s1, s2, s3, s4: TfpgString); procedure DebugLn(const s1, s2, s3, s4, s5: TfpgString); -function DebugMethodEnter(const s1: TfpgString): IInterface; +function DebugMethodEnter(const s1: TfpgString): IInterface; procedure DebugSeparator; // operator overloading of some useful structures -operator = (a: TRect; b: TRect): boolean; +operator = (const a, b: TRect): boolean; +operator = (const a, b: TfpgRect): boolean; operator = (const ASize1, ASize2: TfpgSize) b: Boolean; operator = (const APoint1, APoint2: TPoint) b: Boolean; operator + (const APoint1, APoint2: TPoint) p: TPoint; @@ -446,7 +455,8 @@ operator - (const APoint: TfpgPoint; i: Integer) p: TfpgPoint; operator - (const ASize: TfpgSize; const APoint: TPoint) s: TfpgSize; operator - (const ASize: TfpgSize; const APoint: TfpgPoint) s: TfpgSize; operator - (const ASize: TfpgSize; i: Integer) s: TfpgSize; -operator = (const AColor1, AColor2: TFPColor) b: Boolean; +operator = (const AColor1, AColor2: TFPColor) b: Boolean; deprecated; +operator = (const AColor1, AColor2: TRGBTriple) b: Boolean; implementation @@ -458,7 +468,7 @@ uses Agg2D, {$endif} {$IFDEF DEBUG} - dbugintf, + fpg_dbugintf, {$ENDIF} fpg_imgfmt_bmp, fpg_stdimages, @@ -472,7 +482,9 @@ uses fpg_imgutils, fpg_stylemanager, fpg_style_win2k, // TODO: This needs to be removed! - fpg_style_motif; // TODO: This needs to be removed! + fpg_style_motif, // TODO: This needs to be removed! + fpg_style_carbon, + fpg_style_plastic; var fpgTimers: TList; @@ -621,6 +633,17 @@ begin until ((Now*MSecsPerDay)-lStart) > MilliSeconds; end; +function CopyRect(out Dest: TfpgRect; const Src: TfpgRect): Boolean; +begin + Dest := Src; + if IsRectEmpty(Dest) then + begin + FillChar(Dest, SizeOf(Dest), 0); + Result := false; + end + else + Result := true; +end; function InflateRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; begin @@ -653,6 +676,35 @@ begin Result := False; end; +function IntersectRect(out ARect: TfpgRect; const r1, r2: TfpgRect): Boolean; +begin + ARect := r1; + with r2 do + begin + if Left > r1.Left then + ARect.Left := Left; + if Top > r1.Top then + ARect.Top := Top; + if Right < r1.Right then + ARect.Width := ARect.Left + Right; + if Bottom < r1.Bottom then + ARect.Height := ARect.Top + Bottom; + end; + + if IsRectEmpty(ARect) then + begin + FillChar(ARect, SizeOf(ARect), 0); + Result := false; + end + else + Result := true; +end; + +function IsRectEmpty(const ARect: TfpgRect): Boolean; +begin + Result := (ARect.Width <= 0) or (ARect.Height <= 0); +end; + function OffsetRect(var Rect: TRect; dx: Integer; dy: Integer): Boolean; begin if Assigned(@Rect) then @@ -664,10 +716,10 @@ begin inc(Right, dx); inc(Bottom, dy); end; - OffsetRect := True; + Result := True; end else - OffsetRect := False; + Result := False; end; function OffsetRect(var Rect: TfpgRect; dx: Integer; dy: Integer): Boolean; @@ -679,10 +731,42 @@ begin inc(Left, dx); inc(Top, dy); end; - OffsetRect := True; + Result := True; + end + else + Result := False; +end; + +function PtInRect(const ARect: TfpgRect; const APoint: TPoint): Boolean; +begin + Result := (APoint.x >= ARect.Left) and + (APoint.y >= ARect.Top) and + (APoint.x <= ARect.Right) and + (APoint.y <= ARect.Bottom); +end; + +function UniongRect(out ARect: TfpgRect; const R1, R2: TfpgRect): Boolean; +begin + ARect := R1; + with R2 do + begin + if Left < R1.Left then + ARect.Left := Left; + if Top < R1.Top then + ARect.Top := Top; + if Right > R1.Right then + ARect.Width := ARect.Left + Right; + if Bottom > R1.Bottom then + ARect.Height := ARect.Top + Bottom; + end; + + if IsRectEmpty(ARect) then + begin + FillChar(ARect, SizeOf(ARect), 0); + Result := false; end else - OffsetRect := False; + Result := true; end; function CenterPoint(const Rect: TRect): TPoint; @@ -957,15 +1041,20 @@ begin DebugLn('>--------------------------<'); end; -operator = (a: TRect; b: TRect): boolean; +operator = (const a, b: TRect): boolean; begin - if (a.Top = b.Top) - and (a.Left = b.Left) - and (a.Bottom = b.Bottom) - and (a.Right = b.Right) then - Result := True - else - Result := False; + Result := (a.Top = b.Top) and + (a.Left = b.Left) and + (a.Bottom = b.Bottom) and + (a.Right = b.Right); +end; + +operator = (const a, b: TfpgRect): boolean; +begin + Result := (a.Left = b.Left) and + (a.Top = b.Top) and + (a.Width = b.Width) and + (a.Height = b.Height); end; operator = (const ASize1, ASize2: TfpgSize) b: Boolean; @@ -1088,6 +1177,14 @@ begin and (AColor1.Alpha = AColor2.Alpha); end; +operator = (const AColor1, AColor2: TRGBTriple) b: Boolean; +begin + b := (AColor1.Red = AColor2.Red) + and (AColor1.Green = AColor2.Green) + and (AColor1.Blue = AColor2.Blue) + and (AColor1.Alpha = AColor2.Alpha); +end; + { TfpgTimer } constructor TfpgTimer.Create(AInterval: integer); @@ -1791,16 +1888,6 @@ begin DrawButtonFace(r.Left, r.Top, r.Width, r.Height, AFlags); end; -procedure TfpgCanvas.DrawControlFrame(x, y, w, h: TfpgCoord); -begin - fpgStyle.DrawControlFrame(self, x, y, w, h); -end; - -procedure TfpgCanvas.DrawControlFrame(r: TfpgRect); -begin - DrawControlFrame(r.Left, r.Top, r.Width, r.Height); -end; - procedure TfpgCanvas.DrawBevel(x, y, w, h: TfpgCoord; ARaised: Boolean); begin fpgStyle.DrawBevel(self, x, y, w, h, ARaised); @@ -2008,6 +2095,7 @@ begin fpgSetNamedColor(clGridInactiveSel, $FF99A6BF); // same as clInactiveSel fpgSetNamedColor(clGridInactiveSelText, $FF000000); // same as clInactiveSelText fpgSetNamedColor(clSplitterGrabBar, $FF839EFE); // pale blue + fpgSetNamedColor(clHyperLink, clBlue); // Global Font Objects @@ -2057,17 +2145,17 @@ begin if (btfIsPressed in AFlags) then begin if (btfIsEmbedded in AFlags) then - ACanvas.SetColor(clHilite2) + ACanvas.SetColor(clShadow1) else begin if (btfFlat in AFlags) or (btfHover in AFlags) then ACanvas.SetColor(clShadow1) { light shadow } else - ACanvas.SetColor(clShadow2); { dark shadow } + ACanvas.SetColor(clShadow1); { light shadow } end; end else - ACanvas.SetColor(clHilite2); + ACanvas.SetColor(clHilite2); { white } ACanvas.DrawLine(r.Left, r.Bottom, r.Left, r.Top); // left ACanvas.DrawLine(r.Left, r.Top, r.Right, r.Top); // top @@ -2076,13 +2164,13 @@ begin if (btfIsPressed in AFlags) then begin if (btfIsEmbedded in AFlags) then - ACanvas.SetColor(clHilite1) + ACanvas.SetColor(clShadow1) else begin if (btfFlat in AFlags) or (btfHover in AFlags) then - ACanvas.SetColor(clHilite2) { light shadow } + ACanvas.SetColor(clHilite2) { white } else - ACanvas.SetColor(clShadow2); { dark shadow } + ACanvas.SetColor(clHilite2); { white } end; end else @@ -2099,13 +2187,24 @@ begin if (btfFlat in AFlags) or (btfHover in AFlags) then exit; { "toolbar" style buttons need a nice thin/flat border } + // Left and Top (inner) + if btfIsPressed in AFlags then + begin + if not (btfIsEmbedded in AFlags) then + begin + ACanvas.SetColor(clShadow2); { dark shadow } + ACanvas.DrawLine(r.Left+1, r.Bottom-1, r.Left+1, r.Top+1); // left + ACanvas.DrawLine(r.Left+1, r.Top+1, r.Right-1, r.Top+1); // top + end; + end; + // Right and Bottom (inner) if btfIsPressed in AFlags then begin if (btfIsEmbedded in AFlags) then ACanvas.SetColor(clButtonFace) else - ACanvas.SetColor(clHilite1); + ACanvas.SetColor(clButtonFace); end else ACanvas.SetColor(clShadow1); @@ -2368,6 +2467,83 @@ begin ACanvas.FillRectangle(r); end; +procedure TfpgStyle.DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; + const IsEnabled: Boolean; const IsFocused: Boolean; const IsReadOnly: Boolean; + const ABackgroundColor: TfpgColor; const AInternalBtnRect: TfpgRect; + const ABtnPressed: Boolean); +var + lr: TfpgRect; +begin + lr := r; + if IsEnabled then + begin + if IsReadOnly then + ACanvas.SetColor(clWindowBackground) + else + ACanvas.SetColor(ABackgroundColor); + end + else + ACanvas.SetColor(clWindowBackground); + + ACanvas.FillRectangle(r); + + if IsFocused then + begin + ACanvas.SetColor(clSelection); + InflateRect(lr, -1, -1); + ACanvas.FillRectangle(lr); + end; + + // paint the fake dropdown button + DrawInternalComboBoxButton(ACanvas, AInternalBtnRect, IsEnabled, ABtnPressed); +end; + +procedure TfpgStyle.DrawInternalComboBoxButton(ACanvas: TfpgCanvas; + r: TfpgRect; const IsEnabled: Boolean; const IsPressed: Boolean); +var + ar: TfpgRect; + btnflags: TfpgButtonFlags; +begin + btnflags := []; + ar := r; + + { The bounding rectangle for the arrow } + ar.Width := 8; + ar.Height := 6; + ar.Left := r.Left + ((r.Width-ar.Width) div 2); + ar.Top := r.Top + ((r.Height-ar.Height) div 2); + + if IsPressed then + begin + Include(btnflags, btfIsPressed); + OffsetRect(ar, 1, 1); + end; + // paint button face + DrawButtonFace(ACanvas, r.Left, r.Top, r.Width, r.Height, btnflags); + if IsEnabled then + ACanvas.SetColor(clText1) + else + ACanvas.SetColor(clShadow1); + + // paint arrow + DrawDirectionArrow(ACanvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); +end; + +function TfpgStyle.GetCheckBoxSize: integer; +begin + Result := 13; // 13x13 - it is always a rectangle +end; + +procedure TfpgStyle.DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); +var + img: TfpgImage; + size: integer; +begin + img := fpgImages.GetImage('sys.checkboxes'); // Do NOT localize - return value is a reference only + size := GetCheckBoxSize; + ACanvas.DrawImagePart(x, y, img, ix, iy, size, size); +end; + { TfpgCaret } diff --git a/src/corelib/fpg_stringutils.pas b/src/corelib/fpg_stringutils.pas index 1acd518e..7930870b 100644 --- a/src/corelib/fpg_stringutils.pas +++ b/src/corelib/fpg_stringutils.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -58,10 +58,13 @@ function fpgTrimR(const AString, ATrim: TfpgString; ACaseSensitive: boolean = f // Encoding conversions function CP437ToUTF8(const s: string): TfpgString; // DOS central europe function CP850ToUTF8(const s: string): TfpgString; // DOS western europe +function CP866ToUTF8(const s: string): TfpgString; // DOS and Windows console's cyrillic +function CP1250ToUTF8(const s: string): TfpgString; // central europe function IBMGraphToUTF8(const s: string): TfpgString; // IBM PC / DOS http://www.unicode.org/Public/MAPPINGS/VENDORS/MISC/IBMGRAPH.TXT function IPFToUTF8(const s: string): TfpgString; // minor replacements to improve DocView output function SingleByteToUTF8(const s: string; const Table: TCharToUTF8Table): TfpgString; +function ConvertTextToUTF8(const AEncoding: TfpgTextEncoding; const AText: AnsiString): TfpgString; implementation @@ -935,6 +938,525 @@ const ); + ArrayCP866ToUTF8 : TCharToUTF8Table = ( + #0, //#0 + #1, //#1 + #2, //#2 + #3, //#3 + #4, //#4 + #5, //#5 + #6, //#6 + #7, //#7 + #8, //#8 + #9, //#9 + #10, //#10 + #11, //#11 + #12, //#12 + #13, //#13 + #14, //#14 + #15, //#15 + #16, //#16 + #17, //#17 + #18, //#18 + #19, //#19 + #20, //#20 + #21, //#21 + #22, //#22 + #23, //#23 + #24, //#24 + #25, //#25 + #26, //#26 + #27, //#27 + #28, //#28 + #29, //#29 + #30, //#30 + #31, //#31 + #32, //#32 + #33, //#33 + #34, //#34 + #35, //#35 + #36, //#36 + #37, //#37 + #38, //#38 + #39, //#39 + #40, //#40 + #41, //#41 + #42, //#42 + #43, //#43 + #44, //#44 + #45, //#45 + #46, //#46 + #47, //#47 + #48, //#48 + #49, //#49 + #50, //#50 + #51, //#51 + #52, //#52 + #53, //#53 + #54, //#54 + #55, //#55 + #56, //#56 + #57, //#57 + #58, //#58 + #59, //#59 + #60, //#60 + #61, //#61 + #62, //#62 + #63, //#63 + #64, //#64 + #65, //#65 + #66, //#66 + #67, //#67 + #68, //#68 + #69, //#69 + #70, //#70 + #71, //#71 + #72, //#72 + #73, //#73 + #74, //#74 + #75, //#75 + #76, //#76 + #77, //#77 + #78, //#78 + #79, //#79 + #80, //#80 + #81, //#81 + #82, //#82 + #83, //#83 + #84, //#84 + #85, //#85 + #86, //#86 + #87, //#87 + #88, //#88 + #89, //#89 + #90, //#90 + #91, //#91 + #92, //#92 + #93, //#93 + #94, //#94 + #95, //#95 + #96, //#96 + #97, //#97 + #98, //#98 + #99, //#99 + #100, //#100 + #101, //#101 + #102, //#102 + #103, //#103 + #104, //#104 + #105, //#105 + #106, //#106 + #107, //#107 + #108, //#108 + #109, //#109 + #110, //#110 + #111, //#111 + #112, //#112 + #113, //#113 + #114, //#114 + #115, //#115 + #116, //#116 + #117, //#117 + #118, //#118 + #119, //#119 + #120, //#120 + #121, //#121 + #122, //#122 + #123, //#123 + #124, //#124 + #125, //#125 + #126, //#126 + #127, //#127 + #208#144, //#128 + #208#145, //#129 + #208#146, //#130 + #208#147, //#131 + #208#148, //#132 + #208#149, //#133 + #208#150, //#134 + #208#151, //#135 + #208#152, //#136 + #208#153, //#137 + #208#154, //#138 + #208#155, //#139 + #208#156, //#140 + #208#157, //#141 + #208#158, //#142 + #208#159, //#143 + #208#160, //#144 + #208#161, //#145 + #208#162, //#146 + #208#163, //#147 + #208#164, //#148 + #208#165, //#149 + #208#166, //#150 + #208#167, //#151 + #208#168, //#152 + #208#169, //#153 + #208#170, //#154 + #208#171, //#155 + #208#172, //#156 + #208#173, //#157 + #208#174, //#158 + #208#175, //#159 + #208#176, //#160 + #208#177, //#161 + #208#178, //#162 + #208#179, //#163 + #208#180, //#164 + #208#181, //#165 + #208#182, //#166 + #208#183, //#167 + #208#184, //#168 + #208#185, //#169 + #208#186, //#170 + #208#187, //#171 + #208#188, //#172 + #208#189, //#173 + #208#190, //#174 + #208#191, //#175 + #226#150#145, //#176 + #226#150#146, //#177 + #226#150#147, //#178 + #226#148#130, //#179 + #226#148#164, //#180 + #226#149#161, //#181 + #226#149#162, //#182 + #226#149#150, //#183 + #226#149#149, //#184 + #226#149#163, //#185 + #226#149#145, //#186 + #226#149#151, //#187 + #226#149#157, //#188 + #226#149#156, //#189 + #226#149#155, //#190 + #226#148#144, //#191 + #226#148#148, //#192 + #226#148#180, //#193 + #226#148#172, //#194 + #226#148#156, //#195 + #226#148#128, //#196 + #226#148#188, //#197 + #226#149#158, //#198 + #226#149#159, //#199 + #226#149#154, //#200 + #226#149#148, //#201 + #226#149#169, //#202 + #226#149#166, //#203 + #226#149#160, //#204 + #226#149#144, //#205 + #226#149#172, //#206 + #226#149#167, //#207 + #226#149#168, //#208 + #226#149#164, //#209 + #226#149#165, //#210 + #226#149#153, //#211 + #226#149#152, //#212 + #226#149#146, //#213 + #226#149#147, //#214 + #226#149#171, //#215 + #226#149#170, //#216 + #226#148#152, //#217 + #226#148#140, //#218 + #226#150#136, //#219 + #226#150#132, //#220 + #226#150#140, //#221 + #226#150#144, //#222 + #226#150#128, //#223 + #209#128, //#224 + #209#129, //#225 + #209#130, //#226 + #209#131, //#227 + #209#132, //#228 + #209#133, //#229 + #209#134, //#230 + #209#135, //#231 + #209#136, //#232 + #209#137, //#233 + #209#138, //#234 + #209#139, //#235 + #209#140, //#236 + #209#141, //#237 + #209#142, //#238 + #209#143, //#239 + #208#129, //#240 + #209#145, //#241 + #208#132, //#242 + #209#148, //#243 + #208#135, //#244 + #209#151, //#245 + #208#142, //#246 + #209#158, //#247 + #194#176, //#248 + #226#136#153, //#249 + #194#183, //#250 + #226#136#154, //#251 + #226#132#150, //#252 + #194#164, //#253 + #226#150#160, //#254 + #194#160 //#255 + ); + + + ArrayCP1250ToUTF8: TCharToUTF8Table = ( + #0, // #0 + #1, // #1 + #2, // #2 + #3, // #3 + #4, // #4 + #5, // #5 + #6, // #6 + #7, // #7 + #8, // #8 + #9, // #9 + #10, // #10 + #11, // #11 + #12, // #12 + #13, // #13 + #14, // #14 + #15, // #15 + #16, // #16 + #17, // #17 + #18, // #18 + #19, // #19 + #20, // #20 + #21, // #21 + #22, // #22 + #23, // #23 + #24, // #24 + #25, // #25 + #26, // #26 + #27, // #27 + #28, // #28 + #29, // #29 + #30, // #30 + #31, // #31 + ' ', // ' ' + '!', // '!' + '"', // '"' + '#', // '#' + '$', // '$' + '%', // '%' + '&', // '&' + '''', // '''' + '(', // '(' + ')', // ')' + '*', // '*' + '+', // '+' + ',', // ',' + '-', // '-' + '.', // '.' + '/', // '/' + '0', // '0' + '1', // '1' + '2', // '2' + '3', // '3' + '4', // '4' + '5', // '5' + '6', // '6' + '7', // '7' + '8', // '8' + '9', // '9' + ':', // ':' + ';', // ';' + '<', // '<' + '=', // '=' + '>', // '>' + '?', // '?' + '@', // '@' + 'A', // 'A' + 'B', // 'B' + 'C', // 'C' + 'D', // 'D' + 'E', // 'E' + 'F', // 'F' + 'G', // 'G' + 'H', // 'H' + 'I', // 'I' + 'J', // 'J' + 'K', // 'K' + 'L', // 'L' + 'M', // 'M' + 'N', // 'N' + 'O', // 'O' + 'P', // 'P' + 'Q', // 'Q' + 'R', // 'R' + 'S', // 'S' + 'T', // 'T' + 'U', // 'U' + 'V', // 'V' + 'W', // 'W' + 'X', // 'X' + 'Y', // 'Y' + 'Z', // 'Z' + '[', // '[' + '\', // '\' + ']', // ']' + '^', // '^' + '_', // '_' + '`', // '`' + 'a', // 'a' + 'b', // 'b' + 'c', // 'c' + 'd', // 'd' + 'e', // 'e' + 'f', // 'f' + 'g', // 'g' + 'h', // 'h' + 'i', // 'i' + 'j', // 'j' + 'k', // 'k' + 'l', // 'l' + 'm', // 'm' + 'n', // 'n' + 'o', // 'o' + 'p', // 'p' + 'q', // 'q' + 'r', // 'r' + 's', // 's' + 't', // 't' + 'u', // 'u' + 'v', // 'v' + 'w', // 'w' + 'x', // 'x' + 'y', // 'y' + 'z', // 'z' + '{', // '{' + '|', // '|' + '}', // '}' + '~', // '~' + #127, // #127 + #226#130#172, // #128 + '', // #129 + #226#128#154, // #130 + '', // #131 + #226#128#158, // #132 + #226#128#166, // #133 + #226#128#160, // #134 + #226#128#161, // #135 + '', // #136 + #226#128#176, // #137 + #197#160, // #138 + #226#128#185, // #139 + #197#154, // #140 + #197#164, // #141 + #197#189, // #142 + #197#185, // #143 + '', // #144 + #226#128#152, // #145 + #226#128#153, // #146 + #226#128#156, // #147 + #226#128#157, // #148 + #226#128#162, // #149 + #226#128#147, // #150 + #226#128#148, // #151 + '', // #152 + #226#132#162, // #153 + #197#161, // #154 + #226#128#186, // #155 + #197#155, // #156 + #197#165, // #157 + #197#190, // #158 + #197#186, // #159 + #194#160, // #160 + #203#135, // #161 + #203#152, // #162 + #197#129, // #163 + #194#164, // #164 + #196#132, // #165 + #194#166, // #166 + #194#167, // #167 + #194#168, // #168 + #194#169, // #169 + #197#158, // #170 + #194#171, // #171 + #194#172, // #172 + #194#173, // #173 + #194#174, // #174 + #197#187, // #175 + #194#176, // #176 + #194#177, // #177 + #203#155, // #178 + #197#130, // #179 + #194#180, // #180 + #194#181, // #181 + #194#182, // #182 + #194#183, // #183 + #194#184, // #184 + #196#133, // #185 + #197#159, // #186 + #194#187, // #187 + #196#189, // #188 + #203#157, // #189 + #196#190, // #190 + #197#188, // #191 + #197#148, // #192 + #195#129, // #193 + #195#130, // #194 + #196#130, // #195 + #195#132, // #196 + #196#185, // #197 + #196#134, // #198 + #195#135, // #199 + #196#140, // #200 + #195#137, // #201 + #196#152, // #202 + #195#139, // #203 + #196#154, // #204 + #195#141, // #205 + #195#142, // #206 + #196#142, // #207 + #196#144, // #208 + #197#131, // #209 + #197#135, // #210 + #195#147, // #211 + #195#148, // #212 + #197#144, // #213 + #195#150, // #214 + #195#151, // #215 + #197#152, // #216 + #197#174, // #217 + #195#154, // #218 + #197#176, // #219 + #195#156, // #220 + #195#157, // #221 + #197#162, // #222 + #195#159, // #223 + #197#149, // #224 + #195#161, // #225 + #195#162, // #226 + #196#131, // #227 + #195#164, // #228 + #196#186, // #229 + #196#135, // #230 + #195#167, // #231 + #196#141, // #232 + #195#169, // #233 + #196#153, // #234 + #195#171, // #235 + #196#155, // #236 + #195#173, // #237 + #195#174, // #238 + #196#143, // #239 + #196#145, // #240 + #197#132, // #241 + #197#136, // #242 + #195#179, // #243 + #195#180, // #244 + #197#145, // #245 + #195#182, // #246 + #195#183, // #247 + #197#153, // #248 + #197#175, // #249 + #195#186, // #250 + #197#177, // #251 + #195#188, // #252 + #195#189, // #253 + #197#163, // #254 + #203#153 // #255 + ); + ArrayIBMGraphToUTF8: TCharToUTF8Table = ( #0, // #0 @@ -1465,6 +1987,16 @@ begin Result := SingleByteToUTF8(s, ArrayCP850ToUTF8); end; +function CP866ToUTF8(const s: string): TfpgString; +begin + Result := SingleByteToUTF8(s, ArrayCP866ToUTF8); +end; + +function CP1250ToUTF8(const s: string): TfpgString; +begin + Result := SingleByteToUTF8(s, ArrayCP1250ToUTF8); +end; + function IBMGraphToUTF8(const s: string): TfpgString; begin Result := SingleByteToUTF8(s, ArrayIBMGraphToUTF8); @@ -1539,6 +2071,19 @@ begin SetLength(Result, PtrUInt(Dest)-PtrUInt(Result)); end; +function ConvertTextToUTF8(const AEncoding: TfpgTextEncoding; const AText: AnsiString): TfpgString; +begin + case AEncoding of + encUTF8: Result := IPFToUTF8(AText); + encCP437: Result := CP437ToUTF8(AText); + encCP850: Result := CP850ToUTF8(AText); + encCP866: Result := CP866ToUTF8(AText); + encIBMGraph: Result := IBMGraphToUTF8(AText); + else + Result := IPFToUTF8(AText); + end; +end; + end. diff --git a/src/corelib/fpg_utils.pas b/src/corelib/fpg_utils.pas index 9d0e907d..9a135d73 100644 --- a/src/corelib/fpg_utils.pas +++ b/src/corelib/fpg_utils.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -51,6 +51,7 @@ function fpgIsBitSet(const AData: integer; const AIndex: integer): boolean; // RTL wrapper filesystem functions with platform independant encoding // These functions are common for all platforms and rely on fpgXXXPlatformEncoding +function fpgApplicationName: TfpgString; function fpgFindFirst(const Path: TfpgString; Attr: longint; out Rslt: TSearchRec): longint; function fpgFindNext(var Rslt: TSearchRec): longint; function fpgGetCurrentDir: TfpgString; @@ -63,7 +64,7 @@ function fpgExtractFileDir(const FileName: TfpgString): TfpgString; function fpgExtractFilePath(const FileName: TfpgString): TfpgString; function fpgExtractFileName(const FileName: TfpgString): TfpgString; function fpgExtractFileExt(const FileName: TfpgString): TfpgString; -function fpgExtractRelativepath(const ABaseName, ADestName: TfpgString): TfpgString; +function fpgExtractRelativePath(const ABaseName, ADestName: TfpgString): TfpgString; function fpgForceDirectories(const ADirectory: TfpgString): Boolean; function fpgChangeFileExt(const FileName, Extension: TfpgString): TfpgString; function fpgGetAppConfigDir(const Global: Boolean): TfpgString; @@ -101,6 +102,11 @@ begin Result := ALine; end; +function fpgApplicationName: TfpgString; +begin + Result := fpgFromOSEncoding(ApplicationName); +end; + function fpgFindFirst(const Path: TfpgString; Attr: longint; out Rslt: TSearchRec): longint; begin Result := FindFirst(fpgToOSEncoding(Path), Attr, Rslt); @@ -165,7 +171,7 @@ begin Result := ExtractFileExt(fpgToOSEncoding(Filename)); end; -function fpgExtractRelativepath(const ABaseName, ADestName: TfpgString): TfpgString; +function fpgExtractRelativePath(const ABaseName, ADestName: TfpgString): TfpgString; begin Result := ExtractRelativepath(fpgToOSEncoding(ABaseName), fpgToOSEncoding(ADestName)); end; diff --git a/src/corelib/fpg_widget.pas b/src/corelib/fpg_widget.pas index a74c1b30..527e2987 100644 --- a/src/corelib/fpg_widget.pas +++ b/src/corelib/fpg_widget.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -39,6 +39,8 @@ type TfpgDragDropEvent = procedure(Sender, Source: TObject; X, Y: integer; AData: variant) of object; + { TfpgWidget } + TfpgWidget = class(TfpgWindow) private FAcceptDrops: boolean; @@ -50,12 +52,14 @@ type FOnDragLeave: TNotifyEvent; FOnEnter: TNotifyEvent; FOnExit: TNotifyEvent; + FOnKeyChar: TfpgKeyCharEvent; FOnMouseDown: TMouseButtonEvent; FOnMouseEnter: TNotifyEvent; FOnMouseExit: TNotifyEvent; FOnMouseMove: TMouseMoveEvent; FOnMouseUp: TMouseButtonEvent; FOnMouseScroll: TMouseWheelEvent; + FOnMouseHorizScroll: TMouseWheelEvent; FOnPaint: TPaintEvent; FOnKeyPress: TKeyPressEvent; FOnResize: TNotifyEvent; @@ -81,6 +85,7 @@ type procedure MsgMouseEnter(var msg: TfpgMessageRec); message FPGM_MOUSEENTER; procedure MsgMouseExit(var msg: TfpgMessageRec); message FPGM_MOUSEEXIT; procedure MsgMouseScroll(var msg: TfpgMessageRec); message FPGM_SCROLL; + procedure MsgMouseHorizScroll(var msg: TfpgMessageRec); message FPGM_HSCROLL; procedure MsgDropEnter(var msg: TfpgMessageRec); message FPGM_DROPENTER; procedure MsgDropExit(var msg: TfpgMessageRec); message FPGM_DROPEXIT; protected @@ -134,6 +139,7 @@ type procedure HandleMouseEnter; virtual; procedure HandleMouseExit; virtual; procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); virtual; + procedure HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); virtual; function FindFocusWidget(startwg: TfpgWidget; direction: TFocusSearchDirection): TfpgWidget; procedure HandleAlignments(const dwidth, dheight: TfpgCoord); virtual; procedure HandleShow; virtual; @@ -146,6 +152,7 @@ type property OnDoubleClick: TMouseButtonEvent read FOnDoubleClick write FOnDoubleClick; property OnEnter: TNotifyEvent read FOnEnter write FOnEnter; property OnExit: TNotifyEvent read FOnExit write FOnExit; + property OnKeyChar: TfpgKeyCharEvent read FOnKeyChar write FOnKeyChar; property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress; property OnMouseDown: TMouseButtonEvent read FOnMouseDown write FOnMouseDown; property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter; @@ -153,6 +160,7 @@ type property OnMouseMove: TMouseMoveEvent read FOnMouseMove write FOnMouseMove; property OnMouseUp: TMouseButtonEvent read FOnMouseUp write FOnMouseUp; property OnMouseScroll: TMouseWheelEvent read FOnMouseScroll write FOnMouseScroll; + property OnMouseHorizScroll: TMouseWheelEvent read FOnMouseHorizScroll write FOnMouseHorizScroll; property OnPaint: TPaintEvent read FOnPaint write FOnPaint; property OnResize: TNotifyEvent read FOnResize write FOnResize; property OnShowHint: THintEvent read GetOnShowHint write SetOnShowHint; @@ -161,6 +169,7 @@ type destructor Destroy; override; procedure AfterConstruction; override; function InDesigner: boolean; + function IsLoading: boolean; procedure InvokeHelp; virtual; procedure Realign; procedure SetFocus; @@ -432,6 +441,11 @@ begin Result := (FFormDesigner <> nil) end; +function TfpgWidget.IsLoading: boolean; +begin + Result := csLoading in ComponentState; +end; + procedure TfpgWidget.InvokeHelp; begin case HelpType of @@ -854,6 +868,12 @@ begin msg.Params.mouse.shiftstate, msg.Params.mouse.delta); end; +procedure TfpgWidget.MsgMouseHorizScroll(var msg: TfpgMessageRec); +begin + HandleMouseHorizScroll(msg.Params.mouse.x, msg.Params.mouse.y, + msg.Params.mouse.shiftstate, msg.Params.mouse.delta); +end; + procedure TfpgWidget.MsgDropEnter(var msg: TfpgMessageRec); begin // do nothing @@ -943,7 +963,8 @@ end; procedure TfpgWidget.HandleKeyChar(var AText: TfpgChar; var shiftstate: TShiftState; var consumed: boolean); begin - // descendants will implement this. + if FFocusable and Assigned(OnKeyChar) then + OnKeyChar(self, AText, consumed); end; procedure TfpgWidget.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; @@ -962,8 +983,11 @@ begin if not consumed and (keycode = fpgApplication.HelpKey) and (shiftstate=[]) then begin - InvokeHelp; - consumed := True; + if fpgApplication.HelpFile <> '' then + begin + InvokeHelp; + consumed := True; + end; end; case keycode of @@ -1189,6 +1213,12 @@ begin FOnMouseScroll(self, shiftstate, delta, Point(x, y)); end; +procedure TfpgWidget.HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); +begin + if Assigned(FOnMouseHorizScroll) then + FOnMouseHorizScroll(self, shiftstate, delta, Point(x, y)); +end; + function TfpgWidget.FindFocusWidget(startwg: TfpgWidget; direction: TFocusSearchDirection): TfpgWidget; var w: TfpgWidget; diff --git a/src/corelib/gdi/fpg_gdi.pas b/src/corelib/gdi/fpg_gdi.pas index 196e467a..f1372928 100644 --- a/src/corelib/gdi/fpg_gdi.pas +++ b/src/corelib/gdi/fpg_gdi.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -40,7 +40,7 @@ uses fpg_base, fpg_impl {$IFDEF DEBUG} - ,dbugintf + ,fpg_dbugintf {$ENDIF DEBUG} ,fpg_OLEDragDrop ; @@ -147,6 +147,7 @@ type public constructor Create(awin: TfpgWindowBase); override; destructor Destroy; override; + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); override; end; @@ -262,10 +263,13 @@ type TfpgGDIFileList = class(TfpgFileListBase) + private function EncodeAttributesString(attrs: longword): TFileModeString; - constructor Create; override; + protected function InitializeEntry(sr: TSearchRec): TFileEntry; override; procedure PopulateSpecialDirs(const aDirectory: TfpgString); override; + public + constructor Create; override; end; @@ -705,6 +709,7 @@ var wmsg: TMsg; PaintStruct: TPaintStruct; TmpW: widestring; + wheelpos: integer; //------------ procedure SetMinMaxInfo(var MinMaxInfo: TMINMAXINFO); @@ -722,7 +727,7 @@ var dy := 0; IntfWidth := AWidth; IntfHeight := AHeight; - + GetWindowBorderDimensions(w, dx, dy); Inc(IntfWidth, dx); Inc(IntfHeight, dy); @@ -850,7 +855,7 @@ begin msgp.keyboard.keychar := UTF8Encode(tmpW); fpgSendMessage(nil, w, FPGM_KEYCHAR, msgp); end; - + // Allow Alt+F4 and other system key combinations if (uMsg = WM_SYSKEYUP) or (uMsg = WM_SYSKEYDOWN) then Result := Windows.DefWindowProc(hwnd, uMsg, wParam, lParam); @@ -877,7 +882,7 @@ begin begin {$IFDEF DEBUG} if uMsg <> WM_MOUSEMOVE then - writeln('fpGFX/GDI: Found a mouse button event'); + SendDebug('fpGFX/GDI: Found a mouse button event'); {$ENDIF} // msgp.mouse.x := smallint(lParam and $FFFF); // msgp.mouse.y := smallint((lParam and $FFFF0000) shr 16); @@ -962,7 +967,7 @@ begin end; mcode := FPGM_MOUSEDOWN; end; - + WM_LBUTTONUP, WM_MBUTTONUP, WM_RBUTTONUP: @@ -1000,7 +1005,7 @@ begin WM_LBUTTONDOWN, WM_LBUTTONUP: msgp.mouse.Buttons := MOUSE_LEFT; - + WM_MBUTTONDOWN, WM_MBUTTONUP: msgp.mouse.Buttons := MOUSE_MIDDLE; @@ -1029,8 +1034,8 @@ begin begin if w.FSkipResizeMessage then Exit; - - // note that WM_SIZING allows some control on sizeing + + // note that WM_SIZING allows some control on sizing //writeln('WM_SIZE: wp=',IntToHex(wparam,8), ' lp=',IntToHex(lparam,8)); msgp.rect.Width := smallint(lParam and $FFFF); msgp.rect.Height := smallint((lParam and $FFFF0000) shr 16); @@ -1090,7 +1095,13 @@ begin begin msgp.mouse.x := pt.x; msgp.mouse.y := pt.y; - msgp.mouse.delta := SmallInt(HiWord(wParam)) div -120; + { calculate direction of the mouse wheel } + wheelpos := 0; + dec(wheelpos, SmallInt(HiWord(wParam))); + if wheelpos > 0 then + msgp.mouse.delta := 1 + else + msgp.mouse.delta := -1; i := 0; if (wParam and MK_LBUTTON) <> 0 then @@ -1128,7 +1139,7 @@ begin {$IFDEF DEBUG} SendDebug(w.ClassName + ': WM_TIMECHANGE'); {$ENDIF} - writeln('fpGUI/GDI: ' + w.ClassName + ': WM_TIMECHANGE'); +// writeln('fpGUI/GDI: ' + w.ClassName + ': WM_TIMECHANGE'); fpgResetAllTimers; end; @@ -1248,6 +1259,8 @@ begin end; function TfpgGDIApplication.GetHiddenWindow: HWND; +var + lHandle: TfpgWinHandle; begin if (FHiddenWindow = 0) then begin @@ -1263,8 +1276,12 @@ begin end; Windows.RegisterClass(@HiddenWndClass); + if MainForm <> nil then + lHandle := TfpgGDIWindow(MainForm).FWinHandle + else + lHandle := -1; FHiddenWindow := CreateWindow('FPGHIDDEN', '', - DWORD(WS_POPUP), 0, 0, 0, 0, TfpgGDIWindow(MainForm).FWinHandle, 0, MainInstance, nil); + DWORD(WS_POPUP), 0, 0, 0, 0, lHandle, 0, MainInstance, nil); end; Result := FHiddenWindow; end; @@ -1413,7 +1430,7 @@ var wg: TfpgWidget; begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDLeave '); + SendDebug('TfpgGDIWindow.HandleDNDLeave '); {$ENDIF} FUserMimeSelection := ''; wg := self as TfpgWidget; @@ -1437,7 +1454,7 @@ var msgp: TfpgMessageParams; begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDEnter '); + SendDebug('TfpgGDIWindow.HandleDNDEnter '); {$ENDIF} wg := self as TfpgWidget; if wg.AcceptDrops then @@ -1500,7 +1517,7 @@ begin if FDropPos <> PT then begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIWindow.HandleDNDPosition '); + SendDebug('TfpgGDIWindow.HandleDNDPosition '); {$ENDIF} FDropPos.x := PT.x; FDropPos.y := PT.y; @@ -1521,12 +1538,13 @@ var swg: TfpgWidget; { source widget } CF: DWORD; lIsTranslated: Boolean; + lPoint: Windows.Point; begin if not FUserAcceptDrag then exit; {$IFDEF DND_DEBUG} - Writeln('TfpgGDIWindow.HandleDNDDrop'); + SendDebug('TfpgGDIWindow.HandleDNDDrop'); {$ENDIF} wg := self as TfpgWidget; @@ -1546,7 +1564,11 @@ begin swg := uDragSource as TfpgWidget else swg := nil; - wg.OnDragDrop(wg, swg, pt.x, pt.y, data); + // convert mouse screen coordinates to widget coordinates + lPoint.x := pt.x; + lPoint.y := pt.y; + ScreenToClient(wg.WinHandle, lPoint); + wg.OnDragDrop(wg, swg, lPoint.x, lPoint.y, data); uDragSource := nil; end; GlobalUnlock(stgmed.HGLOBAL); @@ -1603,7 +1625,7 @@ begin CurrentWindowHndl := WindowFromPoint(spt); CursorInDifferentWindow := (CurrentWindowHndl <> uLastWindowHndl); - + if CursorInDifferentWindow then begin FillChar(msgp, sizeof(msgp), 0); @@ -1623,7 +1645,7 @@ begin fpgSendMessage(nil, CurrentWindow, FPGM_MOUSEENTER, msgp); end; end; - + uLastWindowHndl := CurrentWindowHndl; end; @@ -1646,18 +1668,18 @@ begin FNonFullscreenRect.Left := 0; if FNonFullscreenRect.Top < 0 then FNonFullscreenRect.Top := 0; - + Left := 0; Top := 0; Width := wapplication.GetScreenWidth; Height := wapplication.GetScreenHeight; - + if aUpdate then UpdateWindowPosition; FWinStyle := WS_POPUP or WS_SYSMENU; FWinStyle := FWinStyle and not(WS_CAPTION or WS_THICKFRAME); - + if aUpdate then begin {$IFDEF CPU64} @@ -1687,7 +1709,7 @@ begin Top := FNonFullscreenRect.Top; Width := FNonFullscreenRect.Width; Height := FNonFullscreenRect.Height; - + if aUpdate then UpdateWindowPosition; end; @@ -1710,7 +1732,7 @@ var begin if FWinHandle > 0 then Exit; //==> - + FSkipResizeMessage := True; FWinStyle := WS_OVERLAPPEDWINDOW; @@ -1766,7 +1788,7 @@ begin FWinStyle := FWinStyle and not (WS_SIZEBOX or WS_MAXIMIZEBOX); FWinStyle := FWinStyle or WS_CLIPCHILDREN or WS_CLIPSIBLINGS; - + if waFullScreen in FWindowAttributes then WindowSetFullscreen(True, False); @@ -2131,6 +2153,27 @@ begin inherited; end; +procedure TfpgGDICanvas.CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; + var ASrcRect: TfpgRect); +var + srcdc: HDC; + destdc: HDC; +begin + if (TfpgWindow(FWindow).WinHandle <= 0) or (TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle <= 0) then + begin + debugln(' no winhandle available'); + exit; + end; + + destdc := Windows.GetDC(TfpgWindow(FWindow).WinHandle); + srcdc := Windows.GetDC(TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle); + + BitBlt(destdc, ADest_x, ADest_y, ASrcRect.Width, ASrcRect.Height, srcdc, ASrcRect.Left, ASrcRect.Top, SRCCOPY); + + ReleaseDC(TfpgWindow(TfpgGDICanvas(ASrcCanvas).FWindow).WinHandle, srcdc); + ReleaseDC(TfpgWindow(FWindow).WinHandle, destdc); +end; + procedure TfpgGDICanvas.DoBeginDraw(awin: TfpgWindowBase; buffered: boolean); var ARect: TfpgRect; @@ -2199,7 +2242,7 @@ begin DeleteObject(FClipRegion); TryFreeBackBuffer; - + Windows.ReleaseDC(FDrawWindow.FWinHandle, FWingc); FDrawing := False; @@ -2212,8 +2255,10 @@ var c: longword; begin c := Windows.GetPixel(FWinGC, X, Y); + {$IFDEF DEBUG} if c = CLR_INVALID then - Writeln('fpGFX/GDI: TfpgGDICanvas.GetPixel returned an invalid color'); + SendDebug('fpGFX/GDI: TfpgGDICanvas.GetPixel returned an invalid color'); + {$ENDIF} Result := WinColorTofpgColor(c); end; @@ -2457,7 +2502,7 @@ begin if FBufferBitmap > 0 then DeleteObject(FBufferBitmap); FBufferBitmap := 0; - + if FBufgc > 0 then DeleteDC(FBufgc); FBufgc := 0; @@ -2882,7 +2927,7 @@ var drvs: string; begin FSpecialDirs.Clear; - + // making drive list if Copy(aDirectory, 2, 1) = ':' then begin @@ -2929,7 +2974,7 @@ end; destructor TfpgGDIDrag.Destroy; begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIDrag.Destroy '); + SendDebug('TfpgGDIDrag.Destroy '); {$ENDIF} inherited Destroy; end; @@ -2951,14 +2996,14 @@ begin if FDragging then begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIDrag.Execute (already dragging)'); + SendDebug('TfpgGDIDrag.Execute (already dragging)'); {$ENDIF} Result := daIgnore; end else begin {$IFDEF DND_DEBUG} - writeln('TfpgGDIDrag.Execute (new drag)'); + SendDebug('TfpgGDIDrag.Execute (new drag)'); {$ENDIF} FDragging := True; wapplication.Drag := self; @@ -2973,7 +3018,7 @@ begin {$Note OLE DND: We are only handling strings at the moment, this needs to be extended to other types too } itm := FMimeData[i]; {$IFDEF DND_DEBUG} - writeln(' Processing mime-type: ', itm.Format); + SendDebug(' Processing mime-type: ', itm.Format); {$ENDIF} { description of data we are sending } @@ -3089,7 +3134,11 @@ begin ActiveX.RevokeDragDrop(TfpgWidget(FDropTarget).WinHandle); end; -procedure TimerCallBackProc(window_hwnd : hwnd; msg : DWORD; idEvent: UINT; dwTime: DWORD); stdcall; +{$IF FPC_FULLVERSION<20602} +procedure TimerCallBackProc(hWnd: HWND; uMsg: UINT; idEvent: UINT; dwTime: DWORD); stdcall; +{$ELSE} +procedure TimerCallBackProc(hWnd: HWND; uMsg: UINT; idEvent: UINT_PTR; dwTime: DWORD); stdcall; +{$IFEND} begin { idEvent contains the handle to the timer that got triggered } fpgCheckTimers; @@ -3102,7 +3151,6 @@ begin inherited SetEnabled(AValue); if FEnabled then begin -// FHandle := Windows.SetTimer(0, 0, Interval, nil); FHandle := Windows.SetTimer(0, 0, Interval, @TimerCallBackProc); end else @@ -3164,7 +3212,7 @@ initialization GetVersionEx(WinVersion); UnicodeEnabledOS := (WinVersion.dwPlatformID = VER_PLATFORM_WIN32_NT) or (WinVersion.dwPlatformID = VER_PLATFORM_WIN32_CE); - + if SystemParametersInfo(SPI_GETFONTSMOOTHINGTYPE, 0, @FontSmoothingType, 0) and (FontSmoothingType = FE_FONTSMOOTHINGCLEARTYPE) then FontSmoothingType := CLEARTYPE_QUALITY diff --git a/src/corelib/gdi/fpgui_toolkit.lpk b/src/corelib/gdi/fpgui_toolkit.lpk index bf019e5f..dfe56c14 100644 --- a/src/corelib/gdi/fpgui_toolkit.lpk +++ b/src/corelib/gdi/fpgui_toolkit.lpk @@ -1,4 +1,4 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <Package Version="4"> <PathDelim Value="\"/> @@ -30,8 +30,8 @@ </CompilerOptions> <Description Value="fpGUI Toolkit"/> <License Value="LGPL 2 with static linking exception."/> - <Version Major="1"/> - <Files Count="98"> + <Version Major="1" Minor="2"/> + <Files Count="104"> <Item1> <Filename Value="..\stdimages.inc"/> <Type Value="Include"/> @@ -424,8 +424,32 @@ <Filename Value="..\render\software\Agg2D.pas"/> <UnitName Value="Agg2D"/> </Item98> + <Item99> + <Filename Value="..\fpg_dbugintf.pas"/> + <UnitName Value="fpg_dbugintf"/> + </Item99> + <Item100> + <Filename Value="..\fpg_dbugmsg.pas"/> + <UnitName Value="fpg_dbugmsg"/> + </Item100> + <Item101> + <Filename Value="..\..\gui\fpg_style_carbon.pas"/> + <UnitName Value="fpg_style_carbon"/> + </Item101> + <Item102> + <Filename Value="..\..\gui\fpg_style_plastic.pas"/> + <UnitName Value="fpg_style_plastic"/> + </Item102> + <Item103> + <Filename Value="..\..\gui\fpg_style_win8.pas"/> + <UnitName Value="fpg_style_win8"/> + </Item103> + <Item104> + <Filename Value="..\..\gui\inputquerydialog.inc"/> + <Type Value="Include"/> + </Item104> </Files> - <LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/> + <LazDoc Paths="..\..\..\docs\xml\corelib;..\..\..\docs\xml\corelib\x11;..\..\..\docs\xml\corelib\gdi;..\..\..\docs\xml\gui"/> <RequiredPkgs Count="1"> <Item1> <PackageName Value="FCL"/> diff --git a/src/corelib/gdi/fpgui_toolkit.pas b/src/corelib/gdi/fpgui_toolkit.pas index 05501714..12ac41b9 100644 --- a/src/corelib/gdi/fpgui_toolkit.pas +++ b/src/corelib/gdi/fpgui_toolkit.pas @@ -21,7 +21,8 @@ uses fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, - U_ReportImages, U_Visu, fpg_trayicon, Agg2D; + U_ReportImages, U_Visu, fpg_trayicon, Agg2D, fpg_dbugintf, fpg_dbugmsg, + fpg_style_carbon, fpg_style_plastic, fpg_style_win8; implementation diff --git a/src/corelib/predefinedcolors.inc b/src/corelib/predefinedcolors.inc index 130cdd9f..7ad000d4 100644 --- a/src/corelib/predefinedcolors.inc +++ b/src/corelib/predefinedcolors.inc @@ -69,6 +69,7 @@ clGridInactiveSel = TfpgColor(cl_BaseNamedColor + 30); clGridInactiveSelText = TfpgColor(cl_BaseNamedColor + 31); clSplitterGrabBar = TfpgColor(cl_BaseNamedColor + 32); + clHyperLink = TfpgColor(cl_BaseNamedColor + 33); diff --git a/src/corelib/render/software/Agg2D.pas b/src/corelib/render/software/Agg2D.pas index 50a68fb8..229294d2 100644 --- a/src/corelib/render/software/Agg2D.pas +++ b/src/corelib/render/software/Agg2D.pas @@ -400,6 +400,8 @@ type procedure ClearAll(c : TAggColor ); overload; procedure ClearAll(r ,g ,b : byte; a : byte = 255 ); overload; + procedure FillAll(c: TAggColor); overload; + procedure FillAll(r, g, b: byte; a: byte = 255); overload; // Master Rendering Properties procedure BlendMode(m : TAggBlendMode ); overload; @@ -1288,6 +1290,9 @@ begin m_pathTransform.Construct (@m_convCurve ,@m_transform ); m_strokeTransform.Construct(@m_convStroke ,@m_transform ); + m_convDash.remove_all_dashes; + m_convDash.add_dash(600, 0); {$NOTE Find a better way to prevent dash generation } + {$IFDEF AGG2D_USE_FREETYPE } m_fontEngine.Construct; {$ENDIF } @@ -1491,6 +1496,22 @@ begin end; +procedure TAgg2D.FillAll(c: TAggColor); +var + clr: aggclr; +begin + clr.Construct (c ); + m_renBase.fill(@clr ); +end; + +procedure TAgg2D.FillAll(r, g, b: byte; a: byte); +var + clr: TAggColor; +begin + clr.Construct(r, g, b, a); + FillAll(clr); +end; + { CLEARCLIPBOX } procedure TAgg2D.ClearClipBox(c : TAggColor ); var @@ -1517,14 +1538,14 @@ end; { WORLDTOSCREEN } procedure TAgg2D.WorldToScreen(x ,y : PDouble ); begin - m_transform.transform(@m_transform ,double_ptr(x ) ,double_ptr(y ) ); + m_transform.transform(@m_transform, x, y); end; { SCREENTOWORLD } procedure TAgg2D.ScreenToWorld(x ,y : PDouble ); begin - m_transform.inverse_transform(@m_transform ,double_ptr(x ) ,double_ptr(y ) ); + m_transform.inverse_transform(@m_transform, x, y); end; @@ -2649,7 +2670,8 @@ begin m_fontEngine.hinting_(m_textHints ); if cache = AGG_VectorFontCache then - m_fontEngine.height_(height ) + {$NOTE We need to fix this. Translating from font pt to pixels is inaccurate. This is just a temp fix for now. } + m_fontEngine.height_(height * 1.3333 ) // 9pt = ~12px so that is a ratio of 1.3333 else m_fontEngine.height_(worldToScreen(height ) ); {$ENDIF} @@ -3534,18 +3556,29 @@ begin end; procedure TAgg2D.DoSetFontRes(fntres: TfpgFontResourceBase); +{$IFDEF WINDOWS} begin - {$NOTE This is only temporary until I can correctly query font names } - {$IFDEF WINDOWS} + {$IFDEF AGG2D_USE_FREETYPE } + Font('c:\WINNT\Fonts\arial.ttf', 10); + {$ENDIF } + {$IFDEF AGG2D_USE_WINFONTS} Font('Arial', 13); - {$ELSE} - {$IFDEF BSD} - Font('/usr/local/lib/X11/fonts/Liberation/LiberationSans-Regular.ttf', 13); - {$ELSE} - Font('/usr/share/fonts/truetype/ttf-liberation/LiberationSans-Regular.ttf', 13); - {$ENDIF} - {$ENDIF} + {$ENDIF } end; +{$ENDIF} +{$IFDEF UNIX} +var + s: TfpgString; + i: integer; + fnt: TFontCacheItem; + lSize: double; +begin + fnt := FontCacheItemFromFontDesc(TfpgFontResource(fntres).FontDesc, lSize); + i := gFontCache.Find(fnt); + if i > 0 then + Font(gFontCache.Items[i].FileName, lSize, fnt.IsBold, fnt.IsItalic, AGG_VectorFontCache, Deg2Rad(fnt.Angle)); +end; +{$ENDIF} procedure TAgg2D.DoSetTextColor(cl: TfpgColor); var @@ -3555,7 +3588,7 @@ begin c := fpgColorToRGB(cl); t := fpgColorToRGBTriple(c); - FillColor(t.Red, t.Green, t.Blue{, t.Alpha}); + FillColor(t.Red, t.Green, t.Blue, t.Alpha); end; procedure TAgg2D.DoSetColor(cl: TfpgColor); @@ -3566,7 +3599,7 @@ begin c := fpgColorToRGB(cl); t := fpgColorToRGBTriple(c); - LineColor(t.Red, t.Green, t.Blue{, t.Alpha}); + LineColor(t.Red, t.Green, t.Blue, t.Alpha); end; procedure TAgg2D.DoSetLineStyle(awidth: integer; astyle: TfpgLineStyle); @@ -3635,7 +3668,10 @@ end; procedure TAgg2D.DoFillTriangle(x1, y1, x2, y2, x3, y3: TfpgCoord); begin - + LineWidth(1); + FillColor(LineColor); + LineColor(LineColor); + Triangle(x1+0.5, y1+0.5, x2+0.5, y2+0.5, x3+0.5, y3+0.5); end; procedure TAgg2D.DoDrawRectangle(x, y, w, h: TfpgCoord); diff --git a/src/corelib/render/software/agg-demos/Agg2DConsole.dpr b/src/corelib/render/software/agg-demos/Agg2DConsole.dpr new file mode 100644 index 00000000..bc8badbc --- /dev/null +++ b/src/corelib/render/software/agg-demos/Agg2DConsole.dpr @@ -0,0 +1,148 @@ +{ + This is a console application demo. It uses the Agg2D object, + which has a much friendlier API, to do all the drawing. We then + save the image buffer to a JPG, using the fcl-image package, + which comes standard with the Free Pascal Compiler. + +// Paths: ..\;..\svg;..\util;expat-wrap +} +program console_aggpas_2; + +{$mode objfpc}{$H+} + +uses + sysutils, + FPimage, + FPWriteJPEG, + agg_2D, + agg_basics; + +const + ImageWidth = 800; + ImageHeight = 480; + RGBA_Width = 4; + LineCount = 30; + {$IFDEF Unix} + FontFile = '../../arial.ttf'; + {$ENDIF} + {$IFDEF Windows} + FontFile = 'Arial'; + {$ENDIF} + +type + TPainter = class(TObject) + public + procedure HandlePlug; + procedure DrawStuff(agg: Agg2D_ptr); + end; + + +procedure TPainter.HandlePlug; +var + agg: Agg2D_ptr; + buf: array of int8; + image: TFPMemoryImage; + writer: TFPWriterJPEG; + x, y: Integer; + c: TFPColor; + time, totalTime: TDateTime; + function getBufItemAsWord(aDelta: byte): Word; + var + actualY: Integer; + begin + actualY := ImageHeight - y - 1; + result := + Word(buf[x * RGBA_Width + actualY * ImageWidth * RGBA_Width + aDelta] shl 8) + or Word(128); + end; +begin + totalTime := Now; + time := Now; + SetLength(buf, ImageWidth * ImageHeight * RGBA_Width); + New(agg, Construct); + agg^.attach(@(buf[0]), ImageWidth, ImageHeight, ImageWidth * RGBA_Width); + DrawStuff(agg); + Dispose(agg, Destruct); // not necessary to keep it after rendering is finished + time := Now - time; +// Logger.Emit('Draw: time spent: ' + TimeStampToString(time)); + time := Now; + image := TFPMemoryImage.create(ImageWidth, ImageHeight); + for x := 0 to ImageWidth - 1 do + for y := 0 to ImageHeight - 1 do + begin + c.red := getBufItemAsWord(2); + c.green := getBufItemAsWord(1); + c.blue := getBufItemAsWord(0); + c.alpha := getBufItemAsWord(3); + image.Colors[x, y] := c; + end; + time := Now - time; +// WriteLn('Image copy: time spent: ' + DateTimeToString(time)); + time := Now; + writer := TFPWriterJPEG.Create; + writer.CompressionQuality := $FF div 3; // bad quality plz + writer.ProgressiveEncoding := True; + image.SaveToFile('test.jpeg', writer); + image.Free; + writer.Free; + time := Now - time; +// WriteLn('Image encode: time spent: ' + DateTimeToString(time)); + totalTime := Now - totalTime; +// WriteLn('Total time: ' + DateTimeToString(totalTime)); +end; + +procedure TPainter.DrawStuff(agg: Agg2D_ptr); +var + i: Integer; + x, y, px, py, d: Double; +begin + agg^.clearAll(0, 0, 0); + agg^.lineColor(0, 0, 0, 255); + agg^.lineWidth(3); + agg^.rectangle(0, 0, ImageWidth, ImageHeight); + agg^.font(fontfile, 16); + d := ImageWidth / LineCount; + agg^.lineColor(0, 0, 0, 100); + agg^.lineWidth(1); + for i := 1 to LineCount - 1 do + begin + x := i * d; + agg^.line(x, 0, x, ImageHeight); + end; + for i := 1 to trunc(ImageHeight / d) do + begin + y := i * d; + agg^.line(0, y, ImageWidth, y); + end; + x := 0; + y := ImageHeight / 2; + px := x; + py := y; + agg^.lineColor(255, 0, 0, 200); + agg^.fillColor(0, 0, 0, 200); + agg^.lineWidth(3); + for i := 0 to LineCount - 1 do + begin + x := x + d; + y := y + Random(Round(ImageHeight / 3)) - ImageHeight / 6; + if y < 0 then + y := ImageHeight / 6; + if y >= ImageHeight then + y := ImageHeight - ImageHeight / 6; + agg^.line(px, py, x, y); + agg^.text(x, y, char_ptr(IntToStr(i) + ' point'{' шта?'})); + px := x; + py := y; + end; +end; + + +var + p: TPainter; +begin + Randomize; + p := TPainter.Create; + p.HandlePlug; + p.Free; +end. + diff --git a/src/corelib/render/software/agg_2D.pas b/src/corelib/render/software/agg_2D.pas index a6296e2c..45d88e44 100644 --- a/src/corelib/render/software/agg_2D.pas +++ b/src/corelib/render/software/agg_2D.pas @@ -3,11 +3,11 @@ // Based on Anti-Grain Geometry // Copyright (C) 2005 Maxim Shemanarev (http://www.antigrain.com) // -// Agg2D - Version 1.0 Release Milano 3 (AggPas 2.3 RM3) +// Agg2D - Version 1.0 Release Milano 3 (AggPas 2.4 RM3) // Pascal Port By: Milan Marusinec alias Milano // milan@marusinec.sk // http://www.aggpas.org -// Copyright (c) 2007 +// Copyright (c) 2007 - 2008 // // Permission to copy, use, modify, sell and distribute this software // is granted provided this copyright notice appears in all copies. @@ -325,6 +325,8 @@ type procedure clearAll(c : Color ); overload; procedure clearAll(r ,g ,b : unsigned; a : unsigned = 255 ); overload; + procedure FillAll(c: Color); overload; + procedure FillAll(r, g, b: byte; a: byte = 255); overload; procedure clearClipBox(c : Color ); overload; procedure clearClipBox(r ,g ,b : unsigned; a : unsigned = 255 ); overload; @@ -424,7 +426,7 @@ type rxTop ,ryTop : double ); overload; procedure ellipse(cx ,cy ,rx ,ry : double ); - + procedure arc (cx ,cy ,rx ,ry ,start ,sweep : double ); procedure star(cx ,cy ,r1 ,r2 ,startAngle : double; numRays : int ); @@ -932,6 +934,22 @@ begin end; +procedure Agg2D.FillAll(c: Color); +var + clr: aggclr; +begin + clr.Construct (c ); + m_renBase.fill(@clr ); +end; + +procedure Agg2D.FillAll(r, g, b: byte; a: byte); +var + clr: Color; +begin + clr.Construct(r, g, b, a); + FillAll(clr); +end; + { CLEARCLIPBOX } procedure Agg2D.clearClipBox(c : Color ); var diff --git a/src/corelib/render/software/agg_basics.pas b/src/corelib/render/software/agg_basics.pas index cc116cfe..56eb6fba 100644 --- a/src/corelib/render/software/agg_basics.pas +++ b/src/corelib/render/software/agg_basics.pas @@ -357,8 +357,8 @@ type procedure NoP; { These implementations have changed to use FPC's Sar*() functions, so should - now support all platforms with ASM code. At a later date these functions - could be removed completely. } + now support all platforms without the need for ASM code. At a later date these + functions could be removed completely. } function shr_int8 (i ,shift : int8 ) : int8; inline; function shr_int16(i ,shift : int16 ) : int16; inline; function shr_int32(i ,shift : int ) : int; inline; diff --git a/src/corelib/render/software/agg_platform_x11.inc b/src/corelib/render/software/agg_platform_x11.inc index 331b572e..dc5556fa 100644 --- a/src/corelib/render/software/agg_platform_x11.inc +++ b/src/corelib/render/software/agg_platform_x11.inc @@ -18,6 +18,7 @@ {$ifdef uses_implementation} fpg_x11, + fpg_fontcache, {$endif} @@ -27,6 +28,88 @@ type // to get access to protected methods (seeing that FPC doesn't support Friend-classes) TImageHack = class(TfpgImage); +function FontCacheItemFromFontDesc(const desc: string; var asize: double): TFontCacheItem; +var + facename: string; + cp: integer; + c: char; + token: string; + prop, propval: string; + + function NextC: char; + begin + Inc(cp); + if cp > length(desc) then + c := #0 + else + c := desc[cp]; + Result := c; + end; + + procedure NextToken; + begin + token := ''; + while (c <> #0) and (c in [' ', 'a'..'z', 'A'..'Z', '_', '0'..'9', '.']) do + begin + token := token + c; + NextC; + end; + end; + +begin + Result := TFontCacheItem.Create(''); + + cp := 0; + NextC; + NextToken; + + facename := token; + // Add known substites + if lowercase(facename) = 'times' then + facename := 'Times New Roman' + else if lowercase(facename) = 'courier' then + facename := 'Courier New' + else if lowercase(facename) = 'monospace' then + facename := 'Courier New'; + Result.FamilyName := facename; + + if c = '-' then + begin + NextC; + NextToken; + asize := StrToIntDef(token, 0); + end; + + while c = ':' do + begin + NextC; + NextToken; + + prop := UpperCase(token); + propval := ''; + + if c = '=' then + begin + NextC; + NextToken; + propval := UpperCase(token); + end; + + if prop = 'BOLD' then + Result.IsBold := True + else if prop = 'ITALIC' then + Result.IsItalic := True + else if prop = 'ANGLE' then + Result.Angle := StrToFloatDef(propval, 0.0); +// else if prop = 'ANTIALIAS' then +// if propval = 'FALSE' then +// lf.lfQuality := NONANTIALIASED_QUALITY else +// if propval = 'DEFAULT' then +// lf.lfQuality := DEFAULT_QUALITY; + end; +end; + + procedure TAgg2D.DoPutBufferToScreen(x, y, w, h: TfpgCoord); var drawgc: Tgc; diff --git a/src/corelib/render/software/agg_renderer_base.pas b/src/corelib/render/software/agg_renderer_base.pas index 926aebd5..cc2bade4 100644 --- a/src/corelib/render/software/agg_renderer_base.pas +++ b/src/corelib/render/software/agg_renderer_base.pas @@ -79,6 +79,7 @@ type function bounding_ymax : int; virtual; procedure clear(c : aggclr_ptr ); + procedure fill(const c: aggclr_ptr); procedure copy_pixel (x ,y : int; c : aggclr_ptr ); virtual; procedure blend_pixel(x ,y : int; c : aggclr_ptr; cover : int8u ); virtual; @@ -348,6 +349,17 @@ begin end; +procedure renderer_base.fill(const c: aggclr_ptr); +var + y: unsigned; +begin + if (width > 0) and (height > 0) then + begin + for y:=0 to height - 1 do + m_ren.blend_hline(m_ren, 0, y, width, c, cover_mask); + end; +end; + { COPY_PIXEL } procedure renderer_base.copy_pixel(x, y: int; c: aggclr_ptr); begin diff --git a/src/corelib/render/software/fpg_fontcache.pas b/src/corelib/render/software/fpg_fontcache.pas new file mode 100644 index 00000000..15f65e40 --- /dev/null +++ b/src/corelib/render/software/fpg_fontcache.pas @@ -0,0 +1,347 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This is a homegrown font cache, or font translation system. AggPas + references font files (eg: *.ttf) directly, whereas the rest + of fpGUI doesn't. Under X11 for example, the translation of + 'Aria-12' to the actual *.ttf file will be done by the fontconfig + library. Unfortunately fontconfig doesn't have an API to give + use that *.ttf font file it resolved too. So for AggPas (or rather + the AggPas backend in fpGUI) we had to implement our own + font translation system. +} + +unit fpg_fontcache; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, contnrs, fpg_base; + +type + TFontCacheItem = class(TObject) + private + FAngle: double; + FFamilyName: TfpgString; + FFileName: TfpgString; + FFixedWidth: boolean; + FStyleFlags: Integer; + function GetIsBold: boolean; + function GetIsFixedWidth: boolean; + function GetIsItalic: boolean; + function GetIsRegular: boolean; + procedure SetIsBold(AValue: boolean); + procedure SetIsFixedWidth(AValue: boolean); + procedure SetIsItalic(AValue: boolean); + procedure SetIsRegular(AValue: boolean); + public + constructor Create(const AFilename: TfpgString); + property FileName: TfpgString read FFileName write FFileName; + property FamilyName: TfpgString read FFamilyName write FFamilyName; + property StyleFlags: Integer read FStyleFlags write FStyleFlags; + property IsFixedWidth: boolean read GetIsFixedWidth write SetIsFixedWidth; + property IsRegular: boolean read GetIsRegular write SetIsRegular; + property IsItalic: boolean read GetIsItalic write SetIsItalic; + property IsBold: boolean read GetIsBold write SetIsBold; + { following properties are used by FontCacheItemFromFontDesc() only } + property Angle: double read FAngle write FAngle; + end; + + + TFontCacheList = class(TObject) + private + FList: TObjectList; + procedure SearchForFont(const AFontPath: TfpgString); + function BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem; + procedure SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer; const AStyleName: AnsiString; const AStyleBit: integer); + protected + function GetCount: integer; virtual; + function GetItem(AIndex: Integer): TFontCacheItem; virtual; + procedure SetItem(AIndex: Integer; AValue: TFontCacheItem); virtual; + public + constructor Create; + destructor Destroy; override; + procedure BuildFontCache; + function Add(const AObject: TFontCacheItem): integer; + procedure Clear; + property Count: integer read GetCount; + function IndexOf(const AObject: TFontCacheItem): integer; + function Find(const AFontCacheItem: TFontCacheItem): integer; + property Items[AIndex: Integer]: TFontCacheItem read GetItem write SetItem; default; + end; + + +function gFontCache: TFontCacheList; + +implementation + +uses + fpg_utils, + agg_font_freetype_lib; + +const + FPG_FONT_STYLE_REGULAR = 1 shl 0; { Regular, Plain, Book } + FPG_FONT_STYLE_ITALIC = 1 shl 1; { Itelic } + FPG_FONT_STYLE_BOLD = 1 shl 2; { Bold } + FPG_FONT_STYLE_CONDENSED = 1 shl 3; { Condensed } + FPG_FONT_STYLE_EXTRALIGHT = 1 shl 4; { ExtraLight } + FPG_FONT_STYLE_LIGHT = 1 shl 5; { Light } + FPG_FONT_STYLE_SEMIBOLD = 1 shl 6; { Semibold } + FPG_FONT_STYLE_MEDIUM = 1 shl 7; { Medium } + FPG_FONT_STYLE_BLACK = 1 shl 8; { Black } + FPG_FONT_STYLE_FIXEDWIDTH = 1 shl 9; { Fixedwidth } + +var + m_library: FT_Library_ptr; + uFontCacheList: TFontCacheList; + +function gFontCache: TFontCacheList; +begin + if not Assigned(uFontCacheList) then + begin + uFontCacheList := TFontCacheList.Create; + uFontCacheList.BuildFontCache; + end; + Result := uFontCacheList; +end; + +{ TFontCacheItem } + +function TFontCacheItem.GetIsBold: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_BOLD) <> 0; +end; + +function TFontCacheItem.GetIsFixedWidth: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_FIXEDWIDTH) <> 0; +end; + +function TFontCacheItem.GetIsItalic: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_ITALIC) <> 0; +end; + +function TFontCacheItem.GetIsRegular: boolean; +begin + Result := (FStyleFlags and FPG_FONT_STYLE_REGULAR) <> 0; +end; + +procedure TFontCacheItem.SetIsBold(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_BOLD; +end; + +procedure TFontCacheItem.SetIsFixedWidth(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_FIXEDWIDTH; + FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_REGULAR); +end; + +procedure TFontCacheItem.SetIsItalic(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_ITALIC; +end; + +procedure TFontCacheItem.SetIsRegular(AValue: boolean); +begin + FStyleFlags := FStyleFlags or FPG_FONT_STYLE_REGULAR; + FStyleFlags := FStyleFlags and (not FPG_FONT_STYLE_FIXEDWIDTH); +end; + +constructor TFontCacheItem.Create(const AFilename: TfpgString); +begin + inherited Create; + FFileName := AFilename; + FStyleFlags := FPG_FONT_STYLE_REGULAR; + FAngle := 0.0; +end; + +{ TFontCacheList } + +procedure TFontCacheList.SearchForFont(const AFontPath: TfpgString); +var + sr: TSearchRec; + lFont: TFontCacheItem; + s: TfpgString; +begin + // The extra 'or' includes Normal attribute files under Windows. faAnyFile doesn't return those. + // Reported to FPC as bug 9440 in Mantis. + if fpgFindFirst(AFontPath + AllFilesMask, faAnyFile or $00000080, sr) = 0 then + begin + repeat + // check if special files to skip + if (sr.Name = '.') or (sr.Name = '..') or (sr.Name = '') then + Continue; + // We got something, so lets continue + s := fpgFromOSEncoding(sr.Name); + if (sr.Attr and faDirectory) <> 0 then // found a directory + SearchForFont(fpgAppendPathDelim(AFontPath + s)) + else + begin // we have a file + if (lowercase(fpgExtractFileExt(s)) = '.ttf') or + (lowercase(fpgExtractFileExt(s)) = '.otf') then + begin + lFont := BuildFontCacheItem(AFontPath + s); + Add(lFont); + end; + end; + until fpgFindNext(sr) <> 0; + end; +end; + +function TFontCacheList.BuildFontCacheItem(const AFontFile: TfpgString): TFontCacheItem; +var + face_ptr: FT_Face_ptr; + s: Ansistring; + i: integer; + flags: integer; +begin + FT_New_Face(m_library, PChar(AFontFile), 0, face_ptr); + Result := TFontCacheItem.Create(AFontFile); + Result.FamilyName := face_ptr^.family_name; + + // extract simple styles first +// if (face_ptr^.face_flags and FT_FACE_FLAG_FIXED_WIDTH) <> 0 then +// Result.StyleFlags := FPG_FONT_STYLE_FIXEDWIDTH; // this should overwrite Regular style + + if (face_ptr^.style_flags and FT_STYLE_FLAG_ITALIC) <> 0 then + Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_ITALIC; + + if (face_ptr^.style_flags and FT_STYLE_FLAG_BOLD) <> 0 then + Result.StyleFlags := Result.StyleFlags or FPG_FONT_STYLE_BOLD; + + // Now to more complex styles stored in StyleName field. eg: 'Condensed Medium' + s := face_ptr^.style_name; + flags := Result.StyleFlags; + SetStyleIfExists(s, flags, 'Condensed', FPG_FONT_STYLE_CONDENSED); + SetStyleIfExists(s, flags, 'ExtraLight', FPG_FONT_STYLE_EXTRALIGHT); + SetStyleIfExists(s, flags, 'Light', FPG_FONT_STYLE_LIGHT); + SetStyleIfExists(s, flags, 'Semibold', FPG_FONT_STYLE_SEMIBOLD); + SetStyleIfExists(s, flags, 'Medium', FPG_FONT_STYLE_MEDIUM); + SetStyleIfExists(s, flags, 'Black', FPG_FONT_STYLE_BLACK); + Result.StyleFlags := flags; + + FT_Done_Face(face_ptr); +end; + +procedure TFontCacheList.SetStyleIfExists(var AText: Ansistring; var AStyleFlags: integer; + const AStyleName: AnsiString; const AStyleBit: integer); +var + i: integer; +begin + i := Pos(AStyleName, AText); + if i > 0 then + begin + AStyleFlags := AStyleFlags or AStyleBit; + Delete(AText, Length(AStyleName), i); + end; +end; + +function TFontCacheList.GetCount: integer; +begin + Result := FList.Count; +end; + +function TFontCacheList.GetItem(AIndex: Integer): TFontCacheItem; +begin + Result := TFontCacheItem(FList.Items[AIndex]); +end; + +procedure TFontCacheList.SetItem(AIndex: Integer; AValue: TFontCacheItem); +begin + FList.Items[AIndex] := AValue; +end; + +constructor TFontCacheList.Create; +begin + inherited Create; + FList := TObjectList.Create; +end; + +destructor TFontCacheList.Destroy; +begin + FList.Free; + inherited Destroy; +end; + +procedure TFontCacheList.BuildFontCache; +var + lPath: TfpgString; + lPathList: TStringList; + i: integer; +begin + try + m_library := nil; + FT_Init_FreeType(m_library); + + lPathList := TStringList.Create; + lPathList.Add('/usr/share/cups/fonts/'); + lPathList.Add('/usr/share/fonts/truetype/'); + lPathList.Add('/usr/local/lib/X11/fonts/'); + lPathList.Add(GetUserDir + '.fonts/'); + for i := 0 to lPathList.Count-1 do + begin + lPath := lPathList[i]; + SearchForFont(lPath); + end; + finally + FT_Done_FreeType(m_library); + m_library := nil; + lPathList.Free; + end; +end; + +function TFontCacheList.Add(const AObject: TFontCacheItem): integer; +begin + Result := FList.Add(AObject); +end; + +procedure TFontCacheList.Clear; +begin + FList.Clear; +end; + +function TFontCacheList.IndexOf(const AObject: TFontCacheItem): integer; +begin + Result := FList.IndexOf(AObject); +end; + +function TFontCacheList.Find(const AFontCacheItem: TFontCacheItem): integer; +var + i: integer; +begin + Result := -1; // nothing found + for i := 0 to Count-1 do + begin + if (Items[i].FamilyName = AFontCacheItem.FamilyName) and + (Items[i].StyleFlags = AFontCacheItem.StyleFlags) then + begin + Result := i; + exit; + end; + end; +end; + + +initialization + uFontCacheList := nil; + +finalization + uFontCacheList.Free; + +end. + diff --git a/src/corelib/render/software/platform/mac/agg_platform_support.pas b/src/corelib/render/software/platform/mac/agg_platform_support.pas index 608b7854..e9886b64 100644 --- a/src/corelib/render/software/platform/mac/agg_platform_support.pas +++ b/src/corelib/render/software/platform/mac/agg_platform_support.pas @@ -92,10 +92,10 @@ type // Possible formats of the rendering buffer. Initially I thought that it's // reasonable to create the buffer and the rendering functions in // accordance with the native pixel format of the system because it -// would have no overhead for pixel format conersion. +// would have no overhead for pixel format conversion. // But eventually I came to a conclusion that having a possibility to // convert pixel formats on demand is a good idea. First, it was X11 where -// there lots of different formats and visuals and it would be great to +// there are lots of different formats and visuals and it would be great to // render everything in, say, RGB-24 and display it automatically without // any additional efforts. The second reason is to have a possibility to // debug renderers for different pixel formats and colorspaces having only diff --git a/src/corelib/x11/fpg_netlayer_x11.pas b/src/corelib/x11/fpg_netlayer_x11.pas index b328378d..eb9207b0 100644 --- a/src/corelib/x11/fpg_netlayer_x11.pas +++ b/src/corelib/x11/fpg_netlayer_x11.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -415,7 +415,7 @@ begin end; if AValue = nmsBoth then Exit; - // now remove properties we dont want + // now remove properties we don't want Msg.data.l[0] := _NET_WM_STATE_REMOVE; Msg.data.l[1] := 0; @@ -690,6 +690,8 @@ var bytes_after: culong; begin Result := False; + if (AWindow = 0) or (AProperty = 0) then + Exit; XGetWindowProperty (FDisplay, AWindow, AProperty, 0, MaxInt, TBool(False), XA_ATOM, @atomtype, @format, @nitems, @bytes_after, @Atoms); diff --git a/src/corelib/x11/fpg_x11.pas b/src/corelib/x11/fpg_x11.pas index 20974dfe..569772ae 100644 --- a/src/corelib/x11/fpg_x11.pas +++ b/src/corelib/x11/fpg_x11.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2011 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -24,7 +24,7 @@ unit fpg_x11; { TODO : Compiz effects: Menu popup with correct window hint. Same for Combo dropdown window. } { TODO : Under Compiz restoring a window position moves the window down/right the width and height - of the window borders. This as something to do with win_gravity = StaticGravity setting. } + of the window borders. This has something to do with win_gravity = StaticGravity setting. } interface @@ -215,6 +215,7 @@ type public constructor Create(awin: TfpgWindowBase); override; destructor Destroy; override; + procedure CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; var ASrcRect: TfpgRect); override; end; @@ -315,6 +316,7 @@ type xia_wm_delete_window: TAtom; xia_wm_state: TAtom; xia_targets: TAtom; + xia_save_targets: TAtom; netlayer: TNETWindowLayer; InputMethod: PXIM; InputContext: PXIC; @@ -322,6 +324,7 @@ type function DoGetFontFaceList: TStringList; override; procedure DoWaitWindowMessage(atimeoutms: integer); override; function MessagesPending: boolean; override; + function GetHelpViewer: TfpgString; override; public constructor Create(const AParams: string); override; destructor Destroy; override; @@ -340,11 +343,17 @@ type TfpgX11Clipboard = class(TfpgClipboardBase) private FWaitingForSelection: Boolean; + FOwnsSelection: Boolean; + procedure SendClipboardToManager; + procedure DoLostSelection; + procedure DoSetTargets(AWin: TWindow; AProperty: TAtom); protected FClipboardText: TfpgString; function DoGetText: TfpgString; override; procedure DoSetText(const AValue: TfpgString); override; procedure InitClipboard; override; + public + destructor Destroy; override; end; @@ -420,6 +429,7 @@ implementation uses baseunix, + unix, {$IFDEF LINUX} users, { For Linux user and group name support. FPC only supports this in Linux. } {$ENDIF} @@ -430,6 +440,7 @@ uses fpg_utils, fpg_form, // for modal event support fpg_cmdlineparams, + fpg_constants, cursorfont, xatom, // used for XA_WM_NAME keysym, @@ -477,20 +488,27 @@ begin Result := Result or ((rgb and $F80000) shr 8); end; +function ConvertTo555Pixel(rgb: longword): word; +begin + Result := (rgb and $F8) shr 3; + Result := Result or ((rgb and $F800) shr 6); + Result := Result or ((rgb and $F80000) shr 9); +end; + function fpgColorToX(col: TfpgColor): longword; var xc: TXColor; c: TfpgColor; begin c := fpgColorToRGB(col); - if xapplication.DisplayDepth >= 24 then Result := c and $FFFFFF { No Alpha channel information } else if xapplication.DisplayDepth = 16 then Result := ConvertTo565Pixel(c) + else if (xapplication.DisplayDepth = 15) then + Result := ConvertTo555Pixel(c) else begin - c := col; xc.blue := (c and $000000FF) shl 8; xc.green := (c and $0000FF00); xc.red := (c and $00FF0000) shr 8; @@ -665,29 +683,93 @@ begin end; // clipboard event +procedure HandleAtom(var e: TXSelectionEvent; const Atom: TAtom; Prop: TAtom); forward; + + +procedure HandleMultiple(var e: TXSelectionEvent); +type + TAtomPair = record + Target: TAtom; + Prop: TAtom; + end; + +var + Atom: TAtom; + Length: culong; + BytesLeft: culong; + Format: DWord; + Data: Pointer; + xia_Atom_Pair: TAtom; + AtomPair: TAtomPair; + i: Integer; + r: cint; +begin + + xia_Atom_Pair := XInternAtom(xapplication.Display, 'ATOM_PAIR', False); + + // find out how much data there is + r := XGetWindowProperty(xapplication.Display, e.requestor, e._property, 0, 0, False, AnyPropertyType, + @Atom, @Format, @Length, @BytesLeft, @Data); + + if (r <> Success) or (Format <> 32) or (Atom <> xia_Atom_Pair) then + Exit; // ==> + + // read one entry at a time + while BytesLeft > 0 do + begin + // read the data + r := XGetWindowProperty(xapplication.Display, e.requestor, e._property, 0, SizeOf(AtomPair), False, AnyPropertyType, + @Atom, @Format, @Length, @BytesLeft, @Data); + + if r <> Success then + Exit; // ==> + + // copy data to our variable + Move(Data^, AtomPair, SizeOf(TAtomPair)); + XFree(Data); + + // process this target in the list; + HandleAtom(e, AtomPair.Target, AtomPair.Prop); + end; +end; + +procedure HandleAtom(var e: TXSelectionEvent; const Atom: TAtom; Prop: TAtom); +begin + if Atom = None then + begin + Exit; // ==> + end; + + if Atom = xapplication.xia_targets then + begin + fpgClipboard.DoSetTargets(e.requestor, Prop); + end + else if Atom = XInternAtom(xapplication.Display, 'MULTIPLE', False) then + begin + // multiple targets + HandleMultiple(e); + end + else// if Atom = XA_STRING then + begin + XChangeProperty(xapplication.Display, e.requestor, Prop, Atom, + 8, PropModeReplace, PByte(@fpgClipboard.FClipboardText[1]), Length(fpgClipboard.FClipboardText)); + end; + //else WriteLn('Unhandled Selection atom: ', XGetAtomName(xapplication.Display, Atom)); +end; + procedure ProcessSelectionRequest(var ev: TXEvent); var e: TXSelectionEvent; - a: TAtom; begin e._type := SelectionNotify; + e.display := ev.xselectionrequest.display; e.requestor := ev.xselectionrequest.requestor; e.selection := ev.xselectionrequest.selection; e.target := ev.xselectionrequest.target; e.time := ev.xselectionrequest.time; e._property := ev.xselectionrequest._property; - if e.target = xapplication.xia_targets then - begin - a := XA_STRING; - XChangeProperty(xapplication.Display, e.requestor, e._property, XA_ATOM, - 32, PropModeReplace, PByte(@a), Sizeof(TAtom)); // I think last parameter is right? - end - else - begin - XChangeProperty(xapplication.Display, e.requestor, e._property, e.target, - 8, PropModeReplace, PByte(@fpgClipboard.FClipboardText[1]), Length(fpgClipboard.FClipboardText)); - end; + HandleAtom(e, e.target, e._property); XSendEvent(xapplication.Display, e.requestor, false, 0, @e ); end; @@ -1396,6 +1478,7 @@ begin // Initialize atoms xia_clipboard := XInternAtom(FDisplay, 'CLIPBOARD', TBool(False)); xia_targets := XInternAtom(FDisplay, 'TARGETS', TBool(False)); + xia_save_targets := XInternAtom(FDisplay, 'SAVE_TARGETS', TBool(False)); xia_motif_wm_hints := XInternAtom(FDisplay, '_MOTIF_WM_HINTS', TBool(False)); xia_wm_protocols := XInternAtom(FDisplay, 'WM_PROTOCOLS', TBool(False)); xia_wm_delete_window := XInternAtom(FDisplay, 'WM_DELETE_WINDOW', TBool(False)); @@ -1433,6 +1516,16 @@ begin fpgCheckTimers; end; +function TfpgX11Application.GetHelpViewer: TfpgString; +begin + Result := inherited GetHelpViewer; + if not fpgFileExists(Result) then + begin + if fpsystem('which ' + FPG_HELPVIEWER) = 0 then + Result := FPG_HELPVIEWER; + end; +end; + function GetParentWindow(wh: TfpgWinHandle; var pw, rw: TfpgWinHandle): boolean; var rootw: TfpgWinHandle; @@ -1749,31 +1842,50 @@ begin if not blockmsg then begin if (ev.xbutton.button >= 4) and (ev.xbutton.button <= 7) then // mouse wheel + // 4=up, 5=down, 6=left, 7=right begin // generate scroll events: if ev._type = X.ButtonPress then begin - if ev.xbutton.button = Button4 then + if (ev.xbutton.button = Button4) or (ev.xbutton.button = 6) then // x.pp lacks Button6, Button7 i := -1 else i := 1; // Check for other mouse wheel messages in the queue - while XCheckTypedWindowEvent(display, ev.xbutton.window, X.ButtonPress, @NewEvent) do - begin - if NewEvent.xbutton.Button = 4 then - Dec(i) - else if NewEvent.xbutton.Button = 5 then - Inc(i) - else - begin - XPutBackEvent(display, @NewEvent); - break; - end; - end; + if ev.xbutton.button in [Button4,Button5] then + while XCheckTypedWindowEvent(display, ev.xbutton.window, X.ButtonPress, @NewEvent) do + begin + if NewEvent.xbutton.Button = 4 then + Dec(i) + else if NewEvent.xbutton.Button = 5 then + Inc(i) + else + begin + XPutBackEvent(display, @NewEvent); + break; + end; + end + else // button is 6 or 7 + while XCheckTypedWindowEvent(display, ev.xbutton.window, X.ButtonPress, @NewEvent) do + begin + if NewEvent.xbutton.Button = 6 then + Dec(i) + else if NewEvent.xbutton.Button = 7 then + Inc(i) + else + begin + XPutBackEvent(display, @NewEvent); + break; + end; + end; msgp.mouse.delta := i; - fpgPostMessage(nil, w, FPGM_SCROLL, msgp); + + if ev.xbutton.button in [Button4,Button5] then + fpgPostMessage(nil, w, FPGM_SCROLL, msgp) + else + fpgPostMessage(nil, w, FPGM_HSCROLL, msgp); end; end else @@ -2026,9 +2138,13 @@ begin X.SelectionClear: begin { TODO : Not sure if I am handling this correctly? } + { We Get this message when another program has declared that + it has ownership of the xia_clipboard selection atom + } if ev.xselectionclear.selection = xia_clipboard then begin fpgClipboard.FClipboardText := ''; + fpgClipboard.DoLostSelection; Exit; end; end; @@ -2281,9 +2397,17 @@ begin if (FWindowType <> wtChild) and (waSizeable in FWindowAttributes) then begin - hints.flags := hints.flags or PMinSize; + hints.flags := hints.flags or PMinSize or PMaxSize; hints.min_width := FMinWidth; hints.min_height := FMinHeight; + if FMaxWidth > 0 then + hints.max_width := FMaxWidth + else + hints.max_width := xapplication.ScreenWidth; + if FMaxHeight > 0 then + hints.max_height := FMaxHeight + else + hints.max_height := xapplication.ScreenHeight; end else begin @@ -2736,6 +2860,13 @@ begin inherited Destroy; end; +procedure TfpgX11Canvas.CopyRect(ADest_x, ADest_y: TfpgCoord; ASrcCanvas: TfpgCanvasBase; + var ASrcRect: TfpgRect); +begin + SortRect(ASrcRect); + XCopyArea(xapplication.Display, TfpgX11Canvas(ASrcCanvas).FDrawHandle, FDrawHandle, Fgc, ASrcRect.Left, ASrcRect.Top, ASrcRect.Width, ASrcRect.Height, ADest_x, ADest_y); +end; + procedure TfpgX11Canvas.DoBeginDraw(awin: TfpgWindowBase; buffered: boolean); var x: integer; @@ -2907,7 +3038,8 @@ begin Trunc(64 * a1), Trunc(64 * a2)); end; -procedure TfpgX11Canvas.DoDrawPolygon(Points: fpg_base.PPoint; NumPts: Integer; Winding: boolean); +procedure TfpgX11Canvas.DoDrawPolygon(Points: PPoint; NumPts: Integer; + Winding: boolean); var PointArray: PXPoint; i: integer; @@ -3265,8 +3397,70 @@ end; { TfpgX11Clipboard } +procedure TfpgX11Clipboard.SendClipboardToManager; +var + ClipboardManager: TAtom; + StartTime: DWord; +begin + // if we don't own the clipboard then there is nothing to save + if not FOwnsSelection then + Exit; // ==> + + // check if the manager atom exists + ClipboardManager:= XInternAtom(xapplication.Display, 'CLIPBOARD_MANAGER', False); + if ClipboardManager = None then + Exit; // ==> + + // check if a program has control of the manager atom + if XGetSelectionOwner(xapplication.Display, ClipboardManager) = None then + Exit; // ==> + + // this triggers the manager to request the clipboard contents from us + XConvertSelection(xapplication.Display, + ClipboardManager, + xapplication.xia_save_targets, + None, //XInternAtom(xapplication.Display, 'FPG_CLIPBOARD', True), // 'None' seems to work as the property name + FClipboardWndHandle, + CurrentTime); + + XSync(xapplication.Display, False); + + StartTime := fpgGetTickCount; + // now wait for the manager to get the clipboard + repeat + fpgWaitWindowMessage; + fpgDeliverMessages; + until not FOwnsSelection or ((fpgGetTickCount - StartTime) > 3000); // allow 3 seconds for the clipboard to be read +end; + +procedure TfpgX11Clipboard.DoLostSelection; +begin + FOwnsSelection := False; +end; + +procedure TfpgX11Clipboard.DoSetTargets(AWin: TWindow; AProperty: TAtom); +const + target_count = 3; +var + targets: array[0..target_count-1] of TAtom; +begin + + targets[0] := XA_STRING; + targets[1] := xapplication.xia_targets; + targets[2] := xapplication.xia_save_targets; + //targets[3] := XInternAtom(xapplication.Display, 'UTF8_STRING', True); + //targets[4] := XInternAtom(xapplication.Display, 'MULTIPLE', True); + + // list the types of data we have in the clipboard + XChangeProperty(xapplication.Display, AWin, AProperty, XA_ATOM, 32, + PropModeReplace, @targets[0], target_count); +end; + function TfpgX11Clipboard.DoGetText: TfpgString; begin + if FOwnsSelection then + Exit(FClipboardText); // ==> + XConvertSelection(xapplication.Display, xapplication.xia_clipboard, XA_STRING, xapplication.xia_clipboard, FClipboardWndHandle, 0); @@ -3286,6 +3480,8 @@ begin FClipboardText := AValue; XSetSelectionOwner(xapplication.Display, xapplication.xia_clipboard, FClipboardWndHandle, CurrentTime); + DoSetTargets(FClipboardWndHandle, xapplication.xia_targets); + FOwnsSelection := True; end; procedure TfpgX11Clipboard.InitClipboard; @@ -3295,6 +3491,12 @@ begin xapplication.RootWindow, 10, 10, 10, 10, 0, 0, 0); end; +destructor TfpgX11Clipboard.Destroy; +begin + SendClipboardToManager; + inherited Destroy; +end; + { TfpgX11FileList } function TfpgX11FileList.EncodeModeString(FileMode: longword): TFileModeString; diff --git a/src/corelib/x11/fpgui_toolkit.lpk b/src/corelib/x11/fpgui_toolkit.lpk index c769331e..ec8c841f 100644 --- a/src/corelib/x11/fpgui_toolkit.lpk +++ b/src/corelib/x11/fpgui_toolkit.lpk @@ -1,4 +1,4 @@ -<?xml version="1.0"?> +<?xml version="1.0" encoding="UTF-8"?> <CONFIG> <Package Version="4"> <Name Value="fpgui_toolkit"/> @@ -28,8 +28,8 @@ </CompilerOptions> <Description Value="fpGUI Toolkit"/> <License Value="LGPL 2 with static linking exception."/> - <Version Major="1"/> - <Files Count="99"> + <Version Major="1" Minor="2"/> + <Files Count="107"> <Item1> <Filename Value="../stdimages.inc"/> <Type Value="Include"/> @@ -426,6 +426,38 @@ <Filename Value="../render/software/Agg2D.pas"/> <UnitName Value="Agg2D"/> </Item99> + <Item100> + <Filename Value="../fpg_dbugintf.pas"/> + <UnitName Value="fpg_dbugintf"/> + </Item100> + <Item101> + <Filename Value="../fpg_dbugmsg.pas"/> + <UnitName Value="fpg_dbugmsg"/> + </Item101> + <Item102> + <Filename Value="../render/software/fpg_fontcache.pas"/> + <UnitName Value="fpg_fontcache"/> + </Item102> + <Item103> + <Filename Value="../../gui/fpg_style_carbon.pas"/> + <UnitName Value="fpg_style_carbon"/> + </Item103> + <Item104> + <Filename Value="../../gui/fpg_style_plastic.pas"/> + <UnitName Value="fpg_style_plastic"/> + </Item104> + <Item105> + <Filename Value="../../gui/fpg_style_win8.pas"/> + <UnitName Value="fpg_style_win8"/> + </Item105> + <Item106> + <Filename Value="../../gui/fpg_scrollframe.pas"/> + <UnitName Value="fpg_scrollframe"/> + </Item106> + <Item107> + <Filename Value="../../gui/inputintegerdialog.inc"/> + <Type Value="Include"/> + </Item107> </Files> <LazDoc Paths="../../../docs/xml/corelib;../../../docs/xml/corelib/x11;../../../docs/xml/corelib/gdi;../../../docs/xml/gui"/> <RequiredPkgs Count="1"> diff --git a/src/corelib/x11/fpgui_toolkit.pas b/src/corelib/x11/fpgui_toolkit.pas index 10dc7f27..86e456f4 100644 --- a/src/corelib/x11/fpgui_toolkit.pas +++ b/src/corelib/x11/fpgui_toolkit.pas @@ -8,19 +8,22 @@ interface uses fpg_base, fpg_main, fpg_cmdlineparams, fpg_command_intf, fpg_constants, - fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, fpg_popupwindow, - fpg_stdimages, fpg_stringhashlist, fpg_translations, fpg_stringutils, fpg_utils, - fpg_widget, fpg_wuline, fpg_impl, fpg_x11, fpg_netlayer_x11, fpg_keyconv_x11, - fpg_xft_x11, fpg_animation, fpg_basegrid, fpg_button, fpg_checkbox, fpg_combobox, - fpg_customgrid, fpg_dialogs, fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, - fpg_hyperlink, fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, fpg_menu, + fpg_extinterpolation, fpg_imagelist, fpg_imgfmt_bmp, fpg_pofiles, + fpg_popupwindow, fpg_stdimages, fpg_stringhashlist, fpg_translations, + fpg_stringutils, fpg_utils, fpg_widget, fpg_wuline, fpg_impl, fpg_x11, + fpg_netlayer_x11, fpg_keyconv_x11, fpg_xft_x11, fpg_animation, fpg_basegrid, + fpg_button, fpg_checkbox, fpg_combobox, fpg_customgrid, fpg_dialogs, + fpg_editcombo, fpg_edit, fpg_form, fpg_gauge, fpg_grid, fpg_hyperlink, + fpg_iniutils, fpg_label, fpg_listbox, fpg_listview, fpg_memo, fpg_menu, fpg_mru, fpg_panel, fpg_popupcalendar, fpg_progressbar, fpg_radiobutton, - fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, fpg_splitter, - fpg_hint, fpg_spinedit, fpg_extgraphics, fpg_ColorMapping, fpg_ColorWheel, - fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, fpg_stylemanager, - fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, fpg_style_bluecurve, - fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, U_Command, U_Pdf, U_Report, - U_ReportImages, U_Visu, fpg_trayicon, Agg2D; + fpg_scrollbar, fpg_style, fpg_tab, fpg_trackbar, fpg_tree, fpgui_db, + fpg_splitter, fpg_hint, fpg_spinedit, fpg_extgraphics, fpg_ColorMapping, + fpg_ColorWheel, fpg_interface, fpg_editbtn, fpg_imgfmt_jpg, fpg_imgutils, + fpg_stylemanager, fpg_style_win2k, fpg_style_motif, fpg_style_clearlooks, + fpg_style_bluecurve, fpg_style_bitmap, fpg_readonly, fpg_imgfmt_png, + U_Command, U_Pdf, U_Report, U_ReportImages, U_Visu, fpg_trayicon, Agg2D, + fpg_dbugintf, fpg_dbugmsg, fpg_fontcache, fpg_style_carbon, + fpg_style_plastic, fpg_style_win8, fpg_scrollframe; implementation diff --git a/src/extrafpc.cfg b/src/extrafpc.cfg index 24f678b2..d1600da1 100644 --- a/src/extrafpc.cfg +++ b/src/extrafpc.cfg @@ -26,6 +26,8 @@ # For a release compile with optimizes and strip debuginfo #IFDEF RELEASE -Xs + -O2 + -B #WRITE Compiling Release Version #ENDIF @@ -33,6 +35,7 @@ #IFDEF DEBUG -g -Crtoi + -B #WRITE Compiling Debug Version #ENDIF diff --git a/src/gui/fpg_animation.pas b/src/gui/fpg_animation.pas index 36972877..468016f8 100644 --- a/src/gui/fpg_animation.pas +++ b/src/gui/fpg_animation.pas @@ -48,7 +48,7 @@ type protected procedure HandlePaint; override; procedure SetEnabled(const AValue: boolean); override; - procedure SetImageFilename(const AValue: TfpgString); virtual; + procedure SetImageFilename(const AValue: TfpgString); overload; // property Interval: integer read FInterval write SetInterval default 50; property ImageFileName: TfpgString read FImageFilename write SetImageFilename; @@ -58,6 +58,9 @@ type public constructor Create(AOwner: TComponent); override; destructor Destroy; override; + procedure ImageFromByteArray(ABmp: Pointer; ASize: longword); overload; + procedure ImageFromByteArray(ABmp: Pointer; ASize: longword; AMaskSample: TPoint); overload; + procedure SetImageFilename(const AValue: TfpgString; AMaskSample: TPoint); overload; end; @@ -121,7 +124,7 @@ end; procedure TfpgBaseImgAnim.HandlePaint; begin - if (FImageFilename = '') or (FImage = nil) then + if (FImage = nil) then Exit; //==> Canvas.BeginDraw; Canvas.Clear(clWindowBackground); @@ -138,6 +141,11 @@ end; procedure TfpgBaseImgAnim.SetImageFilename(const AValue: TfpgString); begin + SetImageFilename(AValue, Point(0,0)); +end; + +procedure TfpgBaseImgAnim.SetImageFilename(const AValue: TfpgString; AMaskSample: TPoint); +begin if FImageFilename = AValue then Exit; //==> @@ -154,7 +162,29 @@ begin FImage := LoadImage_BMP(FImageFilename); if FTransparent then begin - FImage.CreateMaskFromSample(0, 0); + FImage.CreateMaskFromSample(AMaskSample.X, AMaskSample.Y); + FImage.UpdateImage; + end; + RecalcImageWidth; + Repaint; +end; + +procedure TfpgBaseImgAnim.ImageFromByteArray(ABmp: Pointer; ASize: longword); +begin + ImageFromByteArray(ABmp, ASize, Point(0,0)); +end; + +procedure TfpgBaseImgAnim.ImageFromByteArray(ABmp: Pointer; ASize: longword; AMaskSample: TPoint); +begin + if ABmp=nil then + Exit; + + FTimer.Enabled := False; + FImage.Free; + FImage := CreateImage_BMP(ABmp, ASize); + if FTransparent then + begin + FImage.CreateMaskFromSample(AMaskSample.X, AMaskSample.Y); FImage.UpdateImage; end; RecalcImageWidth; diff --git a/src/gui/fpg_basegrid.pas b/src/gui/fpg_basegrid.pas index 51b50408..cbce739f 100644 --- a/src/gui/fpg_basegrid.pas +++ b/src/gui/fpg_basegrid.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -40,6 +40,7 @@ type TfpgGridHeaderStyle = (ghsButton, ghsThin, ghsFlat); TfpgFocusChangeNotify = procedure(Sender: TObject; ARow, ACol: Integer) of object; + TfpgHeaderClick = procedure(Sender: TObject; ACol: Integer) of object; TfpgRowChangeNotify = procedure(Sender: TObject; ARow: Integer) of object; TfpgCanSelectCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; var ACanSelect: boolean) of object; TfpgDrawCellEvent = procedure(Sender: TObject; const ARow, ACol: Integer; const ARect: TfpgRect; const AFlags: TfpgGridDrawState; var ADefaultDrawing: boolean) of object; @@ -50,12 +51,14 @@ type // Column 2 is special just for testing purposes. Descendant classes will // override that special behavior anyway. + TfpgBaseGrid = class(TfpgWidget) private FColResizing: boolean; FDragPos: integer; // used for column resizing FHeaderStyle: TfpgGridHeaderStyle; FOnDrawCell: TfpgDrawCellEvent; + FOnHeaderClick: TfpgHeaderClick; FResizedCol: integer; // used for column resizing FDefaultColWidth: integer; FDefaultRowHeight: integer; @@ -70,7 +73,6 @@ type FFirstRow: Integer; FFirstCol: Integer; FXOffset: integer; // used for go_SmoothScroll - FMargin: integer; FFont: TfpgFont; FHeaderFont: TfpgFont; FRowSelect: boolean; @@ -88,6 +90,7 @@ type function GetFontDesc: string; function GetHeaderFontDesc: string; function GetTotalColumnWidth: integer; + function GetAdjustedBorderSizes: TRect; procedure HScrollBarMove(Sender: TObject; position: integer); procedure SetFontDesc(const AValue: string); procedure SetHeaderFontDesc(const AValue: string); @@ -103,8 +106,6 @@ type procedure SetShowGrid(const AValue: boolean); procedure SetShowHeader(const AValue: boolean); function VisibleLines: Integer; - function VisibleWidth: integer; - function VisibleHeight: integer; procedure SetFirstRow(const AValue: Integer); procedure SetAlternativeBGColor(const AValue: TfpgColor); procedure SetBorderStyle(AValue: TfpgEditBorderStyle); @@ -132,11 +133,13 @@ type procedure HandleResize(awidth, aheight: TfpgCoord); override; procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; procedure HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); override; procedure HandleLMouseUp(x, y: integer; shiftstate: TShiftState); override; procedure HandleLMouseDown(x, y: integer; shiftstate: TShiftState); override; procedure HandleRMouseUp(x, y: integer; shiftstate: TShiftState); override; procedure FollowFocus; virtual; + procedure PrepareCells (firstrow, lastrow, firstcol, lastcol : integer); virtual; property AlternateBGColor: TfpgColor read FAlternativeBGColor write SetAlternativeBGColor default clHilite1; property BorderStyle: TfpgEditBorderStyle read FBorderStyle write SetBorderStyle default ebsDefault; property DefaultColWidth: integer read FDefaultColWidth write SetDefaultColWidth default 64; @@ -166,6 +169,7 @@ type property Options: TfpgGridOptions read FOptions write FOptions default []; property OnDrawCell: TfpgDrawCellEvent read FOnDrawCell write FOnDrawCell; property OnFocusChange: TfpgFocusChangeNotify read FOnFocusChange write FOnFocusChange; + property OnHeaderClick: TfpgHeaderClick read FOnHeaderClick write FOnHeaderClick; property OnRowChange: TfpgRowChangeNotify read FOnRowChange write FOnRowChange; property OnCanSelectCell: TfpgCanSelectCellEvent read FOnCanSelectCell write FOnCanSelectCell; public @@ -176,6 +180,9 @@ type procedure BeginUpdate; procedure EndUpdate; procedure MouseToCell(X, Y: Integer; var ACol, ARow: Integer); + function GetClientRect: TfpgRect; override; + function VisibleWidth: integer; + function VisibleHeight: integer; end; @@ -226,6 +233,32 @@ begin Result := Result + ColumnWidth[i]; end; +// Adjust theme borders based on BorderStyle property +function TfpgBaseGrid.GetAdjustedBorderSizes: TRect; +begin + Result := fpgStyle.GetControlFrameBorders; + case BorderStyle of + ebsNone: + begin + Result.Left := 0; + Result.Right := 0; + Result.Top := 0; + Result.Bottom := 0; + end; + ebsDefault: + begin + // do nothing - the theme values are correct + end; + ebsSingle: + begin + Result.Left := 1; + Result.Right := 1; + Result.Top := 1; + Result.Bottom := 1; + end; + end; +end; + procedure TfpgBaseGrid.SetFontDesc(const AValue: string); begin FFont.Free; @@ -528,7 +561,7 @@ begin hh := 0; if ShowHeader then hh := hh + FHeaderHeight+1; - Result := (Height - (2*FMargin) - hh) div FDefaultRowHeight; + Result := (GetClientRect.Height - hh) div FDefaultRowHeight; end; function TfpgBaseGrid.VisibleWidth: integer; @@ -536,10 +569,10 @@ var sw: integer; begin if FVScrollBar.Visible then - sw := FVScrollBar.Width-1 + sw := FVScrollBar.Width else sw := 0; - Result := Width - (FMargin*2) - sw; + Result := GetClientRect.Width - sw end; function TfpgBaseGrid.VisibleHeight: integer; @@ -547,10 +580,10 @@ var sw: integer; begin if FHScrollBar.Visible then - sw := FHScrollBar.Height-1 + sw := FHScrollBar.Height else sw := 0; - Result := Height - (FMargin*2) - sw; + Result := GetClientRect.Height - sw; end; procedure TfpgBaseGrid.SetFirstRow(const AValue: Integer); @@ -585,76 +618,186 @@ var VHeight: integer; vw: integer; cw: integer; + vl: integer; i: integer; x: integer; -begin - VHeight := Height - 4; - HWidth := Width - 4; - - vw := VisibleWidth; - cw := 0; - for i := 0 to ColumnCount-1 do - cw := cw + ColumnWidth[i]; - - // This needs improving while resizing - if cw > vw then - FHScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssVertical]) - else + hmax: integer; + vmax: integer; + Hfits, showH : boolean; + Vfits, showV : boolean; + crect: TfpgRect; + borders: TRect; + + procedure hideScrollbar (sb : TfpgScrollBar); begin - FHScrollBar.Visible := False; - FFirstCol := 0; - FXOffset := 0; + with sb do + if Visible then + begin + Visible := False; + UpdateWindowPosition; + end; end; - // This needs improving while resizing - if (RowCount > VisibleLines) then - FVScrollBar.Visible := not (FScrollBarStyle in [ssNone, ssHorizontal]) - else + procedure getVisWidth; begin - FVScrollBar.Visible := False; - FFirstRow := 0; + if showV then + vw := HWidth - (FVScrollBar.Width-1) + else + vw := HWidth; + Hfits := vw >= cw; end; - if FVScrollBar.Visible then + procedure getVisLines; + var + hh : integer; // header height begin + hh := 0; + if ShowHeader then + inc (hh, FHeaderHeight+1); + if showH then + inc (hh, FHScrollBar.Height); + vl := (VHeight - hh) div FDefaultRowHeight; + Vfits := vl >= RowCount; + end; + +begin + // if we don't want any scrollbars, hide them and exit + if FScrollBarStyle = ssNone then + begin + hideScrollbar(FHScrollBar); + hideScrollbar(FVScrollBar); + exit; + end; + + borders := GetAdjustedBorderSizes; + // preliminary width/height calculations + crect := GetClientRect; + VHeight := crect.Height; + HWidth := crect.Width; + cw := 0; + for i := 0 to ColumnCount-1 do + cw := cw + ColumnWidth[i]; + showV := False; + showH := False; + getVisWidth; + getVisLines; + + // determine whether to show scrollbars for different configurations + case FScrollBarStyle of + ssHorizontal: + begin + hideScrollbar (FVScrollBar); + if not Hfits then + begin + showH := true; + getVisLines; + end; + end; + ssVertical: + begin + hideScrollbar (FHScrollBar); + if not Vfits then + begin + showV := true; + getVisWidth; + end; + end; + ssAutoBoth: + if not Vfits then + begin + showV := true; + getVisWidth; + if not Hfits then + begin + showH := true; + getVisLines; + getVisWidth; + end; + end + else if not Hfits then + begin + showH := true; + getVisLines; + if not Vfits then + begin + showV := true; + getVisWidth; + getVisLines; + end; + end; + end; + + // set the scrollbar width/height space + if showV then Dec(HWidth, FVScrollBar.Width); - FVScrollBar.Min := 0; + if showH then + Dec(VHeight, FHScrollBar.Height); + + // show or hide the scrollbars + + if showV then + begin + FVScrollBar.Visible := true; + FVScrollBar.Min := 0; if RowCount > 0 then FVScrollBar.SliderSize := VisibleLines / RowCount else FVScrollBar.SliderSize := 0; - FVScrollBar.Max := RowCount-VisibleLines; - FVScrollBar.Position := FFirstRow; + vmax := RowCount - VisibleLines; + if FFirstRow > vmax then + FFirstRow := vmax; + FVScrollBar.Max := vmax; + FVScrollBar.Position := FFirstRow; FVScrollBar.RepaintSlider; + FVScrollBar.Top := borders.Top; + FVScrollBar.Left := Width - FVScrollBar.Width - borders.Right; + FVScrollBar.Height := VHeight; + end + else + begin + FVScrollBar.Visible := false; + if Vfits then + FFirstRow := 0; + // if vertical doesn't fit and no scrollbar, do not change firstrow end; - - if FHScrollBar.Visible then + + if showH then begin - Dec(VHeight, FHScrollBar.Height); + FHScrollBar.Visible := true; FHScrollBar.Min := 0; if go_SmoothScroll in FOptions then begin - FHScrollBar.Max := cw - vw; + hmax := cw - vw; + FHScrollBar.Max := hmax; + if FXOffset>hmax then + FXOffset:=hmax; FHScrollBar.Position := FXOffset; - FHScrollBar.SliderSize := Width / TotalColumnWidth; + FHScrollBar.SliderSize := HWidth / TotalColumnWidth; + FHScrollBar.PageSize := 5; end else begin FHScrollBar.Max := ColumnCount-1; FHScrollBar.Position := FFirstCol; - FHScrollBar.SliderSize := 1 / ColumnCount; + FHScrollBar.SliderSize := 1 / ColumnCount; + FHScrollBar.PageSize := 1; end; FHScrollBar.RepaintSlider; + FHScrollBar.Top := Height - FHScrollBar.Height - borders.Bottom; + FHScrollBar.Left := borders.Left; + FHScrollBar.Width := HWidth; + end + else + begin + FHScrollBar.Visible := False; + if Hfits then + begin + FFirstCol := 0; + FXOffset := 0; + end; + // if horizontal doesn't fit and no scrollbar, do not change firstcol/xoffset end; - FHScrollBar.Top := Height -FHScrollBar.Height - 2; - FHScrollBar.Left := 2; - FHScrollBar.Width := HWidth; - - FVScrollBar.Top := 2; - FVScrollBar.Left := Width - FVScrollBar.Width - 2; - FVScrollBar.Height := VHeight; - FVScrollBar.UpdateWindowPosition; FHScrollBar.UpdateWindowPosition; end; @@ -673,10 +816,12 @@ var clipr: TfpgRect; // clip rectangle drawstate: TfpgGridDrawState; cLeft: integer; - c: integer; + rTop: integer; + firstcol, lastcol, firstrow, lastrow : integer; + cWidths: array of integer; + rect: TRect; begin Canvas.ClearClipRect; - r.SetRect(0, 0, Width, Height); case BorderStyle of ebsNone: @@ -685,51 +830,103 @@ begin end; ebsDefault: begin - Canvas.DrawControlFrame(r); - InflateRect(r, -2, -2); + fpgStyle.DrawControlFrame(Canvas, r); end; ebsSingle: begin Canvas.SetColor(clShadow2); Canvas.DrawRectangle(r); - InflateRect(r, -1, -1); end; end; - Canvas.SetClipRect(r); + r := GetClientRect; + clipr := r; + Canvas.SetClipRect(clipr); Canvas.SetColor(FBackgroundColor); Canvas.FillRectangle(r); - clipr.SetRect(FMargin, FMargin, VisibleWidth, VisibleHeight); - r := clipr; + cLeft := r.Left; // column starting point + rTop := r.Top; // row starting point - cLeft := FMargin; // column starting point if go_SmoothScroll in FOptions then begin if FHScrollBar.Visible then Dec(cLeft, FHScrollBar.Position); - c := 0; + firstcol := 0; end else begin - c := FFirstCol; + firstcol := FFirstCol; end; + // calculate column widths, and first/last columns + if (ColumnCount <= 0) then + begin + firstcol := -1; + lastcol := -2; + end + else + begin + setlength (cWidths, ColumnCount); + r.Left := cLeft; + for col := firstcol to ColumnCount-1 do + begin + cWidths[col] := ColumnWidth[col]; + r.Width := cWidths[col]; + if (go_SmoothScroll in FOptions) and (r.Left <= clipr.Left) then + begin + firstcol := col; + if col>0 then inc (cLeft, cWidths[col-1]); + end; + lastcol := col; + if r.Right >= clipr.Right then + break; + inc (r.Left, r.Width); + end; + // first/last rows... + if (RowCount <= 0) then + begin + firstrow := -1; + lastrow := -2; + end + else + begin + if ShowHeader then + inc (r.Top, FHeaderHeight); + if r.Top > clipr.Bottom then + begin + firstrow := -1; + lastrow := -2; + end + else + begin + firstrow := FFirstRow; + lastrow := firstrow + (clipr.Bottom - r.Top) div DefaultRowHeight; + if lastrow >= RowCount then + lastrow := RowCount-1; + end; + end; + end; + + PrepareCells (firstrow, lastrow, firstcol, lastcol); + + r.Left := cLeft; + r.Top := rTop; + if (ColumnCount > 0) and ShowHeader then begin // Drawing horizontal headers - r.Left := cLeft; r.Height := FHeaderHeight; Canvas.SetFont(FHeaderFont); - for col := c to ColumnCount-1 do + for col := firstcol to lastcol do begin - r.Width := ColumnWidth[col]; + r.Width := cWidths[col]; Canvas.SetClipRect(clipr); Canvas.AddClipRect(r); DrawHeader(col, r, 0); inc(r.Left, r.Width); - if r.Left >= clipr.Right then - Break; // small optimization. Don't draw what we can't see + //if r.Left >= clipr.Right then + // Break; // optimization made obsolete by lastcol end; inc(r.Top, r.Height); end; @@ -740,13 +937,13 @@ begin r.Height := DefaultRowHeight; Canvas.SetFont(FFont); - for row := FFirstRow to RowCount-1 do + for row := firstrow to lastrow do begin r.Left := cLeft; - for col := c to ColumnCount-1 do + for col := firstcol to lastcol do begin drawstate := []; - r.Width := ColumnWidth[col]; + r.Width := cWidths[col]; Canvas.SetClipRect(clipr); if (row = FFocusRow) and (RowSelect or (col = FFocusCol)) and not (go_HideFocusRect in FOptions) then @@ -774,7 +971,6 @@ begin Include(drawstate, gdFocused); if (row = FFocusRow) and (col = FFocusCol) then Include(drawstate, gdSelected); - if DoDrawCellEvent(row, col, r, drawstate) then DrawCell(row, col, r, drawstate); @@ -783,13 +979,13 @@ begin DrawGrid(row, col, r, 0); inc(r.Left, r.Width); - if r.Left >= clipr.Right then - Break; // small optimization. Don't draw what we can't see + //if r.Left >= clipr.Right then + // Break; // optimization made obsolete by lastcol end; // Inc(r.Top, FDefaultRowHeight+1); inc(r.Top, r.Height); - if r.Top >= clipr.Bottom then - break; + //if r.Top >= clipr.Bottom then + // break; // optimization made obsolete by lastrow end; end; // item drawing @@ -1008,49 +1204,66 @@ end; procedure TfpgBaseGrid.HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); var lRow: Integer; - lCol: Integer; begin inherited HandleMouseScroll(x, y, shiftstate, delta); lRow := FFirstRow; - lCol := FFirstCol; - if delta > 0 then // scroll down - inc(FFirstRow, abs(delta)*3) - else // scroll up - if FFirstRow > 0 then - dec(FFirstRow, abs(delta)*3); + // If vertical scrollbar is not visible, but + // horizontal is, Mouse wheel will scroll horizontally. :) + if FHScrollBar.Visible and (not FVScrollBar.Visible) then + begin + HandleMouseHorizScroll(x, y, shiftstate, delta); + Exit; + end; + + inc(FFirstRow, delta*3); // apply limits if FFirstRow > RowCount - VisibleLines then FFirstRow := RowCount - VisibleLines; if FFirstRow < 0 then FFirstRow := 0; - - // scroll left/right - // If vertical scrollbar is not visible, but - // horizontal is. Mouse wheel will scroll horizontally. :) - if FHScrollBar.Visible and (not FVScrollBar.Visible) then - begin - if delta > 0 then // scroll right - begin - if FFirstCol < (ColumnCount-1) then - inc(FFirstCol); - end - else - begin - if FFirstCol > 0 then - dec(FFirstCol); - end; - end; - if (lRow <> FFirstRow) or (lCol <> FFirstCol) then + if lRow <> FFirstRow then begin UpdateScrollBars; RePaint; end; end; +procedure TfpgBaseGrid.HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); +var + old_val: Integer; +begin + inherited HandleMouseHorizScroll(x, y, shiftstate, delta); + + if go_SmoothScroll in Options then + begin + old_val := FXOffset; + inc(FXOffset, delta*FHScrollBar.ScrollStep); + if (FXOffset<0) then + FXOffset:=0; + // finding the maximum Xoffset is tricky, let updatescrollbars do it. + if (FXOffset=old_val) then + Exit; + end + else + begin + old_val := FFirstCol; + inc(FFirstCol, delta); + if FFirstCol<0 then + FFirstCol:=0 + else if FFirstCol > ColumnCount-1 then + FFirstCol:=ColumnCount-1; + if FFirstCol=old_val then + Exit; + end; + + UpdateScrollBars; + RePaint; +end; + procedure TfpgBaseGrid.HandleMouseMove(x, y: integer; btnstate: word; shiftstate: TShiftState); var hh: integer; @@ -1059,6 +1272,7 @@ var colresize: boolean; cLeft: integer; c: integer; + borders: TRect; begin inherited HandleMouseMove(x, y, btnstate, shiftstate); @@ -1082,8 +1296,9 @@ begin begin colresize := False; hh := FHeaderHeight; + borders := GetAdjustedBorderSizes; - cLeft := FMargin; // column starting point + cLeft := borders.Left; // column starting point if go_SmoothScroll in FOptions then begin if FHScrollBar.Visible then @@ -1095,7 +1310,7 @@ begin c := FFirstCol; end; - if (y <= FMargin + hh) then // we are over the Header row + if (y <= (borders.Top + hh)) then // we are over the Header row begin cw := 0; for n := c to ColumnCount-1 do @@ -1120,12 +1335,62 @@ begin end; procedure TfpgBaseGrid.HandleLMouseUp(x, y: integer; shiftstate: TShiftState); +var + lColumn: integer; + hh: integer; { header height } + cLeft: integer; { column left } + c: integer; + n: integer; + cw: integer; + borders: TRect; begin inherited HandleLMouseUp(x, y, shiftstate); + if not FColResizing then + begin + if not ShowHeader then + Exit; + if (ColumnCount = 0) then + Exit; //==> + // searching for the appropriate character position + hh := FHeaderHeight; + borders := GetAdjustedBorderSizes; + + if (y < (borders.Top+hh)) then // inside Header row + begin + {$IFDEF DEBUG} Writeln('header click...'); {$ENDIF} + + cLeft := borders.Left; // column starting point + if go_SmoothScroll in FOptions then + begin + if FHScrollBar.Visible then + Dec(cLeft, FHScrollBar.Position); + c := 0; + end + else + begin + c := FFirstCol; + end; + + cw := 0; + for n := c to ColumnCount-1 do + begin + inc(cw, ColumnWidth[n]); + if x < (cLeft+cw+4) then + begin + if Assigned(FOnHeaderClick) then + FOnHeaderClick(self, n); + Break; + end; + end; { for } + end; + end; {if not FColResizing } + {$IFDEF DEBUG} if FColResizing then + begin Writeln('Column ', FResizedCol,' width = ', ColumnWidth[FResizedCol]); + end; {$ENDIF} FColResizing := False; @@ -1142,6 +1407,7 @@ var pcol: Integer; c: integer; cLeft: integer; + borders: TRect; begin inherited HandleLMouseDown(x, y, shiftstate); @@ -1150,18 +1416,19 @@ begin pcol := FFocusCol; prow := FFocusRow; + borders := GetAdjustedBorderSizes; // searching for the appropriate character position if ShowHeader then - hh := FHeaderHeight+1 + hh := FHeaderHeight else hh := 0; - if ShowHeader and (y <= FMargin+hh) then // inside Header row + if ShowHeader and (y < (borders.Top+hh)) then // inside Header row begin {$IFDEF DEBUG} Writeln('header click...'); {$ENDIF} - cLeft := FMargin; // column starting point + cLeft := borders.Left; // column starting point if go_SmoothScroll in FOptions then begin if FHScrollBar.Visible then @@ -1226,7 +1493,7 @@ begin else hh := 0; - if ShowHeader and (y > FMargin+hh) then // not in Header row + if ShowHeader and (y > (fpgStyle.GetControlFrameBorders.Top + hh)) then // not in Header row begin PopupMenu.ShowAt(self, x, y); end; @@ -1268,7 +1535,7 @@ begin w := 0; for n := FFocusCol downto FFirstCol do begin - w := w + ColumnWidth[n]+1; + w := w + ColumnWidth[n]; if w > VisibleWidth then begin if n = FFocusCol then @@ -1283,7 +1550,14 @@ begin UpdateScrollBars; end; +procedure TfpgBaseGrid.PrepareCells(firstrow, lastrow, firstcol, lastcol: integer); +begin + // for descendents +end; + constructor TfpgBaseGrid.Create(AOwner: TComponent); +var + borders: TRect; begin Updating; inherited Create(AOwner); @@ -1296,7 +1570,6 @@ begin FPrevRow := -1; FFirstRow := 0; FFirstCol := 0; - FMargin := 2; FShowHeader := True; FShowGrid := True; FRowSelect := False; @@ -1306,6 +1579,8 @@ begin FHeaderStyle := ghsButton; FBorderStyle := ebsDefault; + borders := GetAdjustedBorderSizes; + FFont := fpgGetFont('#Grid'); FHeaderFont := fpgGetFont('#GridHeader'); @@ -1317,8 +1592,8 @@ begin FAlternativeBGColor := clHilite1; FColResizing := False; - MinHeight := HeaderHeight + DefaultRowHeight + FMargin; - MinWidth := DefaultColWidth + FMargin; + MinHeight := HeaderHeight + DefaultRowHeight + borders.Top + borders.Bottom; + MinWidth := DefaultColWidth + borders.Left + borders.Right; FVScrollBar := TfpgScrollBar.Create(self); FVScrollBar.Orientation := orVertical; @@ -1329,7 +1604,7 @@ begin FHScrollBar.Orientation := orHorizontal; FHScrollBar.Visible := False; FHScrollBar.OnScroll := @HScrollBarMove; - FHScrollBar.ScrollStep := 5; + FHScrollBar.ScrollStep := 20; end; destructor TfpgBaseGrid.Destroy; @@ -1388,11 +1663,11 @@ begin else hh := 0; - ARow := FFirstRow + ((y - FMargin - hh) div FDefaultRowHeight); + ARow := FFirstRow + ((y - fpgStyle.GetControlFrameBorders.Top - hh) div FDefaultRowHeight); if ARow > RowCount-1 then ARow := RowCount-1; - cLeft := FMargin; // column starting point + cLeft := fpgStyle.GetControlFrameBorders.Left; // column starting point if go_SmoothScroll in FOptions then begin if FHScrollBar.Visible then @@ -1416,6 +1691,19 @@ begin end; end; +function TfpgBaseGrid.GetClientRect: TfpgRect; +var + rect: TRect; +begin + Result := inherited GetClientRect; + rect := fpgStyle.GetControlFrameBorders; + case BorderStyle of +// ebsNone: // nothing to do + ebsDefault: InflateRect(Result, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } + ebsSingle: InflateRect(Result, -1, -1); + end; +end; + end. diff --git a/src/gui/fpg_button.pas b/src/gui/fpg_button.pas index 3bc026de..0cbb1397 100644 --- a/src/gui/fpg_button.pas +++ b/src/gui/fpg_button.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -171,6 +171,9 @@ type property OnDragLeave; property OnDragDrop; property OnDragStartDetected; + property OnEnter; + property OnExit; + property OnKeyPress; property OnMouseDown; property OnMouseExit; property OnMouseEnter; @@ -543,6 +546,9 @@ begin if FEmbedded then Include(lBtnFlags, btfIsEmbedded); + if not Enabled then + Include(lBtnFlags, btfDisabled); + // In the UI Designer we want the button more visible if not (csDesigning in ComponentState) then begin diff --git a/src/gui/fpg_checkbox.pas b/src/gui/fpg_checkbox.pas index 886f69ca..2b4b11d8 100644 --- a/src/gui/fpg_checkbox.pas +++ b/src/gui/fpg_checkbox.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2011 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -210,8 +210,7 @@ begin ix := (2 + (Ord(FChecked) * 2)) - Ord(FChecked); // paint the check (in this case a X) - img := fpgImages.GetImage('sys.checkboxes'); // Do NOT localize - Canvas.DrawImagePart(r.Left, r.Top, img, ix*FBoxSize, 0, FBoxSize, FBoxSize); + fpgStyle.DrawCheckbox(Canvas, r.Left, r.Top, ix*FBoxSize, 0); r := GetClientRect; { max focus rectangle and text boundry } @@ -291,7 +290,7 @@ begin FTextColor := Parent.TextColor; FBackgroundColor := Parent.BackgroundColor; FFocusable := True; - FBoxSize := 13; + FBoxSize := fpgStyle.GetCheckBoxSize; FImgTextSpacing := 6; FChecked := False; FIsPressed := False; diff --git a/src/gui/fpg_colorwheel.pas b/src/gui/fpg_colorwheel.pas index a6b3795b..e699aebc 100644 --- a/src/gui/fpg_colorwheel.pas +++ b/src/gui/fpg_colorwheel.pas @@ -554,7 +554,7 @@ begin Canvas.FillRectangle(r); Canvas.Color := clBlack; - Canvas.DrawControlFrame(r); + fpgStyle.DrawControlFrame(Canvas, r); end; procedure TfpgValueBar.SetMarginWidth(NewWidth: longint); diff --git a/src/gui/fpg_combobox.pas b/src/gui/fpg_combobox.pas index 8c10f195..bb26ada6 100644 --- a/src/gui/fpg_combobox.pas +++ b/src/gui/fpg_combobox.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -100,7 +100,6 @@ type procedure DoOnDropDown; virtual; procedure DoDropDown; virtual; abstract; procedure DoOnCloseUp; virtual; - procedure PaintInternalButton; virtual; function GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; virtual; property AutoSize: Boolean read FAutoSize write SetAutoSize default False; property DropDownCount: integer read FDropDownCount write SetDropDownCount default 8; @@ -182,14 +181,16 @@ type function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; - h: TfpgCoord = 0): TfpgComboBox; + h: TfpgCoord = 24): TfpgComboBox; implementation uses fpg_listbox, - dbugintf, + {$IFDEF DEBUG} + fpg_dbugintf, + {$ENDIF} math; @@ -385,42 +386,6 @@ begin OnCloseUp(self); end; -procedure TfpgBaseComboBox.PaintInternalButton; -var - ar: TfpgRect; - btnflags: TfpgButtonFlags; -begin - Canvas.BeginDraw; - btnflags := []; - ar := FInternalBtnRect; - - { The bounding rectangle for the arrow } - ar.Width := 8; - ar.Height := 6; - ar.Left := FInternalBtnRect.Left + ((FInternalBtnRect.Width-ar.Width) div 2); - ar.Top := FInternalBtnRect.Top + ((FInternalBtnRect.Height-ar.Height) div 2); - - if FBtnPressed then - begin - Include(btnflags, btfIsPressed); - OffsetRect(ar, 1, 1); - end; - // paint button face - fpgStyle.DrawButtonFace(Canvas, - FInternalBtnRect.Left, - FInternalBtnRect.Top, - FInternalBtnRect.Width, - FInternalBtnRect.Height, btnflags); - if Enabled then - Canvas.SetColor(clText1) - else - Canvas.SetColor(clShadow1); - - // paint arrow - fpgStyle.DrawDirectionArrow(Canvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); - Canvas.EndDraw(FInternalBtnRect); -end; - function TfpgBaseComboBox.GetDropDownPos(AParent, AComboBox, ADropDown: TfpgWidget): TfpgRect; var pt: TPoint; @@ -535,7 +500,9 @@ end; function CreateComboBox(AOwner: TComponent; x, y, w: TfpgCoord; AList: TStringList; - h: TfpgCoord = 0): TfpgComboBox; + h: TfpgCoord): TfpgComboBox; +var + lh: integer; begin Result := TfpgComboBox.Create(AOwner); Result.Left := x; @@ -543,8 +510,9 @@ begin Result.Width := w; Result.Focusable := True; - if h < TfpgComboBox(Result).FFont.Height + (Result.FMargin * 2) then - Result.Height := TfpgComboBox(Result).FFont.Height + (Result.FMargin * 2) + lh := TfpgComboBox(Result).FFont.Height + (Result.FMargin * 2); + if h < lh then + Result.Height := lh else Result.Height := h; @@ -683,7 +651,7 @@ begin inherited HandleLMouseDown(x, y, shiftstate); // button state is down only if user clicked in the button rectangle. FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); - PaintInternalButton; + Repaint; DoDropDown; end; @@ -691,7 +659,7 @@ procedure TfpgBaseStaticCombo.HandleLMouseUp(x, y: integer; shiftstate: TShiftSt begin inherited HandleLMouseUp(x, y, shiftstate); FBtnPressed := False; - PaintInternalButton; + Repaint; end; procedure TfpgBaseStaticCombo.HandleMouseScroll(x, y: integer; @@ -722,47 +690,25 @@ end; procedure TfpgBaseStaticCombo.HandlePaint; var r: TfpgRect; + rect: TRect; begin // inherited HandlePaint; Canvas.ClearClipRect; r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - // internal background rectangle (without frame) - InflateRect(r, -2, -2); + fpgStyle.DrawControlFrame(Canvas, r); + rect := fpgStyle.GetControlFrameBorders; + InflateRect(r, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } Canvas.SetClipRect(r); - if Enabled then - begin - if ReadOnly then - Canvas.SetColor(clWindowBackground) - else - Canvas.SetColor(FBackgroundColor); - end - else - Canvas.SetColor(clWindowBackground); - - Canvas.FillRectangle(r); - - // paint the fake dropdown button - PaintInternalButton; + fpgStyle.DrawStaticComboBox(Canvas, r, Enabled, Focused, ReadOnly, FBackgroundColor, FInternalBtnRect, FBtnPressed); - Dec(r.Width, FInternalBtnRect.Width); - Canvas.SetClipRect(r); +// Dec(r.Width, FInternalBtnRect.Width); +// Canvas.SetClipRect(r); Canvas.SetFont(Font); - if Focused then - begin - Canvas.SetColor(clSelection); - Canvas.SetTextColor(clSelectionText); - InflateRect(r, -1, -1); - Canvas.FillRectangle(r); - end + Canvas.SetTextColor(clSelectionText) else - begin Canvas.SetTextColor(FTextColor); - end; - { adjust rectangle size smaller for text } r.Left := r.Left + Margin; r.Width := r.Width - (Margin*2); diff --git a/src/gui/fpg_customgrid.pas b/src/gui/fpg_customgrid.pas index 83d35aa7..98040374 100644 --- a/src/gui/fpg_customgrid.pas +++ b/src/gui/fpg_customgrid.pas @@ -65,6 +65,7 @@ type FColumns: TFPList; procedure HandleSetFocus; override; procedure SetTextColor(const AValue: TfpgColor); override; + procedure SetBackgroundColor(const AValue: TfpgColor); override; function GetColumns(AIndex: integer): TfpgGridColumn; virtual; procedure DoDeleteColumn(ACol: integer); virtual; procedure DoSetRowCount(AValue: integer); virtual; @@ -140,6 +141,18 @@ begin Update; end; +procedure TfpgCustomGrid.SetBackgroundColor(const AValue: TfpgColor); +var + i: integer; +begin + inherited SetBackgroundColor(AValue); + for i := 0 to ColumnCount-1 do + begin + TfpgGridColumn(FColumns.Items[i]).BackgroundColor := AValue; + end; + RePaint; +end; + function TfpgCustomGrid.GetColumns(AIndex: integer): TfpgGridColumn; begin if (AIndex < 0) or (AIndex > FColumns.Count-1) then diff --git a/src/gui/fpg_dialogs.pas b/src/gui/fpg_dialogs.pas index 8f3639e6..781c0745 100644 --- a/src/gui/fpg_dialogs.pas +++ b/src/gui/fpg_dialogs.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -58,10 +58,10 @@ uses type TfpgMsgDlgType = (mtAbout, mtWarning, mtError, mtInformation, mtConfirmation, mtCustom); - + TfpgMsgDlgBtn = (mbNoButton, mbOK, mbCancel, mbYes, mbNo, mbAbort, mbRetry, mbIgnore, mbAll, mbNoToAll, mbYesToAll, mbHelp, mbClose); - + TfpgMsgDlgButtons = set of TfpgMsgDlgBtn; const @@ -104,7 +104,7 @@ type property CentreText: Boolean read FCentreText write FCentreText default False; property FontDesc: string read GetFontDesc write SetFontDesc; end; - + TfpgBaseDialog = class(TfpgForm) protected @@ -152,8 +152,8 @@ type constructor Create(AOwner: TComponent); override; procedure SetSampleText(AText: string); end; - - + + TfpgFileDialog = class(TfpgBaseDialog) private chlDir: TfpgComboBox; @@ -227,6 +227,7 @@ type {$I charmapdialog.inc} {$I colordialog.inc} {$I inputquerydialog.inc} +{$I inputintegerdialog.inc} {$I managebookmarksdialog.inc} @@ -240,6 +241,7 @@ function SelectDirDialog(const AStartDir: TfpgString = ''): TfpgString; function fpgShowCharMap: TfpgString; function fpgSelectColorDialog(APresetColor: TfpgColor = clBlack): TfpgColor; function fpgInputQuery(const ACaption, APrompt: TfpgString; var Value: TfpgString): Boolean; +function fpgIntegerQuery(const ACaption, APrompt: TfpgString; var Value: Integer; const MaxValue: Integer; const MinValue: Integer = 0): Boolean; implementation @@ -253,8 +255,8 @@ uses {$ENDIF} ,DateUtils ; - - + + procedure WrapText(const AText: String; ALines: TStrings; AFont: TfpgFont; const ALineWidth: Integer; out AWidth: Integer); var @@ -396,7 +398,7 @@ begin dres := dlg.RunOpenFile else dres := dlg.RunSaveFile; - + if dres then Result := dlg.FileName else @@ -532,7 +534,7 @@ var outw: integer; begin WrapText(AMessage, FLines, FFont, FMaxLineWidth, outw); - + // dialog width with 10 pixel border on both sides Width := outw + 2*10; @@ -744,7 +746,7 @@ var NextC; end; end; - + procedure ProcessAliasFont; var i: integer; @@ -785,7 +787,7 @@ begin NextToken; lbFaces.FocusItem := lbFaces.Items.IndexOf(token); - + if c = '-' then begin NextC; @@ -846,7 +848,7 @@ begin MinHeight := Height; FSampleText := 'The quick brown fox jumps over the lazy dog. 0123456789 [oO0,ilLI]'; FMode := 1; // normal fonts - + btnCancel.Left := Width - FDefaultButtonWidth - FSpacing; btnOK.Left := btnCancel.Left - FDefaultButtonWidth - FSpacing; @@ -1000,7 +1002,7 @@ begin Exit; //==> if AText = '' then Exit; //==> - + FSampleText := AText; memSample.Text := FSampleText; end; @@ -1171,7 +1173,7 @@ begin end; { Create lower Panel details } - + pnlFileInfo := TfpgPanel.Create(self); with pnlFileInfo do begin @@ -1194,7 +1196,7 @@ begin OnChange := @edFilenameChanged; OnKeyPress := @edFilenameKeyPressed; end; - + { Filter section } chlFilter := TfpgComboBox.Create(self); @@ -1398,7 +1400,7 @@ begin ExcludeTrailingPathDelimiter(grid.FileList.DirectoryName)) else fsel := ''; - + grid.FileList.FileMask := GetFileFilter; grid.FileList.ShowHidden := ShowHidden; @@ -1407,7 +1409,7 @@ begin ShowMessage(Format(rsErrCouldNotOpenDir, [ADir]), rsError); Exit; //==> end; - + grid.FileList.Sort(soFileName); // we don't want chlDir to call DirChange while populating items @@ -1420,7 +1422,7 @@ begin HighlightFile(fsel) else grid.FocusRow := 0; - + grid.Update; grid.SetFocus; @@ -1583,7 +1585,7 @@ begin if not HighlightFile(fname) then edFilename.Text := fname; - + WindowTitle := rsOpenAFile; btnOK.ImageName := 'stdimg.open'; // Do NOT localize btnOK.Text := rsOpen; @@ -1632,6 +1634,7 @@ end; {$I charmapdialog.inc} {$I colordialog.inc} {$I inputquerydialog.inc} +{$I inputintegerdialog.inc} {$I managebookmarksdialog.inc} diff --git a/src/gui/fpg_edit.pas b/src/gui/fpg_edit.pas index f164ef76..0ed17bfd 100644 --- a/src/gui/fpg_edit.pas +++ b/src/gui/fpg_edit.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -187,6 +187,7 @@ type property OnDragStartDetected; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; property OnMouseEnter; property OnMouseExit; @@ -279,6 +280,7 @@ type property OnChange; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; property OnMouseEnter; property OnMouseExit; @@ -328,6 +330,7 @@ type property OnChange; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; property OnMouseEnter; property OnMouseExit; @@ -375,6 +378,7 @@ type property OnChange; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; property OnMouseEnter; property OnMouseExit; @@ -725,7 +729,7 @@ begin end; ebsDefault: begin - Canvas.DrawControlFrame(r); + fpgStyle.DrawControlFrame(Canvas, r); rect := fpgStyle.GetControlFrameBorders; InflateRect(r, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } end; @@ -754,10 +758,14 @@ var s: TfpgChar; prevval: string; begin + inherited HandleKeyChar(AText, shiftstate, consumed); + if consumed then + Exit; //==> + prevval := Text; s := AText; - if (not consumed) and (not ReadOnly) then + if (not ReadOnly) then begin // Handle only printable characters // UTF-8 characters beyond ANSI range are supposed to be printable @@ -780,8 +788,6 @@ begin if consumed then RePaint; - - inherited HandleKeyChar(AText, shiftstate, consumed); end; procedure TfpgBaseEdit.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); @@ -1110,21 +1116,24 @@ begin end; procedure TfpgBaseEdit.SetFontDesc(const AValue: string); +var + rect: TRect; begin FFont.Free; FFont := fpgGetFont(AValue); if AutoSize then begin + rect := fpgStyle.GetControlFrameBorders; case BorderStyle of ebsNone: if Height < FFont.Height + (FHeightMargin * 2) then - Height:= FFont.Height + (FHeightMargin * 2); + Height := FFont.Height + (FHeightMargin * 2); ebsDefault: - if Height < FFont.Height + 4 + (FHeightMargin * 2) then - Height:= FFont.Height + 4 + (FHeightMargin * 2); + if Height < FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2) then + Height := FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2); ebsSingle: - if Height < FFont.Height + 2 + (FHeightMargin * 2) then - Height:= FFont.Height + 2 + (FHeightMargin * 2); + if Height < FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2) then + Height := FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2); end; end; Adjust; @@ -1173,18 +1182,24 @@ begin end; procedure TfpgBaseEdit.SetHeightMargin(const AValue: integer); +var + rect: TRect; begin if (FHeightMargin = AValue) or (AValue <= 0) then Exit; //=> FHeightMargin := AValue; - case BorderStyle of - ebsNone: - Height:= FFont.Height + (FHeightMargin * 2); - ebsDefault: - Height:= FFont.Height + 4 + (FHeightMargin * 2); - ebsSingle: - Height:= FFont.Height + 2 + (FHeightMargin * 2); + if AutoSize then + begin + rect := fpgStyle.GetControlFrameBorders; + case BorderStyle of + ebsNone: + Height := FFont.Height + (FHeightMargin * 2); + ebsDefault: + Height := FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2); + ebsSingle: + Height := FFont.Height + rect.Top + rect.Bottom + (FHeightMargin * 2); end; + end; Repaint; end; @@ -1420,11 +1435,15 @@ begin end; function TfpgBaseEdit.GetClientRect: TfpgRect; +var + rect: TRect; begin + Result := inherited GetClientRect; + rect := fpgStyle.GetControlFrameBorders; case BorderStyle of - ebsNone: Result := inherited GetClientRect; - ebsDefault: Result.SetRect(2, 2, Width-4, Height-4); - ebsSingle: Result.SetRect(1, 1, Width-2, Height-2); +// ebsNone: // nothing to do + ebsDefault: InflateRect(Result, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } + ebsSingle: InflateRect(Result, -1, -1); end; end; @@ -1866,6 +1885,7 @@ begin FAlignment := taRightJustify; FDecimalSeparator := DecimalSeparator; FThousandSeparator := ThousandSeparator; + FShowThousand := True; FNegativeColor := clRed; FOldColor := TextColor; FMaxLimit := False; @@ -1992,8 +2012,10 @@ begin if ((n >= 48) and (n <= 57) or (AText = '-') and (UTF8Pos(AText, Text) <= 0)) then consumed := False else - consumed := True; + Exit; //==> + inherited HandleKeyChar(AText, shiftstate, consumed); + if FMaxLimit then if GetValue > FMaxValue then SetValue(FMaxValue); @@ -2042,7 +2064,6 @@ end; constructor TfpgEditInteger.Create(AOwner: TComponent); begin inherited Create(AOwner); - FShowThousand := True; FDecimals := 0; end; @@ -2216,8 +2237,10 @@ begin or ((AText = FDecimalSeparator) and (UTF8Pos(AText, Text) <= 0)) then consumed := False else - consumed := True; + Exit; //==> + inherited HandleKeyChar(AText, shiftstate, consumed); + if FMaxLimit then if GetValue > FMaxValue then SetValue(FMaxValue); @@ -2284,7 +2307,6 @@ begin inherited Create(AOwner); FDecimals := -1; FFixedDecimals := -1; - FShowThousand := True; end; { TfpgEditCurrency } @@ -2437,8 +2459,10 @@ begin or ((AText = FDecimalSeparator) and (UTF8Pos(AText, Text) <= 0)) then consumed := False else - consumed := True; + Exit; //==> + inherited HandleKeyChar(AText, shiftstate, consumed); + if FMaxLimit then if GetValue > FMaxValue then SetValue(FMaxValue); @@ -2488,7 +2512,6 @@ constructor TfpgEditCurrency.Create(AOwner: TComponent); begin inherited Create(AOwner); FDecimals := 2; - FShowThousand := True; end; diff --git a/src/gui/fpg_editcombo.pas b/src/gui/fpg_editcombo.pas index 3887cd13..5b011b4d 100644 --- a/src/gui/fpg_editcombo.pas +++ b/src/gui/fpg_editcombo.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -128,15 +128,24 @@ type property Hint; property Items; property Margin; + property ReadOnly; property Text; property TextColor; property Width; property OnChange; property OnCloseUp; + property OnDragEnter; + property OnDragLeave; + property OnDragDrop; + property OnDragStartDetected; property OnDropDown; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + property OnPaint; property OnShowHint; end; @@ -522,6 +531,9 @@ var prevval: string; i: integer; begin + inherited HandleKeyChar(AText, shiftstate, consumed); + if Consumed then + Exit; //==> prevval := FText; s := AText; consumed := False; @@ -529,7 +541,7 @@ begin FNewItem := False; // Handle only printable characters - // Note: This is now UTF-8 compliant! + // Note: This is not UTF-8 compliant! if Enabled and (Ord(AText[1]) > 31) and (Ord(AText[1]) < 127) or (Length(AText) > 1) then begin if (FMaxLength <= 0) or (UTF8Length(FText) < FMaxLength) then @@ -572,8 +584,6 @@ begin if consumed then RePaint; -// else - inherited HandleKeyChar(AText, shiftstate, consumed); end; procedure TfpgBaseEditCombo.HandleKeyPress(var keycode: word; @@ -687,12 +697,12 @@ begin FBtnPressed := PtInRect(FInternalBtnRect, Point(x, y)); if not FAutoCompletion then begin - PaintInternalButton; + Repaint; DoDropDown; end else if FBtnPressed then begin - PaintInternalButton; + Repaint; DoDropDown; end; end; @@ -702,7 +712,7 @@ procedure TfpgBaseEditCombo.HandleLMouseUp(x, y: integer; begin inherited HandleLMouseUp(x, y, shiftstate); FBtnPressed := False; - PaintInternalButton; + Repaint; end; procedure TfpgBaseEditCombo.HandleRMouseUp(x, y: integer; shiftstate: TShiftState); @@ -717,6 +727,7 @@ end; procedure TfpgBaseEditCombo.HandlePaint; var r: TfpgRect; + rect: TRect; tw, tw2, st, len: integer; Texte: string; @@ -761,25 +772,28 @@ var end; begin - Canvas.BeginDraw; // inherited HandlePaint; Canvas.ClearClipRect; r.SetRect(0, 0, Width, Height); - Canvas.DrawControlFrame(r); - - // internal background rectangle (without frame) - InflateRect(r, -2, -2); + fpgStyle.DrawControlFrame(Canvas, r); + rect := fpgStyle.GetControlFrameBorders; + InflateRect(r, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } Canvas.SetClipRect(r); if Enabled then - Canvas.SetColor(FBackgroundColor) + begin + if ReadOnly then + Canvas.SetColor(clWindowBackground) + else + Canvas.SetColor(FBackgroundColor); + end else Canvas.SetColor(clWindowBackground); Canvas.FillRectangle(r); // paint the fake dropdown button - PaintInternalButton; + fpgStyle.DrawInternalComboBoxButton(Canvas, FInternalBtnRect, Enabled, FBtnPressed); Dec(r.Width, FInternalBtnRect.Width); Canvas.SetClipRect(r); @@ -860,8 +874,6 @@ begin else fpgCaret.UnSetCaret(Canvas); end; - - Canvas.EndDraw; end; constructor TfpgBaseEditCombo.Create(AOwner: TComponent); diff --git a/src/gui/fpg_grid.pas b/src/gui/fpg_grid.pas index b7800b55..3f8b52fb 100644 --- a/src/gui/fpg_grid.pas +++ b/src/gui/fpg_grid.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -68,8 +68,17 @@ type property ScrollBarStyle; property TabOrder; property TopRow; - property OnRowChange; + property OnClick; property OnDoubleClick; + property OnEnter; + property OnExit; + property OnKeyPress; + property OnMouseDown; + property OnMouseEnter; + property OnMouseExit; + property OnMouseMove; + property OnMouseUp; + property OnRowChange; property OnShowHint; end; @@ -106,8 +115,7 @@ type property Columns[AIndex: Integer]: TfpgStringColumn read GetColumns; public constructor Create(AOwner: TComponent); override; - function AddColumn(ATitle: string; AWidth: integer; AAlignment: TAlignment = taLeftJustify; - AbackgroundColor: TfpgColor = clDefault; ATextColor: TfpgColor = clDefault): TfpgStringColumn; overload; + function AddColumn(ATitle: string; AWidth: integer; AAlignment: TAlignment = taLeftJustify; AbackgroundColor: TfpgColor = clDefault; ATextColor: TfpgColor = clDefault): TfpgStringColumn; overload; procedure DeleteRow(AIndex: integer); override; property Cells[ACol, ARow: Integer]: string read GetCell write SetCell; property Objects[ACol, ARow: Integer]: TObject read GetObjects write SetObjects; @@ -160,7 +168,10 @@ type property OnClick; property OnDoubleClick; property OnDrawCell; + property OnEnter; + property OnExit; property OnFocusChange; + property OnHeaderClick; property OnKeyPress; property OnMouseDown; property OnMouseEnter; @@ -171,6 +182,7 @@ type property OnShowHint; end; + function CreateStringGrid(AOwner: TComponent; x, y, w, h: TfpgCoord; AColumnCount: integer = 0): TfpgStringGrid; @@ -330,9 +342,9 @@ end; function TfpgCustomStringGrid.GetCell(ACol, ARow: Integer): string; begin - if ACol > ColumnCount-1 then + if (ACol < 0) or (ACol > ColumnCount-1) then Exit; //==> - if ARow > RowCount-1 then + if (ARow < 0) or (ARow > RowCount-1) then Exit; //==> Result := TfpgStringColumn(FColumns.Items[ACol]).Cells[ARow]; end; diff --git a/src/gui/fpg_hyperlink.pas b/src/gui/fpg_hyperlink.pas index a61cb80d..0f0e0896 100644 --- a/src/gui/fpg_hyperlink.pas +++ b/src/gui/fpg_hyperlink.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2011 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -58,7 +58,7 @@ type property FontDesc; property Height; property Hint; - property HotTrackColor: TfpgColor read FHotTrackColor write SetHotTrackColor default clBlue; + property HotTrackColor: TfpgColor read FHotTrackColor write SetHotTrackColor default clHyperLink; property HotTrackFont: TfpgString read FHTFont write SetHotTrackFont; property Layout; property Left; @@ -66,7 +66,7 @@ type property ParentShowHint; property ShowHint; property Text; - property TextColor default clBlue; + property TextColor default clHyperLink; property URL: TfpgString read FUrl write SetURL; property Top; property Width; @@ -80,7 +80,9 @@ end; implementation uses - fpg_utils; + fpg_utils + ,fpg_constants + ; { TfpgHyperlink } @@ -89,12 +91,12 @@ constructor TfpgHyperlink.Create(AOwner: TComponent); begin inherited Create(AOwner); Width := 120; - FHotTrackColor := clBlue; - TextColor := clBlue; - FUrl := 'http://opensoft.homeip.net/fpgui/'; + FHotTrackColor := clHyperLink; + TextColor := clHyperLink; + FUrl := fpGUIWebsite; FText := 'fpGUI website'; - FHTFont := 'Arial-8:antialias=true:underline:bold'; - FontDesc := 'Arial-8:antialias=true:underline'; + FHTFont := FPG_DEFAULT_SANS + '-8:antialias=true:underline:bold'; + FontDesc := FPG_DEFAULT_SANS + '-8:antialias=true:underline'; end; procedure TfpgHyperlink.SetURL(const Value: TfpgString); diff --git a/src/gui/fpg_iniutils.pas b/src/gui/fpg_iniutils.pas index dec642d3..6bbe83bd 100644 --- a/src/gui/fpg_iniutils.pas +++ b/src/gui/fpg_iniutils.pas @@ -80,7 +80,7 @@ begin lFileName := fpgExtractFileName(AFileName); if lDir = '' then - lDir := GetAppConfigDir(False); + lDir := fpgGetAppConfigDir(False); if not (lDir[Length(lDir)] = PathDelim) then lDir := lDir + PathDelim; @@ -90,12 +90,12 @@ begin if lFileName = '' then - lFileName := ApplicationName + '.ini' + lFileName := fpgApplicationName + '.ini' else if fpgExtractFileExt(lFileName) = '' then lFileName := lFileName + '.ini'; lFileName := lDir + lFileName; - Create(lFileName); + Create(fpgToOSEncoding(lFileName)); end; function TfpgINIFile.ReadString(const ASection, AIdent, ADefault: string): string; diff --git a/src/gui/fpg_listbox.pas b/src/gui/fpg_listbox.pas index bbcd4530..11baed01 100644 --- a/src/gui/fpg_listbox.pas +++ b/src/gui/fpg_listbox.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -63,6 +63,10 @@ type procedure SetPopupFrame(const AValue: boolean); procedure UpdateScrollbarCoords; procedure SetAutoHeight(const AValue: boolean); + function GetScrollBarPage: integer; + procedure SetScrollBarPage(const AValue: integer); + function GetScrollBarWidth: integer; + procedure SetScrollBarWidth(const AValue: integer); protected FFont: TfpgFont; FScrollBar: TfpgScrollBar; @@ -74,7 +78,6 @@ type procedure UpdateScrollBar; procedure FollowFocus; function ListHeight: TfpgCoord; - function ScrollBarWidth: TfpgCoord; function PageLength: integer; procedure ScrollBarMove(Sender: TObject; APosition: integer); procedure DrawItem(num: integer; rect: TfpgRect; flags: integer); virtual; @@ -90,6 +93,8 @@ type procedure HandleShow; override; procedure HandlePaint; override; property AutoHeight: boolean read FAutoHeight write SetAutoHeight default False; + property ScrollBarPage: Integer read GetScrollBarPage write SetScrollBarPage; + property ScrollBarWidth: Integer read GetScrollBarWidth write SetScrollBarWidth; property FocusItem: integer read FFocusItem write SetFocusItem; property FontDesc: string read GetFontDesc write SetFontDesc; property HotTrack: boolean read FHotTrack write FHotTrack default False; @@ -105,6 +110,7 @@ type function RowHeight: integer; virtual; procedure SetFirstItem(item: integer); property Font: TfpgFont read FFont; + property VisibleItems: integer read PageLength; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnKeyPress; // to allow to detect return or tab key has been pressed property OnScroll: TNotifyEvent read FOnScroll write FOnScroll; @@ -147,6 +153,8 @@ type property Items; property ParentShowHint; property PopupFrame; + property ScrollBarPage; + property ScrollBarWidth; property ShowHint; property TabOrder; property Text; @@ -416,6 +424,33 @@ begin Height := (Succ(PageLength) * RowHeight) + (2 * FMargin); end; +function TfpgBaseListBox.GetScrollBarPage: integer; +begin + Result:= FScrollBar.PageSize; +end; + +procedure TfpgBaseListBox.SetScrollBarPage(const AValue: integer); +begin + if AValue= FScrollBar.PageSize then + Exit; //==> + FScrollBar.PageSize:= AValue; +end; + +function TfpgBaseListBox.GetScrollBarWidth: integer; +begin + if FScrollBar.Visible then + result := FScrollBar.Width + else + result := 0; +end; + +procedure TfpgBaseListBox.SetScrollBarWidth(const AValue: integer); +begin + if AValue = FScrollBar.Width then + Exit; //==> + FScrollBar.Width := AValue; +end; + procedure TfpgBaseListBox.MsgPaint(var msg: TfpgMessageRec); begin // Optimising painting and preventing OnPaint from firing if not needed @@ -482,14 +517,6 @@ begin result := height - (2*FMargin); end; -function TfpgBaseListBox.ScrollBarWidth: TfpgCoord; -begin - if FScrollBar.Visible then - result := FScrollBar.Width - else - result := 0; -end; - function TfpgBaseListBox.PageLength: integer; begin result := (ListHeight div RowHeight)-1; // component height minus 1 line @@ -673,6 +700,7 @@ procedure TfpgBaseListBox.HandlePaint; var n: integer; r: TfpgRect; + rect: TRect; begin //if FUpdateCount > 0 then // Exit; //==> @@ -691,8 +719,9 @@ begin end else begin - Canvas.DrawControlFrame(r); - InflateRect(r, -2, -2); + fpgStyle.DrawControlFrame(Canvas, r); + rect := fpgStyle.GetControlFrameBorders; + InflateRect(r, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } end; Canvas.SetClipRect(r); @@ -797,6 +826,7 @@ begin r.SetBottom(Height - FMargin); Canvas.FillRectangle(r); end; + UpdateScrollBar; end; constructor TfpgBaseListBox.Create(AOwner: TComponent); @@ -1277,4 +1307,3 @@ begin end; end. - diff --git a/src/gui/fpg_listview.pas b/src/gui/fpg_listview.pas index 8703d6de..0278c952 100644 --- a/src/gui/fpg_listview.pas +++ b/src/gui/fpg_listview.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -209,8 +209,6 @@ type TfpgListView = class(TfpgWidget, IfpgLVItemViewer) private - procedure SetShiftIsPressed(const AValue: Boolean); - private FImages: array[TfpgLVItemStates] of TfpgImageList; FSubitemImages: array[TfpgLVItemStates] of TfpgImageList; FItemIndex: Integer; @@ -225,6 +223,7 @@ type FUpdateCount: Integer; FVScrollBar: TfpgScrollBar; FHScrollBar: TfpgScrollBar; + FScrollBarWidth: integer; FColumns: TfpgLVColumns; FItems: TfpgLVItems; FOnPaintItem: TfpgLVPaintItemEvent; @@ -241,7 +240,9 @@ type procedure SetItems(const AValue: TfpgLVItems); procedure SetMultiSelect(const AValue: Boolean); procedure SetOnColumnClick(const AValue: TfpgLVColumnClickEvent); + procedure SetScrollBarWidth(const AValue: integer); procedure SetShowHeaders(const AValue: Boolean); + procedure SetShiftIsPressed(const AValue: Boolean); function SubItemGetImages(AIndex: integer): TfpgImageList; procedure SubItemSetImages(AIndex: integer; const AValue: TfpgImageList); procedure VScrollChange(Sender: TObject; Position: Integer); @@ -308,6 +309,7 @@ type property Hint; property MultiSelect: Boolean read FMultiSelect write SetMultiSelect; property ParentShowHint; + property ScrollBarWidth: Integer read FScrollBarWidth write SetScrollBarWidth; property SelectionFollowsFocus: Boolean read FSelectionFollowsFocus write FSelectionFollowsFocus; property SubItemImages: TfpgImageList index Ord(lisNoState) read SubItemGetImages write SubItemSetImages; property SubItemImagesSelected: TfpgImageList index Ord(lisSelected) read SubItemGetImages write SubItemSetImages; @@ -738,6 +740,15 @@ begin FOnColumnClick:=AValue; end; +procedure TfpgListView.SetScrollBarWidth(const AValue: integer); +begin + if AValue = FScrollBarWidth then + Exit; //==> + FScrollBarWidth := AValue; + FVScrollBar.Width := FScrollBarWidth; + FHScrollBar.Height:= FScrollBarWidth; +end; + procedure TfpgListView.SetShiftIsPressed(const AValue: Boolean); begin if AValue = FShiftIsPressed then @@ -1077,7 +1088,7 @@ end; procedure TfpgListView.MsgPaint(var msg: TfpgMessageRec); begin // Optimises painting and prevents Begin[End]Draw and OnPaint event firing - // in not needed. + // if not needed. if FUpdateCount = 0 then inherited MsgPaint(msg); end; @@ -1404,23 +1415,38 @@ end; procedure TfpgListView.HandlePaint; var ClipRect: TfpgRect; + rect: TRect; begin //if FScrollBarNeedsUpdate then UpdateScrollBarPositions; - fpgStyle.DrawControlFrame(Canvas, 0, 0, Width, Height); - - ClipRect.SetRect(2, 2, Width-4, Height-4); + Canvas.ClearClipRect; + ClipRect.SetRect(0, 0, Width, Height); + fpgStyle.DrawControlFrame(Canvas, ClipRect); + rect := fpgStyle.GetControlFrameBorders; + InflateRect(ClipRect, -rect.Left, -rect.Top); { assuming borders are even on opposite sides } Canvas.SetClipRect(ClipRect); + if Enabled then + begin +// if ReadOnly then +// Canvas.SetColor(clWindowBackground) +// else + Canvas.SetColor(FBackgroundColor); + end + else + Canvas.SetColor(clWindowBackground); + + Canvas.FillRectangle(ClipRect); + // This paints the small square remaining below the vscrollbar // and to the right of the hscrollbar if FVScrollBar.Visible and FHScrollBar.Visible then begin Canvas.Color := clButtonFace; - Canvas.FillRectangle(Width - 2 - FVScrollBar.Width, - Height - 2 - FHScrollBar.Height, - Width - 2, - Height - 2); + Canvas.FillRectangle(FHScrollBar.Left+FHScrollBar.Width, + FVScrollBar.Top+FVScrollBar.Height, + FVScrollBar.Width, + FHScrollBar.Height); end; if FVScrollBar.Visible then @@ -1777,6 +1803,7 @@ begin FSelectionFollowsFocus := True; FItemIndex := -1; FScrollBarNeedsUpdate := True; + FScrollBarWidth := FVScrollBar.Width; end; destructor TfpgListView.Destroy; diff --git a/src/gui/fpg_memo.pas b/src/gui/fpg_memo.pas index df16367b..374c8d47 100644 --- a/src/gui/fpg_memo.pas +++ b/src/gui/fpg_memo.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2012 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -145,9 +145,17 @@ type property TabOrder; property TextColor; property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnDragEnter; + property OnDragLeave; + property OnDragDrop; + property OnDragStartDetected; property OnEnter; property OnExit; + property OnKeyChar; property OnKeyPress; + property OnMouseEnter; + property OnMouseExit; + property OnPaint; property OnShowHint; end; @@ -938,7 +946,7 @@ begin end; ebsDefault: begin - Canvas.DrawControlFrame(r); + fpgStyle.DrawControlFrame(Canvas, r); InflateRect(r, -2, -2); end; ebsSingle: @@ -1058,11 +1066,14 @@ var s: string; ls: string; begin - inherited; + inherited HandleKeyChar(AText, shiftstate, consumed); + if consumed then + Exit; //==> + prevval := Text; s := AText; - if (not consumed) and (not ReadOnly) then + if (not ReadOnly) then begin // Printable characters only // Note: This is now UTF-8 compliant! @@ -1082,15 +1093,13 @@ begin FSelEndLine := -1; AdjustCursor; end; - consumed := True; end; if prevval <> Text then if Assigned(FOnChange) then FOnChange(self); - end; - + end; { if not ReadOnly } if consumed then RePaint; @@ -1670,6 +1679,7 @@ begin if FUpdateCount <= 0 then begin Invalidate; + RecalcLongestLine; UpdateScrollBars; end; end; diff --git a/src/gui/fpg_menu.pas b/src/gui/fpg_menu.pas index 91db5992..3f634c02 100644 --- a/src/gui/fpg_menu.pas +++ b/src/gui/fpg_menu.pas @@ -417,6 +417,8 @@ begin inherited HandleMouseMove(x, y, btnstate, shiftstate); newf := CalcMouseCol(x); + if newf = VisibleCount then + Exit; //mouse points over the last item // process menu options if mnuo_nofollowingmouse in FMenuOptions then @@ -467,6 +469,9 @@ begin Exit; // We have no menu items in MainMenu. newf := CalcMouseCol(x); + if newf = VisibleCount then + Exit; //mouse points over the last item + if (FLastItemClicked <> -1) and (FLastItemClicked <> newf) then begin // do nothing @@ -585,6 +590,7 @@ begin FHeight := fpgStyle.MenuFont.Height + 6; // 3px margin top and bottom FMenuOptions := []; FMouseIsOver := False; + FIsContainer := True; end; destructor TfpgMenuBar.Destroy; @@ -660,6 +666,8 @@ begin inc(w, ItemWidth(VisibleItem(n))); inc(n); end; + if x > w then + Result := n; end; function TfpgMenuBar.GetItemPosX(index: integer): integer; diff --git a/src/gui/fpg_panel.pas b/src/gui/fpg_panel.pas index 0a0c6e57..aedb7ace 100644 --- a/src/gui/fpg_panel.pas +++ b/src/gui/fpg_panel.pas @@ -177,6 +177,7 @@ type property OnMouseScroll; property OnMouseUp; property OnPaint; + property OnResize; property OnShowHint; end; @@ -307,8 +308,8 @@ type constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Image: TfpgImage read FImage write SetImage; - property OwnsImage: Boolean read FOwnsImage write FOwnsImage; - property ScaleImage: Boolean read FScaleImage write SetScaleImage; + property OwnsImage: Boolean read FOwnsImage write FOwnsImage default False; + property ScaleImage: Boolean read FScaleImage write SetScaleImage default False; end; @@ -1109,6 +1110,7 @@ begin inherited Create(AOwner); FImage := nil; FOwnsImage := False; + FScaleImage := False; end; destructor TfpgImagePanel.Destroy; diff --git a/src/gui/fpg_popupcalendar.pas b/src/gui/fpg_popupcalendar.pas index 87b9f3ad..fcadd9af 100644 --- a/src/gui/fpg_popupcalendar.pas +++ b/src/gui/fpg_popupcalendar.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -1151,7 +1151,7 @@ begin {%region 'Auto-generated GUI code' -fold} {@VFD_BODY_BEGIN: fpgPopupCalendar} Name := 'fpgPopupCalendar'; - SetPosition(370, 182, 233, 142); + SetPosition(370, 182, 235, 149); Hint := ''; edtYear := TfpgEdit.Create(self); @@ -1268,7 +1268,7 @@ begin with grdName1 do begin Name := 'grdName1'; - SetPosition(0, 23, 233, 119); + SetPosition(0, 23, 235, 125); AddColumn('Sun', 33, taCenter); AddColumn('Mon', 32, taCenter); AddColumn('Tue', 33, taCenter); diff --git a/src/gui/fpg_radiobutton.pas b/src/gui/fpg_radiobutton.pas index 2ce8d566..76f36664 100644 --- a/src/gui/fpg_radiobutton.pas +++ b/src/gui/fpg_radiobutton.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -77,6 +77,17 @@ type property Text: string read FText write SetText; property TextColor; property OnChange: TNotifyEvent read FOnChange write FOnChange; + property OnDragEnter; + property OnDragLeave; + property OnDragDrop; + property OnDragStartDetected; + property OnEnter; + property OnExit; + property OnMouseDown; + property OnMouseExit; + property OnMouseEnter; + property OnMouseMove; + property OnMouseUp; property OnShowHint; end; diff --git a/src/gui/fpg_scrollbar.pas b/src/gui/fpg_scrollbar.pas index dd0a4c7c..1ec78952 100644 --- a/src/gui/fpg_scrollbar.pas +++ b/src/gui/fpg_scrollbar.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -21,10 +21,7 @@ unit fpg_scrollbar; { TODO: - * Set slider button to minimum length (default setting) * Create property to enable dynamic sizing of slider button length. - * Paint scroll area between arrow buttons and slider button a different - color on click. } interface @@ -39,7 +36,7 @@ uses type TScrollNotifyEvent = procedure(Sender: TObject; position: integer) of object; - TfpgScrollStyle = (ssNone, ssHorizontal, ssVertical, ssAutoBoth); + TfpgScrollStyle = (ssNone, ssHorizontal, ssVertical, ssAutoBoth, ssBothVisible); TfpgScrollBarPart = (sbpNone, sbpUpBack, sbpPageUpBack, sbpSlider, sbpDownForward, sbpPageDownForward); @@ -137,7 +134,6 @@ end; procedure TfpgScrollBar.HandlePaint; begin - Canvas.BeginDraw; // Do not remove - Scrollbars do painting outside HandlePaint as well! if Orientation = orVertical then begin DrawButton(0, 0, Width, Width, 'sys.sb.up', (FScrollbarDownPart = sbpUpBack) and (FPosition <> FMin), (FPosition <> FMin) and (Parent.Enabled)); @@ -148,9 +144,7 @@ begin DrawButton(0, 0, Height, Height, 'sys.sb.left', (FScrollbarDownPart = sbpUpBack) and (FPosition <> FMin), (FPosition <> FMin) and (Parent.Enabled)); DrawButton(Width-Height, 0, Height, Height, 'sys.sb.right', (FScrollbarDownPart = sbpDownForward) and (FPosition <> FMax), (FPosition <> FMax) and (Parent.Enabled)); end; - DrawSlider(FRecalc); - Canvas.EndDraw; // Do not remove - Scrollbars do painting outside HandlePaint as well! FRecalc := False; end; @@ -165,7 +159,7 @@ begin if not HasHandle then Exit; //==> FRecalc := True; - Invalidate;// DrawSlider(True); + Invalidate; end; procedure TfpgScrollBar.LineUp; @@ -222,7 +216,7 @@ begin FPosition := AValue; if HasHandle then - Invalidate;// DrawSlider(False); + Invalidate; end; procedure TfpgScrollBar.Step(ASteps: Integer); @@ -363,8 +357,6 @@ var area: TfpgCoord; mm: TfpgCoord; begin -// Canvas.BeginDraw; - if SliderSize > 1 then SliderSize := 1; @@ -372,12 +364,12 @@ begin if Orientation = orVertical then begin - Canvas.FillRectangle(0, Width, Width, Height-Width-Width); + Canvas.FillRectangle(0, Width, Width, Height - (2 * Width)); area := Height - (Width shl 1); end else begin - Canvas.FillRectangle(Height, 0, Width-Height-Height, Height); + Canvas.FillRectangle(Height, 0, Width - (2 * Height), Height); area := Width - (Height shl 1); end; @@ -414,7 +406,7 @@ begin else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then begin Canvas.SetColor(clShadow1); - Canvas.FillRectangle(0, FSliderPos + FSliderLength, Width, Height - Width - (FSliderPos + FSliderLength)); + Canvas.FillRectangle(0, Width + FSliderPos + FSliderLength, Width, Height - (2 * Width) - (FSliderPos + FSliderLength)); Canvas.SetColor(clScrollBar); end; end @@ -429,22 +421,16 @@ begin else if FScrollbarDownPart in [{sbpDownForward,} sbpPageDownForward] then begin Canvas.SetColor(clShadow1); - Canvas.FillRectangle(FSliderPos + FSliderLength, 0, Width - Height - (FSliderPos + FSliderLength), Height); + Canvas.FillRectangle(Height + FSliderPos + FSliderLength, 0, Width - (2 * Height) - (FSliderPos + FSliderLength), Height); Canvas.SetColor(clScrollBar); end; end; // Paint the slider button if Orientation = orVertical then - begin - Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); -// Canvas.EndDraw(0, Width, Width, Height - Width - Width); - end + Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]) else - begin Canvas.DrawButtonFace(Height + FSliderPos, 0, FSliderLength, Height, [btfIsEmbedded]); -// Canvas.EndDraw(Height, 0, Width - Height - Height, Height); - end; end; procedure TfpgScrollBar.HandleLMouseDown(x, y: integer; shiftstate: TShiftState); @@ -587,7 +573,7 @@ begin FSliderPos := area; if ppos <> FSliderPos then - Invalidate; // DrawSlider(False); + Invalidate; if area <> 0 then newp := FMin + Trunc((FMax - FMin) * (FSliderPos / area)) @@ -620,7 +606,7 @@ begin if Visible then begin FRecalc := True; - Invalidate; // DrawSlider(True); + Invalidate; end; if Assigned(FOnScroll) then diff --git a/src/gui/fpg_scrollframe.pas b/src/gui/fpg_scrollframe.pas new file mode 100644 index 00000000..008832ce --- /dev/null +++ b/src/gui/fpg_scrollframe.pas @@ -0,0 +1,530 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Defines a scrollable frame widget. + + This unit was originally written by David Emerson <dle3ab@angelbase.com> +} +unit fpg_scrollframe; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + SysUtils, + fpg_base, + fpg_main, + fpg_widget, + fpg_panel, + fpg_scrollbar; + +type + + TfpgScrollFrame = class; + + + TfpgEmbeddingFrame = class (TfpgFrame) + // The purpose of the EmbeddingFrame is to pass scroll events to the ParentScrollFrame + private + FParentScrollFrame : TfpgScrollFrame; + protected + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; + delta: smallint); override; + procedure HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; + delta: smallint); override; + public + property ParentScrollFrame : TfpgScrollFrame read FParentScrollFrame write FParentScrollFrame; + end; + + + TfpgAutoSizingFrame = class (TfpgEmbeddingFrame) + private + FMarginBR : integer; + procedure SetMarginBR (AValue: integer); + public + procedure AfterConstruction; override; + procedure AdjustDimsFor (w : TfpgWidget; updatewp: boolean = true); + procedure AdjustDimsWithout (w : TfpgWidget); + procedure RecalcFrameSize; + property MarginBR : integer read FMarginBR write SetMarginBR; // bottom-right margin + end; + + TfpgASFrameClass = class of TfpgAutoSizingFrame; + + + TfpgScrollFrame = class(TfpgFrame) + private + FContentFrame: TfpgAutoSizingFrame; + FVisibleArea: TfpgEmbeddingFrame; + FHScrollBar: TfpgScrollBar; + FVScrollBar: TfpgScrollBar; + FScrollBarStyle: TfpgScrollStyle; + function GetXOffset: integer; + function GetYOffset: integer; + procedure SetXOffset(x: integer); + procedure SetYOffset(y: integer); + protected + procedure HandleMouseScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleMouseHorizScroll(x, y: integer; shiftstate: TShiftState; delta: smallint); override; + procedure HandleResize(awidth, aheight: TfpgCoord); override; + procedure HandleShow; override; + procedure HandlePaint; override; + procedure HScrollBarMove(Sender: TObject; position: integer); + procedure VScrollBarMove(Sender: TObject; position: integer); + procedure UpdateScrollbars; virtual; + property XOffset: integer read GetXOffset write SetXOffset; // these do not... + property YOffset: integer read GetYOffset write SetYOffset; // ...updatewindowposition + public + constructor Create (AOwner: TComponent); override; + constructor Create (AOwner: TComponent; ContentFrameType: TfpgASFrameClass); virtual; + procedure AfterCreate; override; + procedure SetContentFrameType(AContentFrameType: TfpgASFrameClass); + property ContentFrame: TfpgAutoSizingFrame read FContentFrame write FContentFrame; + end; + + +implementation + + +{ TfpgEmbeddingFrame } + +procedure TfpgEmbeddingFrame.HandleMouseScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +begin + ParentScrollFrame.HandleMouseScroll(x, y, shiftstate, delta); +end; + +procedure TfpgEmbeddingFrame.HandleMouseHorizScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +begin + ParentScrollFrame.HandleMouseHorizScroll(x, y, shiftstate, delta); +end; + + +{ TfpgAutoSizingFrame } + +procedure TfpgAutoSizingFrame.SetMarginBR(AValue: integer); +begin + if FMarginBR=AValue then Exit; + FMarginBR:=AValue; + RecalcFrameSize; +end; + +procedure TfpgAutoSizingFrame.AfterConstruction; +begin + inherited AfterConstruction; + RecalcFrameSize; +end; + +procedure TfpgAutoSizingFrame.AdjustDimsFor (w: TfpgWidget; updatewp: boolean = true); +var + new_w, new_h: integer; +begin + if not w.Visible then + Exit; + new_w := w.Right+MarginBR+1; + new_h := w.Bottom+MarginBR+1; + if (Width < new_w) or (Height < new_h) then + begin + HandleResize(new_w, new_h); + if updatewp then + if ParentScrollFrame is TfpgScrollFrame then + ParentScrollFrame.UpdateScrollbars + else + UpdateWindowPosition; + end; +end; + +procedure TfpgAutoSizingFrame.AdjustDimsWithout (w: TfpgWidget); +begin + if (Width = w.Right+MarginBR+1) + or (Height = w.Bottom+MarginBR+1) then + RecalcFrameSize; +end; + +procedure TfpgAutoSizingFrame.RecalcFrameSize; +var + i : integer; + c : TComponent; + max_w, max_h : integer; + this_need : integer; + par : TfpgWidget; +begin + if ComponentCount=0 then + Exit; + max_w := 1; + max_h := 1; + for i := 0 to ComponentCount-1 do begin + c := Components[i]; + if c is TfpgWidget then + begin + if not TfpgWidget(c).Visible then + continue; + this_need := TfpgWidget(c).right+MarginBR+1; + if (this_need>max_w) then + max_w := this_need; + this_need := TfpgWidget(c).bottom+MarginBR+1; + if (this_need>max_h) then + max_h := this_need; + end; + end; + HandleResize(max_w, max_h); + if ParentScrollFrame is TfpgScrollFrame then + ParentScrollFrame.UpdateScrollbars + else + UpdateWindowPosition; +end; + + +{ TfpgScrollFrame } + +function TfpgScrollFrame.GetXOffset: integer; +begin + result := -FContentFrame.Left; +end; + +function TfpgScrollFrame.GetYOffset: integer; +begin + result := -FContentFrame.Top; +end; + +procedure TfpgScrollFrame.SetXOffset (x: integer); +begin + if ContentFrame.Left = -x then + Exit; + FContentFrame.Left := -x; +end; + +procedure TfpgScrollFrame.SetYOffset (y: integer); +begin + if ContentFrame.Top = -y then + Exit; + FContentFrame.Top := -y; +end; + +procedure TfpgScrollFrame.HandleMouseScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +var + old_val, new_val : integer; +begin + inherited HandleMouseScroll(x, y, shiftstate, delta); + with FVScrollBar do + begin + if not Visible then + Exit; + Position:=Position+delta*ScrollStep; + if YOffset=Position then + Exit; + YOffset:=Position; + end; + UpdateScrollbars; +end; + +procedure TfpgScrollFrame.HandleMouseHorizScroll(x, y: integer; + shiftstate: TShiftState; delta: smallint); +begin + inherited HandleMouseHorizScroll(x, y, shiftstate, delta); + with FHScrollBar do + begin + if not Visible then + Exit; + Position:=Position+delta*ScrollStep; + if XOffset=Position then + Exit; + XOffset:=Position; + end; + UpdateScrollbars; +end; + +procedure TfpgScrollFrame.HandleResize(awidth, aheight: TfpgCoord); +begin + inherited HandleResize(awidth, aheight); + if (csLoading in ComponentState) or (csUpdating in ComponentState) then + Exit; //==> + if HasHandle then + UpdateScrollBars; +end; + +procedure TfpgScrollFrame.HandleShow; +begin + inherited HandleShow; + if (csLoading in ComponentState) then + Exit; + UpdateScrollBars; +end; + +procedure TfpgScrollFrame.HandlePaint; +begin + if csDesigning in ComponentState then + begin + // clear background rectangle + Canvas.Clear(clDarkGray); + // When designing, don't draw colors + // but draw an outline + Canvas.SetLineStyle(1, lsDash); + Canvas.DrawRectangle(GetClientRect); + Canvas.SetLineStyle(1, lsSolid); + Canvas.Color := clUIDesignerGreen; + Canvas.DrawLine(0, 0, Width, Height); + Canvas.DrawLine(Width, 0, 0, Height); + Canvas.TextColor := clShadow1; + Canvas.DrawText(5, 5, Name + ': ' + ClassName); + Exit; //==> + end; + + inherited HandlePaint; +end; + +procedure TfpgScrollFrame.HScrollBarMove (Sender: TObject; position: integer); +begin + if position = XOffset then + Exit; + XOffset := position; + FContentFrame.UpdateWindowPosition; +end; + +procedure TfpgScrollFrame.VScrollBarMove (Sender: TObject; position: integer); +begin + if position = YOffset then + Exit; + YOffset := position; + FContentFrame.UpdateWindowPosition; +end; + +procedure TfpgScrollFrame.UpdateScrollbars; +var + contentWidth, contentHeight: integer; + visWidth, visHeight: integer; + Hfits, Vfits : boolean; + showHsb, showVsb : boolean; + prevHideHsb, prevHideVsb : boolean; + + procedure hideScrollbar (sb : TfpgScrollBar); + begin + with sb do + if Visible then + begin + Visible := False; + UpdateWindowPosition; + end; + end; + + procedure getVisWidth; + begin + if showVsb then + visWidth := Width - (FVScrollBar.Width-1) + else + visWidth := Width; + Hfits := visWidth >= contentWidth + end; + + procedure getVisHeight; + begin + if showHsb then + visHeight := Height - (FHScrollBar.Height-1) + else + visHeight := Height; + Vfits := visHeight >= contentHeight; + end; + +begin + if (csLoading in ComponentState) or (csUpdating in ComponentState) then + Exit; //==> + + // if we don't want any scrollbars, hide them and exit + if FScrollBarStyle = ssNone then + begin + hideScrollbar (FHScrollBar); + hideScrollbar (FVScrollBar); + exit; + end; + + // preliminary width/height calculations + prevHideHsb := not FHScrollBar.Visible; + prevHideVsb := not FVScrollBar.Visible; + showVsb := (FScrollBarStyle = ssBothVisible); + showHsb := showVsb; + contentWidth := ContentFrame.Width; + contentHeight := ContentFrame.Height; + getVisWidth; + getVisHeight; + + // determine whether to show scrollbars for different configurations + case FScrollBarStyle of + ssHorizontal: + begin + hideScrollbar (FVScrollBar); + if not Hfits then + begin + showHsb := true; + getVisHeight; + end; + end; + ssVertical: + begin + hideScrollbar (FHScrollBar); + if not Vfits then + begin + showVsb := true; + getVisWidth; + end; + end; + ssAutoBoth: + if not Vfits then + begin + showVsb := true; + getVisWidth; + if not Hfits then + begin + showHsb := true; + getVisHeight; + getVisWidth; + end; + end + else if not Hfits then + begin + showHsb := true; + getVisHeight; + if not Vfits then + begin + showVsb := true; + getVisWidth; + getVisHeight; + end; + end; + end; + + // show or hide the scrollbars + + if showVsb then with FVScrollBar do + begin + if prevHideVsb then + Position := 0; + Visible := true; + Min := 0; + Max := contentHeight - visHeight; // may set position! + YOffset := Position; + if contentHeight > 0 then + SliderSize := visHeight / contentHeight + else + SliderSize := 0; + RepaintSlider; + Top := 0; + Left := visWidth; + Height := visHeight; + PageSize:= visHeight; + end + else + begin + FVScrollBar.Visible := false; + if Vfits then // if vertical doesn't fit and no scrollbar, do not change offset + YOffset := 0; + end; + + if showHsb then with FHScrollBar do + begin + if prevHideHsb then + Position := 0; + Visible := true; + Min := 0; + Max := contentWidth - visWidth; // may set position! + XOffset := Position; + if contentWidth > 0 then + SliderSize := visWidth / contentWidth + else + SliderSize := 0; + RepaintSlider; + Top := visHeight; + Left := 0; + Width := visWidth; + PageSize:= visWidth; + end + else + begin + FHScrollBar.Visible := false; + if Hfits then // if horizontal doesn't fit and no scrollbar, do not change offset + XOffset := 0; + end; + + FVScrollBar.UpdateWindowPosition; + FHScrollBar.UpdateWindowPosition; + + FVisibleArea.SetPosition(0, 0, visWidth, visHeight); + FVisibleArea.UpdateWindowPosition; + + FContentFrame.UpdateWindowPosition; +end; + +constructor TfpgScrollFrame.Create(AOwner: TComponent); +begin + inherited Create(AOwner); + + FVisibleArea := TfpgEmbeddingFrame.Create(self); + FVisibleArea.HandleMove(0, 0); + FVisibleArea.ParentScrollFrame := self; + + FContentFrame := TfpgAutoSizingFrame.Create(FVisibleArea); + FContentFrame.HandleMove(0, 0); + FContentFrame.ParentScrollFrame := self; +end; + +constructor TfpgScrollFrame.Create(AOwner: TComponent; ContentFrameType: TfpgASFrameClass); +begin + inherited Create(AOwner); + + FVisibleArea := TfpgEmbeddingFrame.Create(self); + FVisibleArea.HandleMove(0, 0); + FVisibleArea.ParentScrollFrame := self; + + FContentFrame := ContentFrameType.Create(FVisibleArea); + FContentFrame.HandleMove(0, 0); + FContentFrame.ParentScrollFrame := self; +end; + +procedure TfpgScrollFrame.AfterCreate; +begin + inherited AfterCreate; + + FVScrollBar := TfpgScrollBar.Create(self); + with FVScrollBar do begin + Orientation := orVertical; + OnScroll := @VScrollBarMove; + Position := 0; + ScrollStep := 10; + end; + + FHScrollBar := TfpgScrollBar.Create(self); + with FHScrollBar do begin + Orientation := orHorizontal; + OnScroll := @HScrollBarMove; + Position := 0; + ScrollStep := 10; + end; + + FScrollBarStyle := ssAutoBoth; +end; + +procedure TfpgScrollFrame.SetContentFrameType(AContentFrameType: TfpgASFrameClass); +begin + if Assigned(FContentFrame) then + FContentFrame.Free; + FContentFrame := AContentFrameType.Create(FVisibleArea); + FContentFrame.HandleMove(0, 0); + FContentFrame.ParentScrollFrame := self; +end; + + +end. diff --git a/src/gui/fpg_spinedit.pas b/src/gui/fpg_spinedit.pas index 444fa2c0..6061eb3b 100644 --- a/src/gui/fpg_spinedit.pas +++ b/src/gui/fpg_spinedit.pas @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, @@ -262,7 +262,7 @@ begin newh := h; Result.SetPosition(x, y, w, newh); - if AMaxValue > AMinValue then + if AMaxValue >= AMinValue then begin Result.MinValue := AMinValue; Result.MaxValue := AMaxValue; @@ -288,7 +288,7 @@ begin newh := h; Result.SetPosition(x, y, w, newh); - if AMaxValue > AMinValue then + if AMaxValue >= AMinValue then begin Result.MinValue := AMinValue; Result.MaxValue := AMaxValue; @@ -550,27 +550,23 @@ end; procedure TfpgSpinEditFloat.SetMaxValue(const AValue: extended); begin - if (FMaxValue <> AValue) and (AValue > FMinValue) then + if (FMaxValue <> AValue) and (AValue >= FMinValue) then begin FMaxValue := AValue; if FValue > FMaxValue then - begin FValue := FMaxValue; - FEdit.Value := FValue; - end; + FEdit.Value := FValue; end; end; procedure TfpgSpinEditFloat.SetMinValue(const AValue: extended); begin - if (FMinValue <> AValue) and (AValue < FMaxValue) then + if (FMinValue <> AValue) and (AValue <= FMaxValue) then begin FMinValue := AValue; if FValue < FMinValue then - begin FValue := FMinValue; - FEdit.Value := FValue; - end; + FEdit.Value := FValue; end; end; @@ -990,27 +986,23 @@ end; procedure TfpgSpinEdit.SetMaxValue(const AValue: integer); begin - if (FMaxValue <> AValue) and (AValue > FMinValue) then + if (FMaxValue <> AValue) and (AValue >= FMinValue) then begin FMaxValue := AValue; if FValue > FMaxValue then - begin FValue := FMaxValue; - FEdit.Value := FValue; - end; + FEdit.Value := FValue; end; end; procedure TfpgSpinEdit.SetMinValue(const AValue: integer); begin - if (FMinValue <> AValue) and (AValue < FMaxValue) then + if (FMinValue <> AValue) and (AValue <= FMaxValue) then begin FMinValue := AValue; if FValue < FMinValue then - begin FValue := FMinValue; - FEdit.Value := FValue; - end; + FEdit.Value := FValue; end; end; diff --git a/src/gui/fpg_style_carbon.pas b/src/gui/fpg_style_carbon.pas new file mode 100644 index 00000000..6ad720ee --- /dev/null +++ b/src/gui/fpg_style_carbon.pas @@ -0,0 +1,250 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Carbon fpGUI styles + + Author: Rochdi Abdelilah +} + +unit fpg_style_carbon; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + fpg_main, + fpg_base; + +type + + TfpgCarbonStyle = class(TfpgStyle) + public + constructor Create; override; + { General } + procedure DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); override; + function GetControlFrameBorders: TRect; override; + procedure DrawBevel(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; ARaised: boolean = True); override; + procedure DrawDirectionArrow(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; direction: TArrowDirection); override; + procedure DrawString(ACanvas: TfpgCanvas; x, y: TfpgCoord; AText: string; AEnabled: boolean = True); override; + procedure DrawFocusRect(ACanvas: TfpgCanvas; r: TfpgRect); override; + { Buttons } + procedure DrawButtonFace(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); override; + function GetButtonBorders: TRect; override; + function GetButtonShift: TPoint; override; + function HasButtonHoverEffect: boolean; override; + procedure DrawMenuBar(ACanvas: TfpgCanvas; r: TfpgRect; ABackgroundColor: TfpgColor); override; + procedure DrawMenuRow(ACanvas: TfpgCanvas; r: TfpgRect; AFlags: TfpgMenuItemFlags); override; + procedure DrawMenuItemSeparator(ACanvas: TfpgCanvas; r: TfpgRect); override; + end; + + +implementation + +uses + fpg_stylemanager; + +const + CarbonBaseColors: array [0..15] of TfpgColor = ( + $FF333333, $FF191919, $FF616161, + $FF202020, $FF474747, $FFC0C0C0, + $FF6E6E6E, $FF3399FF, $FFEAEAEA, + $FF2D2D2D, $FF494949, $FF24617A, + $FF353535, $FF434343, $FF313131, + $FF27546A); + +{ TfpgCarbonStyle } + +constructor TfpgCarbonStyle.Create; +begin + inherited Create; + fpgSetNamedColor(clWindowBackground, CarbonBaseColors[0]); + fpgSetNamedColor(clBoxColor, CarbonBaseColors[1]); + fpgSetNamedColor(clShadow1, CarbonBaseColors[2]); + fpgSetNamedColor(clShadow2, CarbonBaseColors[1]); + fpgSetNamedColor(clHilite1, CarbonBaseColors[3]); + fpgSetNamedColor(clHilite2, CarbonBaseColors[4]); + fpgSetNamedColor(clText1, CarbonBaseColors[5]); + fpgSetNamedColor(clText4, CarbonBaseColors[6]); + fpgSetNamedColor(clSelection, CarbonBaseColors[7]); + fpgSetNamedColor(clSelectionText, CarbonBaseColors[8]); + fpgSetNamedColor(clInactiveSel, CarbonBaseColors[7]); + fpgSetNamedColor(clInactiveSelText, CarbonBaseColors[8]); + fpgSetNamedColor(clScrollBar, CarbonBaseColors[9]); + fpgSetNamedColor(clButtonFace, CarbonBaseColors[0]); + fpgSetNamedColor(clListBox, CarbonBaseColors[1]); + fpgSetNamedColor(clGridLines, CarbonBaseColors[2]); + fpgSetNamedColor(clGridHeader, CarbonBaseColors[0]); + fpgSetNamedColor(clWidgetFrame, CarbonBaseColors[2]); + fpgSetNamedColor(clInactiveWgFrame, CarbonBaseColors[10]); + fpgSetNamedColor(clUnset, CarbonBaseColors[11]); + fpgSetNamedColor(clMenuText, CarbonBaseColors[5]); + fpgSetNamedColor(clMenuDisabled, CarbonBaseColors[0]); + fpgSetNamedColor(clHintWindow, CarbonBaseColors[0]); + fpgSetNamedColor(clGridSelection, CarbonBaseColors[7]); + fpgSetNamedColor(clGridSelectionText, CarbonBaseColors[8]); + fpgSetNamedColor(clGridInactiveSel, CarbonBaseColors[7]); + fpgSetNamedColor(clGridInactiveSelText, CarbonBaseColors[8]); + fpgSetNamedColor(clSplitterGrabBar, CarbonBaseColors[7]); +end; + +procedure TfpgCarbonStyle.DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); +var + r: TfpgRect; +begin + r.SetRect(x, y, w, h); + ACanvas.SetColor(clShadow1); + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.DrawRectangle(r); +end; + +function TfpgCarbonStyle.GetControlFrameBorders: TRect; +begin + Result := Rect(1, 1, 1, 1); +end; + +procedure TfpgCarbonStyle.DrawBevel(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; + ARaised: boolean); +begin + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.GradientFill(fpgRect(x,y,w,h), clUnset, CarbonBaseColors[15], gdVertical); + ACanvas.SetColor(clHilite1); + ACanvas.DrawRectangle(x, y, w, h); +end; + +procedure TfpgCarbonStyle.DrawDirectionArrow(ACanvas: TfpgCanvas; + x, y, w, h: TfpgCoord; direction: TArrowDirection); +begin + ACanvas.SetColor(clBoxColor); + inherited DrawDirectionArrow(ACanvas, x + 1, y + 1, w, h, direction); +end; + +procedure TfpgCarbonStyle.DrawString(ACanvas: TfpgCanvas; x, y: TfpgCoord; + AText: string; AEnabled: boolean); +begin + if AText = '' then + Exit; + if not AEnabled then + ACanvas.SetTextColor(clText4) + else + ACanvas.SetTextColor(clText1); + ACanvas.DrawString(x, y, AText); +end; + +procedure TfpgCarbonStyle.DrawButtonFace(ACanvas: TfpgCanvas; + x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); +var + r: TfpgRect; +begin + ACanvas.SetColor(clBoxColor); + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.FillRectangle(x, y, w, h); + + r.SetRect(x + 1, y + 1, w - 2, h - 2); + + if (btfIsPressed in AFlags) then + begin + if (btfFlat in AFlags) or (btfHover in AFlags) then + ACanvas.SetColor(clHilite2) + else + begin + ACanvas.GradientFill(r, CarbonBaseColors[14], CarbonBaseColors[13], gdVertical); + ACanvas.SetColor(clInactiveWgFrame); + end; + end + else + begin + if btfHover in AFlags then + begin + ACanvas.GradientFill(r, clHilite2, CarbonBaseColors[12], gdVertical); + ACanvas.SetColor(clShadow1); + end + else + begin + if not ((btfFlat in AFlags) and not (btfIsPressed in AFlags)) then + begin + ACanvas.GradientFill(r, CarbonBaseColors[13], CarbonBaseColors[14], gdVertical); + ACanvas.SetColor(clInactiveWgFrame); + end + else if btfFlat in AFlags then + begin + ACanvas.SetColor(clButtonFace); + ACanvas.FillRectangle(r); + end; + end; + end; + + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.DrawRectangle(r); + if btfIsDefault in AFlags then + begin + ACanvas.SetColor(clUnset); + ACanvas.DrawLine(2, 1, w - 2, 1); + ACanvas.DrawLine(2, h - 2, w - 2, h - 2); + end; +end; + +function TfpgCarbonStyle.GetButtonBorders: TRect; +begin + Result := Rect(2, 2, 2, 2); +end; + +function TfpgCarbonStyle.GetButtonShift: TPoint; +begin + Result := Point(0, 0); +end; + +function TfpgCarbonStyle.HasButtonHoverEffect: boolean; +begin + Result := True; +end; + +procedure TfpgCarbonStyle.DrawMenuRow(ACanvas: TfpgCanvas; r: TfpgRect; + AFlags: TfpgMenuItemFlags); +begin + inherited DrawMenuRow(ACanvas, r, AFlags); + if (mifSelected in AFlags) and not (mifSeparator in AFlags) then + ACanvas.GradientFill(r, clUnset, CarbonBaseColors[15], gdVertical); +end; + + +procedure TfpgCarbonStyle.DrawMenuBar(ACanvas: TfpgCanvas; r: TfpgRect; + ABackgroundColor: TfpgColor); +begin + ACanvas.Clear(clWindowBackground); + ACanvas.SetColor(clShadow1); + ACanvas.DrawLine(r.Left, r.Bottom-1, r.Right + 1, r.Bottom-1); + ACanvas.SetColor(clBoxColor); + ACanvas.DrawLine(r.Left, r.Bottom, r.Right + 1, r.Bottom); +end; + +procedure TfpgCarbonStyle.DrawMenuItemSeparator(ACanvas: TfpgCanvas; r: TfpgRect); +begin + ACanvas.SetColor(clBoxColor); + ACanvas.DrawLine(r.Left + 1, r.Top + 2, r.Right, r.Top + 2); +end; + +procedure TfpgCarbonStyle.DrawFocusRect(ACanvas: TfpgCanvas; r: TfpgRect); +begin + ACanvas.SetColor(clUnset); + ACanvas.SetLineStyle(1, lsSolid); + //InflateRect(r, 1, 1); + ACanvas.DrawRectangle(r); +end; + +initialization + fpgStyleManager.RegisterClass('Carbon', TfpgCarbonStyle); + +end. diff --git a/src/gui/fpg_style_plastic.pas b/src/gui/fpg_style_plastic.pas new file mode 100644 index 00000000..2bb43159 --- /dev/null +++ b/src/gui/fpg_style_plastic.pas @@ -0,0 +1,376 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2013 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + Plastic fpGUI styles + + Author: Rochdi Abdelilah +} + +{$define RegPlasticDark} +{$define RegPlasticDarkGray} +{$define RegPlasticMediumGray} +{$define RegPlasticLightGray} + +{$IF not defined(RegPlasticDark) and + not defined(RegPlasticDarkGray) and + not defined(RegPlasticMediumGray) and + not defined(RegPlasticLightGray))} + {$define RegPlasticDark} +{$ifend} + +unit fpg_style_plastic; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, + fpg_main, + fpg_base; + +type + TPlasticColors = array [0..22] of TfpgColor; + PPlasticColors = ^TPlasticColors; + + TfpgPlasticStyle = class(TfpgStyle) + protected + FPlasticColors: PPlasticColors; + procedure LoadPlasticColors; virtual; abstract; + public + constructor Create; override; + { General } + procedure DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); override; overload; + procedure DrawBevel(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; ARaised: boolean = True); override; + procedure DrawDirectionArrow(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; direction: TArrowDirection); override; + procedure DrawString(ACanvas: TfpgCanvas; x, y: TfpgCoord; AText: string; AEnabled: boolean = True); override; + procedure DrawFocusRect(ACanvas: TfpgCanvas; r: TfpgRect); override; + { Buttons } + procedure DrawButtonFace(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); override; + function GetButtonBorders: TRect; override; + function GetButtonShift: TPoint; override; + function HasButtonHoverEffect: boolean; override; + procedure DrawMenuBar(ACanvas: TfpgCanvas; r: TfpgRect; ABackgroundColor: TfpgColor); override; + { Menus } + procedure DrawMenuItemSeparator(ACanvas: TfpgCanvas; r: TfpgRect); override; + end; + + { TfpgPlasticDarkStyle } + + {$IFDEF RegPlasticDark} + TfpgPlasticDarkStyle = class(TfpgPlasticStyle) + protected + procedure LoadPlasticColors; override; + end; + {$ENDIF} + + { TfpgPlasticDarkGrayStyle } + + {$IFDEF RegPlasticDarkGray} + TfpgPlasticDarkGrayStyle = class(TfpgPlasticStyle) + protected + procedure LoadPlasticColors; override; + end; + {$ENDIF} + + { TfpgPlasticMediumGrayStyle } + + {$IFDEF RegPlasticMediumGray} + TfpgPlasticMediumGrayStyle = class(TfpgPlasticStyle) + protected + procedure LoadPlasticColors; override; + end; + {$ENDIF} + + { TfpgPlasticLightGrayStyle } + + {$IFDEF RegPlasticLightGray} + TfpgPlasticLightGrayStyle = class(TfpgPlasticStyle) + protected + procedure LoadPlasticColors; override; + end; + {$ENDIF} + +implementation + +uses + fpg_stylemanager; + +const + {$IFDEF RegPlasticDark} + PlasticDarkColors: TPlasticColors = + ($FF343434, $FF222222, $FF141414, $FF454545, + $FFDDDDDD, $FF4B5367, $FF464646, $FF101010, + $FF4A669B, $FF373737, $FF303030, $FF1F1F1F, + $FF878787, $FF696969, $FF646464, $FF4E4E4E, + $FF262626, $FF1D1D1D, $FF3D3D3D, $FF272727, + $FF282828, $FF292929, $FF2A2A2A); + {$ENDIF} + {$IFDEF RegPlasticDarkGray} + PlasticDarkGrayColors: TPlasticColors = + ($FF535353, $FF3a3a3a, $FF282828, $FF6A6A6A, + $FFE5E5E5, $FF596678, $FF6A6A6A, $FF303030, + $FF506FAC, $FF575757, $FF4D4D4D, $FF333333, + $FFA0A0A0, $FF919191, $FF848484, $FF757575, + $FF3F3F3F, $FF373737, $FF626262, $FF444444, + $FF464646, $FF474747, $FF484848); + {$ENDIF} + {$IFDEF RegPlasticMediumGray} + PlasticMediumGrayColors: TPlasticColors = + ($FFB8B8B8, $FFFFFFFF, $FF707070, $FFCDCDCD, + $FF373737, $FFB7CDF9, $FFC8C8C8, $FF686868, + $FF74AAF3, $FFBBBBBB, $FFA9A9A9, $FF7F7F7F, + $FFFAFAFA, $FFF7F7F7, $FFFEFEFE, $FFE7E7E7, + $FF8D8D8D, $FF868686, $FFBDBDBD, $FF909090, + $FF919191, $FF929292, $FF959595); + {$ENDIF} + {$IFDEF RegPlasticLightGray} + PlasticLightGrayColors: TPlasticColors = + ($FFD6D6D6, $FFFFFFFF, $FF737373, $FFEBEBEB, + $FF373737, $FFB7CDF9, $FFE8E8E8, $FF7C7C7C, + $FF9BCAFA, $FFD9D9D9, $FFC3C3C3, $FF999999, + $FFFFFFFF, $FFF5F5F5, $FFFEFEFE, $FFE6E6E6, + $FFA9A9A9, $FFA0A0A0, $FFD7D7D7, $FFACACAC, + $FFAEAEAE, $FFB7B7B7, $FFBABABA); + {$ENDIF} + +{ TfpgPlasticLightGrayStyle } + +{$IFDEF RegPlasticLightGray} +procedure TfpgPlasticLightGrayStyle.LoadPlasticColors; +begin + FPlasticColors := @PlasticLightGrayColors; +end; +{$ENDIF} + +{ TfpgPlasticMediumGrayStyle } + +{$IFDEF RegPlasticMediumGray} +procedure TfpgPlasticMediumGrayStyle.LoadPlasticColors; +begin + FPlasticColors := @PlasticMediumGrayColors; +end; +{$ENDIF} + +{ TfpgPlasticDarkGrayStyle } + +{$IFDEF RegPlasticDarkGray} +procedure TfpgPlasticDarkGrayStyle.LoadPlasticColors; +begin + FPlasticColors := @PlasticDarkGrayColors; +end; +{$ENDIF} + +{ TfpgPlasticDarkStyle } + +{$IFDEF RegPlasticDark} +procedure TfpgPlasticDarkStyle.LoadPlasticColors; +begin + FPlasticColors := @PlasticDarkColors; +end; +{$ENDIF} + +{ TfpgPlasticStyle } + +constructor TfpgPlasticStyle.Create; +begin + inherited Create; + LoadPlasticColors; + fpgSetNamedColor(clWindowBackground, FPlasticColors^[0]); + fpgSetNamedColor(clBoxColor, FPlasticColors^[1]); + fpgSetNamedColor(clShadow1, FPlasticColors^[2]); + fpgSetNamedColor(clShadow2, FPlasticColors^[3]); + fpgSetNamedColor(clHilite1, FPlasticColors^[3]); + fpgSetNamedColor(clHilite2, FPlasticColors^[3]); + fpgSetNamedColor(clText1, FPlasticColors^[4]); + fpgSetNamedColor(clText4, FPlasticColors^[2]); + fpgSetNamedColor(clSelection, FPlasticColors^[5]); + fpgSetNamedColor(clSelectionText, FPlasticColors^[4]); + fpgSetNamedColor(clInactiveSel, FPlasticColors^[5]); + fpgSetNamedColor(clInactiveSelText, FPlasticColors^[4]); + fpgSetNamedColor(clScrollBar, FPlasticColors^[6]); + fpgSetNamedColor(clButtonFace, FPlasticColors^[0]); + fpgSetNamedColor(clListBox, FPlasticColors^[1]); + fpgSetNamedColor(clGridLines, FPlasticColors^[7]); + fpgSetNamedColor(clGridHeader, FPlasticColors^[0]); + fpgSetNamedColor(clWidgetFrame, FPlasticColors^[3]); + fpgSetNamedColor(clInactiveWgFrame, FPlasticColors^[2]); + fpgSetNamedColor(clMenuText, FPlasticColors^[4]); + fpgSetNamedColor(clHintWindow, FPlasticColors^[1]); + fpgSetNamedColor(clGridSelection, FPlasticColors^[5]); + fpgSetNamedColor(clGridSelectionText, FPlasticColors^[4]); + fpgSetNamedColor(clGridInactiveSel, FPlasticColors^[5]); + fpgSetNamedColor(clGridInactiveSelText, FPlasticColors^[4]); + fpgSetNamedColor(clSplitterGrabBar, FPlasticColors^[8]); +end; + +procedure TfpgPlasticStyle.DrawDirectionArrow(ACanvas: TfpgCanvas; + x, y, w, h: TfpgCoord; direction: TArrowDirection); +begin + ACanvas.SetColor(clText1); + inherited DrawDirectionArrow(ACanvas, x + 2, y + 1, w - 2, h - 3, direction); +end; + +procedure TfpgPlasticStyle.DrawBevel(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; + ARaised: boolean); +begin + DrawButtonFace(ACanvas, x, y, w, h, [btfIsPressed]); +end; + +procedure TfpgPlasticStyle.DrawString(ACanvas: TfpgCanvas; x, y: TfpgCoord; + AText: string; AEnabled: boolean); +var + lOldColor: TfpgColor; +begin + if AText = '' then + Exit; + lOldColor := ACanvas.TextColor; + if not AEnabled then + ACanvas.SetTextColor(clText4) + else + ACanvas.SetTextColor(clText1); + if lOldColor = clShadow1 then + ACanvas.SetTextColor(clHilite2); + ACanvas.DrawString(x, y, AText); + if lOldColor <> clBlue then + ACanvas.SetTextColor(lOldColor); +end; + +procedure TfpgPlasticStyle.DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); +begin + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.GradientFill(fpgRect(x, y, w, h), clWindowBackground, clScrollBar, gdVertical); + ACanvas.Pixels[x, y + h - 1] := FPlasticColors^[9]; + ACanvas.Pixels[x + w - 1, y + h - 1] := FPlasticColors^[9]; + ACanvas.SetColor(clGridLines); + ACanvas.DrawRectangle(fpgRect(x + 1, y + 1, w - 2, h - 2)); + ACanvas.Pixels[x + 1, y + 1] := FPlasticColors^[10]; + ACanvas.Pixels[x + w - 2, y + 1] := FPlasticColors^[10]; + ACanvas.Pixels[x + 1, y + h - 2] := FPlasticColors^[10]; + ACanvas.Pixels[x + w - 2, y + h - 2] := FPlasticColors^[10]; +end; + +procedure TfpgPlasticStyle.DrawFocusRect(ACanvas: TfpgCanvas; r: TfpgRect); +begin + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.SetColor(clSplitterGrabBar); + ACanvas.DrawRectangle(r); + ACanvas.Pixels[r.Left, r.Top] := FPlasticColors^[9]; + ACanvas.Pixels[r.Left + 1, r.Top + 1] := clSplitterGrabBar; + ACanvas.Pixels[r.Width - 1, r.Top] := FPlasticColors^[9]; + ACanvas.Pixels[r.Width - 2, r.Top + 1] := clSplitterGrabBar; + ACanvas.Pixels[r.Left, r.Height - 1] := FPlasticColors^[9]; + ACanvas.Pixels[r.Left + 1, r.Height - 2] := clSplitterGrabBar; + ACanvas.Pixels[r.Width - 1, r.Height - 1] := FPlasticColors^[9]; + ACanvas.Pixels[r.Width - 2, r.Height - 2] := clSplitterGrabBar; +end; + +procedure TfpgPlasticStyle.DrawButtonFace(ACanvas: TfpgCanvas; + x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); +var + r: TfpgRect; +begin + ACanvas.SetLineStyle(1, lsSolid); + r.SetRect(x, y, w, h); + DrawControlFrame(ACanvas, r); + r.SetRect(x + 2, y + 3, w - 4, h - 5); + + if (btfIsPressed in AFlags) then + begin + ACanvas.GradientFill(r, FPlasticColors^[16], FPlasticColors^[17], gdVertical); + ACanvas.SetColor(FPlasticColors^[11]); + end + else + begin + if btfHover in AFlags then + begin + ACanvas.GradientFill(r, FPlasticColors^[14], FPlasticColors^[15], gdVertical); + ACanvas.SetColor(FPlasticColors^[12]); + end + else + begin + if not ((btfFlat in AFlags) and not (btfIsPressed in AFlags)) then + begin + ACanvas.GradientFill(r, FPlasticColors^[15], FPlasticColors^[18], gdVertical); + ACanvas.SetColor(FPlasticColors^[13]); + end + else if btfFlat in AFlags then + begin + ACanvas.SetColor(clWindowBackground); + ACanvas.FillRectangle(r); + end; + end; + end; + if not (btfFlat in AFlags) then + begin + if (btfIsDefault in AFlags) and not (btfIsPressed in AFlags) and + not (btfHasFocus in AFlags) then + ACanvas.SetColor(clSplitterGrabBar); + ACanvas.DrawLine(x + 2, y + 2, x + w - 2, y + 2); + end; + ACanvas.Pixels[x + 2, y + 2] := FPlasticColors^[19]; + ACanvas.Pixels[x + w - 3, y + 2] := FPlasticColors^[20]; + ACanvas.Pixels[x + 2, y + h - 3] := FPlasticColors^[21]; + ACanvas.Pixels[x + w - 3, y + h - 3] := FPlasticColors^[22]; +end; + +function TfpgPlasticStyle.GetButtonBorders: TRect; +begin + Result := Rect(0, 0, 0, 0); +end; + +function TfpgPlasticStyle.GetButtonShift: TPoint; +begin + Result := Point(0, 0); +end; + +function TfpgPlasticStyle.HasButtonHoverEffect: boolean; +begin + Result := True; +end; + +procedure TfpgPlasticStyle.DrawMenuBar(ACanvas: TfpgCanvas; r: TfpgRect; + ABackgroundColor: TfpgColor); +begin + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.SetColor(clWindowBackground); + ACanvas.FillRectangle(r); + ACanvas.SetColor(clShadow2); + ACanvas.DrawLine(r.Left, r.Top, r.Left + r.Right, r.Top); + DrawMenuItemSeparator(ACanvas, fpgRect(r.Left - 1, r.Height - 4, r.Width, r.Height)); +end; + +procedure TfpgPlasticStyle.DrawMenuItemSeparator(ACanvas: TfpgCanvas; r: TfpgRect); +begin + ACanvas.SetColor(clShadow1); + ACanvas.DrawLine(r.Left + 1, r.Top + 2, r.Right, r.Top + 2); + ACanvas.SetColor(clShadow2); + ACanvas.DrawLine(r.Left + 1, r.Top + 3, r.Right, r.Top + 3); +end; + + +initialization + {$IFDEF RegPlasticDark} + fpgStyleManager.RegisterClass('Plastic Dark', TfpgPlasticDarkStyle); + {$ENDIF} + {$IFDEF RegPlasticDarkGray} + fpgStyleManager.RegisterClass('Plastic Dark Gray', TfpgPlasticDarkGrayStyle); + {$ENDIF} + {$IFDEF RegPlasticMediumGray} + fpgStyleManager.RegisterClass('Plastic Medium Gray', TfpgPlasticMediumGrayStyle); + {$ENDIF} + {$IFDEF RegPlasticLightGray} + fpgStyleManager.RegisterClass('Plastic Light Gray', TfpgPlasticLightGrayStyle); + {$ENDIF} +end. diff --git a/src/gui/fpg_style_win8.pas b/src/gui/fpg_style_win8.pas new file mode 100644 index 00000000..f3d99705 --- /dev/null +++ b/src/gui/fpg_style_win8.pas @@ -0,0 +1,541 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This unit implements a Windows 8 (I think) look-alike style + + Author: Graeme Geldenhuys +} + +unit fpg_style_win8; + +{$mode objfpc}{$H+} + +{ + *********************************************************** + ********** This is still under development! *********** + *********************************************************** + + It needs lots of testing and debugging. +} + +interface + +uses + Classes, + fpg_main, + fpg_base; + +type + TfpgWin8Style = class(TfpgStyle) + private + FImages: TfpgImages; + procedure LoadThemeImages; + public + constructor Create; override; + destructor Destroy; override; + { General } + procedure DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); override; overload; + function GetControlFrameBorders: TRect; override; + { Buttons } + procedure DrawButtonFace(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); override; overload; + function GetButtonBorders: TRect; override; + { Combobox } + procedure DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; const IsEnabled: Boolean; const IsFocused: Boolean; const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor; const AInternalBtnRect: TfpgRect; const ABtnPressed: Boolean); override; + { Checkbox } + procedure DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); override; + end; + +implementation + +uses + fpg_stylemanager + ; + +const + Win8BaseColors: array [0..16] of TfpgColor = ( + $FFF0F0F0, $FF606060, $FFABADB3, + $FF202020, $FF474747, $FFC0C0C0, + $FF3399FF, $FF3399FF, $FFFFFFFF, + $FF2D2D2D, $FF494949, $FF24617A, + $FF353535, $FF434343, $FF313131, + $FF27546A, $FFE5E5E5); + + +{%region 'Byte arrays of images' -fold} +const + win8_checkboxes: array[0..2601] of byte = ( + 66, 77, 42, 10, 0, 0, 0, 0, 0, 0, 54, 0, 0, 0, 40, 0, 0, + 0, 65, 0, 0, 0, 13, 0, 0, 0, 1, 0, 24, 0, 0, 0, 0, 0, + 244, 9, 0, 0,196, 14, 0, 0,196, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188, 0,112,112,112,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,112,112,112, + 112,112,112,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,112,112,112,188,188,188,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,188,188,188,188,188,188,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,188,188,188,188,188, + 188,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 188,188,188, 0,112,112,112,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,112,112,112,112,112,112,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,207,207,207,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,112,112,112,188,188,188, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,188, + 188,188,188,188,188,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,208,208,208,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,188,188,188,188,188,188,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,188,188,188, 0,112,112,112,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,112,112, + 112,112,112,112,255,255,255,255,255,255,255,255,255,255,255,255, 95, + 95, 95, 0, 0, 0,207,207,207,255,255,255,255,255,255,255,255,255, + 255,255,255,112,112,112,188,188,188,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,188,188,188,188,188,188,230,230,230, + 230,230,230,230,230,230,230,230,230,156,156,156,112,112,112,208,208, + 208,230,230,230,230,230,230,230,230,230,230,230,230,188,188,188,188, + 188,188,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,188,188,188, 0,112,112,112,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,112,112,112,112,112,112,255,255,255,255, + 255,255,239,239,239, 63, 63, 63, 0, 0, 0, 0, 0, 0, 47, 47, 47, + 255,255,255,255,255,255,255,255,255,255,255,255,112,112,112,188,188, + 188,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 188,188,188,188,188,188,230,230,230,230,230,230,223,223,223,141,141, + 141,112,112,112,112,112,112,134,134,134,230,230,230,230,230,230,230, + 230,230,230,230,230,188,188,188,188,188,188,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,188,188,188, 0,112,112,112, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,112, + 112,112,112,112,112,255,255,255,239,239,239, 47, 47, 47, 0, 0, 0, + 0, 0, 0, 15, 15, 15, 0, 0, 0,127,127,127,255,255,255,255,255, + 255,255,255,255,112,112,112,188,188,188,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,188,188,188,188,188,188,230,230, + 230,223,223,223,134,134,134,112,112,112,112,112,112,119,119,119,112, + 112,112,171,171,171,230,230,230,230,230,230,230,230,230,188,188,188, + 188,188,188,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,188,188,188, 0,112,112,112,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,112,112,112,112,112,112,255,255,255, + 159,159,159, 0, 0, 0, 15, 15, 15,207,207,207,175,175,175, 0, 0, + 0, 0, 0, 0,207,207,207,255,255,255,255,255,255,112,112,112,188, + 188,188,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,188,188,188,188,188,188,230,230,230,186,186,186,112,112,112,119, + 119,119,208,208,208,193,193,193,112,112,112,112,112,112,208,208,208, + 230,230,230,230,230,230,188,188,188,188,188,188,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,188,188,188, 0,112,112, + 112,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 112,112,112,112,112,112,255,255,255,255,255,255,127,127,127,207,207, + 207,255,255,255,255,255,255, 79, 79, 79, 0, 0, 0, 47, 47, 47,255, + 255,255,255,255,255,112,112,112,188,188,188,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,188,188,188,188,188,188,230, + 230,230,230,230,230,171,171,171,208,208,208,230,230,230,230,230,230, + 149,149,149,112,112,112,134,134,134,230,230,230,230,230,230,188,188, + 188,188,188,188,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,188,188,188, 0,112,112,112,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,112,112,112,112,112,112,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,239, + 239,239, 15, 15, 15, 0, 0, 0,127,127,127,255,255,255,112,112,112, + 188,188,188,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,188,188,188,188,188,188,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,223,223,223,119,119,119,112,112, + 112,171,171,171,230,230,230,188,188,188,188,188,188,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,188,188,188, 0,112, + 112,112,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,112,112,112,112,112,112,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,175,175,175, 0, 0, 0, + 15, 15, 15,255,255,255,112,112,112,188,188,188,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,188,188,188,188,188,188, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,193,193,193,112,112,112,119,119,119,230,230,230,188, + 188,188,188,188,188,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,188,188,188, 0,112,112,112,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,112,112,112,112,112,112,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,127,127,127,223,223,223,255,255,255,112,112, + 112,188,188,188,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,188,188,188,188,188,188,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,171, + 171,171,215,215,215,230,230,230,188,188,188,188,188,188,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,188,188,188, 0, + 112,112,112,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,112,112,112,112,112,112,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,112,112,112,188,188,188,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,188,188,188,188,188, + 188,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 188,188,188,188,188,188,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,188,188,188, 0,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112,112, + 112,112,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188,188, + 0); + + +const + win8_radiobuttons: array[0..2601] of byte = ( + 66, 77, 42, 10, 0, 0, 0, 0, 0, 0, 54, 0, 0, 0, 40, 0, 0, + 0, 65, 0, 0, 0, 13, 0, 0, 0, 1, 0, 24, 0, 0, 0, 0, 0, + 244, 9, 0, 0,196, 14, 0, 0,196, 14, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0,255,255,255,255,255,255,255,255,255,209,209,209,168,168, + 168,134,134,134,115,115,115,134,134,134,168,168,168,209,209,209,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 209,209,209,168,168,168,134,134,134,115,115,115,134,134,134,168,168, + 168,209,209,209,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,233,233,233,214,214,214,199,199,199,189,189,189, + 199,199,199,214,214,214,233,233,233,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,233,233,233,214,214,214,199, + 199,199,189,189,189,199,199,199,214,214,214,233,233,233,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,233,233, + 233,214,214,214,199,199,199,189,189,189,199,199,199,214,214,214,233, + 233,233,255,255,255,255,255,255,255,255,255, 0,255,255,255,242,242, + 242,177,177,177,114,114,114,199,199,199,233,233,233,252,252,252,233, + 233,233,199,199,199,114,114,114,177,177,177,242,242,242,255,255,255, + 255,255,255,242,242,242,177,177,177,114,114,114,199,199,199,233,233, + 233,252,252,252,233,233,233,199,199,199,114,114,114,177,177,177,242, + 242,242,255,255,255,255,255,255,249,249,249,218,218,218,189,189,189, + 214,214,214,223,223,223,229,229,229,223,223,223,214,214,214,189,189, + 189,218,218,218,249,249,249,255,255,255,255,255,255,249,249,249,218, + 218,218,189,189,189,214,214,214,223,223,223,229,229,229,223,223,223, + 214,214,214,189,189,189,218,218,218,249,249,249,255,255,255,255,255, + 255,249,249,249,218,218,218,189,189,189,214,214,214,223,223,223,229, + 229,229,223,223,223,214,214,214,189,189,189,218,218,218,249,249,249, + 255,255,255, 0,255,255,255,177,177,177,184,184,184,249,249,249,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,249,249,249, + 184,184,184,177,177,177,255,255,255,255,255,255,177,177,177,184,184, + 184,249,249,249,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,249,249,249,184,184,184,177,177,177,255,255,255,255,255,255, + 218,218,218,209,209,209,228,228,228,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,228,228,228,209,209,209,218,218,218,255, + 255,255,255,255,255,218,218,218,209,209,209,228,228,228,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,228,228,228,209,209, + 209,218,218,218,255,255,255,255,255,255,218,218,218,209,209,209,228, + 228,228,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 228,228,228,209,209,209,218,218,218,255,255,255, 0,209,209,209,114, + 114,114,249,249,249,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,249,249,249,114,114,114,209,209, + 209,209,209,209,114,114,114,249,249,249,255,255,255,171,171,171, 95, + 95, 95, 42, 42, 42, 95, 95, 95,171,171,171,255,255,255,249,249,249, + 114,114,114,209,209,209,233,233,233,189,189,189,228,228,228,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,228,228,228,189,189,189,233,233,233,233,233,233,189,189,189, + 228,228,228,230,230,230,186,186,186,145,145,145,117,117,117,145,145, + 145,186,186,186,230,230,230,228,228,228,189,189,189,233,233,233,233, + 233,233,189,189,189,228,228,228,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,228,228,228,189,189, + 189,233,233,233, 0,168,168,168,199,199,199,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,199,199,199,168,168,168,168,168,168,199,199,199,255, + 255,255,171,171,171, 39, 39, 39, 33, 33, 33, 33, 33, 33, 33, 33, 33, + 39, 39, 39,171,171,171,255,255,255,199,199,199,168,168,168,214,214, + 214,214,214,214,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,214,214,214, + 214,214,214,214,214,214,214,214,214,230,230,230,186,186,186,115,115, + 115,112,112,112,112,112,112,112,112,112,115,115,115,186,186,186,230, + 230,230,214,214,214,214,214,214,214,214,214,214,214,214,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,214,214,214,214,214,214, 0,134,134,134, + 233,233,233,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,233,233,233,134, + 134,134,134,134,134,233,233,233,255,255,255, 95, 95, 95, 33, 33, 33, + 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 95, 95, 95,255,255, + 255,233,233,233,134,134,134,199,199,199,223,223,223,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,223,223,223,199,199,199,199,199,199,223,223, + 223,230,230,230,145,145,145,112,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,145,145,145,230,230,230,223,223,223,199,199,199, + 199,199,199,223,223,223,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,223, + 223,223,199,199,199, 0,115,115,115,252,252,252,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,252,252,252,115,115,115,115,115,115,252,252,252, + 255,255,255, 42, 42, 42, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, + 33, 33, 33, 33, 42, 42, 42,255,255,255,252,252,252,115,115,115,189, + 189,189,229,229,229,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,229,229, + 229,189,189,189,189,189,189,229,229,229,230,230,230,117,117,117,112, + 112,112,112,112,112,112,112,112,112,112,112,112,112,112,117,117,117, + 230,230,230,229,229,229,189,189,189,189,189,189,229,229,229,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,229,229,229,189,189,189, 0,134,134, + 134,233,233,233,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,233,233,233, + 134,134,134,134,134,134,233,233,233,255,255,255, 95, 95, 95, 33, 33, + 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 33, 95, 95, 95,255, + 255,255,233,233,233,134,134,134,199,199,199,223,223,223,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,223,223,223,199,199,199,199,199,199,223, + 223,223,230,230,230,145,145,145,112,112,112,112,112,112,112,112,112, + 112,112,112,112,112,112,145,145,145,230,230,230,223,223,223,199,199, + 199,199,199,199,223,223,223,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 223,223,223,199,199,199, 0,168,168,168,199,199,199,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,199,199,199,168,168,168,168,168,168,199,199, + 199,255,255,255,171,171,171, 39, 39, 39, 33, 33, 33, 33, 33, 33, 33, + 33, 33, 39, 39, 39,171,171,171,255,255,255,199,199,199,168,168,168, + 214,214,214,214,214,214,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,214, + 214,214,214,214,214,214,214,214,214,214,214,230,230,230,186,186,186, + 115,115,115,112,112,112,112,112,112,112,112,112,115,115,115,186,186, + 186,230,230,230,214,214,214,214,214,214,214,214,214,214,214,214,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,214,214,214,214,214,214, 0,209, + 209,209,114,114,114,249,249,249,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,249,249,249,114,114, + 114,209,209,209,209,209,209,114,114,114,249,249,249,255,255,255,171, + 171,171, 95, 95, 95, 42, 42, 42, 95, 95, 95,171,171,171,255,255,255, + 249,249,249,114,114,114,209,209,209,233,233,233,189,189,189,228,228, + 228,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,230,228,228,228,189,189,189,233,233,233,233,233,233, + 189,189,189,228,228,228,230,230,230,186,186,186,145,145,145,117,117, + 117,145,145,145,186,186,186,230,230,230,228,228,228,189,189,189,233, + 233,233,233,233,233,189,189,189,228,228,228,230,230,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,228,228, + 228,189,189,189,233,233,233, 0,255,255,255,177,177,177,184,184,184, + 249,249,249,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,249,249,249,184,184,184,177,177,177,255,255,255,255,255,255,177, + 177,177,184,184,184,249,249,249,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,249,249,249,184,184,184,177,177,177,255,255, + 255,255,255,255,218,218,218,209,209,209,228,228,228,230,230,230,230, + 230,230,230,230,230,230,230,230,230,230,230,228,228,228,209,209,209, + 218,218,218,255,255,255,255,255,255,218,218,218,209,209,209,228,228, + 228,230,230,230,230,230,230,230,230,230,230,230,230,230,230,230,228, + 228,228,209,209,209,218,218,218,255,255,255,255,255,255,218,218,218, + 209,209,209,228,228,228,230,230,230,230,230,230,230,230,230,230,230, + 230,230,230,230,228,228,228,209,209,209,218,218,218,255,255,255, 0, + 255,255,255,242,242,242,177,177,177,114,114,114,199,199,199,233,233, + 233,252,252,252,233,233,233,199,199,199,114,114,114,177,177,177,242, + 242,242,255,255,255,255,255,255,242,242,242,177,177,177,114,114,114, + 199,199,199,233,233,233,252,252,252,233,233,233,199,199,199,114,114, + 114,177,177,177,242,242,242,255,255,255,255,255,255,249,249,249,218, + 218,218,189,189,189,214,214,214,223,223,223,229,229,229,223,223,223, + 214,214,214,189,189,189,218,218,218,249,249,249,255,255,255,255,255, + 255,249,249,249,218,218,218,189,189,189,214,214,214,223,223,223,229, + 229,229,223,223,223,214,214,214,189,189,189,218,218,218,249,249,249, + 255,255,255,255,255,255,249,249,249,218,218,218,189,189,189,214,214, + 214,223,223,223,229,229,229,223,223,223,214,214,214,189,189,189,218, + 218,218,249,249,249,255,255,255, 0,255,255,255,255,255,255,255,255, + 255,209,209,209,168,168,168,134,134,134,115,115,115,134,134,134,168, + 168,168,209,209,209,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,255,255,209,209,209,168,168,168,134,134,134,115,115, + 115,134,134,134,168,168,168,209,209,209,255,255,255,255,255,255,255, + 255,255,255,255,255,255,255,255,255,255,255,233,233,233,214,214,214, + 199,199,199,189,189,189,199,199,199,214,214,214,233,233,233,255,255, + 255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,255,233, + 233,233,214,214,214,199,199,199,189,189,189,199,199,199,214,214,214, + 233,233,233,255,255,255,255,255,255,255,255,255,255,255,255,255,255, + 255,255,255,255,233,233,233,214,214,214,199,199,199,189,189,189,199, + 199,199,214,214,214,233,233,233,255,255,255,255,255,255,255,255,255, + 0); + +{%endregion} + +{ TfpgWin8Style } + +procedure TfpgWin8Style.LoadThemeImages; +begin + //FImages.AddMaskedBMP( // 65x13 in total. 5 images of 13x13 each. + // 'win8.radiobuttons', + // @stdimg_radiobuttons, + // sizeof(stdimg_radiobuttons), 0,0); + + FImages.AddBMP( // 65x13 pixels. 5 images of 13x13 each. + 'win8.radiobuttons', + @win8_radiobuttons, + sizeof(win8_radiobuttons)); + + FImages.AddBMP( // 65x13 pixels. 5 images of 13x13 each. + 'win8.checkboxes', + @win8_checkboxes, + sizeof(win8_checkboxes)); +end; + +constructor TfpgWin8Style.Create; +begin + inherited Create; + FImages := TfpgImages.Create; + LoadThemeImages; + + fpgSetNamedColor(clWindowBackground, Win8BaseColors[0]); + //fpgSetNamedColor(clBoxColor, Win8BaseColors[1]); + fpgSetNamedColor(clShadow1, Win8BaseColors[2]); + fpgSetNamedColor(clShadow2, Win8BaseColors[1]); + //fpgSetNamedColor(clHilite1, Win8BaseColors[3]); + //fpgSetNamedColor(clHilite2, Win8BaseColors[4]); + //fpgSetNamedColor(clText1, Win8BaseColors[5]); + //fpgSetNamedColor(clText4, Win8BaseColors[6]); + fpgSetNamedColor(clSelection, Win8BaseColors[7]); + fpgSetNamedColor(clSelectionText, Win8BaseColors[8]); + //fpgSetNamedColor(clInactiveSel, Win8BaseColors[7]); + //fpgSetNamedColor(clInactiveSelText, Win8BaseColors[8]); + //fpgSetNamedColor(clScrollBar, Win8BaseColors[9]); + //fpgSetNamedColor(clButtonFace, Win8BaseColors[0]); + //fpgSetNamedColor(clListBox, Win8BaseColors[1]); + //fpgSetNamedColor(clGridLines, Win8BaseColors[2]); + //fpgSetNamedColor(clGridHeader, Win8BaseColors[0]); + fpgSetNamedColor(clWidgetFrame, Win8BaseColors[2]); + //fpgSetNamedColor(clInactiveWgFrame, Win8BaseColors[10]); + //fpgSetNamedColor(clUnset, Win8BaseColors[11]); + //fpgSetNamedColor(clMenuText, Win8BaseColors[5]); + //fpgSetNamedColor(clMenuDisabled, Win8BaseColors[0]); + //fpgSetNamedColor(clHintWindow, Win8BaseColors[0]); + //fpgSetNamedColor(clGridSelection, Win8BaseColors[7]); + //fpgSetNamedColor(clGridSelectionText, Win8BaseColors[8]); + //fpgSetNamedColor(clGridInactiveSel, Win8BaseColors[7]); + //fpgSetNamedColor(clGridInactiveSelText, Win8BaseColors[8]); + //fpgSetNamedColor(clSplitterGrabBar, Win8BaseColors[7]); + fpgSetNamedColor(clChoiceListBox, Win8BaseColors[16]); +end; + +destructor TfpgWin8Style.Destroy; +begin + FImages.Free; + inherited Destroy; +end; + +procedure TfpgWin8Style.DrawControlFrame(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord); +var + r: TfpgRect; +begin + r.SetRect(x, y, w, h); + ACanvas.SetLineStyle(1, lsSolid); + ACanvas.SetColor(clWidgetFrame); + ACanvas.DrawRectangle(r); +end; + +function TfpgWin8Style.GetControlFrameBorders: TRect; +begin + Result := Rect(1, 1, 1, 1); +end; + +procedure TfpgWin8Style.DrawButtonFace(ACanvas: TfpgCanvas; x, y, w, h: TfpgCoord; AFlags: TfpgButtonFlags); +var + r: TfpgRect; +begin + r.SetRect(x, y, w, h); + ACanvas.SetLineStyle(1, lsSolid); + if btfDisabled in AFlags then + ACanvas.SetColor(TfpgColor($ffd9d9d9)) + else + begin + if btfIsDefault in AFlags then + ACanvas.SetColor(clSelection) + else + ACanvas.SetColor(TfpgColor($ffacacac)); + end; + ACanvas.DrawRectangle(r); + InflateRect(r, -1, -1); + if btfDisabled in AFlags then + begin + ACanvas.SetColor(TfpgColor($ffefefef)); + ACanvas.FillRectangle(r); + end + else + ACanvas.GradientFill(r, clWindowBackground, TfpgColor($ffe5e5e5), gdVertical); +end; + +function TfpgWin8Style.GetButtonBorders: TRect; +begin + Result := Rect(2, 2, 2, 2); +end; + +procedure TfpgWin8Style.DrawStaticComboBox(ACanvas: TfpgCanvas; r: TfpgRect; + const IsEnabled: Boolean; const IsFocused: Boolean; + const IsReadOnly: Boolean; const ABackgroundColor: TfpgColor; + const AInternalBtnRect: TfpgRect; const ABtnPressed: Boolean); +var + ar: TfpgRect; +begin + //if IsEnabled then + // ACanvas.SetColor(TfpgColor($ffacacac)) + //else + // ACanvas.SetColor(TfpgColor($ffacacac)); + ACanvas.GradientFill(r, clWindowBackground, clChoiceListBox, gdVertical); + + // paint arrow + ACanvas.SetColor(clShadow2); + ar := AInternalBtnRect; + { The bounding rectangle for the arrow } + ar.Width := 8; + ar.Height := 6; + ar.Left := AInternalBtnRect.Left + ((AInternalBtnRect.Width-ar.Width) div 2); + ar.Top := AInternalBtnRect.Top + ((AInternalBtnRect.Height-ar.Height) div 2); + DrawDirectionArrow(ACanvas, ar.Left, ar.Top, ar.Width, ar.Height, adDown); +end; + +procedure TfpgWin8Style.DrawCheckbox(ACanvas: TfpgCanvas; x, y: TfpgCoord; ix, iy: TfpgCoord); +var + img: TfpgImage; + size: integer; +begin + img := FImages.GetImage('win8.checkboxes'); // Do NOT localize - return value is a reference only + size := GetCheckBoxSize; + ACanvas.DrawImagePart(x, y, img, ix, iy, size, size); +end; + + +initialization + fpgStyleManager.RegisterClass('win8', TfpgWin8Style); + +end. + diff --git a/src/gui/fpg_stylemanager.pas b/src/gui/fpg_stylemanager.pas index de49d5a7..a4d47a36 100644 --- a/src/gui/fpg_stylemanager.pas +++ b/src/gui/fpg_stylemanager.pas @@ -25,6 +25,7 @@ interface uses Classes ,Contnrs + ,fpg_base ,fpg_main ; @@ -67,6 +68,7 @@ type function CreateInstance: TfpgStyle; overload; procedure FreeStyleInstance; procedure AssignStyleTypes(const AStrings: TStrings); + function StyleTypesAsString: TfpgString; end; @@ -203,6 +205,19 @@ begin AStrings.Add(TfpgStyleClassMapping(FList.Items[i]).MappingName); end; +function TfpgStyleManager.StyleTypesAsString: TfpgString; +var + i: integer; + s: string; +begin + for i := 0 to FList.Count - 1 do + begin + if i > 0 then + s := ', '; + Result := Result + s + '"' + TfpgStyleClassMapping(FList.Items[i]).MappingName + '"'; + end; +end; + finalization uStyleManager.Free; diff --git a/src/gui/fpg_tab.pas b/src/gui/fpg_tab.pas index 5ef82248..29addb12 100644 --- a/src/gui/fpg_tab.pas +++ b/src/gui/fpg_tab.pas @@ -183,6 +183,10 @@ implementation uses fpg_stringutils; + +const + DFL_TAB_HEIGHT = 21; + DFL_TAB_WIDTH = 0; // compare function used by FPages.Sort @@ -532,7 +536,7 @@ procedure TfpgPageControl.SetFixedTabWidth(const AValue: integer); begin if FFixedTabWidth = AValue then Exit; //==> - if AValue > 5 then + if AValue >= 5 then begin FFixedTabWidth := AValue; RePaint; @@ -543,7 +547,7 @@ procedure TfpgPageControl.SetFixedTabHeight(const AValue: integer); begin if FFixedTabHeight = AValue then Exit; //==> - if AValue > 5 then + if AValue >= 5 then begin FFixedTabHeight := AValue; RePaint; @@ -630,6 +634,11 @@ begin if FTabPosition = AValue then Exit; //==> FTabPosition := AValue; + if FTabPosition = tpNone then + begin + FLeftButton.Visible := False; + FRightButton.Visible := False; + end; RePaint; end; @@ -669,6 +678,8 @@ begin if Mode = 2 then begin r.Height -= 1; + if TabPosition = tpBottom then + r.Top += 1; Canvas.SetColor(ActiveTabColor); end else @@ -691,22 +702,27 @@ begin tpBottom: begin - Canvas.FillRectangle(r.Left, r.Top+1, r.Width-2, r.Height-3); // fill tab background + Canvas.FillRectangle(r.Left, r.Top, r.Width-1, r.Height-2); // fill tab background Canvas.SetColor(clHilite2); Canvas.DrawLine(r.Left, r.Top, r.Left, r.Bottom-1); // left edge Canvas.SetColor(clShadow2); Canvas.DrawLine(r.Left+2, r.Bottom, r.Right-1, r.Bottom); // bottom outer edge Canvas.SetColor(clShadow1); - Canvas.DrawLine(r.Right-1, r.Bottom-1, r.Right-1, r.Top+1); // right inner edge + Canvas.DrawLine(r.Right-1, r.Bottom-1, r.Right-1, r.Top-1); // right inner edge Canvas.DrawLine(r.Left+1, r.Bottom-1, r.Right-1, r.Bottom-1);// bottom inner edge Canvas.SetColor(clShadow2); Canvas.DrawLine(r.Right-1, r.Bottom-1, r.Right, r.Bottom-2); // right rounded edge (1px) - Canvas.DrawLine(r.Right, r.Bottom-2, r.Right, r.Top+1); // right outer edge + Canvas.DrawLine(r.Right, r.Bottom-2, r.Right, r.Top-1); // right outer edge + if Mode = 2 then { selected tab } + begin + Canvas.SetColor(ActiveTabColor); + Canvas.DrawLine(r.Left+1, r.Top-1, r.Right-1, r.Top-1); + end; end; tpLeft: begin - if Mode = 2 then + if Mode = 2 then { selected tab } begin r.Width := r.Width - 1; r.Height := r.Height + 2; @@ -797,7 +813,7 @@ end; procedure TfpgPageControl.RePaintTitles; const - TabHeight = 21; + TAB_HEIGHT = 21; var TabW, TabH: Integer; r2: TfpgRect; @@ -820,7 +836,7 @@ begin TabH:=FixedTabHeight; ActivePageVisible := false; If TabH = 0 then - TabH := TabHeight; + TabH := TAB_HEIGHT; h := TfpgTabSheet(FPages.First); if h = nil then Exit; //==> @@ -913,27 +929,27 @@ begin begin lTxtFlags += TextFlagsDflt; lp := 0; - r2.SetRect(2, Height - ButtonHeight-3, 50, 21); + r2.SetRect(2, Height - ButtonHeight, 50, TabH-2); while h <> nil do begin if h <> ActivePage then begin - toffset := 2; + toffset := 1; h.Visible := False; end else begin - toffset := 4; + toffset := 2; h.Visible := True; - h.SetPosition(FMargin+2, FMargin+2 , Width - (FMargin*2) - 4, Height - r2.Height - (FMargin+2)*2); + h.SetPosition(FMargin+2, FMargin+2 , Width - (FMargin*2) - 4, Height - TabH - (FMargin+2)*2); end; // paint tab button r2.Width := ButtonWidth(h.Text); r3 := DrawTab(r2, h = ActivePage); // paint text on non-active tabs if h <> ActivePage then - Canvas.DrawText(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, - Height-r2.Height-toffset, GetTabText(h.Text), lTxtFlags); + Canvas.DrawText(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, + Height-TabH+toffset, GetTabText(h.Text), lTxtFlags); r2.Left := r2.Left + r2.Width; lp := lp + ButtonWidth(h.Text); @@ -946,7 +962,7 @@ begin r2.Left := 0; r2.Top := 0; r2.Width := Width; - r2.Height := Height - r2.Height; + r2.Height := Height - TabH; Canvas.DrawButtonFace(r2, []); // Draw text of ActivePage, because we didn't before. DrawTab(r3, false, 2); @@ -957,7 +973,7 @@ begin begin lTxtFlags += TextFlagsDflt; lp := 0; - r2.SetRect(2, 2, 50, 21); + r2.SetRect(2, 2, 50, TabH); while h <> nil do begin if h <> ActivePage then @@ -974,7 +990,6 @@ begin // paint tab button r2.Width := ButtonWidth(h.Text); r3 := DrawTab(r2, h = ActivePage); - // paint text on non-active tabs if h <> ActivePage then Canvas.DrawText(lp + (ButtonWidth(h.Text) div 2) - FFont.TextWidth(GetTabText(h.Text)) div 2, @@ -1003,7 +1018,7 @@ begin lTxtFlags += [txtVCenter, txtLeft]; lp := 0; TabW := MaxButtonWidth; - r2.SetRect(Width - 2 - TabW, 2, TabW, 21); + r2.SetRect(Width - 2 - TabW, 2, TabW, TabH); while h <> nil do begin if h <> ActivePage then @@ -1048,7 +1063,7 @@ begin lTxtFlags += [txtVCenter, txtLeft]; lp := 0; TabW := MaxButtonWidth; - r2.SetRect(2, 2, TabW, 21); + r2.SetRect(2, 2, TabW, TabH); while h <> nil do begin if h <> ActivePage then diff --git a/src/gui/fpg_trackbar.pas b/src/gui/fpg_trackbar.pas index ad997817..32da0b99 100644 --- a/src/gui/fpg_trackbar.pas +++ b/src/gui/fpg_trackbar.pas @@ -138,6 +138,12 @@ type property OnChange; property OnEnter; property OnExit; + property OnKeyPress; + property OnMouseDown; + property OnMouseEnter; + property OnMouseExit; + property OnMouseMove; + property OnMouseUp; property OnShowHint; end; @@ -439,7 +445,7 @@ begin if Orientation = orVertical then begin - if (y >= Width + FSliderPos) and (y <= Width + FSliderPos + FSliderLength) then + if (y >= FSliderPos) and (y <= FSliderPos + FSliderLength) then begin FSliderDragging := True; FSliderDragPos := y; @@ -516,8 +522,6 @@ begin if newp <> FPosition then begin Position := newp; - RePaint; - DoChange; end; end; @@ -571,12 +575,20 @@ begin if Orientation = orVertical then begin - Canvas.DrawButtonFace(0, Width + FSliderPos, Width, FSliderLength, [btfIsEmbedded]); + r.SetRect((Width-4) div 2, 1, 4, Height {- tw} - 4); + fpgStyle.DrawControlFrame(Canvas, r); + r.SetRect((Width-20) div 2, FSliderPos, 21, FSliderLength); + Canvas.DrawButtonFace(r, []); + //if FShowPosition then + //begin + // Canvas.SetTextColor(TextColor); + // fpgStyle.DrawString(Canvas, Width - tw, (Height - FFont.Height) div 2, IntToStr(Position), Enabled); + //end; end else begin r.SetRect(1, (Height-4) div 2, Width - tw - 4, 4); - Canvas.DrawControlFrame(r); + fpgStyle.DrawControlFrame(Canvas, r); r.SetRect(FSliderPos, (Height-20) div 2, FSliderLength, 21); Canvas.DrawButtonFace(r, []); if FShowPosition then diff --git a/src/gui/fpg_tree.pas b/src/gui/fpg_tree.pas index 8935ec36..7da5205c 100644 --- a/src/gui/fpg_tree.pas +++ b/src/gui/fpg_tree.pas @@ -84,7 +84,6 @@ type FText: TfpgString; FTextColor: TfpgColor; FHasChildren: Boolean; - FTree: TfpgTreeView; procedure SetCollapsed(const AValue: boolean); procedure SetInactSelColor(const AValue: TfpgColor); procedure SetInactSelTextColor(const AValue: TfpgColor); @@ -97,8 +96,11 @@ type procedure SetHasChildren(const AValue: Boolean); procedure DoTreeCheck(ANode: TfpgTreeNode); procedure SetStateImageIndex(const AValue: integer); + protected + FTree: TfpgTreeView; public - constructor Create; + constructor Create; overload; + constructor Create(ATreeView: TfpgTreeView; AText: TfpgString); overload; destructor Destroy; override; // node related function AppendText(AText: TfpgString): TfpgTreeNode; @@ -133,6 +135,7 @@ type property Parent: TfpgTreeNode read FParent write SetParent; property Prev: TfpgTreeNode read FPrev write FPrev; property Text: TfpgString read FText write SetText; + property TreeView: TfpgTreeView read FTree; { determines the + or - image in the treeview } property HasChildren: Boolean read FHasChildren write SetHasChildren; // color settings @@ -273,10 +276,10 @@ type implementation -{.$IFDEF DEBUG} +{$IFDEF DEBUG} uses - dbugintf; -{.$ENDIF} + fpg_dbugintf; +{$ENDIF} type PColumnLeft = ^integer; @@ -394,7 +397,8 @@ begin FData := nil; FFirstSubNode := nil; FLastSubNode := nil; - FText := ''; + FText := ''; + FTree := nil; FImageIndex := -1; FStateImageIndex := -1; FCollapsed := True; @@ -411,6 +415,13 @@ begin FInactSelTextColor := clUnset; end; +constructor TfpgTreeNode.Create(ATreeView: TfpgTreeView; AText: TfpgString); +begin + Create; + FText := AText; + FTree := ATreeView; +end; + destructor TfpgTreeNode.Destroy; begin if FParent <> nil then diff --git a/src/gui/inputintegerdialog.inc b/src/gui/inputintegerdialog.inc new file mode 100644 index 00000000..237fb549 --- /dev/null +++ b/src/gui/inputintegerdialog.inc @@ -0,0 +1,157 @@ +{ + fpGUI - Free Pascal GUI Toolkit + + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this + distribution, for details of the copyright. + + See the file COPYING.modifiedLGPL, included in this distribution, + for details about redistributing fpGUI. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + Description: + This unit contains the Input Query dialogs. +} + +{%mainunit fpg_dialogs.pas} + +{$IFDEF read_interface} + +type + + TfpgIntegerDialog = class(TfpgForm) + private + {@VFD_HEAD_BEGIN: fpgIntegerDialog} + lblText: TfpgLabel; + edtInteger: TfpgEditInteger; + btnOK: TfpgButton; + btnCancel: TfpgButton; + {@VFD_HEAD_END: fpgIntegerDialog} + procedure SetupCaptions; + procedure edtIntegerKeyPressed(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); + protected + procedure HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); override; + public + procedure AfterCreate; override; + end; + + +{$ENDIF read_interface} + +{$IFDEF read_implementation} + +function fpgIntegerQuery(const ACaption, APrompt: TfpgString; var Value: Integer; const MaxValue: Integer; const MinValue: Integer): Boolean; +var + dlg: TfpgIntegerDialog; +begin + dlg := TfpgIntegerDialog.Create(nil); + try + dlg.WindowTitle := ACaption; + dlg.lblText.Text := APrompt; + dlg.edtInteger.MaxValue:= MaxValue; + dlg.edtinteger.MinValue:= MinValue; + dlg.edtInteger.Value := Value; + Result := dlg.ShowModal = mrOK; + if Result then + Value := dlg.edtInteger.Value; + finally + dlg.Free; + end; +end; + +{ TfpgIntegerDialog } + +procedure TfpgIntegerDialog.SetupCaptions; +begin + btnOK.Text := rsOK; + btnCancel.Text := rsCancel; +end; + +procedure TfpgIntegerDialog.edtIntegerKeyPressed(Sender: TObject; var KeyCode: word; var ShiftState: TShiftState; var Consumed: boolean); +begin + if KeyCode = keyEnter then + btnOK.Click; +end; + +procedure TfpgIntegerDialog.HandleKeyPress(var keycode: word; var shiftstate: TShiftState; var consumed: boolean); +begin + if KeyCode = keyEscape then + begin + consumed := True; + ModalResult := mrCancel; + end; +end; + +procedure TfpgIntegerDialog.AfterCreate; +begin + {%region 'Auto-generated GUI code' -fold} + {@VFD_BODY_BEGIN: fpgIntegerDialog} + Name := 'fpgIntegerDialog'; + SetPosition(100, 150, 208, 97); + WindowTitle := 'IntegerDialog'; + Hint := ''; + WindowPosition := wpOneThirdDown; + + lblText := TfpgLabel.Create(self); + with lblText do + begin + Name := 'lblText'; + SetPosition(8, 8, 208, 16); + Anchors := [anLeft,anRight,anTop]; + FontDesc := '#Label1'; + Hint := ''; + Text := 'lblText'; + end; + + edtInteger := TfpgEditInteger.Create(self); + with edtInteger do + begin + Name := 'edtInteger'; + SetPosition(8, 26, 100, 24); + Anchors := [anLeft,anRight,anTop]; + Hint := ''; + TabOrder := 2; + Text := ''; + FontDesc := '#Edit1'; + Value := 0; + OnKeyPress := @edtIntegerKeyPressed; + end; + + btnOK := TfpgButton.Create(self); + with btnOK do + begin + Name := 'btnOK'; + SetPosition(8, 64, 92, 24); + Anchors := [anRight,anBottom]; + Text := 'OK'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + ModalResult := mrOK; + TabOrder := 3; + end; + + btnCancel := TfpgButton.Create(self); + with btnCancel do + begin + Name := 'btnCancel'; + SetPosition(108, 64, 92, 24); + Anchors := [anRight,anBottom]; + Text := 'Cancel'; + FontDesc := '#Label1'; + Hint := ''; + ImageName := ''; + ModalResult := mrCancel; + TabOrder := 4; + end; + + {@VFD_BODY_END: fpgIntegerDialog} + {%endregion} + + SetupCaptions; +end; + +{$ENDIF read_implementation} + diff --git a/src/gui/inputquerydialog.inc b/src/gui/inputquerydialog.inc index 6330d02c..b41af217 100644 --- a/src/gui/inputquerydialog.inc +++ b/src/gui/inputquerydialog.inc @@ -1,7 +1,7 @@ { fpGUI - Free Pascal GUI Toolkit - Copyright (C) 2006 - 2010 See the file AUTHORS.txt, included in this + Copyright (C) 2006 - 2014 See the file AUTHORS.txt, included in this distribution, for details of the copyright. See the file COPYING.modifiedLGPL, included in this distribution, diff --git a/src/gui/messagedialog.inc b/src/gui/messagedialog.inc index 0e04541d..db894f6d 100644 --- a/src/gui/messagedialog.inc +++ b/src/gui/messagedialog.inc @@ -262,7 +262,6 @@ var y: integer; tw: integer; begin - Canvas.BeginDraw; inherited HandlePaint; case FDialogType of mtAbout: @@ -312,7 +311,6 @@ begin Inc(y, FLineHeight); end; end; - Canvas.EndDraw; end; procedure TfpgMessageDialog.HandleShow; |