├── .gitignore ├── DelphiSnarlDemo ├── DelphiSnarlDemo.dpr ├── DelphiSnarlDemo.res ├── fDelphiSnarlDemo.dfm ├── fDelphiSnarlDemo.pas ├── image.png └── uSnarl.pas ├── JQueryUIProgBar ├── JQueryUIProgBar.dpr ├── JQueryUIProgBar.res ├── fMain.dfm ├── fMain.pas ├── images │ └── pbar-ani.gif ├── index.html ├── jquery-1.3.2.min.js ├── jquery-ui-1.7.1.custom.css └── jquery-ui-1.7.1.custom.min.js ├── Others └── ColinWilson │ ├── README │ ├── unitEXIcon.pas │ ├── unitPEFile.pas │ ├── unitResFile.pas │ ├── unitResourceDetails.pas │ ├── unitResourceExaminer.pas │ ├── unitResourceGraphics.pas │ ├── unitResourceToolbar.pas │ └── unitResourceVersionInfo.pas ├── README ├── SetVersion └── SetVersion.dpr └── dGinaTest ├── BTMemoryModule.pas ├── dGinaTest.dpr ├── dGinaTest.res ├── dgina.dll ├── dgina.rc ├── fdGinaTest.dfm └── fdGinaTest.pas /.gitignore: -------------------------------------------------------------------------------- 1 | *.bpl 2 | *.dcp 3 | *.dcu 4 | *.identcache 5 | *.local 6 | *.exe 7 | *.map 8 | *.jdbg 9 | # Resource files. I tend to compile from RC files, can force add project RES files. 10 | *.res 11 | # Resource String file, always re-generated if compiler setting is set (-GD) 12 | *.drc 13 | # leave out Delphi 2009 project files, because they cause errors when trying to open in Delphi 2007 14 | *.dproj 15 | -------------------------------------------------------------------------------- /DelphiSnarlDemo/DelphiSnarlDemo.dpr: -------------------------------------------------------------------------------- 1 | program DelphiSnarlDemo; 2 | 3 | uses 4 | Forms, 5 | fDelphiSnarlDemo in 'fDelphiSnarlDemo.pas' {frmDelphiSnarlDemo}, 6 | uSnarl in 'uSnarl.pas'; 7 | 8 | {$R *.res} 9 | 10 | begin 11 | Application.Initialize; 12 | Application.MainFormOnTaskbar := True; 13 | Application.CreateForm(TfrmDelphiSnarlDemo, frmDelphiSnarlDemo); 14 | Application.Run; 15 | end. 16 | -------------------------------------------------------------------------------- /DelphiSnarlDemo/DelphiSnarlDemo.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/DelphiSnarlDemo/DelphiSnarlDemo.res -------------------------------------------------------------------------------- /DelphiSnarlDemo/fDelphiSnarlDemo.dfm: -------------------------------------------------------------------------------- 1 | object frmDelphiSnarlDemo: TfrmDelphiSnarlDemo 2 | Left = 0 3 | Top = 0 4 | Caption = 'Snarl Demo' 5 | ClientHeight = 469 6 | ClientWidth = 635 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poScreenCenter 15 | DesignSize = ( 16 | 635 17 | 469) 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object lblTitle: TLabel 21 | Left = 162 22 | Top = 52 23 | Width = 20 24 | Height = 13 25 | Caption = 'Title' 26 | FocusControl = eTitle 27 | end 28 | object lblText: TLabel 29 | Left = 162 30 | Top = 98 31 | Width = 22 32 | Height = 13 33 | Caption = 'Text' 34 | FocusControl = eText 35 | end 36 | object lblMessages: TLabel 37 | Left = 162 38 | Top = 221 39 | Width = 47 40 | Height = 13 41 | Caption = 'Messages' 42 | end 43 | object lblDuration: TLabel 44 | Left = 162 45 | Top = 144 46 | Width = 361 47 | Height = 13 48 | Caption = 49 | 'Duration (0 for "Sticky Notification", it won'#39't fade and disappe' + 50 | 'ar on its own)' 51 | end 52 | object btnRegister: TButton 53 | Left = 24 54 | Top = 12 55 | Width = 125 56 | Height = 25 57 | Caption = 'Register with Snarl' 58 | TabOrder = 0 59 | OnClick = btnRegisterClick 60 | end 61 | object btnSendText: TButton 62 | Left = 24 63 | Top = 69 64 | Width = 125 65 | Height = 25 66 | Caption = 'Send just text' 67 | TabOrder = 1 68 | OnClick = btnSendTextClick 69 | end 70 | object btnSendTextWithImage: TButton 71 | Left = 24 72 | Top = 115 73 | Width = 125 74 | Height = 25 75 | Caption = 'Send text with image' 76 | TabOrder = 2 77 | OnClick = btnSendTextWithImageClick 78 | end 79 | object btnUnregister: TButton 80 | Left = 24 81 | Top = 238 82 | Width = 125 83 | Height = 25 84 | Caption = 'Unregister with Snarl' 85 | TabOrder = 3 86 | OnClick = btnUnregisterClick 87 | end 88 | object eTitle: TEdit 89 | Left = 162 90 | Top = 71 91 | Width = 459 92 | Height = 21 93 | Anchors = [akLeft, akTop, akRight] 94 | TabOrder = 4 95 | Text = 'A Test Title' 96 | end 97 | object eText: TEdit 98 | Left = 162 99 | Top = 117 100 | Width = 459 101 | Height = 21 102 | Anchors = [akLeft, akTop, akRight] 103 | TabOrder = 5 104 | Text = 'Some Test Text' 105 | end 106 | object mmMessages: TMemo 107 | Left = 162 108 | Top = 240 109 | Width = 465 110 | Height = 221 111 | Anchors = [akLeft, akTop, akRight, akBottom] 112 | Font.Charset = DEFAULT_CHARSET 113 | Font.Color = clWindowText 114 | Font.Height = -11 115 | Font.Name = 'Courier New' 116 | Font.Style = [] 117 | ParentFont = False 118 | ScrollBars = ssVertical 119 | TabOrder = 6 120 | end 121 | object eDuration: TEdit 122 | Left = 162 123 | Top = 163 124 | Width = 459 125 | Height = 21 126 | TabOrder = 7 127 | Text = '60' 128 | end 129 | object btnTestWideChars: TButton 130 | Left = 27 131 | Top = 149 132 | Width = 119 133 | Height = 25 134 | Hint = 135 | 'Snarl accepts UTF-8 text, Delphi versions before 2009 should use' + 136 | ' snShowMessageExWide()' 137 | Caption = 'Test sending widechars' 138 | ParentShowHint = False 139 | ShowHint = True 140 | TabOrder = 8 141 | OnClick = btnTestWideCharsClick 142 | end 143 | end 144 | -------------------------------------------------------------------------------- /DelphiSnarlDemo/fDelphiSnarlDemo.pas: -------------------------------------------------------------------------------- 1 | unit fDelphiSnarlDemo; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, StdCtrls, 8 | uSnarl; 9 | 10 | type 11 | TfrmDelphiSnarlDemo = class(TForm) 12 | btnRegister: TButton; 13 | btnSendText: TButton; 14 | btnSendTextWithImage: TButton; 15 | btnUnregister: TButton; 16 | lblTitle: TLabel; 17 | lblText: TLabel; 18 | eTitle: TEdit; 19 | eText: TEdit; 20 | lblMessages: TLabel; 21 | mmMessages: TMemo; 22 | eDuration: TEdit; 23 | lblDuration: TLabel; 24 | btnTestWideChars: TButton; 25 | procedure btnRegisterClick(Sender: TObject); 26 | procedure btnUnregisterClick(Sender: TObject); 27 | procedure btnSendTextClick(Sender: TObject); 28 | procedure btnSendTextWithImageClick(Sender: TObject); 29 | procedure btnTestWideCharsClick(Sender: TObject); 30 | protected 31 | procedure WMSnarlReply(var Msg: TMessage); message WM_SNARL_REPLY; 32 | private 33 | { Private declarations } 34 | function SendSnarl(const aImagePath: String): Integer; 35 | public 36 | { Public declarations } 37 | end; 38 | 39 | var 40 | frmDelphiSnarlDemo: TfrmDelphiSnarlDemo; 41 | 42 | implementation 43 | 44 | {$R *.dfm} 45 | 46 | procedure TfrmDelphiSnarlDemo.btnRegisterClick(Sender: TObject); 47 | begin 48 | snRegisterConfig(Self.Handle, 'Delphi Snarl Demo', 0); 49 | mmMessages.Lines.Add('Registered'); 50 | end; 51 | 52 | procedure TfrmDelphiSnarlDemo.btnSendTextClick(Sender: TObject); 53 | var 54 | id: Integer; 55 | begin 56 | id := SendSnarl(''); 57 | mmMessages.Lines.Add(Format(' Sent message no image, id: %d', [id])); 58 | end; 59 | 60 | procedure TfrmDelphiSnarlDemo.btnSendTextWithImageClick(Sender: TObject); 61 | var 62 | imagePath: String; 63 | id: Integer; 64 | begin 65 | imagePath := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'image.png'; 66 | 67 | id := SendSnarl(imagePath); 68 | mmMessages.Lines.Add(Format(' Sent message with image, id: %d', [id])); 69 | end; 70 | 71 | procedure TfrmDelphiSnarlDemo.btnUnregisterClick(Sender: TObject); 72 | begin 73 | snRevokeConfig(Self.Handle); 74 | mmMessages.Lines.Add('Unregistered'); 75 | end; 76 | 77 | procedure TfrmDelphiSnarlDemo.btnTestWideCharsClick(Sender: TObject); 78 | var 79 | w: WideString; 80 | begin 81 | w := 'Some UTF-8 chars [ÿ ⌂]'; 82 | snShowMessageEx( 83 | 'Default', 84 | 'Test snShowMessageEx', 85 | w, 86 | StrToIntDef(eDuration.Text, 60), 87 | IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'image.png', 88 | Self.Handle, 89 | WM_SNARL_REPLY 90 | ); 91 | {$IFNDEF UNICODE} 92 | snShowMessageExWide( 93 | 'Default', 94 | 'Test snShowMessageExWide', 95 | w, 96 | StrToIntDef(eDuration.Text, 60), 97 | IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName)) + 'image.png', 98 | Self.Handle, 99 | WM_SNARL_REPLY 100 | ); 101 | {$ENDIF} 102 | mmMessages.Lines.Add(Format(' Sent WideString message, [%s]', [w])); 103 | end; 104 | 105 | function TfrmDelphiSnarlDemo.SendSnarl(const aImagePath: String): Integer; 106 | begin 107 | Result := snShowMessageEx( 108 | 'Default', 109 | eTitle.Text, 110 | eText.Text, 111 | StrToIntDef(eDuration.Text, 60), 112 | aImagePath, 113 | Self.Handle, 114 | WM_SNARL_REPLY 115 | ); 116 | end; 117 | 118 | procedure TfrmDelphiSnarlDemo.WMSnarlReply(var Msg: TMessage); 119 | var 120 | id: Integer; 121 | begin 122 | id := Msg.LParam; 123 | 124 | if Msg.WParam = SNARL_NOTIFICATION_LEFT_CLICKED then 125 | mmMessages.Lines.Add(Format(' Left clicked on Snarl Message, id: %d', [id])) 126 | 127 | else if Msg.WParam = SNARL_NOTIFICATION_RIGHT_CLICKED then 128 | mmMessages.Lines.Add(Format(' Right clicked on Snarl Message, id: %d', [id])) 129 | 130 | else if Msg.WParam = SNARL_NOTIFICATION_CANCELLED then // user clicked the X button to close 131 | mmMessages.Lines.Add(Format(' Snarl Message closed, id: %d', [id])) 132 | 133 | else if Msg.WParam = SNARL_NOTIFICATION_TIMED_OUT then 134 | mmMessages.Lines.Add(Format(' Snarl Message Timed out, id: %d', [id])) 135 | 136 | end; 137 | 138 | end. 139 | -------------------------------------------------------------------------------- /DelphiSnarlDemo/image.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/DelphiSnarlDemo/image.png -------------------------------------------------------------------------------- /DelphiSnarlDemo/uSnarl.pas: -------------------------------------------------------------------------------- 1 | unit uSnarl; 2 | 3 | /// I took the file available at fullphat.net and modified it to add some things 4 | /// 5 | /// I make no claim that this code works, and take no responsibility. 6 | 7 | 8 | { For complete information about this unit, please see the Snarl API. 9 | http://www.fullphat.net/developer/developerGuide/api/index.html } 10 | 11 | {$ifdef FPC} 12 | {$mode delphi} 13 | {$endif} 14 | 15 | interface 16 | 17 | uses 18 | Windows, Messages; 19 | 20 | const 21 | WM_SNARL_REPLY = WM_USER + 1623; 22 | 23 | (* 24 | * Registered window message and event identifiers (passed in wParam when either SNARL_GLOBAL_MSG or ReplyMsg is received) 25 | *) 26 | const 27 | SNARL_GLOBAL_MSG = 'SnarlGlobalEvent'; 28 | // SNARL_NOTIFICATION_CANCELLED = 0; // V37 changes this. 29 | SNARL_LAUNCHED = 1; 30 | SNARL_QUIT = 2; 31 | SNARL_ASK_APPLET_VER = 3; // introduced in V36 32 | SNARL_SHOW_APP_UI = 4; // introduced in V37 33 | 34 | SNARL_NOTIFICATION_CLICKED = 32; // notification was right-clicked by user 35 | SNARL_NOTIFICATION_TIMED_OUT = 33; 36 | SNARL_NOTIFICATION_ACK = 34; // notification was left-clicked by user 37 | SNARL_NOTIFICATION_CANCELLED = 37; 38 | 39 | WM_SNARLTEST = WM_USER + 237; 40 | 41 | SNARL_NOTIFICATION_LEFT_CLICKED = SNARL_NOTIFICATION_ACK; 42 | SNARL_NOTIFICATION_RIGHT_CLICKED = SNARL_NOTIFICATION_CLICKED; 43 | (* 44 | * Snarl Data Types 45 | *) 46 | type 47 | TSnarlCommand = ( 48 | SNARL_SHOW = 1, 49 | SNARL_HIDE = 2, 50 | SNARL_UPDATE = 3, 51 | SNARL_IS_VISIBLE = 4, 52 | SNARL_GET_VERSION = 5, 53 | SNARL_REGISTER_CONFIG_WINDOW = 6, 54 | SNARL_REVOKE_CONFIG_WINDOW = 7, 55 | SNARL_REGISTER_ALERT = 8, 56 | SNARL_REVOKE_ALERT = 9, 57 | SNARL_REGISTER_CONFIG_WINDOW_2 = 10, 58 | SNARL_EX_SHOW = 32 59 | ); 60 | 61 | TSnarlBuffer = array[0..1023] of Byte; 62 | 63 | TSnarlStruct = record 64 | Cmd: TSnarlCommand; // What to do... 65 | Id: Integer; // Message ID (returned by snShowMessage()) 66 | Timeout: Integer; // Timeout in seconds (0=sticky) 67 | LngData2: Integer; // Reserved 68 | Title: TSnarlBuffer; 69 | Text: TSnarlBuffer; 70 | Icon: TSnarlBuffer; 71 | end; 72 | 73 | TSnarlStructEx = record 74 | Cmd: TSnarlCommand; // What to do... 75 | Id: Integer; // Message ID (returned by snShowMessage()) 76 | Timeout: Integer; // Timeout in seconds (0=sticky) 77 | LngData2: Integer; // Reserved 78 | Title: TSnarlBuffer; 79 | Text: TSnarlBuffer; 80 | Icon: TSnarlBuffer; 81 | 82 | SnarlClass: TSnarlBuffer; 83 | Extra: TSnarlBuffer; 84 | Extra2: TSnarlBuffer; 85 | Reserved1: Integer; 86 | Reserved2: Integer; 87 | end; 88 | 89 | (* 90 | * Snarl Helper Functions 91 | *) 92 | function snGetSnarlWindow: Cardinal; 93 | function snGetAppPath: String; 94 | function snGetGlobalMsg: Integer; 95 | function snGetIconsPath: String; 96 | 97 | function snShowMessage(const ATitle, AText: String; ATimeout: Integer = 0; 98 | const AIconPath: String = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0): Integer; 99 | 100 | function snShowMessageEx(const ASnarlClass, ATitle, AText: String; ATimeout: Integer = 0; 101 | const AIconPath: String = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0; 102 | const ASoundPath: String = ''): Integer; 103 | 104 | {$IFNDEF UNICODE} 105 | function snShowMessageExWide(const ASnarlClass, ATitle, AText: WideString; ATimeout: Integer = 0; 106 | const AIconPath: WideString = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0; 107 | const ASoundPath: WideString = ''): Integer; overload; 108 | {$ENDIF} 109 | 110 | function snUpdateMessage(AId: Integer; const ATitle, AText: String; ATimeOut: Integer = 0): Boolean; 111 | function snHideMessage(AId: Integer): Boolean; 112 | function snIsMessageVisible(AId: Integer): Boolean; 113 | function snGetVersion(var Major, Minor: Word): Boolean; 114 | function snGetVersionEx: Integer; 115 | function snRegisterConfig(AHandle: HWND; const AAppName: String; AReplyMsg: Integer): Integer; 116 | function snRegisterConfig2(AHandle: HWND; const AAppName: String; AReplyMsg: Integer; const AIconPath: String): Integer; 117 | function snRevokeConfig(AHandle: HWND): Integer; 118 | function snRegisterAlert(const AAppName, AAlertName: String): Integer; 119 | function snRevokeAlert: Integer; 120 | 121 | implementation 122 | 123 | var 124 | hWndFrom: HWND = 0; 125 | 126 | (* 127 | * Private utility functions: 128 | * _Send(TSnarlStruct) 129 | * Used by most public helper functions to send the WM_COPYDATA message. 130 | * _Clear(TSnarlStruct) 131 | * Clears all data in the structure 132 | *) 133 | function _Send(pss: TSnarlStruct): Integer; overload; 134 | var 135 | hwnd: THandle; 136 | pcd: TCopyDataStruct; 137 | begin 138 | { WIll get a window class when snarl is released } 139 | hwnd := snGetSnarlWindow; 140 | if not IsWindow(hwnd) then 141 | Result := 0 142 | else 143 | begin 144 | pcd.dwData := 2; 145 | pcd.cbData := Sizeof(pss); 146 | pcd.lpData := @pss; 147 | Result := Integer(SendMessage(hwnd, WM_COPYDATA, hWndFrom, Integer(@pcd))); 148 | end; 149 | end; 150 | 151 | function _Post(pss: TSnarlStruct): Integer; overload; 152 | var 153 | hwnd: THandle; 154 | pcd: TCopyDataStruct; 155 | begin 156 | { WIll get a window class when snarl is released } 157 | hwnd := snGetSnarlWindow; 158 | if not IsWindow(hwnd) then 159 | Result := 0 160 | else 161 | begin 162 | pcd.dwData := 2; 163 | pcd.cbData := Sizeof(pss); 164 | pcd.lpData := @pss; 165 | Result := Integer(PostMessage(hwnd, WM_COPYDATA, hWndFrom, Integer(@pcd))); 166 | end; 167 | end; 168 | 169 | function _Send(pss: TSnarlStructEx): Integer; overload; 170 | var 171 | hwnd: THandle; 172 | pcd: TCopyDataStruct; 173 | begin 174 | { WIll get a window class when snarl is released } 175 | hwnd := snGetSnarlWindow; 176 | if not IsWindow(hwnd) then 177 | Result := 0 178 | else 179 | begin 180 | pcd.dwData := 2; 181 | pcd.cbData := Sizeof(pss); 182 | pcd.lpData := @pss; 183 | Result := Integer(SendMessage(hwnd, WM_COPYDATA, hWndFrom, Integer(@pcd))); 184 | end; 185 | end; 186 | 187 | procedure _Clear(var pss: TSnarlStruct); overload; 188 | begin 189 | FillChar(pss, Sizeof(pss), 0); 190 | end; 191 | 192 | procedure _Clear(var pss: TSnarlStructEx); overload; 193 | begin 194 | FillChar(pss, Sizeof(pss), 0); 195 | end; 196 | 197 | procedure _CopySnarlBuffer(const aDestination: Pointer; const aText: String); 198 | begin 199 | CopyMemory(aDestination, PByte(UTF8String(aText) + #0), 1023); 200 | end; 201 | 202 | (************************************************************ 203 | * The Helper Functions 204 | ************************************************************) 205 | 206 | function snGetSnarlWindow: Cardinal; 207 | begin 208 | Result := FindWindow(nil, 'Snarl'); 209 | end; 210 | 211 | function snGetAppPath: String; 212 | var 213 | hWnd, hWndPath: Cardinal; 214 | hr: Integer; 215 | some_string: array[0..MAX_PATH] of Char; 216 | begin 217 | hWnd := snGetSnarlWindow; 218 | if hWnd <> 0 then 219 | begin 220 | hWndPath := FindWindowEx(hWnd, 0, 'static', nil); 221 | if hWndPath <> 0 then 222 | begin 223 | hr := GetWindowText(hWndPath, some_string, MAX_PATH+1); 224 | if hr > 0 then 225 | Result := Copy(some_string, 0, hr); 226 | end; 227 | end; 228 | end; 229 | 230 | function snGetGlobalMsg: Integer; 231 | begin 232 | Result := RegisterWindowMessage(SNARL_GLOBAL_MSG); 233 | end; 234 | 235 | function snGetIconsPath: String; 236 | var 237 | s: String; 238 | begin 239 | Result := ''; 240 | 241 | s := snGetAppPath; 242 | if s <> '' then 243 | Result := s + 'etc\icons\'; 244 | end; 245 | 246 | function snShowMessage(const ATitle, AText: String; ATimeout: Integer = 0; 247 | const AIconPath: String = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0): Integer; 248 | var 249 | pss: TSnarlStruct; 250 | begin 251 | _Clear(pss); 252 | 253 | pss.Cmd := SNARL_SHOW; 254 | 255 | _CopySnarlBuffer(@pss.Title, ATitle); 256 | _CopySnarlBuffer(@pss.Text, AText); 257 | _CopySnarlBuffer(@pss.Icon, AIconPath); 258 | 259 | pss.Timeout := ATimeout; 260 | { R0.3 } 261 | pss.LngData2 := AhwndReply; 262 | pss.Id := AReplyMsg; 263 | 264 | Result := _Send(pss); 265 | end; 266 | 267 | /// SNARL_EX_SHOW (V36) 268 | /// Parameter Description 269 | ///-------------------------- 270 | /// Cmd: SNARL_EX_SHOW 271 | /// Id: Message to send back if notification is clicked by user 272 | /// Timeout: Number of seconds to display notification for (0 means infinite) 273 | /// LngData2: Handle of window to send reply message to if notification is clicked by user 274 | /// Title: Text to display in title 275 | /// Text: Text to display in notification body 276 | /// Icon: Path of image to use 277 | /// Extra: Path to sound file to play 278 | function snShowMessageEx(const ASnarlClass, ATitle, AText: String; ATimeout: Integer = 0; 279 | const AIconPath: String = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0; 280 | const ASoundPath: String = ''): Integer; 281 | var 282 | pssEx: TSnarlStructEx; 283 | begin 284 | _Clear(pssEx); 285 | 286 | pssEx.Cmd := SNARL_EX_SHOW; 287 | pssEx.Id := AReplyMsg; 288 | pssEx.Timeout := ATimeout; 289 | pssEx.LngData2 := AhwndReply; 290 | 291 | _CopySnarlBuffer(@pssEx.Title, ATitle); 292 | _CopySnarlBuffer(@pssEx.Text, AText); 293 | _CopySnarlBuffer(@pssEx.Icon, AIconPath); 294 | 295 | // V36 296 | _CopySnarlBuffer(@pssEx.SnarlClass, ASnarlClass); 297 | _CopySnarlBuffer(@pssEx.Extra, ASoundPath); 298 | 299 | Result := _Send(pssEx); 300 | end; 301 | 302 | {$IFNDEF UNICODE} 303 | /// Snarl expects UTF-8 encoded strings. 304 | /// For Delphi versions where UNICODE is defined, UTF8String() [in _CopySnarlBuffer()] will convert the UnicodeStrings to UTF-8 305 | /// Delphi versions prior to where UNICODE is defined, you must explicitly call UTF8Encode() 306 | function snShowMessageExWide(const ASnarlClass, ATitle, AText: WideString; ATimeout: Integer = 0; 307 | const AIconPath: WideString = ''; AhwndReply: Integer = 0; AReplyMsg: Integer = 0; 308 | const ASoundPath: WideString = ''): Integer; 309 | begin 310 | Result := snShowMessageEx( 311 | UTF8Encode(ASnarlClass), 312 | UTF8Encode(ATitle), 313 | UTF8Encode(AText), 314 | ATimeout, 315 | UTF8Encode(AIconPath), 316 | AhwndReply, 317 | AReplyMsg, 318 | UTF8Encode(ASoundPath) 319 | ); 320 | end; 321 | {$ENDIF} 322 | 323 | function snUpdateMessage(AId: Integer; const ATitle, AText: String; ATimeOut: Integer = 0): Boolean; 324 | var 325 | pss: TSnarlStruct; 326 | begin 327 | _Clear(pss); 328 | 329 | pss.Id := AId; 330 | pss.Cmd := SNARL_UPDATE; 331 | pss.Timeout := ATimeOut; 332 | 333 | _CopySnarlBuffer(@pss.Title, ATitle); 334 | _CopySnarlBuffer(@pss.Text, AText); 335 | 336 | Result := Boolean(_Send(pss)); 337 | end; 338 | 339 | function snHideMessage(AId: Integer): Boolean; 340 | var 341 | pss: TSnarlStruct; 342 | begin 343 | _Clear(pss); 344 | 345 | pss.Id := AId; 346 | pss.Cmd := SNARL_HIDE; 347 | 348 | Result := Boolean(_Send(pss)); 349 | end; 350 | 351 | function snIsMessageVisible(AId: Integer): Boolean; 352 | var 353 | pss: TSnarlStruct; 354 | begin 355 | _Clear(pss); 356 | 357 | pss.Id := AId; 358 | pss.Cmd := SNARL_IS_VISIBLE; 359 | 360 | Result := Boolean(_Send(pss)); 361 | end; 362 | 363 | function snGetVersion(var Major, Minor: Word): Boolean; 364 | var 365 | pss: TSnarlStruct; 366 | hr: Integer; 367 | begin 368 | _Clear(pss); 369 | 370 | pss.Cmd := SNARL_GET_VERSION; 371 | 372 | hr := Integer(_Send(pss)); 373 | Result := hr <> 0; 374 | if Result then 375 | begin 376 | Major := HiWord(hr); 377 | Minor := LoWord(hr); 378 | end; 379 | end; 380 | 381 | function snGetVersionEx: Integer; 382 | var 383 | pss: TSnarlStruct; 384 | begin 385 | _Clear(pss); 386 | 387 | pss.Cmd := SNARL_GET_VERSION; 388 | 389 | Result := Integer(_Send(pss)); 390 | end; 391 | 392 | function _snRegisterConfig(aCmd: TSnarlCommand; AHandle: HWND; const AAppName: String; AReplyMsg: Integer; const AIconPath: String): Integer; 393 | var 394 | pss: TSnarlStruct; 395 | begin 396 | hWndFrom := AHandle; 397 | 398 | _Clear(pss); 399 | 400 | pss.Cmd := aCmd; 401 | pss.Id := AReplyMsg; 402 | pss.LngData2 := AHandle; 403 | 404 | _CopySnarlBuffer(@pss.Title, AAppName); 405 | _CopySnarlBuffer(@pss.Icon, AIconPath); 406 | 407 | Result := _Send(pss); 408 | end; 409 | 410 | function snRegisterConfig(AHandle: HWND; const AAppName: String; AReplyMsg: Integer): Integer; 411 | begin 412 | Result := _snRegisterConfig(SNARL_REGISTER_CONFIG_WINDOW, AHandle, AAppName, AReplyMsg, ''); 413 | end; 414 | 415 | function snRegisterConfig2(AHandle: HWND; const AAppName: String; AReplyMsg: Integer; const AIconPath: String): Integer; 416 | begin 417 | Result := _snRegisterConfig(SNARL_REGISTER_CONFIG_WINDOW_2, AHandle, AAppName, AReplyMsg, AIconPath); 418 | end; 419 | 420 | function snRevokeConfig(AHandle: HWND): Integer; 421 | var 422 | pss: TSnarlStruct; 423 | begin 424 | hWndFrom := 0; 425 | 426 | _Clear(pss); 427 | 428 | pss.Cmd := SNARL_REVOKE_CONFIG_WINDOW; 429 | pss.LngData2 := AHandle; 430 | 431 | Result := _Send(pss); 432 | end; 433 | 434 | /// SNARL_REGISTER_ALERT (V37) 435 | /// Parameter Description 436 | ///------------------------ 437 | /// Cmd: SNARL_REGISTER_ALERT 438 | /// Title: Name of the application the alert belongs to 439 | /// Text: Name of the alert 440 | function snRegisterAlert(const AAppName, AAlertName: String): Integer; 441 | var 442 | pss: TSnarlStruct; 443 | begin 444 | _Clear(pss); 445 | 446 | pss.Cmd := SNARL_REGISTER_ALERT; 447 | 448 | _CopySnarlBuffer(@pss.Title, AAppName); 449 | _CopySnarlBuffer(@pss.Text, AAlertName); 450 | 451 | Result := _Send(pss); 452 | end; 453 | 454 | function snRevokeAlert: Integer; 455 | var 456 | pss: TSnarlStruct; 457 | begin 458 | _Clear(pss); 459 | 460 | pss.Cmd := SNARL_REVOKE_ALERT; 461 | 462 | Result := _Send(pss); 463 | end; 464 | 465 | end. 466 | -------------------------------------------------------------------------------- /JQueryUIProgBar/JQueryUIProgBar.dpr: -------------------------------------------------------------------------------- 1 | program JQueryUIProgBar; 2 | 3 | uses 4 | Forms, 5 | fMain in 'fMain.pas' {frmMain}; 6 | 7 | {$R *.res} 8 | 9 | begin 10 | Application.Initialize; 11 | {$IF CompilerVersion > 18.0} 12 | Application.MainFormOnTaskbar := True; 13 | {$IFEND} 14 | Application.CreateForm(TfrmMain, frmMain); 15 | Application.Run; 16 | end. 17 | -------------------------------------------------------------------------------- /JQueryUIProgBar/JQueryUIProgBar.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/JQueryUIProgBar/JQueryUIProgBar.res -------------------------------------------------------------------------------- /JQueryUIProgBar/fMain.dfm: -------------------------------------------------------------------------------- 1 | object frmMain: TfrmMain 2 | Left = 0 3 | Top = 0 4 | Caption = 'JQuery with TableSorter plugin' 5 | ClientHeight = 634 6 | ClientWidth = 829 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poScreenCenter 15 | OnActivate = FormActivate 16 | DesignSize = ( 17 | 829 18 | 634) 19 | PixelsPerInch = 96 20 | TextHeight = 13 21 | object WebBrowser1: TWebBrowser 22 | Left = 8 23 | Top = 8 24 | Width = 702 25 | Height = 618 26 | Anchors = [akLeft, akTop, akRight, akBottom] 27 | TabOrder = 0 28 | ControlData = { 29 | 4C0000008E480000DF3F00000000000000000000000000000000000000000000 30 | 000000004C000000000000000000000001000000E0D057007335CF11AE690800 31 | 2B2E126208000000000000004C0000000114020000000000C000000000000046 32 | 8000000000000000000000000000000000000000000000000000000000000000 33 | 00000000000000000100000000000000000000000000000000000000} 34 | end 35 | object btnInject: TButton 36 | Left = 716 37 | Top = 8 38 | Width = 105 39 | Height = 25 40 | Anchors = [akTop, akRight] 41 | Caption = 'Inject' 42 | TabOrder = 1 43 | OnClick = btnInjectClick 44 | end 45 | object Edit1: TEdit 46 | Left = 716 47 | Top = 39 48 | Width = 105 49 | Height = 21 50 | Anchors = [akTop, akRight] 51 | TabOrder = 2 52 | Text = '37' 53 | end 54 | object btnSetProgValue: TButton 55 | Left = 716 56 | Top = 66 57 | Width = 105 58 | Height = 25 59 | Anchors = [akTop, akRight] 60 | Caption = 'Set Prog Value' 61 | TabOrder = 3 62 | OnClick = btnSetProgValueClick 63 | end 64 | object btnIncProgValue: TButton 65 | Left = 716 66 | Top = 106 67 | Width = 105 68 | Height = 25 69 | Anchors = [akTop, akRight] 70 | Caption = 'Inc Prog Value' 71 | TabOrder = 4 72 | OnClick = btnIncProgValueClick 73 | end 74 | end 75 | -------------------------------------------------------------------------------- /JQueryUIProgBar/fMain.pas: -------------------------------------------------------------------------------- 1 | unit fMain; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, OleCtrls, SHDocVw, ExtCtrls, StdCtrls; 8 | 9 | type 10 | TfrmMain = class(TForm) 11 | WebBrowser1: TWebBrowser; 12 | btnInject: TButton; 13 | Edit1: TEdit; 14 | btnSetProgValue: TButton; 15 | btnIncProgValue: TButton; 16 | procedure btnInjectClick(Sender: TObject); 17 | procedure btnSetProgValueClick(Sender: TObject); 18 | procedure FormActivate(Sender: TObject); 19 | procedure btnIncProgValueClick(Sender: TObject); 20 | private 21 | { Private declarations } 22 | fAlreadyDone: Boolean; 23 | 24 | procedure ExecJS(const javascript: String); 25 | public 26 | { Public declarations } 27 | end; 28 | 29 | var 30 | frmMain: TfrmMain; 31 | 32 | implementation 33 | 34 | {$R *.dfm} 35 | 36 | uses 37 | MSHTML, ActiveX; 38 | 39 | procedure TfrmMain.btnInjectClick(Sender: TObject); 40 | function GetFileAsString(const aFileName: String): String; 41 | var 42 | ts: TStringList; 43 | begin 44 | ts := TStringList.Create; 45 | try 46 | ts.LoadFromFile(aFileName); 47 | Result := ts.Text; 48 | finally 49 | ts.Free; 50 | end; 51 | end; 52 | 53 | function ChangeImagePaths(const source: String): String; 54 | function FileProtocol(const s: String): String; 55 | begin 56 | Result := 'file:///' + StringReplace(s, '\', '/', [rfReplaceAll]); 57 | end; 58 | function AppPath(const s: String): String; 59 | begin 60 | Result := IncludeTrailingPathDelimiter( ExtractFilePath(Forms.Application.ExeName) ) + s; 61 | end; 62 | begin 63 | Result := StringReplace(source, 'url(images', 'url(' + FileProtocol(AppPath('images')), [rfReplaceAll]); 64 | end; 65 | var 66 | document: IHTMLDocument2; 67 | stylesheet: IHTMLStyleSheet; 68 | stylesheetIndex: Integer; 69 | begin 70 | // Inject JavaScripts 71 | ExecJS(GetFileAsString('jquery-1.3.2.min.js')); 72 | ExecJS(GetFileAsString('jquery-ui-1.7.1.custom.min.js')); 73 | 74 | // Inject CSS Style Sheets 75 | document := webBrowser1.Document as IHTMLDocument2; 76 | 77 | stylesheetIndex := document.styleSheets.length; 78 | if stylesheetIndex > 31 then 79 | raise Exception.Create('Already have the maximum amount of CSS stylesheets'); 80 | 81 | stylesheet := document.createStyleSheet('', stylesheetIndex); 82 | stylesheet.cssText := ChangeImagePaths( GetFileAsString('jquery-ui-1.7.1.custom.css') ); 83 | 84 | stylesheetIndex := document.styleSheets.length; 85 | if stylesheetIndex > 31 then 86 | raise Exception.Create('Already have the maximum amount of CSS stylesheets'); 87 | stylesheet := document.createStyleSheet('', stylesheetIndex); 88 | stylesheet.cssText := ChangeImagePaths( 89 | '.ui-progressbar { ' + 90 | ' height: 1em; ' + 91 | '} ' + 92 | '.ui-progressbar-value { ' + 93 | ' background-image: url(images/pbar-ani.gif); ' + 94 | '}' 95 | ); 96 | 97 | // Add a JQuery UI ProgressBar to the end of the [document.body] 98 | ExecJS( 99 | '$(document.body).append(''
''); ' + 100 | '$(document.body).append(''
'');' 101 | ); 102 | ExecJS( 103 | '$("#progressbar").progressbar({value: 0});' 104 | ); 105 | end; 106 | 107 | procedure TfrmMain.btnSetProgValueClick(Sender: TObject); 108 | begin 109 | ExecJS( 110 | Format( 111 | '$("#progressbar").progressbar(''option'', ''value'', %s);', 112 | [Edit1.Text] 113 | ) 114 | ); 115 | end; 116 | 117 | procedure TfrmMain.btnIncProgValueClick(Sender: TObject); 118 | begin 119 | ExecJS( 120 | Format( 121 | 'var i = $("#progressbar").progressbar(''option'', ''value''); ' + 122 | '$("#progressbar").progressbar(''option'', ''value'', parseInt(i) + 1);', 123 | [Edit1.Text] 124 | ) 125 | ); 126 | end; 127 | 128 | procedure TfrmMain.ExecJS(const javascript: String); 129 | var 130 | aHTMLDocument2: IHTMLDocument2; 131 | begin 132 | if Supports(WebBrowser1.Document, IHTMLDocument2, aHTMLDocument2) then 133 | aHTMLDocument2.parentWindow.execScript(javascript, 'JavaScript'); 134 | end; 135 | 136 | procedure TfrmMain.FormActivate(Sender: TObject); 137 | begin 138 | if not fAlreadyDone then 139 | begin 140 | WebBrowser1.Navigate('http://www.google.com/'); 141 | fAlreadyDone := true; 142 | end; 143 | end; 144 | 145 | end. 146 | -------------------------------------------------------------------------------- /JQueryUIProgBar/images/pbar-ani.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/JQueryUIProgBar/images/pbar-ani.gif -------------------------------------------------------------------------------- /JQueryUIProgBar/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | jQuery UI Example Page 6 | 7 | 8 | 9 | 63 | 73 | 74 | 75 |

Welcome to jQuery UI!

76 |

This page demonstrates the widgets you downloaded using the theme you selected in the download builder. We've included and linked to minified versions of jQuery, your personalized copy of jQuery UI (js/jquery-ui-1.7.1.custom.min.js), and css/smoothness/jquery-ui-1.7.1.custom.css which imports the entire jQuery UI CSS Framework. You can choose to link a subset of the CSS Framework depending on your needs.

77 |

You've downloaded components and a theme that are compatible with jQuery 1.3+. Please make sure you are using jQuery 1.3+ in your production environment. If you need jQuery UI components that work with an earlier version of jQuery, you can choose an older version in the jQuery UI download builder.

78 | 79 |

YOUR COMPONENTS:

80 | 81 | 82 |

Accordion

83 |
84 |
85 |

First

86 |
Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet. Lorem ipsum dolor sit amet.
87 |
88 |
89 |

Second

90 |
Phasellus mattis tincidunt nibh.
91 |
92 |
93 |

Third

94 |
Nam dui erat, auctor a, dignissim quis.
95 |
96 |
97 | 98 | 99 |

Tabs

100 |
101 | 106 |
Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.
107 |
Phasellus mattis tincidunt nibh. Cras orci urna, blandit id, pretium vel, aliquet ornare, felis. Maecenas scelerisque sem non nisl. Fusce sed lorem in enim dictum bibendum.
108 |
Nam dui erat, auctor a, dignissim quis, sollicitudin eu, felis. Pellentesque nisi urna, interdum eget, sagittis et, consequat vestibulum, lacus. Mauris porttitor ullamcorper augue.
109 |
110 | 111 | 112 |

Dialog

113 |

Open Dialog

114 | 115 | 116 |

Overlay and Shadow Classes (not currently used in UI widgets)

117 |
118 |

Lorem ipsum dolor sit amet, Nulla nec tortor. Donec id elit quis purus consectetur consequat.

Nam congue semper tellus. Sed erat dolor, dapibus sit amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse scelerisque dui nec velit. Duis augue augue, gravida euismod, vulputate ac, facilisis id, sem. Morbi in orci.

Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec, quam. Nam molestie scelerisque quam. Nullam feugiat cursus lacus.orem ipsum dolor sit amet, consectetur adipiscing elit. Donec libero risus, commodo vitae, pharetra mollis, posuere eu, pede. Nulla nec tortor. Donec id elit quis purus consectetur consequat.

Nam congue semper tellus. Sed erat dolor, dapibus sit amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse scelerisque dui nec velit. Duis augue augue, gravida euismod, vulputate ac, facilisis id, sem. Morbi in orci. Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec, quam. Nam molestie scelerisque quam.

Nullam feugiat cursus lacus.orem ipsum dolor sit amet, consectetur adipiscing elit. Donec libero risus, commodo vitae, pharetra mollis, posuere eu, pede. Nulla nec tortor. Donec id elit quis purus consectetur consequat. Nam congue semper tellus. Sed erat dolor, dapibus sit amet, venenatis ornare, ultrices ut, nisi. Aliquam ante.

Suspendisse scelerisque dui nec velit. Duis augue augue, gravida euismod, vulputate ac, facilisis id, sem. Morbi in orci. Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec, quam. Nam molestie scelerisque quam. Nullam feugiat cursus lacus.orem ipsum dolor sit amet, consectetur adipiscing elit. Donec libero risus, commodo vitae, pharetra mollis, posuere eu, pede. Nulla nec tortor. Donec id elit quis purus consectetur consequat. Nam congue semper tellus. Sed erat dolor, dapibus sit amet, venenatis ornare, ultrices ut, nisi.

119 | 120 | 121 |
122 |
123 |
124 |

Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.

125 |
126 |
127 | 128 |
129 | 130 | 131 | 132 |
133 |

Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.

134 |
135 | 136 | 137 | 138 |

Framework Icons (content color preview)

139 | 334 | 335 | 336 | 337 |

Slider

338 |
339 | 340 | 341 |

Datepicker

342 |
343 | 344 | 345 |

Progressbar

346 |
347 | 348 | 349 |

Highlight / Error

350 |
351 |
352 |

353 | Hey! Sample ui-state-highlight style.

354 |
355 |
356 |
357 |
358 |
359 |

360 | Alert: Sample ui-state-error style.

361 |
362 |
363 | 364 | 365 | 366 | 367 | 368 | -------------------------------------------------------------------------------- /JQueryUIProgBar/jquery-ui-1.7.1.custom.css: -------------------------------------------------------------------------------- 1 | /* 2 | * jQuery UI CSS Framework 3 | * Copyright (c) 2009 AUTHORS.txt (http://jqueryui.com/about) 4 | * Dual licensed under the MIT (MIT-LICENSE.txt) and GPL (GPL-LICENSE.txt) licenses. 5 | */ 6 | 7 | /* Layout helpers 8 | ----------------------------------*/ 9 | .ui-helper-hidden { display: none; } 10 | .ui-helper-hidden-accessible { position: absolute; left: -99999999px; } 11 | .ui-helper-reset { margin: 0; padding: 0; border: 0; outline: 0; line-height: 1.3; text-decoration: none; font-size: 100%; list-style: none; } 12 | .ui-helper-clearfix:after { content: "."; display: block; height: 0; clear: both; visibility: hidden; } 13 | .ui-helper-clearfix { display: inline-block; } 14 | /* required comment for clearfix to work in Opera \*/ 15 | * html .ui-helper-clearfix { height:1%; } 16 | .ui-helper-clearfix { display:block; } 17 | /* end clearfix */ 18 | .ui-helper-zfix { width: 100%; height: 100%; top: 0; left: 0; position: absolute; opacity: 0; filter:Alpha(Opacity=0); } 19 | 20 | 21 | /* Interaction Cues 22 | ----------------------------------*/ 23 | .ui-state-disabled { cursor: default !important; } 24 | 25 | 26 | /* Icons 27 | ----------------------------------*/ 28 | 29 | /* states and images */ 30 | .ui-icon { display: block; text-indent: -99999px; overflow: hidden; background-repeat: no-repeat; } 31 | 32 | 33 | /* Misc visuals 34 | ----------------------------------*/ 35 | 36 | /* Overlays */ 37 | .ui-widget-overlay { position: absolute; top: 0; left: 0; width: 100%; height: 100%; } 38 | 39 | /* 40 | * jQuery UI CSS Framework 41 | * Copyright (c) 2009 AUTHORS.txt (http://jqueryui.com/about) 42 | * Dual licensed under the MIT (MIT-LICENSE.txt) and GPL (GPL-LICENSE.txt) licenses. 43 | * To view and modify this theme, visit http://jqueryui.com/themeroller/?ffDefault=Verdana,Arial,sans-serif&fwDefault=normal&fsDefault=1.1em&cornerRadius=4px&bgColorHeader=cccccc&bgTextureHeader=03_highlight_soft.png&bgImgOpacityHeader=75&borderColorHeader=aaaaaa&fcHeader=222222&iconColorHeader=222222&bgColorContent=ffffff&bgTextureContent=01_flat.png&bgImgOpacityContent=75&borderColorContent=aaaaaa&fcContent=222222&iconColorContent=222222&bgColorDefault=e6e6e6&bgTextureDefault=02_glass.png&bgImgOpacityDefault=75&borderColorDefault=d3d3d3&fcDefault=555555&iconColorDefault=888888&bgColorHover=dadada&bgTextureHover=02_glass.png&bgImgOpacityHover=75&borderColorHover=999999&fcHover=212121&iconColorHover=454545&bgColorActive=ffffff&bgTextureActive=02_glass.png&bgImgOpacityActive=65&borderColorActive=aaaaaa&fcActive=212121&iconColorActive=454545&bgColorHighlight=fbf9ee&bgTextureHighlight=02_glass.png&bgImgOpacityHighlight=55&borderColorHighlight=fcefa1&fcHighlight=363636&iconColorHighlight=2e83ff&bgColorError=fef1ec&bgTextureError=02_glass.png&bgImgOpacityError=95&borderColorError=cd0a0a&fcError=cd0a0a&iconColorError=cd0a0a&bgColorOverlay=aaaaaa&bgTextureOverlay=01_flat.png&bgImgOpacityOverlay=0&opacityOverlay=30&bgColorShadow=aaaaaa&bgTextureShadow=01_flat.png&bgImgOpacityShadow=0&opacityShadow=30&thicknessShadow=8px&offsetTopShadow=-8px&offsetLeftShadow=-8px&cornerRadiusShadow=8px 44 | */ 45 | 46 | 47 | /* Component containers 48 | ----------------------------------*/ 49 | .ui-widget { font-family: Verdana,Arial,sans-serif; font-size: 1.1em; } 50 | .ui-widget input, .ui-widget select, .ui-widget textarea, .ui-widget button { font-family: Verdana,Arial,sans-serif; font-size: 1em; } 51 | .ui-widget-content { border: 1px solid #aaaaaa; background: #ffffff url(images/ui-bg_flat_75_ffffff_40x100.png) 50% 50% repeat-x; color: #222222; } 52 | .ui-widget-content a { color: #222222; } 53 | .ui-widget-header { border: 1px solid #aaaaaa; background: #cccccc url(images/ui-bg_highlight-soft_75_cccccc_1x100.png) 50% 50% repeat-x; color: #222222; font-weight: bold; } 54 | .ui-widget-header a { color: #222222; } 55 | 56 | /* Interaction states 57 | ----------------------------------*/ 58 | .ui-state-default, .ui-widget-content .ui-state-default { border: 1px solid #d3d3d3; background: #e6e6e6 url(images/ui-bg_glass_75_e6e6e6_1x400.png) 50% 50% repeat-x; font-weight: normal; color: #555555; outline: none; } 59 | .ui-state-default a, .ui-state-default a:link, .ui-state-default a:visited { color: #555555; text-decoration: none; outline: none; } 60 | .ui-state-hover, .ui-widget-content .ui-state-hover, .ui-state-focus, .ui-widget-content .ui-state-focus { border: 1px solid #999999; background: #dadada url(images/ui-bg_glass_75_dadada_1x400.png) 50% 50% repeat-x; font-weight: normal; color: #212121; outline: none; } 61 | .ui-state-hover a, .ui-state-hover a:hover { color: #212121; text-decoration: none; outline: none; } 62 | .ui-state-active, .ui-widget-content .ui-state-active { border: 1px solid #aaaaaa; background: #ffffff url(images/ui-bg_glass_65_ffffff_1x400.png) 50% 50% repeat-x; font-weight: normal; color: #212121; outline: none; } 63 | .ui-state-active a, .ui-state-active a:link, .ui-state-active a:visited { color: #212121; outline: none; text-decoration: none; } 64 | 65 | /* Interaction Cues 66 | ----------------------------------*/ 67 | .ui-state-highlight, .ui-widget-content .ui-state-highlight {border: 1px solid #fcefa1; background: #fbf9ee url(images/ui-bg_glass_55_fbf9ee_1x400.png) 50% 50% repeat-x; color: #363636; } 68 | .ui-state-highlight a, .ui-widget-content .ui-state-highlight a { color: #363636; } 69 | .ui-state-error, .ui-widget-content .ui-state-error {border: 1px solid #cd0a0a; background: #fef1ec url(images/ui-bg_glass_95_fef1ec_1x400.png) 50% 50% repeat-x; color: #cd0a0a; } 70 | .ui-state-error a, .ui-widget-content .ui-state-error a { color: #cd0a0a; } 71 | .ui-state-error-text, .ui-widget-content .ui-state-error-text { color: #cd0a0a; } 72 | .ui-state-disabled, .ui-widget-content .ui-state-disabled { opacity: .35; filter:Alpha(Opacity=35); background-image: none; } 73 | .ui-priority-primary, .ui-widget-content .ui-priority-primary { font-weight: bold; } 74 | .ui-priority-secondary, .ui-widget-content .ui-priority-secondary { opacity: .7; filter:Alpha(Opacity=70); font-weight: normal; } 75 | 76 | /* Icons 77 | ----------------------------------*/ 78 | 79 | /* states and images */ 80 | .ui-icon { width: 16px; height: 16px; background-image: url(images/ui-icons_222222_256x240.png); } 81 | .ui-widget-content .ui-icon {background-image: url(images/ui-icons_222222_256x240.png); } 82 | .ui-widget-header .ui-icon {background-image: url(images/ui-icons_222222_256x240.png); } 83 | .ui-state-default .ui-icon { background-image: url(images/ui-icons_888888_256x240.png); } 84 | .ui-state-hover .ui-icon, .ui-state-focus .ui-icon {background-image: url(images/ui-icons_454545_256x240.png); } 85 | .ui-state-active .ui-icon {background-image: url(images/ui-icons_454545_256x240.png); } 86 | .ui-state-highlight .ui-icon {background-image: url(images/ui-icons_2e83ff_256x240.png); } 87 | .ui-state-error .ui-icon, .ui-state-error-text .ui-icon {background-image: url(images/ui-icons_cd0a0a_256x240.png); } 88 | 89 | /* positioning */ 90 | .ui-icon-carat-1-n { background-position: 0 0; } 91 | .ui-icon-carat-1-ne { background-position: -16px 0; } 92 | .ui-icon-carat-1-e { background-position: -32px 0; } 93 | .ui-icon-carat-1-se { background-position: -48px 0; } 94 | .ui-icon-carat-1-s { background-position: -64px 0; } 95 | .ui-icon-carat-1-sw { background-position: -80px 0; } 96 | .ui-icon-carat-1-w { background-position: -96px 0; } 97 | .ui-icon-carat-1-nw { background-position: -112px 0; } 98 | .ui-icon-carat-2-n-s { background-position: -128px 0; } 99 | .ui-icon-carat-2-e-w { background-position: -144px 0; } 100 | .ui-icon-triangle-1-n { background-position: 0 -16px; } 101 | .ui-icon-triangle-1-ne { background-position: -16px -16px; } 102 | .ui-icon-triangle-1-e { background-position: -32px -16px; } 103 | .ui-icon-triangle-1-se { background-position: -48px -16px; } 104 | .ui-icon-triangle-1-s { background-position: -64px -16px; } 105 | .ui-icon-triangle-1-sw { background-position: -80px -16px; } 106 | .ui-icon-triangle-1-w { background-position: -96px -16px; } 107 | .ui-icon-triangle-1-nw { background-position: -112px -16px; } 108 | .ui-icon-triangle-2-n-s { background-position: -128px -16px; } 109 | .ui-icon-triangle-2-e-w { background-position: -144px -16px; } 110 | .ui-icon-arrow-1-n { background-position: 0 -32px; } 111 | .ui-icon-arrow-1-ne { background-position: -16px -32px; } 112 | .ui-icon-arrow-1-e { background-position: -32px -32px; } 113 | .ui-icon-arrow-1-se { background-position: -48px -32px; } 114 | .ui-icon-arrow-1-s { background-position: -64px -32px; } 115 | .ui-icon-arrow-1-sw { background-position: -80px -32px; } 116 | .ui-icon-arrow-1-w { background-position: -96px -32px; } 117 | .ui-icon-arrow-1-nw { background-position: -112px -32px; } 118 | .ui-icon-arrow-2-n-s { background-position: -128px -32px; } 119 | .ui-icon-arrow-2-ne-sw { background-position: -144px -32px; } 120 | .ui-icon-arrow-2-e-w { background-position: -160px -32px; } 121 | .ui-icon-arrow-2-se-nw { background-position: -176px -32px; } 122 | .ui-icon-arrowstop-1-n { background-position: -192px -32px; } 123 | .ui-icon-arrowstop-1-e { background-position: -208px -32px; } 124 | .ui-icon-arrowstop-1-s { background-position: -224px -32px; } 125 | .ui-icon-arrowstop-1-w { background-position: -240px -32px; } 126 | .ui-icon-arrowthick-1-n { background-position: 0 -48px; } 127 | .ui-icon-arrowthick-1-ne { background-position: -16px -48px; } 128 | .ui-icon-arrowthick-1-e { background-position: -32px -48px; } 129 | .ui-icon-arrowthick-1-se { background-position: -48px -48px; } 130 | .ui-icon-arrowthick-1-s { background-position: -64px -48px; } 131 | .ui-icon-arrowthick-1-sw { background-position: -80px -48px; } 132 | .ui-icon-arrowthick-1-w { background-position: -96px -48px; } 133 | .ui-icon-arrowthick-1-nw { background-position: -112px -48px; } 134 | .ui-icon-arrowthick-2-n-s { background-position: -128px -48px; } 135 | .ui-icon-arrowthick-2-ne-sw { background-position: -144px -48px; } 136 | .ui-icon-arrowthick-2-e-w { background-position: -160px -48px; } 137 | .ui-icon-arrowthick-2-se-nw { background-position: -176px -48px; } 138 | .ui-icon-arrowthickstop-1-n { background-position: -192px -48px; } 139 | .ui-icon-arrowthickstop-1-e { background-position: -208px -48px; } 140 | .ui-icon-arrowthickstop-1-s { background-position: -224px -48px; } 141 | .ui-icon-arrowthickstop-1-w { background-position: -240px -48px; } 142 | .ui-icon-arrowreturnthick-1-w { background-position: 0 -64px; } 143 | .ui-icon-arrowreturnthick-1-n { background-position: -16px -64px; } 144 | .ui-icon-arrowreturnthick-1-e { background-position: -32px -64px; } 145 | .ui-icon-arrowreturnthick-1-s { background-position: -48px -64px; } 146 | .ui-icon-arrowreturn-1-w { background-position: -64px -64px; } 147 | .ui-icon-arrowreturn-1-n { background-position: -80px -64px; } 148 | .ui-icon-arrowreturn-1-e { background-position: -96px -64px; } 149 | .ui-icon-arrowreturn-1-s { background-position: -112px -64px; } 150 | .ui-icon-arrowrefresh-1-w { background-position: -128px -64px; } 151 | .ui-icon-arrowrefresh-1-n { background-position: -144px -64px; } 152 | .ui-icon-arrowrefresh-1-e { background-position: -160px -64px; } 153 | .ui-icon-arrowrefresh-1-s { background-position: -176px -64px; } 154 | .ui-icon-arrow-4 { background-position: 0 -80px; } 155 | .ui-icon-arrow-4-diag { background-position: -16px -80px; } 156 | .ui-icon-extlink { background-position: -32px -80px; } 157 | .ui-icon-newwin { background-position: -48px -80px; } 158 | .ui-icon-refresh { background-position: -64px -80px; } 159 | .ui-icon-shuffle { background-position: -80px -80px; } 160 | .ui-icon-transfer-e-w { background-position: -96px -80px; } 161 | .ui-icon-transferthick-e-w { background-position: -112px -80px; } 162 | .ui-icon-folder-collapsed { background-position: 0 -96px; } 163 | .ui-icon-folder-open { background-position: -16px -96px; } 164 | .ui-icon-document { background-position: -32px -96px; } 165 | .ui-icon-document-b { background-position: -48px -96px; } 166 | .ui-icon-note { background-position: -64px -96px; } 167 | .ui-icon-mail-closed { background-position: -80px -96px; } 168 | .ui-icon-mail-open { background-position: -96px -96px; } 169 | .ui-icon-suitcase { background-position: -112px -96px; } 170 | .ui-icon-comment { background-position: -128px -96px; } 171 | .ui-icon-person { background-position: -144px -96px; } 172 | .ui-icon-print { background-position: -160px -96px; } 173 | .ui-icon-trash { background-position: -176px -96px; } 174 | .ui-icon-locked { background-position: -192px -96px; } 175 | .ui-icon-unlocked { background-position: -208px -96px; } 176 | .ui-icon-bookmark { background-position: -224px -96px; } 177 | .ui-icon-tag { background-position: -240px -96px; } 178 | .ui-icon-home { background-position: 0 -112px; } 179 | .ui-icon-flag { background-position: -16px -112px; } 180 | .ui-icon-calendar { background-position: -32px -112px; } 181 | .ui-icon-cart { background-position: -48px -112px; } 182 | .ui-icon-pencil { background-position: -64px -112px; } 183 | .ui-icon-clock { background-position: -80px -112px; } 184 | .ui-icon-disk { background-position: -96px -112px; } 185 | .ui-icon-calculator { background-position: -112px -112px; } 186 | .ui-icon-zoomin { background-position: -128px -112px; } 187 | .ui-icon-zoomout { background-position: -144px -112px; } 188 | .ui-icon-search { background-position: -160px -112px; } 189 | .ui-icon-wrench { background-position: -176px -112px; } 190 | .ui-icon-gear { background-position: -192px -112px; } 191 | .ui-icon-heart { background-position: -208px -112px; } 192 | .ui-icon-star { background-position: -224px -112px; } 193 | .ui-icon-link { background-position: -240px -112px; } 194 | .ui-icon-cancel { background-position: 0 -128px; } 195 | .ui-icon-plus { background-position: -16px -128px; } 196 | .ui-icon-plusthick { background-position: -32px -128px; } 197 | .ui-icon-minus { background-position: -48px -128px; } 198 | .ui-icon-minusthick { background-position: -64px -128px; } 199 | .ui-icon-close { background-position: -80px -128px; } 200 | .ui-icon-closethick { background-position: -96px -128px; } 201 | .ui-icon-key { background-position: -112px -128px; } 202 | .ui-icon-lightbulb { background-position: -128px -128px; } 203 | .ui-icon-scissors { background-position: -144px -128px; } 204 | .ui-icon-clipboard { background-position: -160px -128px; } 205 | .ui-icon-copy { background-position: -176px -128px; } 206 | .ui-icon-contact { background-position: -192px -128px; } 207 | .ui-icon-image { background-position: -208px -128px; } 208 | .ui-icon-video { background-position: -224px -128px; } 209 | .ui-icon-script { background-position: -240px -128px; } 210 | .ui-icon-alert { background-position: 0 -144px; } 211 | .ui-icon-info { background-position: -16px -144px; } 212 | .ui-icon-notice { background-position: -32px -144px; } 213 | .ui-icon-help { background-position: -48px -144px; } 214 | .ui-icon-check { background-position: -64px -144px; } 215 | .ui-icon-bullet { background-position: -80px -144px; } 216 | .ui-icon-radio-off { background-position: -96px -144px; } 217 | .ui-icon-radio-on { background-position: -112px -144px; } 218 | .ui-icon-pin-w { background-position: -128px -144px; } 219 | .ui-icon-pin-s { background-position: -144px -144px; } 220 | .ui-icon-play { background-position: 0 -160px; } 221 | .ui-icon-pause { background-position: -16px -160px; } 222 | .ui-icon-seek-next { background-position: -32px -160px; } 223 | .ui-icon-seek-prev { background-position: -48px -160px; } 224 | .ui-icon-seek-end { background-position: -64px -160px; } 225 | .ui-icon-seek-first { background-position: -80px -160px; } 226 | .ui-icon-stop { background-position: -96px -160px; } 227 | .ui-icon-eject { background-position: -112px -160px; } 228 | .ui-icon-volume-off { background-position: -128px -160px; } 229 | .ui-icon-volume-on { background-position: -144px -160px; } 230 | .ui-icon-power { background-position: 0 -176px; } 231 | .ui-icon-signal-diag { background-position: -16px -176px; } 232 | .ui-icon-signal { background-position: -32px -176px; } 233 | .ui-icon-battery-0 { background-position: -48px -176px; } 234 | .ui-icon-battery-1 { background-position: -64px -176px; } 235 | .ui-icon-battery-2 { background-position: -80px -176px; } 236 | .ui-icon-battery-3 { background-position: -96px -176px; } 237 | .ui-icon-circle-plus { background-position: 0 -192px; } 238 | .ui-icon-circle-minus { background-position: -16px -192px; } 239 | .ui-icon-circle-close { background-position: -32px -192px; } 240 | .ui-icon-circle-triangle-e { background-position: -48px -192px; } 241 | .ui-icon-circle-triangle-s { background-position: -64px -192px; } 242 | .ui-icon-circle-triangle-w { background-position: -80px -192px; } 243 | .ui-icon-circle-triangle-n { background-position: -96px -192px; } 244 | .ui-icon-circle-arrow-e { background-position: -112px -192px; } 245 | .ui-icon-circle-arrow-s { background-position: -128px -192px; } 246 | .ui-icon-circle-arrow-w { background-position: -144px -192px; } 247 | .ui-icon-circle-arrow-n { background-position: -160px -192px; } 248 | .ui-icon-circle-zoomin { background-position: -176px -192px; } 249 | .ui-icon-circle-zoomout { background-position: -192px -192px; } 250 | .ui-icon-circle-check { background-position: -208px -192px; } 251 | .ui-icon-circlesmall-plus { background-position: 0 -208px; } 252 | .ui-icon-circlesmall-minus { background-position: -16px -208px; } 253 | .ui-icon-circlesmall-close { background-position: -32px -208px; } 254 | .ui-icon-squaresmall-plus { background-position: -48px -208px; } 255 | .ui-icon-squaresmall-minus { background-position: -64px -208px; } 256 | .ui-icon-squaresmall-close { background-position: -80px -208px; } 257 | .ui-icon-grip-dotted-vertical { background-position: 0 -224px; } 258 | .ui-icon-grip-dotted-horizontal { background-position: -16px -224px; } 259 | .ui-icon-grip-solid-vertical { background-position: -32px -224px; } 260 | .ui-icon-grip-solid-horizontal { background-position: -48px -224px; } 261 | .ui-icon-gripsmall-diagonal-se { background-position: -64px -224px; } 262 | .ui-icon-grip-diagonal-se { background-position: -80px -224px; } 263 | 264 | 265 | /* Misc visuals 266 | ----------------------------------*/ 267 | 268 | /* Corner radius */ 269 | .ui-corner-tl { -moz-border-radius-topleft: 4px; -webkit-border-top-left-radius: 4px; } 270 | .ui-corner-tr { -moz-border-radius-topright: 4px; -webkit-border-top-right-radius: 4px; } 271 | .ui-corner-bl { -moz-border-radius-bottomleft: 4px; -webkit-border-bottom-left-radius: 4px; } 272 | .ui-corner-br { -moz-border-radius-bottomright: 4px; -webkit-border-bottom-right-radius: 4px; } 273 | .ui-corner-top { -moz-border-radius-topleft: 4px; -webkit-border-top-left-radius: 4px; -moz-border-radius-topright: 4px; -webkit-border-top-right-radius: 4px; } 274 | .ui-corner-bottom { -moz-border-radius-bottomleft: 4px; -webkit-border-bottom-left-radius: 4px; -moz-border-radius-bottomright: 4px; -webkit-border-bottom-right-radius: 4px; } 275 | .ui-corner-right { -moz-border-radius-topright: 4px; -webkit-border-top-right-radius: 4px; -moz-border-radius-bottomright: 4px; -webkit-border-bottom-right-radius: 4px; } 276 | .ui-corner-left { -moz-border-radius-topleft: 4px; -webkit-border-top-left-radius: 4px; -moz-border-radius-bottomleft: 4px; -webkit-border-bottom-left-radius: 4px; } 277 | .ui-corner-all { -moz-border-radius: 4px; -webkit-border-radius: 4px; } 278 | 279 | /* Overlays */ 280 | .ui-widget-overlay { background: #aaaaaa url(images/ui-bg_flat_0_aaaaaa_40x100.png) 50% 50% repeat-x; opacity: .30;filter:Alpha(Opacity=30); } 281 | .ui-widget-shadow { margin: -8px 0 0 -8px; padding: 8px; background: #aaaaaa url(images/ui-bg_flat_0_aaaaaa_40x100.png) 50% 50% repeat-x; opacity: .30;filter:Alpha(Opacity=30); -moz-border-radius: 8px; -webkit-border-radius: 8px; }/* Accordion 282 | ----------------------------------*/ 283 | .ui-accordion .ui-accordion-header { cursor: pointer; position: relative; margin-top: 1px; zoom: 1; } 284 | .ui-accordion .ui-accordion-li-fix { display: inline; } 285 | .ui-accordion .ui-accordion-header-active { border-bottom: 0 !important; } 286 | .ui-accordion .ui-accordion-header a { display: block; font-size: 1em; padding: .5em .5em .5em 2.2em; } 287 | .ui-accordion .ui-accordion-header .ui-icon { position: absolute; left: .5em; top: 50%; margin-top: -8px; } 288 | .ui-accordion .ui-accordion-content { padding: 1em 2.2em; border-top: 0; margin-top: -2px; position: relative; top: 1px; margin-bottom: 2px; overflow: auto; display: none; } 289 | .ui-accordion .ui-accordion-content-active { display: block; }/* Datepicker 290 | ----------------------------------*/ 291 | .ui-datepicker { width: 17em; padding: .2em .2em 0; } 292 | .ui-datepicker .ui-datepicker-header { position:relative; padding:.2em 0; } 293 | .ui-datepicker .ui-datepicker-prev, .ui-datepicker .ui-datepicker-next { position:absolute; top: 2px; width: 1.8em; height: 1.8em; } 294 | .ui-datepicker .ui-datepicker-prev-hover, .ui-datepicker .ui-datepicker-next-hover { top: 1px; } 295 | .ui-datepicker .ui-datepicker-prev { left:2px; } 296 | .ui-datepicker .ui-datepicker-next { right:2px; } 297 | .ui-datepicker .ui-datepicker-prev-hover { left:1px; } 298 | .ui-datepicker .ui-datepicker-next-hover { right:1px; } 299 | .ui-datepicker .ui-datepicker-prev span, .ui-datepicker .ui-datepicker-next span { display: block; position: absolute; left: 50%; margin-left: -8px; top: 50%; margin-top: -8px; } 300 | .ui-datepicker .ui-datepicker-title { margin: 0 2.3em; line-height: 1.8em; text-align: center; } 301 | .ui-datepicker .ui-datepicker-title select { float:left; font-size:1em; margin:1px 0; } 302 | .ui-datepicker select.ui-datepicker-month-year {width: 100%;} 303 | .ui-datepicker select.ui-datepicker-month, 304 | .ui-datepicker select.ui-datepicker-year { width: 49%;} 305 | .ui-datepicker .ui-datepicker-title select.ui-datepicker-year { float: right; } 306 | .ui-datepicker table {width: 100%; font-size: .9em; border-collapse: collapse; margin:0 0 .4em; } 307 | .ui-datepicker th { padding: .7em .3em; text-align: center; font-weight: bold; border: 0; } 308 | .ui-datepicker td { border: 0; padding: 1px; } 309 | .ui-datepicker td span, .ui-datepicker td a { display: block; padding: .2em; text-align: right; text-decoration: none; } 310 | .ui-datepicker .ui-datepicker-buttonpane { background-image: none; margin: .7em 0 0 0; padding:0 .2em; border-left: 0; border-right: 0; border-bottom: 0; } 311 | .ui-datepicker .ui-datepicker-buttonpane button { float: right; margin: .5em .2em .4em; cursor: pointer; padding: .2em .6em .3em .6em; width:auto; overflow:visible; } 312 | .ui-datepicker .ui-datepicker-buttonpane button.ui-datepicker-current { float:left; } 313 | 314 | /* with multiple calendars */ 315 | .ui-datepicker.ui-datepicker-multi { width:auto; } 316 | .ui-datepicker-multi .ui-datepicker-group { float:left; } 317 | .ui-datepicker-multi .ui-datepicker-group table { width:95%; margin:0 auto .4em; } 318 | .ui-datepicker-multi-2 .ui-datepicker-group { width:50%; } 319 | .ui-datepicker-multi-3 .ui-datepicker-group { width:33.3%; } 320 | .ui-datepicker-multi-4 .ui-datepicker-group { width:25%; } 321 | .ui-datepicker-multi .ui-datepicker-group-last .ui-datepicker-header { border-left-width:0; } 322 | .ui-datepicker-multi .ui-datepicker-group-middle .ui-datepicker-header { border-left-width:0; } 323 | .ui-datepicker-multi .ui-datepicker-buttonpane { clear:left; } 324 | .ui-datepicker-row-break { clear:both; width:100%; } 325 | 326 | /* RTL support */ 327 | .ui-datepicker-rtl { direction: rtl; } 328 | .ui-datepicker-rtl .ui-datepicker-prev { right: 2px; left: auto; } 329 | .ui-datepicker-rtl .ui-datepicker-next { left: 2px; right: auto; } 330 | .ui-datepicker-rtl .ui-datepicker-prev:hover { right: 1px; left: auto; } 331 | .ui-datepicker-rtl .ui-datepicker-next:hover { left: 1px; right: auto; } 332 | .ui-datepicker-rtl .ui-datepicker-buttonpane { clear:right; } 333 | .ui-datepicker-rtl .ui-datepicker-buttonpane button { float: left; } 334 | .ui-datepicker-rtl .ui-datepicker-buttonpane button.ui-datepicker-current { float:right; } 335 | .ui-datepicker-rtl .ui-datepicker-group { float:right; } 336 | .ui-datepicker-rtl .ui-datepicker-group-last .ui-datepicker-header { border-right-width:0; border-left-width:1px; } 337 | .ui-datepicker-rtl .ui-datepicker-group-middle .ui-datepicker-header { border-right-width:0; border-left-width:1px; } 338 | 339 | /* IE6 IFRAME FIX (taken from datepicker 1.5.3 */ 340 | .ui-datepicker-cover { 341 | display: none; /*sorry for IE5*/ 342 | display/**/: block; /*sorry for IE5*/ 343 | position: absolute; /*must have*/ 344 | z-index: -1; /*must have*/ 345 | filter: mask(); /*must have*/ 346 | top: -4px; /*must have*/ 347 | left: -4px; /*must have*/ 348 | width: 200px; /*must have*/ 349 | height: 200px; /*must have*/ 350 | }/* Dialog 351 | ----------------------------------*/ 352 | .ui-dialog { position: relative; padding: .2em; width: 300px; } 353 | .ui-dialog .ui-dialog-titlebar { padding: .5em .3em .3em 1em; position: relative; } 354 | .ui-dialog .ui-dialog-title { float: left; margin: .1em 0 .2em; } 355 | .ui-dialog .ui-dialog-titlebar-close { position: absolute; right: .3em; top: 50%; width: 19px; margin: -10px 0 0 0; padding: 1px; height: 18px; } 356 | .ui-dialog .ui-dialog-titlebar-close span { display: block; margin: 1px; } 357 | .ui-dialog .ui-dialog-titlebar-close:hover, .ui-dialog .ui-dialog-titlebar-close:focus { padding: 0; } 358 | .ui-dialog .ui-dialog-content { border: 0; padding: .5em 1em; background: none; overflow: auto; zoom: 1; } 359 | .ui-dialog .ui-dialog-buttonpane { text-align: left; border-width: 1px 0 0 0; background-image: none; margin: .5em 0 0 0; padding: .3em 1em .5em .4em; } 360 | .ui-dialog .ui-dialog-buttonpane button { float: right; margin: .5em .4em .5em 0; cursor: pointer; padding: .2em .6em .3em .6em; line-height: 1.4em; width:auto; overflow:visible; } 361 | .ui-dialog .ui-resizable-se { width: 14px; height: 14px; right: 3px; bottom: 3px; } 362 | .ui-draggable .ui-dialog-titlebar { cursor: move; } 363 | /* Progressbar 364 | ----------------------------------*/ 365 | .ui-progressbar { height:2em; text-align: left; } 366 | .ui-progressbar .ui-progressbar-value {margin: -1px; height:100%; }/* Resizable 367 | ----------------------------------*/ 368 | .ui-resizable { position: relative;} 369 | .ui-resizable-handle { position: absolute;font-size: 0.1px;z-index: 99999; display: block;} 370 | .ui-resizable-disabled .ui-resizable-handle, .ui-resizable-autohide .ui-resizable-handle { display: none; } 371 | .ui-resizable-n { cursor: n-resize; height: 7px; width: 100%; top: -5px; left: 0px; } 372 | .ui-resizable-s { cursor: s-resize; height: 7px; width: 100%; bottom: -5px; left: 0px; } 373 | .ui-resizable-e { cursor: e-resize; width: 7px; right: -5px; top: 0px; height: 100%; } 374 | .ui-resizable-w { cursor: w-resize; width: 7px; left: -5px; top: 0px; height: 100%; } 375 | .ui-resizable-se { cursor: se-resize; width: 12px; height: 12px; right: 1px; bottom: 1px; } 376 | .ui-resizable-sw { cursor: sw-resize; width: 9px; height: 9px; left: -5px; bottom: -5px; } 377 | .ui-resizable-nw { cursor: nw-resize; width: 9px; height: 9px; left: -5px; top: -5px; } 378 | .ui-resizable-ne { cursor: ne-resize; width: 9px; height: 9px; right: -5px; top: -5px;}/* Slider 379 | ----------------------------------*/ 380 | .ui-slider { position: relative; text-align: left; } 381 | .ui-slider .ui-slider-handle { position: absolute; z-index: 2; width: 1.2em; height: 1.2em; cursor: default; } 382 | .ui-slider .ui-slider-range { position: absolute; z-index: 1; font-size: .7em; display: block; border: 0; } 383 | 384 | .ui-slider-horizontal { height: .8em; } 385 | .ui-slider-horizontal .ui-slider-handle { top: -.3em; margin-left: -.6em; } 386 | .ui-slider-horizontal .ui-slider-range { top: 0; height: 100%; } 387 | .ui-slider-horizontal .ui-slider-range-min { left: 0; } 388 | .ui-slider-horizontal .ui-slider-range-max { right: 0; } 389 | 390 | .ui-slider-vertical { width: .8em; height: 100px; } 391 | .ui-slider-vertical .ui-slider-handle { left: -.3em; margin-left: 0; margin-bottom: -.6em; } 392 | .ui-slider-vertical .ui-slider-range { left: 0; width: 100%; } 393 | .ui-slider-vertical .ui-slider-range-min { bottom: 0; } 394 | .ui-slider-vertical .ui-slider-range-max { top: 0; }/* Tabs 395 | ----------------------------------*/ 396 | .ui-tabs { padding: .2em; zoom: 1; } 397 | .ui-tabs .ui-tabs-nav { list-style: none; position: relative; padding: .2em .2em 0; } 398 | .ui-tabs .ui-tabs-nav li { position: relative; float: left; border-bottom-width: 0 !important; margin: 0 .2em -1px 0; padding: 0; } 399 | .ui-tabs .ui-tabs-nav li a { float: left; text-decoration: none; padding: .5em 1em; } 400 | .ui-tabs .ui-tabs-nav li.ui-tabs-selected { padding-bottom: 1px; border-bottom-width: 0; } 401 | .ui-tabs .ui-tabs-nav li.ui-tabs-selected a, .ui-tabs .ui-tabs-nav li.ui-state-disabled a, .ui-tabs .ui-tabs-nav li.ui-state-processing a { cursor: text; } 402 | .ui-tabs .ui-tabs-nav li a, .ui-tabs.ui-tabs-collapsible .ui-tabs-nav li.ui-tabs-selected a { cursor: pointer; } /* first selector in group seems obsolete, but required to overcome bug in Opera applying cursor: text overall if defined elsewhere... */ 403 | .ui-tabs .ui-tabs-panel { padding: 1em 1.4em; display: block; border-width: 0; background: none; } 404 | .ui-tabs .ui-tabs-hide { display: none !important; } 405 | -------------------------------------------------------------------------------- /Others/ColinWilson/README: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/Others/ColinWilson/README -------------------------------------------------------------------------------- /Others/ColinWilson/unitEXIcon.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/Others/ColinWilson/unitEXIcon.pas -------------------------------------------------------------------------------- /Others/ColinWilson/unitResFile.pas: -------------------------------------------------------------------------------- 1 | unit unitResFile; 2 | 3 | interface 4 | 5 | uses Windows, Classes, SysUtils, ConTnrs, unitResourceDetails; 6 | 7 | type 8 | TResourceList = class (TResourceModule) 9 | private 10 | fResourceList : TObjectList; 11 | protected 12 | function GetResourceCount: Integer; override; 13 | function GetResourceDetails(idx: Integer): TResourceDetails; override; 14 | public 15 | constructor Create; 16 | destructor Destroy; override; 17 | procedure Assign (src : TResourceModule); 18 | procedure InsertResource (idx : Integer; details : TResourceDetails); override; 19 | procedure DeleteResource (idx : Integer); override; 20 | function AddResource (details : TResourceDetails) : Integer; override; 21 | function IndexOfResource (details : TResourceDetails) : Integer; override; 22 | procedure SortResources; override; 23 | end; 24 | 25 | TResModule = class (TResourceList) 26 | private 27 | f16Bit : boolean; 28 | procedure ParseResource(header, data: PAnsiChar; dataSize: Integer); 29 | protected 30 | public 31 | procedure SaveToStream (stream : TStream); override; 32 | procedure LoadFromStream (stream : TStream); override; 33 | end; 34 | 35 | implementation 36 | 37 | { TResModule } 38 | 39 | procedure TResModule.ParseResource (header, data : PAnsiChar; dataSize : Integer); 40 | var 41 | p : PAnsiChar; 42 | sName, sType : String; 43 | res : TResourceDetails; 44 | language, memoryFlags : word; 45 | version, dataVersion, characteristics : DWORD; 46 | 47 | function GetName : String; 48 | begin 49 | if PWord (p)^ = $ffff then 50 | begin 51 | Inc (p, sizeof (word)); 52 | result := IntToStr (PWord (p)^); 53 | Inc (p, sizeof (word)) 54 | end 55 | else 56 | begin 57 | result := UnicodeString (PWideChar (p)); 58 | Inc (p, (Length (result) + 1) * sizeof (WideChar)) 59 | end 60 | end; 61 | 62 | begin 63 | try 64 | p := header; 65 | Inc (p, 2 * sizeof (Integer)); 66 | sType := GetName; 67 | sName := GetName; 68 | 69 | if (Integer (p) mod 4) <> 0 then 70 | Inc (p, 4 - Integer (p) mod 4); 71 | 72 | dataVersion := PDWORD (p)^; 73 | Inc (p, sizeof (DWORD)); 74 | memoryFlags := PWORD (p)^; 75 | Inc (p, sizeof (word)); 76 | language := PWORD (p)^; 77 | Inc (p, sizeof (word)); 78 | version := PDWORD (p)^; 79 | Inc (p, sizeof (DWORD)); 80 | characteristics := PDWORD (p)^; 81 | Inc (p, sizeof (DWORD)); 82 | 83 | if (dataSize <> 0) or (sName <> '0') then 84 | begin 85 | res := TResourceDetails.CreateResourceDetails (self, language, sName, sType, dataSize, data); 86 | res.Characteristics := characteristics; 87 | res.Version := version; 88 | res.MemoryFlags := memoryFlags; 89 | res.DataVersion := dataVersion; 90 | AddResource (res) 91 | end 92 | else // NB!!! 32 bit .RES files start with a dummy '32-bit indicator' 93 | // resource !!! Is this documented? I don't think so! 94 | 95 | f16Bit := False; 96 | except 97 | raise Exception.Create('The resource file is corrupt'); 98 | 99 | end; 100 | end; 101 | 102 | procedure TResModule.LoadFromStream(stream: TStream); 103 | var 104 | buffer, p, q : PAnsiChar; 105 | bufLen, n, DataSize, HeaderSize, ChunkSize : Integer; 106 | begin 107 | bufLen := stream.Size; 108 | GetMem (buffer, bufLen); 109 | try 110 | stream.ReadBuffer (buffer^, bufLen); // Read the entite file 111 | 112 | p := buffer; 113 | n := 0; 114 | f16Bit := True; 115 | // Parse each resource 116 | while n + 2 * sizeof (Integer) < bufLen do 117 | begin 118 | DataSize := PInteger (p)^; 119 | q := p; 120 | Inc (q, SizeOf (Integer)); 121 | HeaderSize := PInteger (q)^; 122 | q := p; 123 | Inc (q, HeaderSize); 124 | 125 | ParseResource (p, q, DataSize); 126 | ChunkSize := DataSize + HeaderSize; 127 | ChunkSize := ((ChunkSize + 3) div 4) * 4; 128 | Inc (p, ChunkSize); 129 | Inc (n, ChunkSize); 130 | end; 131 | 132 | finally 133 | FreeMem (buffer) 134 | end; 135 | SortResources 136 | end; 137 | 138 | procedure TResModule.SaveToStream(stream: TStream); 139 | var 140 | res : TResourceDetails; 141 | dataSize, headerSize, totalSize : Integer; 142 | header : array [0..1023] of Byte; 143 | i : Integer; 144 | 145 | function GetResHeader (header : PByte) : DWORD; 146 | var 147 | pos : DWORD; 148 | len, dw : DWORD; 149 | w : word; 150 | i : Integer; 151 | ws : WideString; 152 | begin 153 | pos := 0; 154 | ZeroMemory (header, 1024); 155 | 156 | i := ResourceNameToInt (res.ResourceType); 157 | if i = -1 then 158 | begin 159 | ws := res.ResourceType; 160 | len := (Length (ws) + 1) * sizeof (WideChar); 161 | Move (PWideChar (ws)^, header [pos], len); 162 | Inc (pos, len) 163 | end 164 | else 165 | begin 166 | w := $ffff; 167 | Move (w, header [pos], sizeof (w)); 168 | Inc (pos, sizeof (w)); 169 | 170 | w := Word (i); 171 | Move (w, header [pos], sizeof (w)); 172 | Inc (pos, sizeof (w)) 173 | end; 174 | 175 | i := ResourceNameToInt (res.ResourceName); 176 | if i = -1 then 177 | begin 178 | ws := res.ResourceName; 179 | len := (Length (ws) + 1) * sizeof (WideChar); 180 | Move (PWideChar (ws)^, header [pos], len); 181 | Inc (pos, len) 182 | end 183 | else 184 | begin 185 | w := $ffff; 186 | Move (w, header [pos], sizeof (w)); 187 | Inc (pos, sizeof (w)); 188 | 189 | w := Word (i); 190 | Move (w, header [pos], sizeof (w)); 191 | Inc (pos, sizeof (w)) 192 | end; 193 | 194 | if (pos mod 4) <> 0 then 195 | Inc (pos, 4 - (pos mod 4)); 196 | 197 | dw := res.DataVersion; 198 | Move (dw, header [pos], sizeof (DWORD)); 199 | Inc (pos, sizeof (DWORD)); 200 | 201 | w := res.MemoryFlags; 202 | Move (w, header [pos], sizeof (WORD)); 203 | Inc (pos, sizeof (WORD)); 204 | 205 | w := res.ResourceLanguage; 206 | Move (w, header [pos], sizeof (WORD)); 207 | Inc (pos, sizeof (WORD)); 208 | 209 | dw := res.Version; 210 | Move (dw, header [pos], sizeof (DWORD)); 211 | Inc (pos, sizeof (DWORD)); 212 | 213 | dw := res.Characteristics; 214 | Move (dw, header [pos], sizeof (DWORD)); 215 | Inc (pos, sizeof (DWORD)); 216 | result := pos; 217 | end; 218 | 219 | begin 220 | if not f16Bit then // Write 32-bit resource indicator (An empty type 0 resource) 221 | begin 222 | res := TResourceDetails.CreateNew (nil, 0, '0'); 223 | try 224 | dataSize := res.Data.Size; 225 | 226 | stream.WriteBuffer (dataSize, sizeof (dataSize)); 227 | headerSize := GetResHeader (@header); 228 | 229 | totalSize := headerSize + 2 * sizeof (DWORD); 230 | 231 | stream.WriteBuffer (totalSize, sizeof (headerSize)); 232 | stream.WriteBuffer (header, headerSize); 233 | finally 234 | res.Free 235 | end 236 | end; 237 | 238 | dataSize := 0; 239 | if ResourceCount > 0 then 240 | for i := 0 to ResourceCount - 1 do 241 | begin 242 | res := ResourceDetails [i]; 243 | dataSize := res.Data.Size; 244 | 245 | stream.WriteBuffer (dataSize, sizeof (dataSize)); 246 | headerSize := GetResHeader (@header); 247 | 248 | totalSize := headerSize + 2 * sizeof (DWORD); 249 | 250 | stream.WriteBuffer (totalSize, sizeof (headerSize)); 251 | stream.WriteBuffer (header, headerSize); 252 | stream.WriteBuffer (res.Data.Memory^, dataSize); 253 | 254 | totalSize := dataSize + totalSize; 255 | ZeroMemory (@header, sizeof (header)); 256 | 257 | if (totalSize mod 4) <> 0 then 258 | stream.WriteBuffer (header, 4 - (totalSize mod 4)); 259 | end 260 | end; 261 | 262 | { TResourceList } 263 | 264 | function TResourceList.AddResource(details: TResourceDetails): Integer; 265 | begin 266 | Result := fResourceList.Add (details); 267 | end; 268 | 269 | procedure TResourceList.Assign(src: TResourceModule); 270 | var 271 | i : Integer; 272 | res : TResourceDetails; 273 | begin 274 | fResourceList.Clear; 275 | 276 | for i := 0 to src.ResourceCount - 1 do 277 | begin 278 | res := TResourceDetails.CreateResourceDetails ( 279 | Self, 280 | src.ResourceDetails [i].ResourceLanguage, 281 | src.ResourceDetails [i].ResourceName, 282 | src.ResourceDetails [i].ResourceType, 283 | src.ResourceDetails [i].Data.Size, 284 | src.ResourceDetails [i].Data.Memory); 285 | 286 | fResourceList.Add (res) 287 | end 288 | end; 289 | 290 | constructor TResourceList.Create; 291 | begin 292 | fResourceList := TObjectList.Create; 293 | end; 294 | 295 | procedure TResourceList.DeleteResource(idx: Integer); 296 | var 297 | res : TResourceDetails; 298 | begin 299 | res := ResourceDetails [idx]; 300 | inherited; 301 | idx := IndexOfResource (Res); 302 | if idx <> -1 then 303 | fResourceList.Delete (idx) 304 | end; 305 | 306 | destructor TResourceList.Destroy; 307 | begin 308 | fResourceList.Free; 309 | inherited; 310 | end; 311 | 312 | function TResourceList.GetResourceCount: Integer; 313 | begin 314 | result := fResourceList.Count 315 | end; 316 | 317 | function TResourceList.GetResourceDetails(idx: Integer): TResourceDetails; 318 | begin 319 | result := TResourceDetails (fResourceList [idx]) 320 | end; 321 | 322 | function TResourceList.IndexOfResource(details: TResourceDetails): Integer; 323 | begin 324 | result := fResourceList.IndexOf (details) 325 | end; 326 | 327 | procedure TResourceList.InsertResource(idx: Integer; 328 | details: TResourceDetails); 329 | begin 330 | fResourceList.Insert (idx, details) 331 | end; 332 | 333 | procedure TResourceList.SortResources; 334 | begin 335 | fResourceList.Sort (compareDetails); 336 | end; 337 | 338 | end. 339 | -------------------------------------------------------------------------------- /Others/ColinWilson/unitResourceDetails.pas: -------------------------------------------------------------------------------- 1 | (*======================================================================* 2 | | unitResourceDetails | 3 | | | 4 | | Ultra-light classes to wrap resources and resource modules. | 5 | | | 6 | | TResourceModule is an abstract base class for things that can | 7 | | provide lists of resources - eg. .RES files, modules, etc. | 8 | | | 9 | | TResourceDetails is a base class for resources. | 10 | | | 11 | | ... and here's the neat trick... | 12 | | | 13 | | Call the class function TResourceDetails.CreateResourceDetails to | 14 | | create an instance of the appropriate registered TResourceDetails | 15 | | descendant | 16 | | | 17 | | ** Gold code ** | 18 | | | 19 | | Copyright (c) Colin Wilson 2001 | 20 | | | 21 | | All rights reserved | 22 | | | 23 | | Version Date By Description | 24 | | ------- ---------- ---- ------------------------------------------| 25 | | 1.0 06/02/2001 CPWW Original | 26 | | 28/05/2005 CPWW ClearDirty made Protected instead of | 27 | | Public | 28 | | TResourceDetails.Create can now take | 29 | | optional data. | 30 | | 16/5/2008 CPWW Tiburon version | 31 | *======================================================================*) 32 | 33 | 34 | unit unitResourceDetails; 35 | 36 | interface 37 | 38 | uses Windows, Classes, SysUtils; 39 | 40 | type 41 | 42 | TResourceDetails = class; 43 | TResourceDetailsClass = class of TResourceDetails; 44 | 45 | 46 | {$region 'TResourceModule class'} 47 | //====================================================================== 48 | // TResourceModule class 49 | 50 | TResourceModule = class 51 | private 52 | fDirty : Boolean; 53 | function GetDirty: Boolean; 54 | protected 55 | function GetResourceCount: Integer; virtual; abstract; 56 | function GetResourceDetails(idx: Integer): TResourceDetails; virtual; abstract; 57 | procedure ClearDirty; 58 | 59 | public 60 | procedure DeleteResource (idx : Integer); virtual; 61 | procedure InsertResource (idx : Integer; details : TResourceDetails); virtual; 62 | function AddResource (details : TResourceDetails) : Integer; virtual; 63 | function IndexOfResource (details : TResourceDetails) : Integer; virtual; abstract; 64 | function GetUniqueResourceName (const tp : UnicodeString) : UnicodeString; 65 | 66 | procedure SaveToStream (stream : TStream); virtual; 67 | procedure LoadFromStream (stream : TStream); virtual; 68 | 69 | procedure SaveToFile (const FileName : string); virtual; 70 | procedure LoadFromFile (const FileName : string); virtual; 71 | procedure SortResources; virtual; 72 | 73 | function FindResource (const tp, Name : UnicodeString; ALanguage : Integer) : TResourceDetails; 74 | 75 | property ResourceCount : Integer read GetResourceCount; 76 | property ResourceDetails [idx : Integer] : TResourceDetails read GetResourceDetails; 77 | property Dirty : Boolean read GetDirty write fDirty; 78 | end; 79 | 80 | {$endregion} 81 | 82 | {$region 'TResourceDetails class'} 83 | //====================================================================== 84 | // TResourceDetails class 85 | 86 | TResourceDetails = class 87 | private 88 | fParent : TResourceModule; 89 | fData : TMemoryStream; 90 | fCodePage : Integer; 91 | fResourceLanguage: LCID; 92 | fResourceName: UnicodeString; 93 | fResourceType: UnicodeString; 94 | 95 | fMemoryFlags : word; // Resource memory flags 96 | fDataVersion, fVersion : DWORD; // Resource header version info 97 | fCharacteristics : DWORD; 98 | fDirty : Boolean; 99 | fTag: Integer; 100 | procedure SetResourceType(const Value: UnicodeString); 101 | // Resource header characteristics 102 | 103 | protected 104 | constructor Create (AParent : TResourceModule; ALanguage : Integer; const AName, AType : UnicodeString; ASize : Integer; AData : pointer); virtual; 105 | procedure InitNew; virtual; 106 | procedure SetResourceName(const Value: UnicodeString); virtual; 107 | class function SupportsRCData (const AName : UnicodeString; Size : Integer; data : Pointer) : Boolean; virtual; 108 | class function SupportsData (Size : Integer; data : Pointer) : Boolean; virtual; 109 | function GetData: TMemoryStream; virtual; 110 | public 111 | class function CreateResourceDetails (AParent : TResourceModule; ALanguage : Integer; const AName, AType : UnicodeString; ASize : Integer; AData : pointer) : TResourceDetails; 112 | class function GetBaseType : UnicodeString; virtual; 113 | 114 | constructor CreateNew (AParent : TResourceModule; ALanguage : Integer; const AName : UnicodeString); virtual; 115 | destructor Destroy; override; 116 | procedure BeforeDelete; virtual; 117 | 118 | procedure ChangeData (newData : TMemoryStream); virtual; 119 | 120 | property Parent : TResourceModule read fParent; 121 | property Data : TMemoryStream read GetData; 122 | property RawData : TMemoryStream read fData; 123 | property ResourceName : UnicodeString read fResourceName write SetResourceName; 124 | property ResourceType : UnicodeString read fResourceType write SetResourceType; 125 | property ResourceLanguage : LCID read fResourceLanguage write fResourceLanguage; 126 | 127 | property CodePage : Integer read fCodePage write fCodePage; 128 | property Characteristics : DWORD read fCharacteristics write fCharacteristics; 129 | property Version : DWORD read fVersion write fDataVersion; 130 | property DataVersion : DWORD read fDataVersion write fDataVersion; 131 | property MemoryFlags : WORD read fMemoryFlags write fMemoryFlags; 132 | 133 | property Dirty : Boolean read fDirty write fDirty; 134 | property Tag : Integer read fTag write fTag; 135 | end; 136 | {$endregion} 137 | 138 | {$region 'TAnsiResourceDetails class'} 139 | //====================================================================== 140 | // TAnsiResourceDetails class 141 | 142 | TAnsiResourceDetails = class (TResourceDetails) 143 | private 144 | function GetText: AnsiString; 145 | procedure SetText(const Value: AnsiString); 146 | protected 147 | procedure InitNew; override; 148 | class function SupportsData (Size : Integer; data : Pointer) : Boolean; override; 149 | public 150 | property Text : AnsiString read GetText write SetText; 151 | end; 152 | 153 | TUTF8ResourceDetails = class (TResourceDetails) 154 | private 155 | function GetText: UnicodeString; 156 | procedure SetText(const Value: UnicodeString); 157 | protected 158 | procedure InitNew; override; 159 | class function SupportsData (Size : Integer; data : Pointer) : Boolean; override; 160 | public 161 | property Text : UnicodeString read GetText write SetText; 162 | end; 163 | {$endregion} 164 | 165 | {$region 'TUnicodeResourceDetails'} 166 | //====================================================================== 167 | // TAnsiResourceDetails class 168 | 169 | TUnicodeResourceDetails = class (TResourceDetails) 170 | private 171 | function GetText: UnicodeString; 172 | procedure SetText(const Value: UnicodeString); 173 | protected 174 | procedure InitNew; override; 175 | class function SupportsData (Size : Integer; data : Pointer) : Boolean; override; 176 | public 177 | property Text : UnicodeString read GetText write SetText; 178 | end; 179 | {$endregion} 180 | 181 | //====================================================================== 182 | // Global function definitions 183 | 184 | procedure RegisterResourceDetails (resourceClass : TResourceDetailsClass); 185 | procedure UnRegisterResourceDetails (resourceClass : TResourceDetailsClass); 186 | function ResourceNameToInt (const s : UnicodeString) : Integer; 187 | function ResourceWideCharToWideStr (var wstr : PWideChar) : UnicodeString; 188 | function ResourceWideCharToAnsiStr (var wstr : PWideChar; codepage : DWORD) : AnsiString; 189 | procedure ResourceWideStrToWideChar (const s : UnicodeString; var p : PWideChar); 190 | function CompareDetails (p1, p2 : Pointer) : Integer; 191 | 192 | implementation 193 | 194 | {$region 'Local Declarations and Functions'} 195 | var 196 | registeredResourceDetails : array of TResourceDetailsClass; 197 | registeredResourceDetailsCount : Integer = 0; 198 | 199 | resourcestring 200 | rstNoBaseType = 'Can''t register resource details class with no base type'; 201 | rstNoStreaming = 'Module doesn''t support streaming'; 202 | 203 | (*----------------------------------------------------------------------* 204 | | procedure RegisterResourceDetails | 205 | | | 206 | | Add a class, derived from TResourceDetails, to the list of | 207 | | registered resource details classes | 208 | *----------------------------------------------------------------------*) 209 | procedure RegisterResourceDetails (resourceClass : TResourceDetailsClass); 210 | begin 211 | if Length (registeredResourceDetails) = registeredResourceDetailsCount then 212 | SetLength (registeredResourceDetails, Length (registeredResourceDetails) + 10); 213 | 214 | registeredResourceDetails [registeredResourceDetailsCount] := resourceClass; 215 | 216 | Inc (registeredResourceDetailsCount) 217 | end; 218 | 219 | (*----------------------------------------------------------------------* 220 | | procedure UnRegisterResourceDetails | 221 | | | 222 | | Remove a class, derived from TResourceDetails, from the list of | 223 | | registered resource details classes | 224 | *----------------------------------------------------------------------*) 225 | procedure UnRegisterResourceDetails (resourceClass : TResourceDetailsClass); 226 | var 227 | i : Integer; 228 | begin 229 | i := 0; 230 | while i < registeredResourceDetailsCount do 231 | if registeredResourceDetails [i] = resourceClass then 232 | begin 233 | if i < Length (registeredResourceDetails) - 1 then 234 | Move (registeredResourceDetails [i + 1], registeredResourceDetails [i], (Length (registeredResourceDetails) - i - 1) * sizeof (TResourceDetailsClass)); 235 | 236 | Dec (registeredResourceDetailsCount) 237 | end 238 | else 239 | Inc (i) 240 | end; 241 | 242 | (*----------------------------------------------------------------------* 243 | | procedure ResourceNameToInt | 244 | | | 245 | | Get integer value of resource name (or type). Return -1 if it's | 246 | | not numeric. | 247 | *----------------------------------------------------------------------*) 248 | 249 | function ResourceNameToInt (const s : UnicodeString) : Integer; 250 | var 251 | isNumeric : Boolean; 252 | i : Integer; 253 | begin 254 | isNumeric := Length (s) > 0; 255 | for i := 1 to Length (s) do 256 | if (s [i] < '0') or (s [i] > '9') then 257 | begin 258 | isNumeric := False; 259 | break 260 | end; 261 | 262 | if isNumeric then 263 | Result := StrToInt (s) 264 | else 265 | Result := -1 266 | end; 267 | 268 | (*----------------------------------------------------------------------------* 269 | | procedure ResourceWideCharToWideStr () | 270 | | | 271 | | Convert Pascal-style WideChar array to a WideString | 272 | | | 273 | | Parameters: | 274 | | WStr : PWChar The characters | 275 | *----------------------------------------------------------------------------*) 276 | function ResourceWideCharToWideStr (var wstr : PWideChar) : UnicodeString; 277 | var 278 | len : word; 279 | begin 280 | len := word (wstr^); 281 | SetLength (result, len); 282 | Inc (wstr); 283 | Move (wstr^, PWideChar (result)^, len * sizeof (WideChar)); 284 | Inc (wstr, len); 285 | end; 286 | 287 | function ResourceWideCharToAnsiStr (var wstr : PWideChar; codepage : DWORD) : AnsiString; 288 | var 289 | s : UnicodeString; 290 | lu, la : Integer; 291 | begin 292 | s := ResourceWideCharToWideStr (wstr); 293 | 294 | lu := Length (s)+1; 295 | la := (4 * lu) + 1; 296 | SetLength (result, la); 297 | 298 | la := WideChartoMultiByte (codepage, 0, PWideChar (s), lu, PAnsiChar (result), la, nil, nil); 299 | SetLength (result, la-1); 300 | end; 301 | (*----------------------------------------------------------------------------* 302 | | procedure ResourceWideStrToWideChar () | 303 | | | 304 | | Convert a wide string to a Pascal style Wide char array | 305 | | | 306 | | Parameters: | 307 | | s : string The string | 308 | | var p : PWideChar [in] Points to the start of the receiving buf | 309 | | [out] Points after the characters. | 310 | *----------------------------------------------------------------------------*) 311 | procedure ResourceWideStrToWideChar (const s : UnicodeString; var p : PWideChar); 312 | var 313 | len : word; 314 | begin 315 | len := Length (s); 316 | p^ := WideChar (len); 317 | Inc (p); 318 | Move (PWideChar (s)^, p^, len * sizeof (WideChar)); 319 | Inc (p, len) 320 | end; 321 | 322 | (*----------------------------------------------------------------------* 323 | | function CompareDetails | 324 | | | 325 | | 'Compare' function used when sorting resources. p1 and p2 must be | 326 | | TResourceDetails references. Returns > 0 if details at p1 are > | 327 | | details at p2. | 328 | | | 329 | | * Compare resource types. If they match then compare names. | 330 | | * 'Integer' ids or names must come *after* non integer ids or names.| 331 | *----------------------------------------------------------------------*) 332 | function CompareDetails (p1, p2 : Pointer) : Integer; 333 | var 334 | d1 : TResourceDetails; 335 | d2 : TResourceDetails; 336 | i1, i2 : Integer; 337 | begin 338 | d1 := TResourceDetails (p1); 339 | d2 := TResourceDetails (p2); 340 | 341 | i1 := ResourceNameToInt (d1.ResourceType); 342 | i2 := ResourceNameToInt (d2.ResourceType); 343 | 344 | if i1 >= 0 then 345 | if i2 >= 0 then 346 | Result := i1 - i2 // Compare two integer ids 347 | else 348 | Result := 1 // id1 is int, so it's greater than non-int id2 349 | else 350 | if i2 >= 0 then 351 | Result := -1 // id2 is int, so it's less than non-int id1 352 | else 353 | // Compare two string resource ids 354 | Result := CompareText (d1.ResourceType, d2.ResourceType); 355 | 356 | if Result = 0 then // If they match, do the same with the names 357 | begin 358 | i1 := ResourceNameToInt (d1.ResourceName); 359 | i2 := ResourceNameToInt (d2.ResourceName); 360 | 361 | if i1 >= 0 then 362 | if i2 >= 0 then 363 | Result := i1 - i2 364 | else 365 | Result := 1 366 | else 367 | if i2 >= 0 then 368 | Result := -1 369 | else 370 | Result := CompareText (d1.ResourceName, d2.ResourceName) 371 | end 372 | end; 373 | 374 | (*----------------------------------------------------------------------* 375 | | function LCIDTOCodePage | 376 | | | 377 | | Get the ANSI code page for a given language ID | 378 | *----------------------------------------------------------------------*) 379 | function LCIDToCodePage(ALcid: LCID): Integer; 380 | var 381 | Buffer: array [0..6] of Char; 382 | begin 383 | GetLocaleInfo(ALcid, LOCALE_IDEFAULTANSICODEPAGE, Buffer, SizeOf(Buffer)); 384 | Result:= StrToIntDef(Buffer, GetACP); 385 | end; 386 | 387 | {$endregion} 388 | 389 | {$region 'TResourceDetails implementation'} 390 | { TResourceDetails } 391 | 392 | (*----------------------------------------------------------------------* 393 | | TResourceDetails.BeforeDelete | 394 | | | 395 | | Can override this to clear up before deleting. Eg. deleting an | 396 | | icon removes it from the icon group it's in. Deleting an icon group | 397 | | removes the individual icon resources, etc. | 398 | *----------------------------------------------------------------------*) 399 | procedure TResourceDetails.BeforeDelete; 400 | begin 401 | // Stub 402 | end; 403 | 404 | (*----------------------------------------------------------------------* 405 | | TResourceDetails.ChangeData | 406 | | | 407 | | Change all the data. Handy for implementing 'undo', etc. | 408 | *----------------------------------------------------------------------*) 409 | procedure TResourceDetails.ChangeData(newData: TMemoryStream); 410 | begin 411 | fData.Clear; 412 | fData.CopyFrom (newData, 0); 413 | end; 414 | 415 | (*----------------------------------------------------------------------* 416 | | TResourceDetails.Create | 417 | | | 418 | | Raw - protected - constructor for resource details. | 419 | *----------------------------------------------------------------------*) 420 | constructor TResourceDetails.Create(AParent: TResourceModule; ALanguage: Integer; const AName, AType: UnicodeString; ASize: Integer; 421 | AData: pointer); 422 | begin 423 | fParent := AParent; 424 | fResourceLanguage := ALanguage; 425 | fCodePage := LCIDToCodePage (fResourceLanguage); 426 | fResourceName := AName; 427 | fResourceType := AType; 428 | fData := TMemoryStream.Create; 429 | if AData <> Nil then 430 | fData.Write (AData^, ASize) 431 | else 432 | InitNew 433 | end; 434 | 435 | (*----------------------------------------------------------------------* 436 | | TResourceDetails.CreateNew | 437 | | | 438 | | Constructor to be used when adding new resources to a module. | 439 | *----------------------------------------------------------------------*) 440 | constructor TResourceDetails.CreateNew(AParent: TResourceModule; 441 | ALanguage: Integer; const aName : UnicodeString); 442 | begin 443 | fParent := AParent; 444 | fResourceLanguage := ALanguage; 445 | fCodePage := LCIDToCodePage (fResourceLanguage); 446 | fResourceName := AName; 447 | fResourceType := GetBaseType; 448 | if Assigned (AParent) then 449 | AParent.AddResource (Self); 450 | fData := TMemoryStream.Create; 451 | InitNew 452 | end; 453 | 454 | (*----------------------------------------------------------------------* 455 | | TResourceDetails.CreateResourceDetails | 456 | | | 457 | | Create a class derived from TResourceDetals that reflects the 'Type' | 458 | | If no matching class is registered, create a base 'TResourceDetails' | 459 | | class. (Ha! Try doing *that* in C++ ! ) | 460 | *----------------------------------------------------------------------*) 461 | class function TResourceDetails.CreateResourceDetails( 462 | AParent: TResourceModule; ALanguage: Integer; const AName, 463 | AType: UnicodeString; ASize: Integer; AData: pointer): TResourceDetails; 464 | var 465 | i : Integer; 466 | begin 467 | result := Nil; 468 | 469 | if (Length (AType) > 0) then 470 | try 471 | 472 | // Check for exact match 473 | 474 | for i := 0 to registeredResourceDetailsCount - 1 do 475 | if registeredResourceDetails [i].GetBaseType = AType then 476 | begin 477 | if (AType <> IntToStr (Integer (RT_RCDATA))) or registeredResourceDetails [i].SupportsRCData (AName, ASize, AData) then 478 | begin 479 | result := registeredResourceDetails [i].Create (AParent, ALanguage, AName, AType, ASize, AData); 480 | break 481 | end 482 | end; 483 | except 484 | end; 485 | 486 | // If no exact match, check each clas to see if it supports the data 487 | if Result = nil then 488 | try 489 | for i := 0 to registeredResourceDetailsCount - 1 do 490 | if registeredResourceDetails [i].SupportsData (ASize, AData) then 491 | begin 492 | result := registeredResourceDetails [i].Create (AParent, ALanguage, AName, AType, ASize, AData); 493 | break 494 | end; 495 | except 496 | end; 497 | 498 | if result = Nil then 499 | if TAnsiResourceDetails.SupportsData(ASize, AData) then 500 | result := TAnsiResourceDetails.Create (AParent, ALanguage, AName, AType, ASize, AData) 501 | else 502 | if TUnicodeResourceDetails.SupportsData(ASize, AData) then 503 | result := TUnicodeResourceDetails.Create (AParent, ALanguage, AName, AType, ASize, AData) 504 | else 505 | result := TResourceDetails.Create (AParent, ALanguage, AName, AType, ASize, AData) 506 | end; 507 | 508 | (*----------------------------------------------------------------------* 509 | | TResourceDetails.Destroy | 510 | *----------------------------------------------------------------------*) 511 | destructor TResourceDetails.Destroy; 512 | begin 513 | fData.Free; 514 | inherited; 515 | end; 516 | 517 | (*----------------------------------------------------------------------* 518 | | TResourceDetails.GetBaseType | 519 | | | 520 | | Return the base type for the resource details. This is overridden | 521 | | in derived classes. | 522 | *----------------------------------------------------------------------*) 523 | class function TResourceDetails.GetBaseType: UnicodeString; 524 | begin 525 | Result := '0'; 526 | end; 527 | 528 | function TResourceDetails.GetData: TMemoryStream; 529 | begin 530 | result := fData 531 | end; 532 | 533 | (*----------------------------------------------------------------------* 534 | | TResourceDetails.InitNew | 535 | | | 536 | | Override this to initialize a new resource being added to a module. | 537 | *----------------------------------------------------------------------*) 538 | procedure TResourceDetails.InitNew; 539 | begin 540 | // Stub 541 | end; 542 | 543 | (*----------------------------------------------------------------------* 544 | | TResourceDetails.SetResourceName | 545 | | | 546 | | Set the resource name. | 547 | *----------------------------------------------------------------------*) 548 | procedure TResourceDetails.SetResourceName(const Value: UnicodeString); 549 | begin 550 | if fResourceName <> Value then 551 | begin 552 | fResourceName := Value; 553 | fDirty := True 554 | end 555 | end; 556 | 557 | procedure TResourceDetails.SetResourceType(const Value: UnicodeString); 558 | begin 559 | if fResourceType <> Value then 560 | begin 561 | fResourceType := Value; 562 | fDirty := True 563 | end 564 | end; 565 | 566 | (*----------------------------------------------------------------------* 567 | | TResourceDetails.SupportsData | 568 | | | 569 | | Can be overridden to support a custom resource class, where you can | 570 | | determine the custom class from the data - eg. RIFF data, etc. | 571 | *----------------------------------------------------------------------*) 572 | class function TResourceDetails.SupportsData(Size: Integer; 573 | data: Pointer): Boolean; 574 | begin 575 | Result := False; // stub 576 | end; 577 | 578 | (*----------------------------------------------------------------------* 579 | | TResourceDetails.SupportsData | 580 | | | 581 | | Can be overridden to support RC data where you can determine the | 582 | | type from the data and name - eg. the Delphi splash screen JPEG | 583 | *----------------------------------------------------------------------*) 584 | class function TResourceDetails.SupportsRCData(const AName: UnicodeString; 585 | Size: Integer; data: Pointer): Boolean; 586 | begin 587 | Result := False; // stub 588 | end; 589 | 590 | {$endregion} 591 | 592 | {$region 'TResourceModule implementation'} 593 | { TResourceModule } 594 | 595 | function TResourceModule.AddResource(details: TResourceDetails): Integer; 596 | begin 597 | result := -1 598 | // Stub 599 | end; 600 | 601 | procedure TResourceModule.ClearDirty; 602 | var 603 | i : Integer; 604 | begin 605 | fDirty := False; 606 | for i := 0 to ResourceCount - 1 do 607 | ResourceDetails [i].Dirty := False 608 | end; 609 | 610 | (*----------------------------------------------------------------------* 611 | | TResourceModule.DeleteResource | 612 | | | 613 | | Must be overridden to remove the resource details object from | 614 | | wherever it's stored. The overriding method must call | 615 | | inherited | 616 | *----------------------------------------------------------------------*) 617 | procedure TResourceModule.DeleteResource(idx: Integer); 618 | begin 619 | fDirty := True; 620 | ResourceDetails [idx].BeforeDelete; 621 | end; 622 | 623 | (*----------------------------------------------------------------------* 624 | | TResourceModule.FindResource | 625 | | | 626 | | Find a resource with a given type/name | 627 | *----------------------------------------------------------------------*) 628 | function TResourceModule.FindResource(const tp, 629 | Name: UnicodeString; ALanguage : Integer): TResourceDetails; 630 | var 631 | i : Integer; 632 | begin 633 | Result := nil; 634 | for i := 0 to ResourceCount - 1 do 635 | if (ResourceDetails [i].fResourceType = tp) and (ResourceDetails [i].fResourceName = Name) and (Integer (ResourceDetails [i].fResourceLanguage) = ALanguage) then 636 | begin 637 | Result := ResourceDetails [i]; 638 | break 639 | end; 640 | 641 | if not Assigned (result) then 642 | for i := 0 to ResourceCount - 1 do 643 | if (ResourceDetails [i].fResourceType = tp) and (ResourceDetails [i].fResourceName = Name) and (ResourceDetails [i].fResourceLanguage = 0) then 644 | begin 645 | Result := ResourceDetails [i]; 646 | break 647 | end 648 | end; 649 | 650 | (*----------------------------------------------------------------------* 651 | | TResourceModule.GetDirty | 652 | | | 653 | | Returns true if the module or it's resources are 'dirty' | 654 | | | 655 | | nb. fDirty is only set if resources have been deleted. | 656 | | After adding a resource make sure the resource's Dirty is set to | 657 | | true. | 658 | *----------------------------------------------------------------------*) 659 | function TResourceModule.GetDirty: Boolean; 660 | var 661 | i : Integer; 662 | begin 663 | Result := fDirty; 664 | if not fDirty then 665 | for i := 0 to ResourceCount - 1 do 666 | if ResourceDetails [i].Dirty then 667 | begin 668 | Result := True; 669 | break 670 | end 671 | end; 672 | 673 | (*----------------------------------------------------------------------* 674 | | TResourceModule.GetUniqueResourceName | 675 | | | 676 | | Generate a unique resource name for a given type. Names start at | 677 | | 1 (though string lists downgrade that to '0') | 678 | *----------------------------------------------------------------------*) 679 | function TResourceModule.GetUniqueResourceName(const tp: UnicodeString): UnicodeString; 680 | var 681 | i : Integer; 682 | n, n1 : Integer; 683 | details : TResourceDetails; 684 | begin 685 | n := 0; 686 | 687 | for i := 0 to ResourceCount - 1 do 688 | begin 689 | details := ResourceDetails [i]; 690 | if details.ResourceType = tp then 691 | begin 692 | n1 := ResourceNametoInt (details.ResourceName); 693 | if n1 > n then 694 | n := n1 695 | end 696 | end; 697 | 698 | Result := IntToStr (n + 1); 699 | end; 700 | 701 | procedure TResourceModule.InsertResource(idx: Integer; 702 | details: TResourceDetails); 703 | begin 704 | // Stub 705 | end; 706 | 707 | (*----------------------------------------------------------------------* 708 | | TResourceModule.LoadFromFile | 709 | | | 710 | | Load from file. This can be overriden but usually isn't as it | 711 | | relies on LoadFromStream, which must be. | 712 | *----------------------------------------------------------------------*) 713 | procedure TResourceModule.LoadFromFile(const FileName: string); 714 | var 715 | s : TFileStream; 716 | begin 717 | s := TFileStream.Create (FileName, fmOpenRead or fmShareDenyNone); 718 | try 719 | LoadFromStream (s); 720 | finally 721 | s.Free 722 | end 723 | end; 724 | 725 | 726 | procedure TResourceModule.LoadFromStream(stream: TStream); 727 | begin 728 | raise Exception.Create (rstNoStreaming); 729 | end; 730 | 731 | (*----------------------------------------------------------------------* 732 | | TResourceModule.SaveToFile | 733 | | | 734 | | Save to file. This can be overriden but usually isn't as it | 735 | | relies on SaveToStream, which must be. | 736 | *----------------------------------------------------------------------*) 737 | procedure TResourceModule.SaveToFile(const FileName: string); 738 | var 739 | s : TFileStream; 740 | oldFileName, ext : string; 741 | p : PChar; 742 | begin 743 | // Rename old file to .~ext' 744 | oldFileName := FileName; 745 | UniqueString (oldFileName); 746 | p := StrRScan (PChar (oldFileName), '.'); 747 | if p <> Nil then 748 | begin 749 | p^ := #0; 750 | Inc (p); 751 | ext := p; 752 | oldFileName := PChar (oldFileName); 753 | end 754 | else 755 | ext := ''; 756 | ext := '~' + ext; 757 | oldFileName := oldFileName + '.' + ext; 758 | 759 | if FileExists (oldFileName) then 760 | DeleteFile (oldFileName); 761 | 762 | RenameFile (FileName, oldFileName); 763 | 764 | try 765 | s := TFileStream.Create (FileName, fmCreate); 766 | try 767 | SaveToStream (s); 768 | ClearDirty 769 | finally 770 | s.Free 771 | end 772 | except 773 | // Failed. Rename old file back. 774 | DeleteFile (FileName); 775 | RenameFile (oldFileName, FileName); 776 | raise 777 | end 778 | end; 779 | 780 | procedure TResourceModule.SaveToStream(stream: TStream); 781 | begin 782 | raise Exception.Create (rstNoStreaming); 783 | end; 784 | 785 | procedure TResourceModule.SortResources; 786 | begin 787 | // Stub 788 | end; 789 | {$endregion} 790 | 791 | {$region 'TAnsiResourceDetails implementation'} 792 | { TAnsiResourceDetails } 793 | 794 | function TAnsiResourceDetails.GetText: AnsiString; 795 | begin 796 | data.Seek(0, soFromBeginning); 797 | SetString (result, PAnsiChar (data.Memory), data.Size); 798 | end; 799 | 800 | procedure TAnsiResourceDetails.InitNew; 801 | begin 802 | Data.Clear; 803 | end; 804 | 805 | procedure TAnsiResourceDetails.SetText(const Value: AnsiString); 806 | begin 807 | data.Clear; 808 | data.Write(Value [1], Length (Value)) 809 | end; 810 | 811 | class function TAnsiResourceDetails.SupportsData(Size: Integer; 812 | data: Pointer): Boolean; 813 | var 814 | i, sample : Integer; 815 | pc : PAnsiChar; 816 | begin 817 | result := Size > 0; 818 | sample := Size; 819 | if Sample > 1024 then 820 | Sample := 1024; 821 | pc := PAnsiChar (data); 822 | 823 | if result then 824 | for i := 0 to Sample - 1 do 825 | begin 826 | if (pc^ < ' ') or (pc^ > #127) then 827 | if not (pc^ in [#9, #10, #13]) then 828 | begin 829 | result := False; 830 | break 831 | end; 832 | 833 | Inc (pc) 834 | end 835 | end; 836 | {$endregion} 837 | 838 | {$region 'TUnicodeResourceDetails implementation'} 839 | { TUnicodeResourceDetails } 840 | 841 | function TUnicodeResourceDetails.GetText: UnicodeString; 842 | begin 843 | SetLength (result, Data.Size div sizeof (WideChar)); 844 | Move (Data.Memory^, result [1], data.Size); 845 | end; 846 | 847 | procedure TUnicodeResourceDetails.InitNew; 848 | begin 849 | Data.Clear; 850 | end; 851 | 852 | procedure TUnicodeResourceDetails.SetText(const Value: UnicodeString); 853 | begin 854 | data.Write(Value [1], Length (Value) * sizeof (WideChar)) 855 | end; 856 | 857 | class function TUnicodeResourceDetails.SupportsData(Size: Integer; 858 | data: Pointer): Boolean; 859 | var 860 | i, sample : Integer; 861 | pc : PWideChar; 862 | begin 863 | result := Size > 5; 864 | sample := Size div 2; 865 | if Sample > 1024 then 866 | Sample := 1024 867 | else 868 | Dec (Sample); 869 | pc := PWideChar (data); 870 | 871 | if result then 872 | for i := 0 to Sample - 2 do 873 | begin 874 | if (pc^ < ' ') or (pc^ > #127) then 875 | if (pc^ <> #9) and (pc^ <> #10) and (pc^ <> #13) then 876 | begin 877 | result := False; 878 | break 879 | end; 880 | 881 | Inc (pc) 882 | end 883 | end; 884 | {$endregion} 885 | 886 | { TUTF8ResourceDetails } 887 | 888 | function TUTF8ResourceDetails.GetText: UnicodeString; 889 | var 890 | st : UTF8String; 891 | begin 892 | data.Seek(0, soFromBeginning); 893 | SetString (st, PAnsiChar (data.Memory), data.Size); 894 | result := UTF8ToUnicodeString (st); // ****** 895 | // raise Exception.Create('Must check bug is fixed!!!') 896 | end; 897 | 898 | procedure TUTF8ResourceDetails.InitNew; 899 | begin 900 | Data.Clear; 901 | end; 902 | 903 | procedure TUTF8ResourceDetails.SetText(const Value: UnicodeString); 904 | var 905 | st : UTF8String; 906 | begin 907 | st := UTf8Encode (Value); 908 | data.Clear; 909 | data.Write(st [1], Length (st)) 910 | end; 911 | 912 | class function TUTF8ResourceDetails.SupportsData(Size: Integer; 913 | data: Pointer): Boolean; 914 | var 915 | i, sample : Integer; 916 | pc : PAnsiChar; 917 | begin 918 | result := Size > 0; 919 | sample := Size; 920 | if Sample > 1024 then 921 | Sample := 1024; 922 | pc := PAnsiChar (data); 923 | 924 | if result then 925 | for i := 0 to Sample - 1 do 926 | begin 927 | if (pc^ < ' ') or (pc^ > #127) then 928 | if not (pc^ in [#9, #10, #13]) then 929 | begin 930 | result := False; 931 | break 932 | end; 933 | 934 | Inc (pc) 935 | end 936 | end; 937 | 938 | end. 939 | -------------------------------------------------------------------------------- /Others/ColinWilson/unitResourceExaminer.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/Others/ColinWilson/unitResourceExaminer.pas -------------------------------------------------------------------------------- /Others/ColinWilson/unitResourceGraphics.pas: -------------------------------------------------------------------------------- 1 | (*======================================================================* 2 | | unitResourceGraphics | 3 | | | 4 | | Encapsulates graphics in resources (icon, cursor, bitmap) | 5 | | | 6 | | Version Date By Description | 7 | | ------- ---------- ---- ------------------------------------------| 8 | | 1.0 05/01/2001 CPWW Original | 9 | *======================================================================*) 10 | 11 | unit unitResourceGraphics; 12 | 13 | interface 14 | 15 | uses Windows, Classes, SysUtils, unitResourceDetails, graphics, unitExIcon, gifimg; 16 | 17 | type 18 | 19 | //------------------------------------------------------------------------ 20 | // Base class 21 | 22 | TGraphicsResourceDetails = class (TResourceDetails) 23 | protected 24 | function GetHeight: Integer; virtual; abstract; 25 | function GetPixelFormat: TPixelFormat; virtual; abstract; 26 | function GetWidth: Integer; virtual; abstract; 27 | public 28 | procedure GetImage (picture : TPicture); virtual; abstract; 29 | procedure SetImage (image : TPicture); virtual; 30 | 31 | property Width : Integer read GetWidth; 32 | property Height : Integer read GetHeight; 33 | property PixelFormat : TPixelFormat read GetPixelFormat; 34 | end; 35 | 36 | TGraphicsResourceDetailsClass = class of TGraphicsResourceDetails; 37 | 38 | //------------------------------------------------------------------------ 39 | // Bitmap resource details class 40 | 41 | TBitmapResourceDetails = class (TGraphicsResourceDetails) 42 | protected 43 | function GetHeight: Integer; override; 44 | function GetPixelFormat: TPixelFormat; override; 45 | function GetWidth: Integer; override; 46 | procedure InitNew; override; 47 | procedure InternalGetImage (s : TStream; picture : TPicture); 48 | procedure InternalSetImage (s : TStream; image : TPicture); 49 | 50 | public 51 | class function GetBaseType : UnicodeString; override; 52 | procedure GetImage (picture : TPicture); override; 53 | procedure SetImage (image : TPicture); override; 54 | procedure LoadImage (const FileName : string); 55 | end; 56 | 57 | //------------------------------------------------------------------------ 58 | // DIB resource details class 59 | // 60 | // Same as RT_BITMAP resources, but they have a TBitmapFileHeader at the start 61 | // of the resource, before the TBitmapInfoHeader. See 62 | // \program files\Microsoft Office\office\1033\outlibr.dll 63 | 64 | TDIBResourceDetails = class (TBitmapResourceDetails) 65 | protected 66 | class function SupportsData (Size : Integer; data : Pointer) : Boolean; override; 67 | procedure InitNew; override; 68 | public 69 | class function GetBaseType : UnicodeString; override; 70 | procedure GetImage (picture : TPicture); override; 71 | procedure SetImage (image : TPicture); override; 72 | end; 73 | 74 | TIconCursorResourceDetails = class; 75 | 76 | //------------------------------------------------------------------------ 77 | // Icon / Cursor group resource details class 78 | 79 | TIconCursorGroupResourceDetails = class (TResourceDetails) 80 | private 81 | fDeleting : Boolean; 82 | function GetResourceCount: Integer; 83 | function GetResourceDetails(idx: Integer): TIconCursorResourceDetails; 84 | protected 85 | procedure InitNew; override; 86 | public 87 | procedure GetImage (picture : TPicture); 88 | property ResourceCount : Integer read GetResourceCount; 89 | property ResourceDetails [idx : Integer] : TIconCursorResourceDetails read GetResourceDetails; 90 | function Contains (details : TIconCursorResourceDetails) : Boolean; 91 | procedure RemoveFromGroup (details : TIconCursorResourceDetails); 92 | procedure AddToGroup (details : TIconCursorResourceDetails); 93 | procedure LoadImage (const FileName : string); 94 | procedure BeforeDelete; override; 95 | end; 96 | 97 | //------------------------------------------------------------------------ 98 | // Icon group resource details class 99 | 100 | TIconGroupResourceDetails = class (TIconCursorGroupResourceDetails) 101 | public 102 | class function GetBaseType : UnicodeString; override; 103 | end; 104 | 105 | //------------------------------------------------------------------------ 106 | // Cursor group resource details class 107 | 108 | TCursorGroupResourceDetails = class (TIconCursorGroupResourceDetails) 109 | public 110 | class function GetBaseType : UnicodeString; override; 111 | end; 112 | 113 | //------------------------------------------------------------------------ 114 | // Icon / Cursor resource details class 115 | 116 | TIconCursorResourceDetails = class (TGraphicsResourceDetails) 117 | protected 118 | function GetHeight: Integer; override; 119 | function GetPixelFormat: TPixelFormat; override; 120 | function GetWidth: Integer; override; 121 | protected 122 | procedure InitNew; override; 123 | public 124 | procedure BeforeDelete; override; 125 | procedure GetImage (picture : TPicture); override; 126 | procedure SetImage (image : TPicture); override; 127 | property Width : Integer read GetWidth; 128 | property Height : Integer read GetHeight; 129 | property PixelFormat : TPixelFormat read GetPixelFormat; 130 | end; 131 | 132 | //------------------------------------------------------------------------ 133 | // Icon resource details class 134 | 135 | TIconResourceDetails = class (TIconCursorResourceDetails) 136 | public 137 | class function GetBaseType : UnicodeString; override; 138 | end; 139 | 140 | //------------------------------------------------------------------------ 141 | // Cursor resource details class 142 | 143 | TCursorResourceDetails = class (TIconCursorResourceDetails) 144 | protected 145 | public 146 | class function GetBaseType : UnicodeString; override; 147 | end; 148 | 149 | const 150 | DefaultIconCursorWidth : Integer = 32; 151 | DefaultIconCursorHeight : Integer = 32; 152 | DefaultIconCursorPixelFormat : TPixelFormat = pf4Bit; 153 | DefaultCursorHotspot : DWord = $00100010; 154 | 155 | DefaultBitmapWidth : Integer = 128; 156 | DefaultBitmapHeight : Integer = 96; 157 | DefaultBitmapPixelFormat : TPixelFormat = pf24Bit; 158 | 159 | implementation 160 | 161 | type 162 | 163 | TResourceDirectory = packed record 164 | details : packed record case boolean of 165 | False : (cursorWidth, cursorHeight : word); 166 | True : (iconWidth, iconHeight, iconColorCount, iconReserved : BYTE) 167 | end; 168 | wPlanes, wBitCount : word; 169 | lBytesInRes : DWORD; 170 | wNameOrdinal : word 171 | end; 172 | PResourceDirectory = ^TResourceDirectory; 173 | 174 | resourcestring 175 | rstCursors = 'Cursors'; 176 | rstIcons = 'Icons'; 177 | 178 | { TBitmapResourceDetails } 179 | 180 | (*----------------------------------------------------------------------* 181 | | TBitmapResourceDetails.GetBaseType | 182 | *----------------------------------------------------------------------*) 183 | class function TBitmapResourceDetails.GetBaseType: UnicodeString; 184 | begin 185 | result := IntToStr (Integer (RT_BITMAP)); 186 | end; 187 | 188 | (*----------------------------------------------------------------------* 189 | | TBitmapResourceDetails.GetHeight | 190 | *----------------------------------------------------------------------*) 191 | function TBitmapResourceDetails.GetHeight: Integer; 192 | begin 193 | result := PBitmapInfoHeader (RawData.Memory)^.biHeight 194 | end; 195 | 196 | (*----------------------------------------------------------------------* 197 | | TBitmapResourceDetails.GetImage | 198 | *----------------------------------------------------------------------*) 199 | procedure TBitmapResourceDetails.GetImage(picture: TPicture); 200 | var 201 | s : TMemoryStream; 202 | hdr : TBitmapFileHeader; 203 | begin 204 | s := TMemoryStream.Create; 205 | try 206 | hdr.bfType :=$4D42; // TBitmap.LoadFromStream requires a bitmapfileheader 207 | hdr.bfSize := RawData.size; // before the data... 208 | hdr.bfReserved1 := 0; 209 | hdr.bfReserved2 := 0; 210 | hdr.bfOffBits := sizeof (hdr); 211 | 212 | s.Write (hdr, sizeof (hdr)); 213 | RawData.Seek (0, soFromBeginning); 214 | s.CopyFrom (RawData, RawData.size); 215 | 216 | InternalGetImage (s, picture) 217 | finally 218 | s.Free 219 | end 220 | end; 221 | 222 | (*----------------------------------------------------------------------* 223 | | TBitmapResourceDetails.GetPixelFormat | 224 | *----------------------------------------------------------------------*) 225 | function TBitmapResourceDetails.GetPixelFormat: TPixelFormat; 226 | begin 227 | result := GetBitmapInfoPixelFormat (PBitmapInfoHeader (RawData.Memory)^); 228 | end; 229 | 230 | (*----------------------------------------------------------------------* 231 | | TBitmapResourceDetails.GetWidth | 232 | *----------------------------------------------------------------------*) 233 | function TBitmapResourceDetails.GetWidth: Integer; 234 | begin 235 | result := PBitmapInfoHeader (RawData.Memory)^.biWidth 236 | end; 237 | 238 | (*----------------------------------------------------------------------* 239 | | TBitmapResourceDetails.SetImage | 240 | *----------------------------------------------------------------------*) 241 | procedure TBitmapResourceDetails.InitNew; 242 | var 243 | bi : TBitmapInfoHeader; 244 | imageSize : DWORD; 245 | bits : PByte; 246 | begin 247 | bi.biSize := SizeOf (bi); 248 | bi.biWidth := DefaultBitmapWidth; 249 | bi.biHeight := DefaultBitmapHeight; 250 | bi.biPlanes := 1; 251 | bi.biBitCount := GetPixelFormatBitCount (DefaultBitmapPixelFormat); 252 | bi.biCompression := BI_RGB; 253 | 254 | imageSize := BytesPerScanLine (DefaultBitmapWidth, bi.biBitCount, 32) * DefaultBitmapHeight; 255 | bi.biSizeImage := imageSize; 256 | 257 | bi.biXPelsPerMeter := 0; 258 | bi.biYPelsPerMeter := 0; 259 | 260 | bi.biClrUsed := 0; 261 | bi.biClrImportant := 0; 262 | 263 | RawData.Write (bi, SizeOf (bi)); 264 | 265 | bits := AllocMem (ImageSize); 266 | try 267 | RawData.Write (bits^, ImageSize); 268 | finally 269 | ReallocMem (bits, 0) 270 | end 271 | end; 272 | 273 | procedure TBitmapResourceDetails.InternalGetImage(s : TStream; picture: TPicture); 274 | var 275 | pHdr : PBitmapInfoHeader; 276 | pal : HPalette; 277 | colors : DWORD; 278 | hangOnToPalette : Boolean; 279 | newBmp : TBitmap; 280 | begin 281 | s.Seek (0, soFromBeginning); 282 | picture.Bitmap.IgnorePalette := False; 283 | picture.Bitmap.LoadFromStream (s); 284 | 285 | pHdr := PBitmapInfoHeader (RawData.Memory); 286 | 287 | // TBitmap makes all RLE encoded bitmaps into pfDevice 288 | // ... that's not good enough for us! At least 289 | // select the correct pixel format, preserve their carefully set 290 | // up palette, etc. 291 | // 292 | // But revisit this - we probably shouldn't call LoadFromStream 293 | // at all if this is the case... 294 | // 295 | // You can get a couple of RLE bitmaps out of winhlp32.exe 296 | 297 | if PHdr^.biCompression in [BI_RLE4, BI_RLE8] then 298 | begin 299 | hangOnToPalette := False; 300 | if pHdr^.biBitCount in [1, 4, 8] then 301 | begin 302 | pal := picture.Bitmap.Palette; 303 | if pal <> 0 then 304 | begin 305 | colors := 0; 306 | GetObject (pal, SizeOf (colors), @Colors); 307 | 308 | if colors = 1 shl pHdr^.biBitCount then 309 | begin 310 | hangOnToPalette := True; 311 | 312 | newBmp := TBitmap.Create; 313 | try 314 | case pHdr^.biBitCount of 315 | 1 : newBmp.PixelFormat := pf1Bit; 316 | 4 : newBmp.PixelFormat := pf4Bit; 317 | 8 : newBmp.PixelFormat := pf8Bit; 318 | end; 319 | 320 | newBmp.Width := Picture.Bitmap.Width; 321 | newBmp.Height := Picture.Bitmap.Height; 322 | newBmp.Palette := CopyPalette (pal); 323 | newBmp.Canvas.Draw (0, 0, picture.Bitmap); 324 | picture.Bitmap.Assign (newBmp); 325 | finally 326 | newBmp.Free 327 | end 328 | end 329 | end 330 | end; 331 | 332 | if not hangOnToPalette then 333 | case pHdr^.biBitCount of 334 | 1 : picture.Bitmap.PixelFormat := pf1Bit; 335 | 4 : picture.Bitmap.PixelFormat := pf4Bit; 336 | 8 : picture.Bitmap.PixelFormat := pf8Bit; 337 | else 338 | picture.Bitmap.PixelFormat := pf24Bit 339 | end 340 | end 341 | end; 342 | 343 | (*----------------------------------------------------------------------* 344 | | TBitmapResourceDetails.InternalSetImage | 345 | | | 346 | | Save image 'image' to stream 's' as a bitmap | 347 | | | 348 | | Parameters: | 349 | | | 350 | | s : TStream The stream to save to | 351 | | image : TPicture The image to save | 352 | *----------------------------------------------------------------------*) 353 | procedure TBitmapResourceDetails.InternalSetImage(s: TStream; image: TPicture); 354 | var 355 | bmp : TBitmap; 356 | begin 357 | s.Size := 0; 358 | bmp := TBitmap.Create; 359 | try 360 | bmp.Assign (image.graphic); 361 | bmp.SaveToStream (s); 362 | finally 363 | bmp.Free; 364 | end 365 | end; 366 | 367 | (*----------------------------------------------------------------------* 368 | | TBitmapResourceDetails.SetImage | 369 | *----------------------------------------------------------------------*) 370 | procedure TBitmapResourceDetails.LoadImage(const FileName: string); 371 | var 372 | s : TMemoryStream; 373 | begin 374 | s := TMemoryStream.Create; 375 | try 376 | s.LoadFromFile(FileName); 377 | RawData.Clear; 378 | RawData.Write ((PByte (s.Memory) + sizeof (TBitmapFileHeader))^, s.Size - sizeof (TBitmapFileHeader)); 379 | finally 380 | s.Free; 381 | end 382 | end; 383 | 384 | procedure TBitmapResourceDetails.SetImage(image : TPicture); 385 | var 386 | s : TMemoryStream; 387 | begin 388 | s := TMemoryStream.Create; 389 | try 390 | InternalSetImage (s, image); 391 | RawData.Clear; 392 | RawData.Write ((PByte (s.Memory) + sizeof (TBitmapFileHeader))^, s.Size - sizeof (TBitmapFileHeader)); 393 | finally 394 | s.Free; 395 | end 396 | end; 397 | 398 | { TIconGroupResourceDetails } 399 | 400 | (*----------------------------------------------------------------------* 401 | | TIconGroupResourceDetails.GetBaseType | 402 | *----------------------------------------------------------------------*) 403 | class function TIconGroupResourceDetails.GetBaseType: UnicodeString; 404 | begin 405 | result := IntToStr (Integer (RT_GROUP_ICON)); 406 | end; 407 | 408 | { TCursorGroupResourceDetails } 409 | 410 | (*----------------------------------------------------------------------* 411 | | TCursorGroupResourceDetails.GetBaseType | 412 | *----------------------------------------------------------------------*) 413 | class function TCursorGroupResourceDetails.GetBaseType: UnicodeString; 414 | begin 415 | result := IntToStr (Integer (RT_GROUP_CURSOR)); 416 | end; 417 | 418 | { TIconResourceDetails } 419 | 420 | (*----------------------------------------------------------------------* 421 | | TIconResourceDetails.GetBaseType | 422 | *----------------------------------------------------------------------*) 423 | class function TIconResourceDetails.GetBaseType: UnicodeString; 424 | begin 425 | result := IntToStr (Integer (RT_ICON)); 426 | end; 427 | 428 | { TCursorResourceDetails } 429 | 430 | (*----------------------------------------------------------------------* 431 | | TCursorResourceDetails.GetBaseType | 432 | *----------------------------------------------------------------------*) 433 | class function TCursorResourceDetails.GetBaseType: UnicodeString; 434 | begin 435 | result := IntToStr (Integer (RT_CURSOR)); 436 | end; 437 | 438 | { TGraphicsResourceDetails } 439 | 440 | 441 | { TIconCursorResourceDetails } 442 | 443 | (*----------------------------------------------------------------------* 444 | | TIconCursorResourceDetails.GetHeight | 445 | *----------------------------------------------------------------------*) 446 | function TIconCursorResourceDetails.GetHeight: Integer; 447 | var 448 | infoHeader : PBitmapInfoHeader; 449 | begin 450 | if self is TCursorResourceDetails then // Not very 'OOP'. Sorry 451 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory) + sizeof (DWORD)) 452 | else 453 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory)); 454 | 455 | result := infoHeader.biHeight div 2 456 | end; 457 | 458 | (*----------------------------------------------------------------------* 459 | | TIconCursorResourceDetails.GetImage | 460 | *----------------------------------------------------------------------*) 461 | procedure TIconCursorResourceDetails.GetImage(picture: TPicture); 462 | var 463 | iconCursor : TExIconCursor; 464 | strm : TMemoryStream; 465 | hdr : TIconHeader; 466 | dirEntry : TIconDirEntry; 467 | infoHeader : PBitmapInfoHeader; 468 | begin 469 | if RawData.Size = 0 then Exit; 470 | 471 | 472 | strm := Nil; 473 | if self is TCursorResourceDetails then 474 | begin 475 | hdr.wType := 2; 476 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory) + sizeof (DWORD)); 477 | iconCursor := TExCursor.Create 478 | end 479 | else 480 | begin 481 | hdr.wType := 1; 482 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory)); 483 | iconCursor := TExIcon.Create 484 | end; 485 | 486 | try 487 | strm := TMemoryStream.Create; 488 | hdr.wReserved := 0; 489 | hdr.wCount := 1; 490 | 491 | strm.Write (hdr, sizeof (hdr)); 492 | 493 | dirEntry.bWidth := infoHeader^.biWidth; 494 | dirEntry.bHeight := infoHeader^.biHeight div 2; 495 | dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^); 496 | dirEntry.bReserved := 0; 497 | 498 | dirEntry.wPlanes := infoHeader^.biPlanes; 499 | dirEntry.wBitCount := infoHeader^.biBitCount; 500 | 501 | dirEntry.dwBytesInRes := RawData.Size; 502 | dirEntry.dwImageOffset := sizeof (hdr) + sizeof (dirEntry); 503 | 504 | strm.Write (dirEntry, sizeof (dirEntry)); 505 | strm.CopyFrom (RawData, 0); 506 | strm.Seek (0, soFromBeginning); 507 | 508 | iconcursor.LoadFromStream (strm); 509 | picture.Graphic := iconcursor 510 | finally 511 | strm.Free; 512 | iconcursor.Free 513 | end 514 | end; 515 | 516 | (*----------------------------------------------------------------------* 517 | | TIconCursorResourceDetails.SetImage | 518 | *----------------------------------------------------------------------*) 519 | procedure TIconCursorResourceDetails.SetImage(image: TPicture); 520 | var 521 | icon : TExIconCursor; 522 | begin 523 | icon := TExIconCursor (image.graphic); 524 | RawData.Clear; 525 | RawData.CopyFrom (icon.Images [icon.CurrentImage].MemoryImage, 0); 526 | end; 527 | 528 | 529 | (*----------------------------------------------------------------------* 530 | | TIconCursorResourceDetails.GetPixelFormat | 531 | *----------------------------------------------------------------------*) 532 | function TIconCursorResourceDetails.GetPixelFormat: TPixelFormat; 533 | var 534 | infoHeader : PBitmapInfoHeader; 535 | begin 536 | if self is TCursorResourceDetails then 537 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory) + sizeof (DWORD)) 538 | else 539 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory)); 540 | 541 | result := GetBitmapInfoPixelFormat (infoHeader^); 542 | end; 543 | 544 | (*----------------------------------------------------------------------* 545 | | TIconCursorResourceDetails.GetWidth | 546 | *----------------------------------------------------------------------*) 547 | function TIconCursorResourceDetails.GetWidth: Integer; 548 | var 549 | infoHeader : PBitmapInfoHeader; 550 | begin 551 | if self is TCursorResourceDetails then 552 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory) + sizeof (DWORD)) 553 | else 554 | infoHeader := PBitmapInfoHeader (PByte (RawData.Memory)); 555 | 556 | result := infoHeader.biWidth 557 | end; 558 | 559 | { TIconCursorGroupResourceDetails } 560 | 561 | (*----------------------------------------------------------------------* 562 | | TIconCursorGroupResourceDetails.BeforeDelete 563 | | | 564 | *----------------------------------------------------------------------*) 565 | procedure TIconCursorGroupResourceDetails.AddToGroup( 566 | details: TIconCursorResourceDetails); 567 | var 568 | attributes : PResourceDirectory; 569 | infoHeader : PBitmapInfoHeader; 570 | cc : Integer; 571 | begin 572 | RawData.Size := RawData.Size + sizeof (TResourceDirectory); 573 | attributes := PResourceDirectory (PByte (RawData.Memory) + sizeof (TIconHeader)); 574 | 575 | Inc (Attributes, PIconHeader (RawData.Memory)^.wCount); 576 | 577 | attributes^.wNameOrdinal := StrToInt (details.ResourceName); 578 | attributes^.lBytesInRes := details.RawData.Size; 579 | 580 | if details is TIconResourceDetails then 581 | begin 582 | infoHeader := PBitmapInfoHeader (PByte (details.RawData.Memory)); 583 | attributes^.details.iconWidth := infoHeader^.biWidth; 584 | attributes^.details.iconHeight := infoHeader^.biHeight div 2; 585 | cc := GetBitmapInfoNumColors (infoHeader^); 586 | if cc < 256 then 587 | attributes^.details.iconColorCount := cc 588 | else 589 | attributes^.details.iconColorCount := 0; 590 | attributes^.details.iconReserved := 0 591 | end 592 | else 593 | begin 594 | infoHeader := PBitmapInfoHeader (PByte (details.RawData.Memory) + sizeof (DWORD)); 595 | attributes^.details.cursorWidth := infoHeader^.biWidth; 596 | attributes^.details.cursorHeight := infoHeader^.biHeight div 2 597 | end; 598 | 599 | attributes^.wPlanes := infoHeader^.biPlanes; 600 | attributes^.wBitCount := infoHeader^.biBitCount; 601 | 602 | Inc (PIconHeader (RawData.Memory)^.wCount); 603 | end; 604 | 605 | procedure TIconCursorGroupResourceDetails.BeforeDelete; 606 | begin 607 | fDeleting := True; 608 | try 609 | while ResourceCount > 0 do 610 | Parent.DeleteResource (Parent.IndexOfResource (ResourceDetails [0])); 611 | finally 612 | fDeleting := False 613 | end 614 | end; 615 | 616 | (*----------------------------------------------------------------------* 617 | | TIconCursorGroupResourceDetails.Contains | 618 | *----------------------------------------------------------------------*) 619 | function TIconCursorGroupResourceDetails.Contains( 620 | details: TIconCursorResourceDetails): Boolean; 621 | var 622 | i, id : Integer; 623 | attributes : PResourceDirectory; 624 | begin 625 | Result := False; 626 | if ResourceNameToInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then 627 | begin 628 | attributes := PResourceDirectory (PByte (RawData.Memory) + sizeof (TIconHeader)); 629 | id := ResourceNameToInt (details.ResourceName); 630 | 631 | for i := 0 to PIconHeader (RawData.Memory)^.wCount - 1 do 632 | if attributes^.wNameOrdinal = id then 633 | begin 634 | Result := True; 635 | break 636 | end 637 | else 638 | Inc (attributes) 639 | end 640 | end; 641 | 642 | (*----------------------------------------------------------------------* 643 | | TIconCursorGroupResourceDetails.GetImage | 644 | *----------------------------------------------------------------------*) 645 | procedure TIconCursorGroupResourceDetails.GetImage(picture: TPicture); 646 | var 647 | i, hdrOffset, imgOffset : Integer; 648 | iconCursor : TExIconCursor; 649 | strm : TMemoryStream; 650 | hdr : TIconHeader; 651 | dirEntry : TIconDirEntry; 652 | pdirEntry : PIconDirEntry; 653 | infoHeader : PBitmapInfoHeader; 654 | begin 655 | if RawData.Size = 0 then Exit; 656 | 657 | strm := Nil; 658 | if self is TCursorGroupResourceDetails then 659 | begin 660 | hdr.wType := 2; 661 | hdrOffset := SizeOf (DWORD); 662 | iconCursor := TExCursor.Create 663 | end 664 | else 665 | begin 666 | hdr.wType := 1; 667 | hdrOffset := 0; 668 | iconCursor := TExIcon.Create 669 | end; 670 | 671 | try 672 | strm := TMemoryStream.Create; 673 | hdr.wReserved := 0; 674 | hdr.wCount := ResourceCount; 675 | 676 | strm.Write (hdr, sizeof (hdr)); 677 | 678 | for i := 0 to ResourceCount - 1 do 679 | begin 680 | infoHeader := PBitmapInfoHeader (PByte (ResourceDetails [i].RawData.Memory) + hdrOffset); 681 | dirEntry.bWidth := infoHeader^.biWidth; 682 | dirEntry.bHeight := infoHeader^.biHeight div 2; 683 | dirEntry.wPlanes := infoHeader^.biPlanes; 684 | dirEntry.bColorCount := GetBitmapInfoNumColors (infoHeader^); 685 | dirEntry.bReserved := 0; 686 | dirEntry.wBitCount := infoHeader^.biBitCount; 687 | dirEntry.dwBytesInRes := resourceDetails [i].RawData.Size; 688 | dirEntry.dwImageOffset := 0; 689 | 690 | strm.Write (dirEntry, sizeof (dirEntry)); 691 | end; 692 | 693 | for i := 0 to ResourceCount - 1 do 694 | begin 695 | imgOffset := strm.Position; 696 | pDirEntry := PIconDirEntry (PByte (strm.Memory) + SizeOf (TIconHeader) + i * SizeOf (TIconDirEntry)); 697 | pDirEntry^.dwImageOffset := imgOffset; 698 | 699 | strm.CopyFrom (ResourceDetails [i].RawData, 0); 700 | end; 701 | 702 | if ResourceCount > 0 then 703 | begin 704 | strm.Seek (0, soFromBeginning); 705 | iconcursor.LoadFromStream (strm); 706 | picture.Graphic := iconcursor 707 | end 708 | else 709 | picture.Graphic := Nil 710 | finally 711 | strm.Free; 712 | iconcursor.Free 713 | end 714 | end; 715 | 716 | (*----------------------------------------------------------------------* 717 | | TIconCursorGroupResourceDetails.GetResourceCount | 718 | *----------------------------------------------------------------------*) 719 | function TIconCursorGroupResourceDetails.GetResourceCount: Integer; 720 | begin 721 | result := PIconHeader (RawData.Memory)^.wCount 722 | end; 723 | 724 | (*----------------------------------------------------------------------* 725 | | TIconCursorGroupResourceDetails.GetResourceDetails | 726 | *----------------------------------------------------------------------*) 727 | function TIconCursorGroupResourceDetails.GetResourceDetails( 728 | idx: Integer): TIconCursorResourceDetails; 729 | var 730 | i : Integer; 731 | res : TResourceDetails; 732 | attributes : PResourceDirectory; 733 | iconCursorResourceType : UnicodeString; 734 | begin 735 | result := Nil; 736 | attributes := PResourceDirectory (PByte (RawData.Memory) + sizeof (TIconHeader)); 737 | Inc (attributes, idx); 738 | 739 | // DIFFERENCE (from Windows.pas) is 11. It's the difference between a 'group 740 | // resource' and the resource itself. They called it 'DIFFERENCE' to be annoying. 741 | 742 | iconCursorResourceType := IntToStr (ResourceNameToInt (ResourceType) - DIFFERENCE); 743 | for i := 0 to Parent.ResourceCount - 1 do 744 | begin 745 | res := Parent.ResourceDetails [i]; 746 | if (res is TIconCursorResourceDetails) and (iconCursorResourceType = res.ResourceType) and (attributes.wNameOrdinal = ResourceNameToInt (res.ResourceName)) then 747 | begin 748 | result := TIconCursorResourceDetails (res); 749 | break 750 | end 751 | end 752 | end; 753 | 754 | (*----------------------------------------------------------------------* 755 | | TIconCursorGroupResourceDetails.InitNew | 756 | *----------------------------------------------------------------------*) 757 | procedure TIconCursorGroupResourceDetails.InitNew; 758 | var 759 | imageResource : TIconCursorResourceDetails; 760 | iconHeader : TIconHeader; 761 | dir : TResourceDirectory; 762 | nm : UnicodeString; 763 | 764 | begin 765 | iconHeader.wCount := 1; 766 | iconHeader.wReserved := 0; 767 | 768 | if Self is TCursorGroupResourceDetails then 769 | begin 770 | iconHeader.wType := 2; 771 | nm := Parent.GetUniqueResourceName (TCursorResourceDetails.GetBaseType); 772 | imageResource := TCursorResourceDetails.CreateNew (Parent, ResourceLanguage, nm) 773 | end 774 | else 775 | begin 776 | iconHeader.wType := 1; 777 | nm := Parent.GetUniqueResourceName (TIconResourceDetails.GetBaseType); 778 | imageResource := TIconResourceDetails.CreateNew (Parent, ResourceLanguage, nm) 779 | end; 780 | 781 | RawData.Write (iconHeader, SizeOf (iconHeader)); 782 | 783 | if Self is TIconGroupResourceDetails then 784 | begin 785 | dir.details.iconWidth := DefaultIconCursorWidth; 786 | dir.details.iconHeight := DefaultIconCursorHeight; 787 | dir.details.iconColorCount := GetPixelFormatNumColors (DefaultIconCursorPixelFormat); 788 | dir.details.iconReserved := 0 789 | end 790 | else 791 | begin 792 | dir.details.cursorWidth := DefaultIconCursorWidth; 793 | dir.details.cursorHeight := DefaultIconCursorHeight 794 | end; 795 | 796 | dir.wPlanes := 1; 797 | dir.wBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat); 798 | dir.lBytesInRes := imageResource.RawData.Size; 799 | dir.wNameOrdinal := ResourceNametoInt (imageResource.ResourceName); 800 | 801 | RawData.Write (dir, SizeOf (dir)); 802 | end; 803 | 804 | (*----------------------------------------------------------------------* 805 | | TIconCursorResourceDetails.BeforeDelete | 806 | | | 807 | | If we're deleting an icon/curor resource, remove its reference from | 808 | | the icon/cursor group resource. | 809 | *----------------------------------------------------------------------*) 810 | procedure TIconCursorResourceDetails.BeforeDelete; 811 | var 812 | i : Integer; 813 | details : TResourceDetails; 814 | resGroup : TIconCursorGroupResourceDetails; 815 | begin 816 | for i := 0 to Parent.ResourceCount - 1 do 817 | begin 818 | details := Parent.ResourceDetails [i]; 819 | if (details.ResourceType = IntToStr (ResourceNameToInt (ResourceType) + DIFFERENCE)) then 820 | begin 821 | resGroup := details as TIconCursorGroupResourceDetails; 822 | if resGroup.Contains (Self) then 823 | begin 824 | resGroup.RemoveFromGroup (Self); 825 | break 826 | end 827 | end 828 | end 829 | end; 830 | 831 | procedure TIconCursorGroupResourceDetails.LoadImage( 832 | const FileName: string); 833 | var 834 | img : TExIconCursor; 835 | hdr : TIconHeader; 836 | i : Integer; 837 | dirEntry : TResourceDirectory; 838 | res : TIconCursorResourceDetails; 839 | resTp : UnicodeString; 840 | begin 841 | BeforeDelete; // Make source there are no existing image resources 842 | 843 | if Self is TIconGroupResourceDetails then 844 | begin 845 | hdr.wType := 1; 846 | img := TExIcon.Create; 847 | resTp := TIconResourceDetails.GetBaseType; 848 | end 849 | else 850 | begin 851 | hdr.wType := 2; 852 | img := TExCursor.Create; 853 | resTp := TCursorResourceDetails.GetBaseType; 854 | end; 855 | 856 | img.LoadFromFile (FileName); 857 | 858 | hdr.wReserved := 0; 859 | hdr.wCount := img.ImageCount; 860 | 861 | RawData.Clear; 862 | 863 | RawData.Write (hdr, SizeOf (hdr)); 864 | 865 | for i := 0 to img.ImageCount - 1 do 866 | begin 867 | if hdr.wType = 1 then 868 | begin 869 | dirEntry.details.iconWidth := img.Images [i].FWidth; 870 | dirEntry.details.iconHeight := img.Images [i].FHeight; 871 | dirEntry.details.iconColorCount := GetPixelFormatNumColors (img.Images [i].FPixelFormat); 872 | dirEntry.details.iconReserved := 0 873 | end 874 | else 875 | begin 876 | dirEntry.details.cursorWidth := img.Images [i].FWidth; 877 | dirEntry.details.cursorHeight := img.Images [i].FHeight; 878 | end; 879 | 880 | dirEntry.wPlanes := 1; 881 | dirEntry.wBitCount := GetPixelFormatBitCount (img.Images [i].FPixelFormat); 882 | 883 | dirEntry.lBytesInRes := img.Images [i].FMemoryImage.Size; 884 | 885 | if hdr.wType = 1 then 886 | res := TIconResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory) 887 | else 888 | res := TCursorResourceDetails.Create (Parent, ResourceLanguage, Parent.GetUniqueResourceName (resTp), resTp, img.Images [i].FMemoryImage.Size, img.Images [i].FMemoryImage.Memory); 889 | Parent.AddResource (res); 890 | dirEntry.wNameOrdinal := ResourceNameToInt (res.ResourceName); 891 | 892 | RawData.Write (dirEntry, SizeOf (dirEntry)); 893 | end 894 | end; 895 | 896 | (*----------------------------------------------------------------------* 897 | | TIconCursorGroupResourceDetails.RemoveFromGroup | 898 | *----------------------------------------------------------------------*) 899 | procedure TIconCursorGroupResourceDetails.RemoveFromGroup( 900 | details: TIconCursorResourceDetails); 901 | var 902 | i, id, count : Integer; 903 | attributes, ap : PResourceDirectory; 904 | begin 905 | if ResourceNametoInt (details.ResourceType) = ResourceNameToInt (ResourceType) - DIFFERENCE then 906 | begin 907 | attributes := PResourceDirectory (PByte (RawData.Memory) + sizeof (TIconHeader)); 908 | id := ResourceNametoInt (details.ResourceName); 909 | 910 | Count := PIconHeader (RawData.Memory)^.wCount; 911 | 912 | for i := 0 to Count - 1 do 913 | if attributes^.wNameOrdinal = id then 914 | begin 915 | if i < Count - 1 then 916 | begin 917 | ap := Attributes; 918 | Inc (ap); 919 | Move (ap^, Attributes^, SizeOf (TResourceDirectory) * (Count - i - 1)); 920 | end; 921 | 922 | RawData.Size := RawData.Size - SizeOf (TResourceDirectory); 923 | PIconHeader (RawData.Memory)^.wCount := Count - 1; 924 | if (Count = 1) and not fDeleting then 925 | Parent.DeleteResource (Parent.IndexOfResource (Self)); 926 | break 927 | end 928 | else 929 | Inc (attributes) 930 | end 931 | end; 932 | 933 | (*----------------------------------------------------------------------* 934 | | TIconCursorResourceDetails.InitNew | 935 | *----------------------------------------------------------------------*) 936 | procedure TIconCursorResourceDetails.InitNew; 937 | var 938 | hdr : TBitmapInfoHeader; 939 | cImageSize : DWORD; 940 | pal : HPALETTE; 941 | entries : PPALETTEENTRY; 942 | w : DWORD; 943 | p : PByte; 944 | 945 | begin 946 | if Self is TCursorResourceDetails then 947 | RawData.Write (DefaultCursorHotspot, SizeOf (DefaultCursorHotspot)); 948 | 949 | hdr.biSize := SizeOf (hdr); 950 | hdr.biWidth := DefaultIconCursorWidth; 951 | hdr.biHeight := DefaultIconCursorHeight * 2; 952 | hdr.biPlanes := 1; 953 | hdr.biBitCount := GetPixelFormatBitCount (DefaultIconCursorPixelFormat); 954 | 955 | if DefaultIconCursorPixelFormat = pf16Bit then 956 | hdr.biCompression := BI_BITFIELDS 957 | else 958 | hdr.biCompression := BI_RGB; 959 | 960 | hdr.biSizeImage := 0; // See note in unitExIcon 961 | 962 | hdr.biXPelsPerMeter := 0; 963 | hdr.biYPelsPerMeter := 0; 964 | 965 | hdr.biClrUsed := GetPixelFormatNumColors (DefaultIconCursorPixelFormat); 966 | hdr.biClrImportant := hdr.biClrUsed; 967 | 968 | RawData.Write (hdr, SizeOf (hdr)); 969 | 970 | pal := 0; 971 | case DefaultIconCursorPixelFormat of 972 | pf1Bit : pal := SystemPalette2; 973 | pf4Bit : pal := SystemPalette16; 974 | pf8Bit : pal := SystemPalette256 975 | end; 976 | 977 | entries := Nil; 978 | try 979 | if pal > 0 then 980 | begin 981 | GetMem (entries, hdr.biClrUsed * sizeof (PALETTEENTRY)); 982 | GetPaletteEntries (pal, 0, hdr.biClrUsed, entries^); 983 | 984 | RawData.Write (entries^, hdr.biClrUsed * SizeOf (PALETTEENTRY)) 985 | end 986 | else 987 | if hdr.biCompression = BI_BITFIELDS then 988 | begin { 5,6,5 bitfield } 989 | w := $0f800; // 1111 1000 0000 0000 5 bit R mask 990 | RawData.Write (w, SizeOf (w)); 991 | w := $07e0; // 0000 0111 1110 0000 6 bit G mask 992 | RawData.Write (w, SizeOf (w)); 993 | w := $001f; // 0000 0000 0001 1111 5 bit B mask 994 | RawData.Write (w, SizeOf (w)) 995 | end 996 | 997 | finally 998 | ReallocMem (entries, 0) 999 | end; 1000 | 1001 | // Write dummy image 1002 | cImageSize := BytesPerScanLine (hdr.biWidth, hdr.biBitCount, 32) * DefaultIconCursorHeight; 1003 | p := AllocMem (cImageSize); 1004 | try 1005 | RawData.Write (p^, cImageSize); 1006 | finally 1007 | ReallocMem (p, 0) 1008 | end; 1009 | 1010 | // Write dummy mask 1011 | cImageSize := DefaultIconCursorHeight * DefaultIconCursorWidth div 8; 1012 | 1013 | GetMem (p, cImageSize); 1014 | FillChar (p^, cImageSize, $ff); 1015 | 1016 | try 1017 | RawData.Write (p^, cImageSize); 1018 | finally 1019 | ReallocMem (p, 0) 1020 | end; 1021 | end; 1022 | 1023 | { TDIBResourceDetails } 1024 | 1025 | class function TDIBResourceDetails.GetBaseType: UnicodeString; 1026 | begin 1027 | Result := 'DIB'; 1028 | end; 1029 | 1030 | procedure TDIBResourceDetails.GetImage(picture: TPicture); 1031 | begin 1032 | InternalGetImage (RawData, Picture); 1033 | end; 1034 | 1035 | procedure TDIBResourceDetails.InitNew; 1036 | var 1037 | hdr : TBitmapFileHeader; 1038 | begin 1039 | hdr.bfType := $4d42; 1040 | hdr.bfSize := SizeOf (TBitmapFileHeader) + SizeOf (TBitmapInfoHeader); 1041 | hdr.bfReserved1 := 0; 1042 | hdr.bfReserved2 := 0; 1043 | hdr.bfOffBits := hdr.bfSize; 1044 | RawData.Write (hdr, SizeOf (hdr)); 1045 | 1046 | inherited; 1047 | end; 1048 | 1049 | procedure TDIBResourceDetails.SetImage(image: TPicture); 1050 | begin 1051 | InternalSetImage (RawData, image); 1052 | end; 1053 | 1054 | class function TDIBResourceDetails.SupportsData(Size: Integer; 1055 | Data: Pointer): Boolean; 1056 | var 1057 | p : PBitmapFileHeader; 1058 | hdrSize : DWORD; 1059 | begin 1060 | Result := False; 1061 | p := PBitmapFileHeader (Data); 1062 | if (p^.bfType = $4d42) and (p^.bfReserved1 = 0) and (p^.bfReserved2 = 0) then 1063 | begin 1064 | hdrSize := PDWORD (PByte (Data) + SizeOf (TBitmapFileHeader))^; 1065 | 1066 | case hdrSize of 1067 | SizeOf (TBitmapInfoHeader) : Result := True; 1068 | SizeOf (TBitmapV4Header) : Result := True; 1069 | SizeOf (TBitmapV5Header) : Result := True 1070 | end 1071 | end 1072 | end; 1073 | 1074 | { TGraphicsResourceDetails } 1075 | 1076 | procedure TGraphicsResourceDetails.SetImage(image: TPicture); 1077 | begin 1078 | RawData.Clear; 1079 | image.Graphic.SaveToStream (RawData); 1080 | end; 1081 | 1082 | initialization 1083 | TPicture.RegisterFileFormat ('ICO', rstIcons, TExIcon); 1084 | TPicture.RegisterFileFormat ('CUR', rstCursors, TExCursor); 1085 | TPicture.UnregisterGraphicClass (TIcon); 1086 | 1087 | RegisterResourceDetails (TBitmapResourceDetails); 1088 | RegisterResourceDetails (TDIBResourceDetails); 1089 | RegisterResourceDetails (TIconGroupResourceDetails); 1090 | RegisterResourceDetails (TCursorGroupResourceDetails); 1091 | RegisterResourceDetails (TIconResourceDetails); 1092 | RegisterResourceDetails (TCursorResourceDetails); 1093 | finalization 1094 | TPicture.UnregisterGraphicClass (TExIcon); 1095 | TPicture.UnregisterGraphicClass (TExCursor); 1096 | TPicture.RegisterFileFormat ('ICO', 'Icon', TIcon); 1097 | UnregisterResourceDetails (TCursorResourceDetails); 1098 | UnregisterResourceDetails (TIconResourceDetails); 1099 | UnregisterResourceDetails (TCursorGroupResourceDetails); 1100 | UnregisterResourceDetails (TIconGroupResourceDetails); 1101 | UnregisterResourceDetails (TDIBResourceDetails); 1102 | UnregisterResourceDetails (TBitmapResourceDetails); 1103 | end. 1104 | -------------------------------------------------------------------------------- /Others/ColinWilson/unitResourceToolbar.pas: -------------------------------------------------------------------------------- 1 | (*======================================================================* 2 | | unitResourceToolbar | 3 | | | 4 | | Encapsulates Toolbar resources in resources | 5 | | | 6 | | Copyright (c) Colin Wilson 2001,2008 | 7 | | | 8 | | All rights reserved | 9 | | | 10 | | Version Date By Description | 11 | | ------- ---------- ---- ------------------------------------------| 12 | | 1.0 06/02/2001 CPWW Original | 13 | | 16/5/2008 CPWW Tiburon version | 14 | *======================================================================*) 15 | unit unitResourceToolbar; 16 | 17 | interface 18 | 19 | uses Windows, Classes, SysUtils, Contnrs, unitResourceDetails, Menus; 20 | 21 | const 22 | RT_TOOLBAR = MakeIntResource (241); 23 | 24 | type 25 | TToolbarResourceDetails = class (TResourceDetails) 26 | private 27 | // fHelpID : Integer; // Extended menu's help ID 28 | protected 29 | constructor Create (AParent : TResourceModule; ALanguage : Integer; const AName, AType : UnicodeString; ASize : Integer; AData : pointer); override; 30 | 31 | public 32 | destructor Destroy; override; 33 | 34 | class function GetBaseType : UnicodeString; override; 35 | procedure ChangeData (newData : TMemoryStream); override; 36 | 37 | procedure InitNew; override; 38 | end; 39 | 40 | implementation 41 | 42 | type 43 | 44 | TToolbarData = packed record // From a CodeGuru message quoting MFC source... 45 | wVersion : word; 46 | wBtnWidth : word; 47 | wBtnHeight : word; 48 | wBtnCount : word; 49 | wButtonIDs : array [0..0] of word; 50 | end; 51 | 52 | { TToolbarResourceDetails } 53 | 54 | procedure TToolbarResourceDetails.ChangeData(newData: TMemoryStream); 55 | begin 56 | inherited; 57 | end; 58 | 59 | constructor TToolbarResourceDetails.Create(AParent: TResourceModule; 60 | ALanguage: Integer; const AName, AType: UnicodeString; ASize: Integer; 61 | AData: pointer); 62 | begin 63 | inherited Create (AParent, ALanguage, AName, AType, ASize, AData); 64 | end; 65 | 66 | destructor TToolbarResourceDetails.Destroy; 67 | begin 68 | inherited; 69 | end; 70 | 71 | class function TToolbarResourceDetails.GetBaseType: UnicodeString; 72 | begin 73 | result := IntToStr (Integer (RT_TOOLBAR)); 74 | end; 75 | 76 | procedure TToolbarResourceDetails.InitNew; 77 | var 78 | dat : TToolbarData; 79 | begin 80 | dat.wVersion := 1; 81 | dat.wBtnWidth := 16; 82 | dat.wBtnHeight := 15; 83 | dat.wBtnCount := 0; 84 | 85 | data.Write(dat, sizeof (dat) - sizeof (dat.wButtonIDs)) 86 | end; 87 | 88 | initialization 89 | RegisterResourceDetails (TToolbarResourceDetails); 90 | finalization 91 | UnregisterResourceDetails (TToolbarResourceDetails); 92 | end. 93 | 94 | 95 | -------------------------------------------------------------------------------- /Others/ColinWilson/unitResourceVersionInfo.pas: -------------------------------------------------------------------------------- 1 | (*======================================================================* 2 | | unitResourceVersionInfo | 3 | | | 4 | | Encapsulates Version Info resources in resources | 5 | | | 6 | | Copyright (c) Colin Wilson 2001,2008 | 7 | | | 8 | | All rights reserved | 9 | | | 10 | | Version Date By Description | 11 | | ------- ---------- ---- ------------------------------------------| 12 | | 1.0 06/02/2001 CPWW Original | 13 | | 16/5/2008 CPWW Tiburon version | 14 | *======================================================================*) 15 | unit unitResourceVersionInfo; 16 | 17 | interface 18 | 19 | uses Windows, Classes, SysUtils, Contnrs, unitResourceDetails; 20 | 21 | type 22 | TFileFlags = (ffDebug, ffInfoInferred, ffPatched, ffPreRelease, ffPrivateBuild, ffSpecialBuild); 23 | TVersionFileFlags = set of TFileFlags; 24 | 25 | TVersionStringValue = class 26 | private 27 | fKeyName : UnicodeString; 28 | fValue : UnicodeString; 29 | fLangId : Integer; 30 | fCodePage : Integer; 31 | 32 | public 33 | constructor Create (const AKeyName, AValue : UnicodeString; ALangId, ACodePage : Integer); 34 | property KeyName : UnicodeString read fKeyName; 35 | property Value : UnicodeString read fValue; 36 | end; 37 | 38 | TVersionInfoResourceDetails = class (TResourceDetails) 39 | private 40 | fChildStrings : TObjectList; 41 | fFixedInfo : PVSFixedFileInfo; 42 | fTranslations : TList; 43 | procedure GetFixedFileInfo; 44 | procedure UpdateData; 45 | procedure ExportToStream (strm : TStream); 46 | 47 | function GetFileFlags: TVersionFileFlags; 48 | function GetFileVersion: TULargeInteger; 49 | function GetKey(idx: Integer): TVersionStringValue; 50 | function GetKeyCount: Integer; 51 | function GetProductVersion: TULargeInteger; 52 | procedure SetFileFlags(const Value: TVersionFileFlags); 53 | procedure SetFileVersion(const Value: TULargeInteger); 54 | procedure SetProductVersion(const Value: TULargeInteger); 55 | protected 56 | constructor Create (AParent : TResourceModule; ALanguage : Integer; const AName, AType : UnicodeString; ASize : Integer; AData : pointer); override; 57 | procedure InitNew; override; 58 | public 59 | constructor CreateNew (AParent : TResourceModule; ALanguage : Integer; const AName : UnicodeString); override; 60 | destructor Destroy; override; 61 | class function GetBaseType : UnicodeString; override; 62 | procedure ChangeData (newData : TMemoryStream); override; 63 | function SetKeyValue (const AKeyName, AValue : UnicodeString) : Integer; 64 | procedure ChangeKey (const AOldKey, ANewKey : UnicodeString); 65 | procedure DeleteKey (idx : Integer); 66 | function IndexOf (const AKeyName : UnicodeString) : Integer; 67 | property ProductVersion : TULargeInteger read GetProductVersion write SetProductVersion; 68 | property FileVersion : TULargeInteger read GetFileVersion write SetFileVersion; 69 | property FileFlags : TVersionFileFlags read GetFileFlags write SetFileFlags; 70 | property KeyCount : Integer read GetKeyCount; 71 | property Key [idx : Integer] : TVersionStringValue read GetKey; 72 | end; 73 | 74 | implementation 75 | 76 | 77 | resourcestring 78 | rstFlagsChanged = 'change flags'; 79 | rstFileVersionChanged = 'change file version'; 80 | rstProductVersionChanged = 'change product version'; 81 | rstVersion = 'Version'; 82 | rstInvalidVersionInfoResource = 'Invalid version info resource'; 83 | rstStringChanged = 'change string'; 84 | rstStringAdded = 'add string'; 85 | rstStringDeleted = 'delete string'; 86 | rstCodePageChanged = 'change code page'; 87 | rstKeyNameChanged = 'change string name'; 88 | 89 | { TVersionInfoResourceDetails } 90 | 91 | procedure TVersionInfoResourceDetails.ChangeData(newData: TMemoryStream); 92 | begin 93 | inherited; 94 | 95 | fFixedInfo := nil; 96 | end; 97 | 98 | procedure TVersionInfoResourceDetails.ChangeKey(const AOldKey, 99 | ANewKey: UnicodeString); 100 | var 101 | idx : Integer; 102 | begin 103 | if AOldKey <> ANewKey then 104 | begin 105 | idx := IndexOf (AOldKey); 106 | if idx > -1 then 107 | begin 108 | Key [idx].fKeyName := ANewKey; 109 | UpdateData 110 | end 111 | else 112 | SetKeyValue (ANewKey, '') 113 | end 114 | end; 115 | 116 | constructor TVersionInfoResourceDetails.Create(AParent: TResourceModule; 117 | ALanguage: Integer; const AName, AType: UnicodeString; ASize: Integer; 118 | AData: pointer); 119 | begin 120 | fChildStrings := TObjectList.Create; 121 | fTranslations := TList.Create; 122 | inherited Create (AParent, ALanguage, AName, AType, ASize, AData); 123 | end; 124 | 125 | constructor TVersionInfoResourceDetails.CreateNew(AParent: TResourceModule; 126 | ALanguage: Integer; const AName: UnicodeString); 127 | begin 128 | fChildStrings := TObjectList.Create; 129 | fTranslations := TList.Create; 130 | inherited; 131 | 132 | end; 133 | 134 | procedure TVersionInfoResourceDetails.DeleteKey(idx: Integer); 135 | begin 136 | fChildStrings.Delete (idx); 137 | UpdateData 138 | end; 139 | 140 | destructor TVersionInfoResourceDetails.Destroy; 141 | begin 142 | fChildStrings.Free; 143 | fTranslations.Free; 144 | inherited; 145 | end; 146 | 147 | procedure TVersionInfoResourceDetails.ExportToStream(strm: TStream); 148 | var 149 | zeros, v : DWORD; 150 | wSize : WORD; 151 | stringInfoStream : TMemoryStream; 152 | strg : TVersionStringValue; 153 | i, p, p1 : Integer; 154 | wValue : WideString; 155 | 156 | procedure PadStream (strm : TStream); 157 | begin 158 | if strm.Position mod 4 <> 0 then 159 | strm.Write (zeros, 4 - (strm.Position mod 4)) 160 | end; 161 | 162 | procedure SaveVersionHeader (strm : TStream; wLength, wValueLength, wType : word; const wKey : UnicodeString; const value); 163 | var 164 | valueLen : word; 165 | keyLen : word; 166 | begin 167 | strm.Write (wLength, sizeof (wLength)); 168 | 169 | strm.Write (wValueLength, sizeof (wValueLength)); 170 | strm.Write (wType, sizeof (wType)); 171 | keyLen := (Length (wKey) + 1) * sizeof (WideChar); 172 | strm.Write (wKey [1], keyLen); 173 | 174 | PadStream (strm); 175 | 176 | if wValueLength > 0 then 177 | begin 178 | valueLen := wValueLength; 179 | if wType = 1 then 180 | valueLen := valueLen * sizeof (WideChar); 181 | strm.Write (value, valueLen) 182 | end; 183 | end; 184 | 185 | begin { ExportToStream } 186 | GetFixedFileInfo; 187 | if fFixedInfo <> Nil then 188 | begin 189 | zeros := 0; 190 | 191 | SaveVersionHeader (strm, 0, sizeof (fFixedInfo^), 0, 'VS_VERSION_INFO', fFixedInfo^); 192 | 193 | if fChildStrings.Count > 0 then 194 | begin 195 | stringInfoStream := TMemoryStream.Create; 196 | try 197 | SaveVersionHeader (stringInfoStream, 0, 0, 0, IntToHex (ResourceLanguage, 4) + IntToHex (CodePage, 4), zeros); 198 | 199 | for i := 0 to fChildStrings.Count - 1 do 200 | begin 201 | PadStream (stringInfoStream); 202 | 203 | p := stringInfoStream.Position; 204 | strg := TVersionStringValue (fChildStrings [i]); 205 | wValue := strg.fValue; 206 | SaveVersionHeader (stringInfoStream, 0, Length (strg.fValue) + 1, 1, strg.KeyName, wValue [1]); 207 | wSize := stringInfoStream.Size - p; 208 | stringInfoStream.Seek (p, soFromBeginning); 209 | stringInfoStream.Write (wSize, sizeof (wSize)); 210 | stringInfoStream.Seek (0, soFromEnd); 211 | 212 | end; 213 | 214 | stringInfoStream.Seek (0, soFromBeginning); 215 | wSize := stringInfoStream.Size; 216 | stringInfoStream.Write (wSize, sizeof (wSize)); 217 | 218 | PadStream (strm); 219 | p := strm.Position; 220 | SaveVersionHeader (strm, 0, 0, 0, 'StringFileInfo', zeros); 221 | strm.Write (stringInfoStream.Memory^, stringInfoStream.size); 222 | wSize := strm.Size - p; 223 | finally 224 | stringInfoStream.Free 225 | end; 226 | strm.Seek (p, soFromBeginning); 227 | strm.Write (wSize, sizeof (wSize)); 228 | strm.Seek (0, soFromEnd) 229 | end; 230 | 231 | if fTranslations.Count > 0 then 232 | begin 233 | PadStream (strm); 234 | p := strm.Position; 235 | SaveVersionHeader (strm, 0, 0, 0, 'VarFileInfo', zeros); 236 | PadStream (strm); 237 | 238 | p1 := strm.Position; 239 | SaveVersionHeader (strm, 0, 0, 0, 'Translation', zeros); 240 | 241 | for i := 0 to fTranslations.Count - 1 do 242 | begin 243 | v := Integer (fTranslations [i]); 244 | strm.Write (v, sizeof (v)) 245 | end; 246 | 247 | wSize := strm.Size - p1; 248 | strm.Seek (p1, soFromBeginning); 249 | strm.Write (wSize, sizeof (wSize)); 250 | wSize := sizeof (Integer) * fTranslations.Count; 251 | strm.Write (wSize, sizeof (wSize)); 252 | 253 | wSize := strm.Size - p; 254 | strm.Seek (p, soFromBeginning); 255 | strm.Write (wSize, sizeof (wSize)); 256 | end; 257 | 258 | strm.Seek (0, soFromBeginning); 259 | wSize := strm.Size; 260 | strm.Write (wSize, sizeof (wSize)); 261 | strm.Seek (0, soFromEnd); 262 | end 263 | else 264 | raise Exception.Create ('Invalid version resource'); 265 | end; 266 | 267 | class function TVersionInfoResourceDetails.GetBaseType: UnicodeString; 268 | begin 269 | result := IntToStr (Integer (RT_VERSION)); 270 | end; 271 | 272 | function TVersionInfoResourceDetails.GetFileFlags: TVersionFileFlags; 273 | var 274 | flags : Integer; 275 | begin 276 | GetFixedFileInfo; 277 | result := []; 278 | flags := fFixedInfo^.dwFileFlags and fFixedInfo^.dwFileFlagsMask; 279 | 280 | if (flags and VS_FF_DEBUG) <> 0 then result := result + [ffDebug]; 281 | if (flags and VS_FF_INFOINFERRED) <> 0 then result := result + [ffInfoInferred]; 282 | if (flags and VS_FF_PATCHED) <> 0 then result := result + [ffPatched]; 283 | if (flags and VS_FF_PRERELEASE) <> 0 then result := result + [ffPreRelease]; 284 | if (flags and VS_FF_PRIVATEBUILD) <> 0 then result := result + [ffPrivateBuild]; 285 | if (flags and VS_FF_SPECIALBUILD) <> 0 then result := result + [ffSpecialBuild]; 286 | end; 287 | 288 | function TVersionInfoResourceDetails.GetFileVersion: TULargeInteger; 289 | begin 290 | GetFixedFileInfo; 291 | result.LowPart := fFixedInfo^.dwFileVersionLS; 292 | result.HighPart := fFixedInfo^.dwFileVersionMS; 293 | end; 294 | 295 | procedure TVersionInfoResourceDetails.GetFixedFileInfo; 296 | var 297 | p : PByte; 298 | t, wLength, wValueLength, wType : word; 299 | key : UnicodeString; 300 | 301 | varwLength, varwValueLength, varwType : word; 302 | varKey : UnicodeString; 303 | 304 | function GetVersionHeader (var p : PByte; var wLength, wValueLength, wType : word; var wKey : UnicodeString) : Integer; 305 | var 306 | baseP : PByte; 307 | szKey : PWideChar; 308 | begin 309 | baseP := p; 310 | wLength := PWord (p)^; 311 | Inc (p, sizeof (word)); 312 | wValueLength := PWord (p)^; 313 | Inc (p, sizeof (word)); 314 | wType := PWord (p)^; 315 | Inc (p, sizeof (word)); 316 | szKey := PWideChar (p); 317 | Inc (p, (lstrlenw (szKey) + 1) * sizeof (WideChar)); 318 | while Integer (p) mod 4 <> 0 do 319 | Inc (p); 320 | result := p - baseP; 321 | wKey := szKey; 322 | end; 323 | 324 | procedure GetStringChildren (var base : PByte; len : word); 325 | var 326 | p, strBase : PByte; 327 | t, wLength, wValueLength, wType, wStrLength, wStrValueLength, wStrType : word; 328 | key, value : UnicodeString; 329 | langID, codePage : Integer; 330 | 331 | begin 332 | p := base; 333 | while (p - base) < len do 334 | begin 335 | t := GetVersionHeader (p, wLength, wValueLength, wType, key); 336 | Dec (wLength, t); 337 | 338 | langID := StrToInt ('$' + Copy (key, 1, 4)); 339 | codePage := StrToInt ('$' + Copy (key, 5, 4)); 340 | 341 | strBase := p; 342 | fChildStrings.Clear; 343 | fTranslations.Clear; 344 | 345 | while (p - strBase) < wLength do 346 | begin 347 | t := GetVersionHeader (p, wStrLength, wStrValueLength, wStrType, key); 348 | Dec (wStrLength, t); 349 | 350 | if wStrValueLength = 0 then 351 | value := '' 352 | else 353 | value := PWideChar (p); 354 | Inc (p, wStrLength); 355 | while Integer (p) mod 4 <> 0 do 356 | Inc (p); 357 | 358 | if codePage = 0 then 359 | codePage := self.codePage; 360 | fChildStrings.Add (TVersionStringValue.Create (key, Value, langID, codePage)); 361 | end 362 | end; 363 | base := p 364 | end; 365 | 366 | procedure GetVarChildren (var base : PByte; len : word); 367 | var 368 | p, strBase : PByte; 369 | t, wLength, wValueLength, wType: word; 370 | key : UnicodeString; 371 | v : DWORD; 372 | begin 373 | p := base; 374 | while (p - base) < len do 375 | begin 376 | t := GetVersionHeader (p, wLength, wValueLength, wType, key); 377 | Dec (wLength, t); 378 | 379 | strBase := p; 380 | fTranslations.Clear; 381 | 382 | while (p - strBase) < wLength do 383 | begin 384 | v := PDWORD (p)^; 385 | Inc (p, sizeof (DWORD)); 386 | fTranslations.Add (pointer (v)); 387 | end 388 | end; 389 | base := p 390 | end; 391 | 392 | begin 393 | if fFixedInfo <> nil then Exit; 394 | 395 | fChildStrings.Clear; 396 | fTranslations.Clear; 397 | p := data.memory; 398 | GetVersionHeader (p, wLength, wValueLength, wType, key); 399 | 400 | if wValueLength <> 0 then 401 | begin 402 | fFixedInfo := PVSFixedFileInfo (p); 403 | if fFixedInfo^.dwSignature <> $feef04bd then 404 | raise Exception.Create (rstInvalidVersionInfoResource); 405 | 406 | Inc (p, wValueLength); 407 | while Integer (p) mod 4 <> 0 do 408 | Inc (p); 409 | end 410 | else 411 | fFixedInfo := Nil; 412 | 413 | while wLength > (Integer (p) - Integer (data.memory)) do 414 | begin 415 | t := GetVersionHeader (p, varwLength, varwValueLength, varwType, varKey); 416 | Dec (varwLength, t); 417 | 418 | if varKey = 'StringFileInfo' then 419 | GetStringChildren (p, varwLength) 420 | else 421 | if varKey = 'VarFileInfo' then 422 | GetVarChildren (p, varwLength) 423 | else 424 | break; 425 | end 426 | end; 427 | 428 | function TVersionInfoResourceDetails.GetKey( 429 | idx: Integer): TVersionStringValue; 430 | begin 431 | GetFixedFileInfo; 432 | result := TVersionStringValue (fChildStrings [idx]) 433 | end; 434 | 435 | function TVersionInfoResourceDetails.GetKeyCount: Integer; 436 | begin 437 | GetFixedFileInfo; 438 | result := fChildStrings.Count 439 | end; 440 | 441 | function TVersionInfoResourceDetails.GetProductVersion: TULargeInteger; 442 | begin 443 | GetFixedFileInfo; 444 | result.LowPart := fFixedInfo^.dwProductVersionLS; 445 | result.HighPart := fFixedInfo^.dwProductVersionMS 446 | end; 447 | 448 | function TVersionInfoResourceDetails.IndexOf( 449 | const AKeyName: UnicodeString): Integer; 450 | var 451 | i : Integer; 452 | k : TVersionStringValue; 453 | begin 454 | result := -1; 455 | for i := 0 to KeyCount - 1 do 456 | begin 457 | k := Key [i]; 458 | if CompareText (k.KeyName, AKeyName) = 0 then 459 | begin 460 | result := i; 461 | break 462 | end 463 | end 464 | end; 465 | 466 | procedure TVersionInfoResourceDetails.InitNew; 467 | var 468 | w, l : word; 469 | fixedInfo : TVSFixedFileInfo; 470 | ws : UnicodeString; 471 | begin 472 | l := 0; 473 | 474 | w := 0; 475 | Data.Write(w, sizeof (w)); 476 | 477 | w := sizeof (fixedInfo); 478 | Data.Write (w, sizeof (w)); 479 | 480 | w := 0; 481 | Data.Write (w, sizeof (w)); 482 | 483 | ws := 'VS_VERSION_INFO'; 484 | Data.Write(ws [1], (Length (ws) + 1) * sizeof (WideChar)); 485 | 486 | w := 0; 487 | while Data.Size mod sizeof (DWORD) <> 0 do 488 | Data.Write (w, sizeof (w)); 489 | 490 | ZeroMemory (@fixedInfo, sizeof (fixedInfo)); 491 | fixedInfo.dwSignature := $FEEF04BD; 492 | fixedInfo.dwStrucVersion := $00010000; 493 | fixedInfo.dwFileVersionMS := $00010000; 494 | fixedInfo.dwFileVersionLS := $00000000; 495 | fixedInfo.dwProductVersionMS := $00010000; 496 | fixedInfo.dwProductVersionLS := $00000000; 497 | fixedInfo.dwFileFlagsMask := $3f; 498 | fixedInfo.dwFileFlags := 0; 499 | fixedInfo.dwFileOS := 4; 500 | fixedInfo.dwFileType := VFT_UNKNOWN; 501 | fixedInfo.dwFileSubtype := VFT2_UNKNOWN; 502 | fixedInfo.dwFileDateMS := 0; 503 | fixedInfo.dwFileDateLS := 0; 504 | 505 | Data.Write(fixedInfo, sizeof (fixedInfo)); 506 | 507 | w := 0; 508 | while Data.Size mod sizeof (DWORD) <> 0 do 509 | Data.Write (w, sizeof (w)); 510 | 511 | l := Data.Size; 512 | Data.Seek(0, soFromBeginning); 513 | 514 | Data.Write(l, sizeof (l)) 515 | end; 516 | 517 | procedure TVersionInfoResourceDetails.SetFileFlags( 518 | const Value: TVersionFileFlags); 519 | var 520 | flags : DWORD; 521 | begin 522 | GetFixedFileInfo; 523 | 524 | flags := 0; 525 | if ffDebug in value then flags := flags or VS_FF_DEBUG; 526 | if ffInfoInferred in value then flags := flags or VS_FF_INFOINFERRED; 527 | if ffPatched in value then flags := flags or VS_FF_PATCHED; 528 | if ffPreRelease in value then flags := flags or VS_FF_PRERELEASE; 529 | if ffPrivateBuild in value then flags := flags or VS_FF_PRIVATEBUILD; 530 | if ffSpecialBuild in value then flags := flags or VS_FF_SPECIALBUILD; 531 | 532 | if (fFixedInfo^.dwFileFlags and fFixedInfo^.dwFileFlagsMask) <> flags then 533 | fFixedInfo^.dwFileFlags := (fFixedInfo^.dwFileFlags and not fFixedInfo^.dwFileFlagsMask) or flags; 534 | end; 535 | 536 | procedure TVersionInfoResourceDetails.SetFileVersion( 537 | const Value: TULargeInteger); 538 | begin 539 | GetFixedFileInfo; 540 | if (value.LowPart <> fFixedInfo^.dwFileVersionLS) or (value.HighPart <> fFixedInfo^.dwFileVersionMS) then 541 | begin 542 | fFixedInfo^.dwFileVersionLS := value.LowPart; 543 | fFixedInfo^.dwFileVersionMS := value.HighPart; 544 | end 545 | end; 546 | 547 | function TVersionInfoResourceDetails.SetKeyValue(const AKeyName, 548 | AValue: UnicodeString): Integer; 549 | var 550 | idx : Integer; 551 | k : TVersionStringValue; 552 | begin 553 | idx := IndexOf (AKeyName); 554 | 555 | if idx = -1 then 556 | begin 557 | if AKeyName <> '' then 558 | idx := fChildStrings.Add (TVersionStringValue.Create (AKeyNAme, AValue, ResourceLanguage, CodePage)) 559 | end 560 | else 561 | begin 562 | k := Key [idx]; 563 | if (AValue <> k.fValue) or (AKeyName <> k.fKeyName) then 564 | begin 565 | k.fKeyName := AKeyName; 566 | k.fValue := AValue; 567 | end 568 | end; 569 | 570 | result := idx; 571 | UpdateData 572 | end; 573 | 574 | procedure TVersionInfoResourceDetails.SetProductVersion( 575 | const Value: TULargeInteger); 576 | begin 577 | GetFixedFileInfo; 578 | if (value.LowPart <> fFixedInfo^.dwProductVersionLS) or (value.HighPart <> fFixedInfo^.dwProductVersionMS) then 579 | begin 580 | fFixedInfo^.dwProductVersionLS := value.LowPart; 581 | ffixedInfo^.dwProductVersionMS := value.HighPart; 582 | end 583 | end; 584 | 585 | procedure TVersionInfoResourceDetails.UpdateData; 586 | var 587 | st : TMemoryStream; 588 | begin 589 | st := TMemoryStream.Create; 590 | try 591 | ExportToStream (st); 592 | st.Seek (0, soFromBeginning); 593 | data.Seek (0, soFromBeginning); 594 | data.size := 0; 595 | data.CopyFrom (st, st.Size); 596 | finally 597 | st.Free 598 | end 599 | end; 600 | 601 | { TVersionStringValue } 602 | 603 | constructor TVersionStringValue.Create(const AKeyName, AValue: UnicodeString; ALangId, ACodePage : Integer); 604 | begin 605 | fKeyName := AKeyName; 606 | fValue := AValue; 607 | fLangId := ALangId; 608 | fCodePage := ACodePage; 609 | end; 610 | 611 | initialization 612 | RegisterResourceDetails (TVersionInfoResourceDetails); 613 | finalization 614 | UnregisterResourceDetails (TVersionInfoResourceDetails); 615 | end. 616 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is a repository for random code demos and examples. -------------------------------------------------------------------------------- /SetVersion/SetVersion.dpr: -------------------------------------------------------------------------------- 1 | program SetVersion; 2 | 3 | {$APPTYPE CONSOLE} 4 | 5 | uses 6 | SysUtils, Windows, 7 | unitEXIcon in '..\Others\ColinWilson\unitEXIcon.pas', 8 | unitPEFile in '..\Others\ColinWilson\unitPEFile.pas', 9 | unitResFile in '..\Others\ColinWilson\unitResFile.pas', 10 | unitResourceDetails in '..\Others\ColinWilson\unitResourceDetails.pas', 11 | unitResourceExaminer in '..\Others\ColinWilson\unitResourceExaminer.pas', 12 | unitResourceGraphics in '..\Others\ColinWilson\unitResourceGraphics.pas', 13 | unitResourceToolbar in '..\Others\ColinWilson\unitResourceToolbar.pas', 14 | unitResourceVersionInfo in '..\Others\ColinWilson\unitResourceVersionInfo.pas'; 15 | 16 | type 17 | TVersionNumber = record 18 | Major, Minor, Release, Build: Integer; 19 | 20 | procedure FromULargeInteger(aULargeInteger: TULargeInteger); 21 | function AsULargeInteger: TULargeInteger; 22 | end; 23 | 24 | TResourceType = (rtRES, rtEXE); 25 | 26 | TResourceFile = record 27 | ResourceType: TResourceType; 28 | FileName: String; 29 | end; 30 | 31 | function GetResourceFile(const s: String): TResourceFile; 32 | begin 33 | Result.FileName := s; 34 | 35 | if SameText(ExtractFileExt(s), '.EXE') and FileExists(s) then 36 | Result.ResourceType := rtEXE 37 | 38 | else if SameText(ExtractFileExt(s), '.RES') and FileExists(s) then 39 | Result.ResourceType := rtRES 40 | 41 | else 42 | begin 43 | Result.FileName := ChangeFileExt(Result.FileName, '.res'); 44 | if FileExists(Result.FileName) then 45 | Result.ResourceType := rtRES 46 | 47 | else 48 | begin 49 | Result.FileName := ChangeFileExt(Result.FileName, '.exe'); 50 | if FileExists(Result.FileName) then 51 | Result.ResourceType := rtRes 52 | 53 | else 54 | raise Exception.CreateFmt('Could not find an EXE or RES file matching that name "%s".', [s]); 55 | end; 56 | end; 57 | end; 58 | 59 | { VersionNumber } 60 | 61 | function TVersionNumber.AsULargeInteger: TULargeInteger; 62 | begin 63 | Result.HighPart := Major shl 16 or Minor; 64 | Result.LowPart := Release shl 16 or Build 65 | end; 66 | 67 | procedure TVersionNumber.FromULargeInteger(aULargeInteger: TULargeInteger); 68 | begin 69 | Major := aULargeInteger.HighPart shr 16; 70 | Minor := aULargeInteger.HighPart and ((1 shl 16) - 1); 71 | Release := aULargeInteger.LowPart shr 16; 72 | Build := aULargeInteger.LowPart and ((1 shl 16) - 1); 73 | end; 74 | 75 | function GetVersionInfoResourceDetails(aResModule: TResourceModule): TVersionInfoResourceDetails; 76 | var 77 | i: Integer; 78 | begin 79 | Result := nil; 80 | 81 | for i := 0 to aResModule.ResourceCount - 1 do 82 | begin 83 | aResModule.ResourceDetails[i]; 84 | if aResModule.ResourceDetails[i] is TVersionInfoResourceDetails then 85 | begin 86 | Result := (aResModule.ResourceDetails[i]) as TVersionInfoResourceDetails; 87 | Break; // I believe there should only ever be one Version resource. 88 | end; 89 | end; 90 | end; 91 | 92 | procedure SetVersionFromString(var aVersionString: String; out aVersionPart: Integer); 93 | var 94 | idx: Integer; 95 | begin 96 | if aVersionString = '' then 97 | aVersionPart := 0 98 | else 99 | begin 100 | idx := Pos('.', aVersionString); 101 | if idx <= 1 then 102 | begin 103 | if not TryStrToInt(aVersionString, aVersionPart) then 104 | aVersionPart := 0; 105 | 106 | aVersionString := ''; 107 | end 108 | else 109 | begin 110 | if not TryStrToInt(Copy(aVersionString, 1, idx-1), aVersionPart) then 111 | raise Exception.CreateFmt('"%s" is not a valid version number', [Copy(aVersionString, 1, idx-1)]); 112 | Delete(aVersionString, 1, idx); 113 | end; 114 | end; 115 | end; 116 | 117 | procedure HandleVersionNumber(const aResourceModule: TResourceModule; 118 | const aFileName: String; aVersion: String; const aIncrement, aPrintVersion, aSaveFile: Boolean); 119 | var 120 | VersionInfoResourceDetails: TVersionInfoResourceDetails; 121 | VersionNumber: TVersionNumber; 122 | begin 123 | aResourceModule.LoadFromFile(aFileName); 124 | 125 | VersionInfoResourceDetails := GetVersionInfoResourceDetails(aResourceModule); 126 | 127 | if not Assigned(VersionInfoResourceDetails) then 128 | raise Exception.CreateFmt('No VersionInfo found in %s', [aFileName]) 129 | else 130 | begin 131 | VersionNumber.FromULargeInteger(VersionInfoResourceDetails.FileVersion); 132 | 133 | if aPrintVersion and aIncrement and (not aSaveFile) and (aVersion = '') then 134 | Writeln('Warning: Increment was chosen, but Save was not; file will not be updated.'); 135 | 136 | if aVersion <> '' then 137 | begin 138 | SetVersionFromString(aVersion, VersionNumber.Major); 139 | SetVersionFromString(aVersion, VersionNumber.Minor); 140 | SetVersionFromString(aVersion, VersionNumber.Release); 141 | SetVersionFromString(aVersion, VersionNumber.Build); 142 | end; 143 | 144 | if aIncrement then 145 | Inc(VersionNumber.Build); 146 | 147 | if aPrintVersion then 148 | begin 149 | Writeln( 150 | Format( 151 | '%s: %d.%d.%d.%d', 152 | [aFileName, VersionNumber.Major, VersionNumber.Minor, VersionNumber.Release, VersionNumber.Build] 153 | ) 154 | ); 155 | end; 156 | 157 | VersionInfoResourceDetails.FileVersion := VersionNumber.AsULargeInteger; 158 | 159 | if aSaveFile then 160 | begin 161 | // commenting this out will copy existing RES files to [resfile].~res backup files 162 | DeleteFile(PChar(aFileName)); 163 | aResourceModule.SaveToFile(aFileName); 164 | end; 165 | end; 166 | end; 167 | 168 | procedure HandleResFile(const aFileName, aVersion: String; const aIncrement, aPrintVersion, aSaveFile: Boolean); 169 | var 170 | ResModule: TResModule; 171 | begin 172 | ResModule := TResModule.Create; 173 | try 174 | HandleVersionNumber(ResModule, aFileName, aVersion, aIncrement, aPrintVersion, aSaveFile); 175 | finally 176 | ResModule.Free; 177 | end; 178 | end; 179 | 180 | procedure HandleExeFile(const aFileName, aVersion: String; const aIncrement, aPrintVersion, aSaveFile: Boolean); 181 | var 182 | PEResourceModule: TPEResourceModule; 183 | begin 184 | PEResourceModule := TPEResourceModule.Create; 185 | try 186 | HandleVersionNumber(PEResourceModule, aFileName, aVersion, aIncrement, aPrintVersion, aSaveFile); 187 | finally 188 | PEResourceModule.Free; 189 | end; 190 | end; 191 | 192 | var 193 | i: Integer; 194 | version: String; 195 | increment, print_version, save_file: Boolean; 196 | ResourceFile: TResourceFile; 197 | begin 198 | try 199 | if ParamCount < 1 then 200 | begin 201 | Writeln(''); 202 | Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' [-vX.X.X.X] [-i] [-p] [-s] project_name'); 203 | Writeln(''); 204 | Writeln(' -vX.X.X.X will set the version to X.X.X.X'); 205 | Writeln(' -i will increment the build number'); 206 | Writeln(' -p will print the (new) build number'); 207 | Writeln(' -s will save the changes to the EXE/RES file.'); 208 | Writeln(''); 209 | Exit; 210 | end; 211 | 212 | increment := false; 213 | print_version := false; 214 | save_file := false; 215 | 216 | for i := 1 to ParamCount do 217 | begin 218 | if Copy(ParamStr(i), 1, 2) = '-v' then 219 | version := Copy(ParamStr(i), 3) 220 | else if Copy(ParamStr(i), 1, 2) = '-i' then 221 | increment := true 222 | else if Copy(ParamStr(i), 1, 2) = '-p' then 223 | print_version := true 224 | else if Copy(ParamStr(i), 1, 2) = '-s' then 225 | save_file := true 226 | else 227 | ResourceFile := GetResourceFile(ParamStr(i)); 228 | end; 229 | 230 | case ResourceFile.ResourceType of 231 | rtRES: HandleResFile(ResourceFile.FileName, version, increment, print_version, save_file); 232 | rtEXE: HandleExeFile(ResourceFile.FileName, version, increment, print_version, save_file); 233 | end; 234 | 235 | ResourceFile.FileName := ''; 236 | except 237 | on E:Exception do 238 | Writeln(E.Classname, ': ', E.Message); 239 | end; 240 | 241 | ReportMemoryLeaksOnShutdown := true; 242 | end. 243 | -------------------------------------------------------------------------------- /dGinaTest/BTMemoryModule.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/dGinaTest/BTMemoryModule.pas -------------------------------------------------------------------------------- /dGinaTest/dGinaTest.dpr: -------------------------------------------------------------------------------- 1 | program dGinaTest; 2 | 3 | {$R 'dgina.res' 'dgina.rc'} 4 | 5 | uses 6 | Forms, 7 | fdGinaTest in 'fdGinaTest.pas' {frmdGinaTest}, 8 | BTMemoryModule in 'BTMemoryModule.pas'; 9 | 10 | {$R *.res} 11 | 12 | begin 13 | Application.Initialize; 14 | {$IF CompilerVersion > 18} 15 | Application.MainFormOnTaskbar := True; 16 | {$IFEND} 17 | Application.CreateForm(TfrmdGinaTest, frmdGinaTest); 18 | Application.Run; 19 | end. 20 | -------------------------------------------------------------------------------- /dGinaTest/dGinaTest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/dGinaTest/dGinaTest.res -------------------------------------------------------------------------------- /dGinaTest/dgina.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jasonpenny/democode/be335c1f5c9899776795edfbdb84c2f4b338598c/dGinaTest/dgina.dll -------------------------------------------------------------------------------- /dGinaTest/dgina.rc: -------------------------------------------------------------------------------- 1 | dgina RCDATA dgina.dll 2 | -------------------------------------------------------------------------------- /dGinaTest/fdGinaTest.dfm: -------------------------------------------------------------------------------- 1 | object frmdGinaTest: TfrmdGinaTest 2 | Left = 0 3 | Top = 0 4 | Caption = 'dGina.dll test with BtMemoryModule' 5 | ClientHeight = 133 6 | ClientWidth = 399 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'Tahoma' 12 | Font.Style = [] 13 | OldCreateOrder = False 14 | Position = poScreenCenter 15 | DesignSize = ( 16 | 399 17 | 133) 18 | PixelsPerInch = 96 19 | TextHeight = 13 20 | object btnLoad: TButton 21 | Left = 151 22 | Top = 23 23 | Width = 97 24 | Height = 25 25 | Anchors = [] 26 | Caption = 'Load' 27 | TabOrder = 0 28 | OnClick = btnLoadClick 29 | end 30 | object btnDisableTaskbar: TButton 31 | Left = 151 32 | Top = 54 33 | Width = 97 34 | Height = 25 35 | Anchors = [] 36 | Caption = 'Disable Taskbar' 37 | TabOrder = 1 38 | OnClick = btnDisableTaskbarClick 39 | end 40 | object btnUnload: TButton 41 | Left = 151 42 | Top = 85 43 | Width = 97 44 | Height = 25 45 | Anchors = [] 46 | Caption = 'Unload' 47 | TabOrder = 2 48 | OnClick = btnUnloadClick 49 | end 50 | end 51 | -------------------------------------------------------------------------------- /dGinaTest/fdGinaTest.pas: -------------------------------------------------------------------------------- 1 | unit fdGinaTest; 2 | 3 | interface 4 | 5 | uses 6 | Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, 7 | Dialogs, StdCtrls; 8 | 9 | type 10 | TfrmdGinaTest = class(TForm) 11 | btnLoad: TButton; 12 | btnDisableTaskbar: TButton; 13 | btnUnload: TButton; 14 | procedure btnLoadClick(Sender: TObject); 15 | procedure btnUnloadClick(Sender: TObject); 16 | procedure btnDisableTaskbarClick(Sender: TObject); 17 | private 18 | { Private declarations } 19 | public 20 | { Public declarations } 21 | end; 22 | 23 | var 24 | frmdGinaTest: TfrmdGinaTest; 25 | 26 | implementation 27 | 28 | {$R *.dfm} 29 | 30 | uses 31 | BTMemoryModule; 32 | 33 | var 34 | HookLib: PBTMemoryModule = nil; 35 | 36 | pDisableItem: procedure(Key: integer; disable: integer) stdcall = nil; 37 | pRestoreAll : procedure stdcall = nil; 38 | 39 | const 40 | wlTaskBar = 1; 41 | 42 | procedure TfrmdGinaTest.btnLoadClick(Sender: TObject); 43 | function LoadLibraryFromResource(const aResourceName: String): PBTMemoryModule; 44 | var 45 | ms: TMemoryStream; 46 | rs: TResourceStream; 47 | begin 48 | ms := TMemoryStream.Create; 49 | try 50 | rs := TResourceStream.Create(HInstance, aResourceName, RT_RCDATA); 51 | try 52 | ms.CopyFrom(rs, 0); 53 | ms.Position := 0; 54 | finally 55 | rs.Free; 56 | end; 57 | 58 | Result := BTMemoryLoadLibary(ms.Memory, ms.Size); 59 | finally 60 | ms.Free; 61 | end; 62 | end; 63 | begin 64 | HookLib := LoadLibraryFromResource('dgina'); // HookLib := LoadLibrary('dgina.dll'); 65 | 66 | if Hooklib <> nil then 67 | begin 68 | @pDisableItem := BTMemoryGetProcAddress(HookLib, 'wlDisableItem'); // pDisableItem := GetProcAddress(HookLib, 'wlDisableItem'); 69 | @pRestoreAll := BTMemoryGetProcAddress(HookLib, 'wlRestoreAll'); // pRestoreAll := GetProcAddress(HookLib, 'wlRestoreAll'); 70 | end; 71 | end; 72 | 73 | procedure TfrmdGinaTest.btnDisableTaskbarClick(Sender: TObject); 74 | begin 75 | pDisableItem(wlTaskBar, 1); 76 | end; 77 | 78 | procedure TfrmdGinaTest.btnUnloadClick(Sender: TObject); 79 | begin 80 | pRestoreAll; 81 | 82 | if HookLib <> nil then 83 | BTMemoryFreeLibrary(HookLib); // FreeLibrary(HookLib); 84 | end; 85 | 86 | end. 87 | --------------------------------------------------------------------------------