Kirill Krasnov avatar Kirill Krasnov committed 951d342

Version 1.1.1.0

Comments (0)

Files changed (13)

+syntax: glob
+*.dcu
+*.identcache
+*.local
+**Назначение программы**
+Программа VL: Screenshot предназначена для организации Web-сервиса скриншотов (снимков экрана или его части) на Web-сервере в Internet или локальных сетях.
+
+**Системные требования:**
+**Клиентская программа:**
+    Процессор - не ниже Pentium IV;
+    Оперативная память - не менее 256 МБайт;
+    Операционная система - Microsoft Windows XP/2003 Server/Vista/7.
+**Серверная часть:**
+    Web-сервер или хостинг с установленным PHP версии 5.0 или более поздней;
+    Каталог в файловой системе для изображений с достаточным количеством свободного места (до 50 КБайт на скриншот) и правами на запись для скрипта.
+
+**Условия распространения и использования**
+Программу разрешается свободно использовать, вносить изменения, необходимые для обеспечения функционирования в своей среде, бесплатно распространять. Для облегчения развёртывания и корректировки программы под свою среду в архив включены исходные тексты программы на Delphi 2009 и вся необходимая для развёртывания информация (читайте файлы readme.txt).
+И, конечно же, автор снимает с себя ответственность за какие-либо ошибки в программе. Тем не менее, обнаруженные ошибки будут исправляться. Об обнаруженных ошибках просьба сообщать автору через форму «Связаться с автором».
+object Form1: TForm1
+  Left = 0
+  Top = 0
+  Cursor = crCross
+  BorderStyle = bsNone
+  Caption = 'Form1'
+  ClientHeight = 281
+  ClientWidth = 413
+  Color = clBtnFace
+  TransparentColorValue = clWhite
+  Font.Charset = DEFAULT_CHARSET
+  Font.Color = clWindowText
+  Font.Height = -11
+  Font.Name = 'Tahoma'
+  Font.Style = []
+  OldCreateOrder = False
+  Visible = True
+  WindowState = wsMaximized
+  OnClose = OnClose
+  OnMouseDown = OnMouseDown
+  OnMouseUp = OnMouseUp
+  OnShow = OnShow
+  PixelsPerInch = 96
+  TextHeight = 13
+  object Screen_Image: TImage
+    Left = 0
+    Top = 0
+    Width = 105
+    Height = 105
+    OnMouseDown = OnMouseDown
+    OnMouseMove = OnMouseMove
+    OnMouseUp = OnMouseUp
+  end
+  object IdHTTP: TIdHTTP
+    AllowCookies = False
+    HandleRedirects = True
+    ProtocolVersion = pv1_0
+    ProxyParams.BasicAuthentication = False
+    ProxyParams.ProxyPort = 0
+    Request.ContentLength = -1
+    Request.Accept = 'text/html, */*'
+    Request.BasicAuthentication = False
+    Request.UserAgent = 'Mozilla/3.0 (compatible; Indy Library)'
+    HTTPOptions = [hoForceEncodeParams]
+    OnAuthorization = OnAuth
+    Left = 120
+    Top = 8
+  end
+end
+unit Unit1;
+
+// программа VL:Screenshot - основной модуль
+// написано в 2011 году - Любезный В. В.
+
+interface
+
+uses
+ Windows,SysUtils,Variants,Classes,Graphics,Controls,Forms,IdBaseComponent,IdComponent,IdTCPConnection,IdTCPClient,IdHTTP,ExtCtrls,IdAuthentication;
+
+type
+ TForm1 = class (TForm)
+           IdHTTP       : TIdHTTP;   // компонент, который будет отправлять скрин на сервер
+           Screen_Image : TImage;    // образ, на который мы поместим скриншот, развернув форму на максимум
+           procedure OnMouseDown (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+           procedure OnMouseUp (Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
+           procedure OnShow (Sender: TObject);
+           procedure OnClose (Sender: TObject; var Action: TCloseAction);
+           procedure OnMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer);
+           procedure OnAuth (Sender: TObject; Authentication: TIdAuthentication;  var Handled: Boolean);
+          private
+           { Private declarations }
+          public
+           { Public declarations }
+          end;
+
+var
+ Form1: TForm1;
+
+implementation
+
+{$R *.dfm}
+
+uses pngimage,IdMultipartFormData,xmlwork,ShellAPI,proxy,config,ClipBrd;
+
+var
+ Conf        : TConfig;  // объект параметров конфигурации
+ SelStarted  : Boolean;  // флаг, показывающий, происходит ли выделение фрагмента изображения
+ X1,Y1,X2,Y2 : integer;  // координаты выделяемого фрагмента изображения
+ Scr         : TBitmap;  // указатель на объект для полного скриншота
+ Clicked     : Boolean;  // флаг уже нажатой левой кнопки - для тормозных компов, чтобы не обрабатывать событие по нескольку раз
+
+
+// событие OnShow
+procedure TForm1.OnShow (Sender: TObject);
+var
+ MinX,MinY,MaxX,MaxY,n : integer;
+begin
+ // читаем конфигурацию
+ Conf.Read;
+ // рассчитываем координаты крайних точек пространства для расчёта ширины и высоты рабочего стола
+ MinX := 65535;
+ MinY := 65535;
+ MaxX := 0;
+ MaxY := 0;
+ for n := 0 to Screen.MonitorCount - 1
+  do begin
+      if Screen.Monitors [n].Left < MinX then MinX := Screen.Monitors [n].Left;
+      if Screen.Monitors [n].Top < MinY then MinY := Screen.Monitors [n].Top;
+      if Screen.Monitors [n].Left + Screen.Monitors [n].Width > MaxX then MaxX := Screen.Monitors [n].Left + Screen.Monitors [n].Width;
+      if Screen.Monitors [n].Top + Screen.Monitors [n].Height > MaxY then MaxY := Screen.Monitors [n].Top + Screen.Monitors [n].Height;
+     end;
+ // создаём объект для полного скриншота
+ Scr := TBitmap.Create;
+ // делаем снимок всего экрана на момент запуска программы и кладём его в Scr
+ Scr.Width := MaxX - MinX;
+ Scr.Height := MaxY - MinY;
+ BitBlt (Scr.Canvas.Handle,MinX,MinY,Scr.Width,Scr.Height,GetDC (0),0,0,SRCCOPY);
+ // копируем полученный скриншот в Screen_Image, не забыв установить высоту и ширину контрола
+ Screen_Image.Width := Scr.Width;
+ Screen_Image.Height := Scr.Height;
+ Screen_Image.Picture.Bitmap.Assign (Scr);
+ // устанавливаем параметры "карандаша" для отрисовки прямоугольника при выделении фрагмента
+ Screen_Image.Canvas.Pen.Color := clBlack;
+ Screen_Image.Canvas.Pen.Style := psDash;
+ // если монитор не один, разводим окно на все мониторы для возможности снятия скриншота сразу со всех
+ if Screen.MonitorCount > 1
+  then begin
+        Self.WindowState := wsNormal;
+        Self.Left := MinX;
+        Self.Top := MinY;
+        Self.Width := Scr.Width;
+        Self.Height := Scr.Height;
+        Self.Activate;
+       end;
+ // устанавливаем флаг начала выбора в False - показываем, что пользователь ещё не начал выбирать фрагмент
+ SelStarted := False;
+ // устанавливаем флаг окончания выбора в False
+ Clicked := False;
+end;
+
+
+// обработка авторизации
+procedure TForm1.OnAuth (Sender: TObject; Authentication: TIdAuthentication; var Handled: Boolean);
+begin
+ if Conf.SendLogin <> ''
+  then begin
+        Handled := True;
+        Authentication.Username := Conf.SendLogin;
+        Authentication.Password := Conf.SendPwd;
+       end;
+end;
+
+// закрытие окна
+procedure TForm1.OnClose (Sender: TObject; var Action: TCloseAction);
+begin
+ // пишем конфиг
+ Conf.Write;
+ // освобождаем объект со скриншотом
+ Scr.Free;
+end;
+
+// нажатие кнопки мыши - съём координат на щелчок
+procedure TForm1.OnMouseDown (Sender: TObject; Button: TMouseButton;  Shift: TShiftState; X, Y: Integer);
+begin
+ // если нажата правая кнопка мыши, выходим из программы
+ if Button = mbRight then Close
+ else if not Clicked
+  then begin
+        // иначе засекаем координаты точки, с которой выделяется фрагмент изображения
+        X1 := X;
+        Y1 := Y;
+        // и устанавливаем флаг, по которому событие OnMouseMove определяет, просто двигается мышь или выбирается фрагмент
+        SelStarted := True;
+       end;
+end;
+
+// OnMouseMove на картинке - прямоугольник select-а
+procedure TForm1.OnMouseMove (Sender: TObject; Shift: TShiftState; X, Y: Integer);
+begin
+ // если пользователь выделяет
+ if SelStarted
+  then begin
+        // устанавливаем в Screen_Image исходный скриншот из Scr, убирая таким образом ранее отрисованный прямоугольник выделения
+        Screen_Image.Picture.Bitmap.Assign (Scr);
+        // рисуем новый прямоугольник с новыми координатами
+        Screen_Image.Canvas.FrameRect (Rect (X1,Y1,X,Y));
+       end;
+end;
+
+// отпускание кнопки мыши
+procedure TForm1.OnMouseUp (Sender: TObject; Button: TMouseButton;  Shift: TShiftState; X, Y: Integer);
+var
+ Dest      : TBitmap;
+ Img       : TPngImage;
+ t         : integer;
+ PS,PB,ACU : string;
+ DS,MS     : TMemoryStream;
+ POSTdata  : TIdMultiPartFormDataStream;
+ SL        : TStringList;
+ XML       : TXMLFile;
+begin
+ // снимаем флаг отработки выделения фрагмента
+ SelStarted := False;
+ // если отпущена правая кнопка, выходим
+ if Button = mbRight then Close
+ else if not Clicked
+  then begin
+        // иначе приступаем к основным действиям
+        // устанавливаем флаг Clicked
+        Clicked := True;
+        // хватаем координаты курсора на момент отпускания кнопки мыши в X2 и Y2
+        X2 := X;
+        Y2 := Y;
+        // пересчитываем координаты прямоугольника в зависимости от того, что больше, а что меньше
+        // в X1/Y1 - левый верхний угол, в X2/Y2 - правый нижний
+        // переменную t используем как промежуточную для обмена значениями
+        if X1 > X2
+         then begin
+               t := X1;
+               X1 := X2;
+               X2 := t;
+              end;
+        if Y1 > Y2
+         then begin
+               t := Y1;
+               Y1 := Y2;
+               Y2 := t;
+              end;
+        // копируем выбранный фрагмент из снимка экрана, сделанного при запуске программы и записанного в Scr
+        // фрагмент копируется в новый объект Dest
+        Dest := TBitmap.Create;
+        with Dest
+         do begin
+             Width := X2 - X1 + 1;
+             Height := Y2 - Y1 + 1;
+             Canvas.CopyMode := cmSrcCopy;
+             Canvas.CopyRect (Rect (0,0,Width,Height),Scr.Canvas,Rect (X1,Y1,X2,Y2));
+            end;
+        // преобразуем полученное изображение в png и пишем его в stream для отправки
+        // для этого создаём объекты Img типа TPNGImage и MS типа TMemoryStream
+        Img := TPngImage.Create;
+        Img.Assign (Dest);
+        MS := TMemoryStream.Create;
+        Img.SaveToStream (MS);
+        // уничтожаем уже не нужные объекты Img и Dest
+        Img.Free;
+        Dest.Free;
+        // следующая задача - пересылка полученного png на сервер
+        // первым делом настраиваем IdHttp
+        // задача - прописать параметры прокси и авторизации в соответствии с настройками
+        // если ProxyServer - пустая строка, пропускаем
+        // если значение параметра Proxy auto , детектим
+        if Conf.ProxyServer <> ''
+         then if Conf.ProxyServer = 'auto'
+          then begin
+                // определяем параметры прокси для URL с помощью функций WinHttpProxy и при наличии прокси настраиваем IdHttp
+                GetProxyForURL (Conf.SendURL,PS,PB,ACU);
+                if PS <> ''
+                 then begin
+                       t := Pos (':',PS);
+                       if t <> 0
+                        then begin
+                              IdHttp.ProxyParams.ProxyPort := StrToInt (Copy (PS,t+1,Length (PS)-t));
+                              IdHttp.ProxyParams.ProxyServer := Copy (PS,1,t-1);
+                             end;
+                      end;
+               end
+          else begin
+                // если прокси прописан ручками, проставляем в конфиг параметры сервера и при необходимости авторизацию
+                // сперва сервер
+                t := Pos (':',Conf.ProxyServer);
+                if t <> 0
+                 then begin
+                       IdHttp.ProxyParams.ProxyPort := StrToInt (Copy (Conf.ProxyServer,t+1,Length (Conf.ProxyServer)-t));
+                       IdHttp.ProxyParams.ProxyServer := Copy (Conf.ProxyServer,1,t-1);
+                      end;
+                // теперь авторизацию (если надо)
+                if Conf.ProxyLogin <> ''
+                 then begin
+                       IdHttp.ProxyParams.BasicAuthentication := True;
+                       IdHttp.ProxyParams.ProxyUsername := Conf.ProxyLogin;
+                       IdHttp.ProxyParams.ProxyPassword := Conf.ProxyPwd;
+                      end;
+               end;
+        // теперь создаём поток POST-данных и загоняем туда файл
+        POSTData := TIdMultiPartFormDataStream.Create;
+        MS.Seek (0,soFromBeginning);
+        POSTData.AddObject ('pic','image/png',MS,'sshot.png');
+        // устанавливаем Content-Type для запроса
+        IdHTTP.Request.ContentType:='multipart/form-data';
+        // создаём объекты для приёма ответа от сервера
+        DS := TMemoryStream.Create;
+        SL := TStringList.Create;
+        // отсылаем запрос в try - except
+        try
+         IdHTTP.Post (Conf.SendURL,POSTData,DS);
+         if IdHttp.ResponseCode = 200
+          then begin
+                // грузим ответ в SL
+                DS.Seek (0,soFromBeginning);
+                SL.LoadFromStream (DS);
+                // в SL.Text у нас ответ - его нужно распарсить
+                XML := TXMLFile.Create;
+                XML.Data := SL.Text;
+                //  для ссылки на картинку используем уже не нужную нам переменную PS
+                PS := '';
+                if not XML.Parse then MessageBox (Handle,'Сервер вернул неверный ответ.','Ошибка',mb_IconError)
+                else begin
+                      // XML правильный - парсим атрибуты корневого тэга
+                      if XML.Tag.Name = 'picture'
+                       then if Length (XML.Tag.Attrs) > 0
+                        then if XML.Tag.Attrs [0].Name = 'link'
+                         then PS := XML.Tag.Attrs [0].Value;
+                      // если PS не пустая, то в ней ссылка на картинку
+                      if PS = ''
+                       then MessageBox (Handle,'Ответ от сервера не содержит ссылки на картинку.','Ошибка',mb_IconError)
+                       else begin
+                             // копируем ссылку в буфер обмена
+                             Clipboard.Open;
+                             Clipboard.SetTextBuf (PChar (PS));
+                             Clipboard.Close;
+                             // открываем ссылку в браузере
+                             ShellExecute (Handle,'open',PChar (PS),'','',sw_maximize);
+                            end;
+                     end;
+                // прибиваем XML-парсер - он нам больше не нужен
+                XML.Destroy;
+               end
+          else MessageBox (Handle,PChar ('Сервер вернул ошибку '+IntToStr (IdHttp.ResponseCode)+' '+IdHttp.ResponseText),'Ошибка',mb_IconError);
+        except
+         MessageBox (Handle,'Не удалось соединиться с сервером.','Ошибка',mb_IconError);
+        end;
+        // заканчиваем
+        POSTData.Free;
+        SL.Free;
+        DS.Free;
+        MS.Free;
+        Close;
+       end;
+end;
+
+end.

client/config.pas

+unit config;
+
+// программа VL:Screenshot
+// Модуль конфигурации
+// написано в 2011 году - Любезный В. В.
+
+interface
+
+const
+ RegPath : string = '\Software\VL\VLSS'; // путь к ветке реестра от HKEY_CURRENT_USER
+
+type
+
+ // объект конфигурации
+ TConfig = object
+            // свойства - параметры конфигурации
+            // параметры для отправки
+            SendURL     : string;  // URL для отправки скриншота
+            SendLogin   : string;  // логин для отправки скриншота (если пустой, то без авторизации)
+            SendPwd     : string;  // пароль для отправки скриншота
+            ProxyServer : string;  // пустая строка - без прокси; auto - автоопределение; иначе ручное задание
+            ProxyLogin  : string;  // логин для прокси (если пустая строка или ProxyServer=auto - прокси без авторизации)
+            ProxyPwd    : string;  // пароль для прокси
+            // методы
+            procedure Init;   // установка значений по умолчанию
+            procedure Read;   // чтение конфига
+            procedure Write;  // запись конфига
+           end;
+
+implementation
+
+uses Registry;
+
+procedure TConfig.Init;
+begin
+ SendUrl := 'http://www.example.com/sshots/load.php';
+ SendLogin := '';
+ SendPwd := '';
+ ProxyServer := 'auto';
+ ProxyLogin := '';
+ ProxyPwd := '';
+end;
+
+procedure TConfig.Read;
+var
+ Reg : TRegistry;
+ s   : string;
+begin
+ Init;
+ Reg := TRegistry.Create;
+ // если ключ существует и открывается,
+ if Reg.OpenKey (RegPath,False)
+  then begin
+        // читаем параметры
+        s := Reg.ReadString ('SendURL');
+        if s <> '' then SendUrl := s;
+        s := Reg.ReadString ('SendLogin');
+        if s <> '' then SendLogin := s;
+        s := Reg.ReadString ('SendPwd');
+        if s <> '' then SendPwd := s;
+        s := Reg.ReadString ('ProxyServer');
+        if s <> '' then ProxyServer := s;
+        s := Reg.ReadString ('ProxyLogin');
+        if s <> '' then ProxyLogin := s;
+        s := Reg.ReadString ('ProxyPwd');
+        if s <> '' then ProxyPwd := s;
+        // закрываем ключ реестра
+        Reg.CloseKey;
+       end;
+ Reg.Free;
+end;
+
+procedure TConfig.Write;
+var
+ Reg : TRegistry;
+begin
+ Reg := TRegistry.Create;
+ // открываем ключ; если его нет, создаём
+ if Reg.OpenKey (RegPath,True)
+  then begin
+        Reg.WriteString ('SendURL',SendURL);
+        Reg.WriteString ('SendLogin',SendLogin);
+        Reg.WriteString ('SendPwd',SendPwd);
+        Reg.WriteString ('ProxyServer',ProxyServer);
+        Reg.WriteString ('ProxyLogin',ProxyLogin);
+        Reg.WriteString ('ProxyPwd',ProxyPwd);
+        // закрываем ключ реестра
+        Reg.CloseKey;
+       end;
+ Reg.Free;
+end;
+
+end.
+unit proxy;
+
+// Функция получения прокси и юнит winhttpproxy (с)тырены с http://www.cyberforum.ru/delphi-networks/thread46823.html
+
+interface
+
+uses windows;
+
+function GetProxyForUrl (Url: WideString; var Proxy,ProxyBypass,AutoConfigUrl: string): DWord;
+
+implementation
+
+uses winhttpproxy;
+
+function GetProxyForUrl (Url: WideString; var Proxy,ProxyBypass,AutoConfigUrl: string): DWord;
+var
+ Config: TWinHttpCurrentUserIEProxyConfig;
+ AutoProxyOptions: TWinHttpAutoProxyOptions;
+ ProxyInfo: TWinHttpProxyInfo;
+ hSession: HINTERNET;
+begin
+ AutoProxyOptions.dwFlags:= 0;
+ AutoProxyOptions.dwAutoDetectFlags:= 0;
+ AutoProxyOptions.lpvReserved:= nil;
+ AutoProxyOptions.dwReserved:= 0;
+ Result:= 0;
+ if WinHttpGetIEProxyConfigForCurrentUser (@Config) = True
+  then begin
+        Proxy:= Config.lpszProxy;
+        ProxyBypass:= Config.lpszProxyBypass;
+        AutoConfigUrl:= Config.lpszAutoConfigUrl;
+        if Config.fAutoDetect
+         then begin
+               AutoProxyOptions.dwFlags:= WINHTTP_AUTOPROXY_AUTO_DETECT;
+               AutoProxyOptions.dwAutoDetectFlags:= WINHTTP_AUTO_DETECT_TYPE_DHCP + WINHTTP_AUTO_DETECT_TYPE_DNS_A;
+              end;
+        if Config.lpszAutoConfigUrl <> ''
+         then begin
+               AutoProxyOptions.dwFlags:= AutoProxyOptions.dwFlags + WINHTTP_AUTOPROXY_CONFIG_URL;
+               AutoProxyOptions.lpszAutoConfigUrl:= Config.lpszAutoConfigUrl;
+              end;
+       end
+  else begin
+        AutoProxyOptions.dwFlags:= WINHTTP_AUTOPROXY_AUTO_DETECT;
+        AutoProxyOptions.dwAutoDetectFlags:= WINHTTP_AUTO_DETECT_TYPE_DHCP + WINHTTP_AUTO_DETECT_TYPE_DNS_A;
+       end;
+ hSession:= WinHttpOpen ('WinHTTP AutoProxy/1.0',WINHTTP_ACCESS_TYPE_NO_PROXY,WINHTTP_NO_PROXY_NAME,WINHTTP_NO_PROXY_BYPASS,0);
+ try
+  AutoProxyOptions.fAutoLogonIfChallenged:= True;
+  if WinHttpGetProxyForUrl (hSession,PWideChar (Url),@AutoProxyOptions,@ProxyInfo) = True
+   then Proxy:= ProxyInfo.lpszProxy
+   else Result:= GetLastError;
+ finally
+  WinHttpCloseHandle (hSession);
+ end;
+end;
+
+end.
+program vlss;
+
+uses
+  Forms,
+  Unit1 in 'Unit1.pas' {Form1},
+  xmlwork in 'xmlwork.pas',
+  winhttpproxy in 'winhttpproxy.pas',
+  proxy in 'proxy.pas',
+  config in 'config.pas';
+
+{$R *.res}
+
+begin
+  Application.Initialize;
+  Application.MainFormOnTaskbar := False;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.

client/vlss.dproj

+п»ї	<Project xmlns="http://schemas.microsoft.com/developer/msbuild/2003">
+		<PropertyGroup>
+			<ProjectGuid>{E01A4257-9D46-4012-9065-9C6D6D66E204}</ProjectGuid>
+			<ProjectVersion>12.0</ProjectVersion>
+			<MainSource>vlss.dpr</MainSource>
+			<Config Condition="'$(Config)'==''">Debug</Config>
+			<DCC_DCCCompiler>DCC32</DCC_DCCCompiler>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Config)'=='Base' or '$(Base)'!=''">
+			<Base>true</Base>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Config)'=='Release' or '$(Cfg_1)'!=''">
+			<Cfg_1>true</Cfg_1>
+			<CfgParent>Base</CfgParent>
+			<Base>true</Base>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Config)'=='Debug' or '$(Cfg_2)'!=''">
+			<Cfg_2>true</Cfg_2>
+			<CfgParent>Base</CfgParent>
+			<Base>true</Base>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Base)'!=''">
+			<DCC_DependencyCheckOutputName>vlss.exe</DCC_DependencyCheckOutputName>
+			<DCC_ImageBase>00400000</DCC_ImageBase>
+			<DCC_UnitAlias>WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE;$(DCC_UnitAlias)</DCC_UnitAlias>
+			<DCC_Platform>x86</DCC_Platform>
+			<DCC_E>false</DCC_E>
+			<DCC_N>false</DCC_N>
+			<DCC_S>false</DCC_S>
+			<DCC_F>false</DCC_F>
+			<DCC_K>false</DCC_K>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Cfg_1)'!=''">
+			<DCC_LocalDebugSymbols>false</DCC_LocalDebugSymbols>
+			<DCC_Define>RELEASE;$(DCC_Define)</DCC_Define>
+			<DCC_SymbolReferenceInfo>0</DCC_SymbolReferenceInfo>
+			<DCC_DebugInformation>false</DCC_DebugInformation>
+		</PropertyGroup>
+		<PropertyGroup Condition="'$(Cfg_2)'!=''">
+			<DCC_Define>DEBUG;$(DCC_Define)</DCC_Define>
+		</PropertyGroup>
+		<ItemGroup>
+			<DelphiCompile Include="vlss.dpr">
+				<MainSource>MainSource</MainSource>
+			</DelphiCompile>
+			<DCCReference Include="Unit1.pas">
+				<Form>Form1</Form>
+			</DCCReference>
+			<DCCReference Include="xmlwork.pas"/>
+			<DCCReference Include="winhttpproxy.pas"/>
+			<DCCReference Include="proxy.pas"/>
+			<DCCReference Include="config.pas"/>
+			<BuildConfiguration Include="Base">
+				<Key>Base</Key>
+			</BuildConfiguration>
+			<BuildConfiguration Include="Debug">
+				<Key>Cfg_2</Key>
+				<CfgParent>Base</CfgParent>
+			</BuildConfiguration>
+			<BuildConfiguration Include="Release">
+				<Key>Cfg_1</Key>
+				<CfgParent>Base</CfgParent>
+			</BuildConfiguration>
+		</ItemGroup>
+		<Import Project="$(BDS)\Bin\CodeGear.Delphi.Targets" Condition="Exists('$(BDS)\Bin\CodeGear.Delphi.Targets')"/>
+		<ProjectExtensions>
+			<Borland.Personality>Delphi.Personality.12</Borland.Personality>
+			<Borland.ProjectType/>
+			<BorlandProject>
+				<Delphi.Personality>
+					<Parameters>
+						<Parameters Name="UseLauncher">False</Parameters>
+						<Parameters Name="LoadAllSymbols">True</Parameters>
+						<Parameters Name="LoadUnspecifiedSymbols">False</Parameters>
+					</Parameters>
+					<VersionInfo>
+						<VersionInfo Name="IncludeVerInfo">True</VersionInfo>
+						<VersionInfo Name="AutoIncBuild">False</VersionInfo>
+						<VersionInfo Name="MajorVer">1</VersionInfo>
+						<VersionInfo Name="MinorVer">1</VersionInfo>
+						<VersionInfo Name="Release">1</VersionInfo>
+						<VersionInfo Name="Build">0</VersionInfo>
+						<VersionInfo Name="Debug">False</VersionInfo>
+						<VersionInfo Name="PreRelease">False</VersionInfo>
+						<VersionInfo Name="Special">False</VersionInfo>
+						<VersionInfo Name="Private">False</VersionInfo>
+						<VersionInfo Name="DLL">False</VersionInfo>
+						<VersionInfo Name="Locale">1049</VersionInfo>
+						<VersionInfo Name="CodePage">1251</VersionInfo>
+					</VersionInfo>
+					<VersionInfoKeys>
+						<VersionInfoKeys Name="CompanyName">Viktor V. Lyubeznyy</VersionInfoKeys>
+						<VersionInfoKeys Name="FileDescription"/>
+						<VersionInfoKeys Name="FileVersion">1.1.1.0</VersionInfoKeys>
+						<VersionInfoKeys Name="InternalName"/>
+						<VersionInfoKeys Name="LegalCopyright">Viktor V. Lyubeznyy</VersionInfoKeys>
+						<VersionInfoKeys Name="LegalTrademarks"/>
+						<VersionInfoKeys Name="OriginalFilename"/>
+						<VersionInfoKeys Name="ProductName">VL:Screenshot</VersionInfoKeys>
+						<VersionInfoKeys Name="ProductVersion">1.1.1.0</VersionInfoKeys>
+						<VersionInfoKeys Name="Comments">Screenshot client software</VersionInfoKeys>
+					</VersionInfoKeys>
+					<Source>
+						<Source Name="MainSource">vlss.dpr</Source>
+					</Source>
+				</Delphi.Personality>
+			</BorlandProject>
+			<ProjectFileVersion>12</ProjectFileVersion>
+		</ProjectExtensions>
+	</Project>

Binary file added.

client/winhttpproxy.pas

+unit winhttpproxy;
+
+// Функция получения прокси и юнит winhttpproxy (с)тырены с http://www.cyberforum.ru/delphi-networks/thread46823.html
+
+interface
+
+uses Windows;
+
+type
+ HINTERNET = Pointer;
+
+ PWinHttpProxyInfo = ^TWinHttpProxyInfo;
+ TWinHttpProxyInfo = record
+                      dwAccessType    : DWORD;    // see WINHTTP_ACCESS_ types below
+                      lpszProxy       : LPWSTR;   // proxy server list
+                      lpszProxyBypass : LPWSTR;   // proxy bypass list
+                     end;
+
+ PWinHttpAutoProxyOptions = ^TWinHttpAutoProxyOptions;
+ TWinHttpAutoProxyOptions = record
+                             dwFlags                : DWORD;
+                             dwAutoDetectFlags      : DWORD;
+                             lpszAutoConfigUrl      : LPWSTR; //PWideChar;
+                             lpvReserved            : Pointer;
+                             dwReserved             : DWORD;
+                             fAutoLogonIfChallenged : BOOL;
+                            end;
+
+
+ PWinHttpCurrentUserIEProxyConfig = ^TWinHttpCurrentUserIEProxyConfig;
+ TWinHttpCurrentUserIEProxyConfig = record
+                                     fAutoDetect       : boolean;
+                                     lpszAutoConfigUrl : LPWSTR; //PWideChar;
+                                     lpszProxy         : LPWSTR; //PWideChar;
+                                     lpszProxyBypass   : LPWSTR; //PWideChar;
+                                    end;
+
+const
+ winhttpdll = 'winhttp.dll';
+
+ WINHTTP_ACCESS_TYPE_DEFAULT_PROXY       = 0;
+ WINHTTP_ACCESS_TYPE_NO_PROXY            = 1;
+ WINHTTP_ACCESS_TYPE_NAMED_PROXY         = 3;
+
+ WINHTTP_NO_PROXY_NAME                   = nil;
+ WINHTTP_NO_PROXY_BYPASS                 = nil;
+
+ INTERNET_DEFAULT_PORT                   = 0;
+ INTERNET_DEFAULT_HTTP_PORT              = 80;
+ INTERNET_DEFAULT_HTTPS_PORT             = 443;
+ INTERNET_SCHEME_HTTP                    = (1);
+ INTERNET_SCHEME_HTTPS                   = (2);
+ WINHTTP_AUTOPROXY_AUTO_DETECT           = $00000001;
+ WINHTTP_AUTOPROXY_CONFIG_URL            = $00000002;
+ WINHTTP_AUTOPROXY_RUN_OUTPROCESS_ONLY   = $00020000;
+ WINHTTP_AUTO_DETECT_TYPE_DHCP           = $00000001;
+ WINHTTP_AUTO_DETECT_TYPE_DNS_A          = $00000002;
+
+ WINHTTP_ERROR_BASE = 12000;
+ ERROR_WINHTTP_AUTO_PROXY_SERVICE_ERROR = (WINHTTP_ERROR_BASE + 178);
+ ERROR_WINHTTP_BAD_AUTO_PROXY_SCRIPT = (WINHTTP_ERROR_BASE + 166);
+
+ { prototypes }
+
+//function WinHttpQueryOption(hInet: HINTERNET; dwOption: DWORD;
+//  lpBuffer: Pointer; var lpdwBufferLength: DWORD): BOOL; stdcall;
+//  {$EXTERNALSYM WinHttpQueryOption}
+
+//function WinHttpDetectAutoProxyConfigUrl(dwAutoDetectFlags: DWORD;
+//  var ppwszAutoConfigUrl: LPWSTR): BOOL; stdcall;
+//  {$EXTERNALSYM WinHttpDetectAutoProxyConfigUrl}
+
+function WinHttpGetDefaultProxyConfiguration (var pProxyInfo: PWinHttpProxyInfo): BOOL; stdcall;
+ {$EXTERNALSYM WinHttpGetDefaultProxyConfiguration}
+
+function WinHttpGetIEProxyConfigForCurrentUser (pProxyInfo: PWinHttpCurrentUserIEProxyConfig): BOOL; stdcall;
+ {$EXTERNALSYM WinHttpGetIEProxyConfigForCurrentUser}
+
+function WinHttpGetProxyForUrl (hSession: HINTERNET; lpcwszUrl: PWideChar; pAutoProxyOptions: PWinHttpAutoProxyOptions; pProxyInfo: PWinHttpProxyInfo): BOOL; stdcall;
+ {$EXTERNALSYM WinHttpGetProxyForUrl}
+
+
+function WinHttpCheckPlatform: BOOL; stdcall;
+ {$EXTERNALSYM WinHttpCheckPlatform}
+
+function WinHttpOpen (pwszUserAgent: PWideChar; dwAccessType: DWORD; pwszProxyName, pwszProxyBypass: PWideChar; dwFlags: DWORD): HINTERNET; stdcall;
+ {$EXTERNALSYM WinHttpOpen}
+
+function WinHttpCloseHandle (hInternet: HINTERNET): BOOL; stdcall;
+ {$EXTERNALSYM WinHttpCloseHandle}
+
+
+implementation
+
+function WinHttpGetDefaultProxyConfiguration;
+external winhttpdll name 'WinHttpGetDefaultProxyConfiguration';
+
+function WinHttpGetIEProxyConfigForCurrentUser;
+external winhttpdll name 'WinHttpGetIEProxyConfigForCurrentUser';
+
+function WinHttpCheckPlatform;
+external winhttpdll name 'WinHttpCheckPlatform';
+
+function WinHttpOpen;
+external winhttpdll name 'WinHttpOpen';
+
+function WinHttpCloseHandle;
+external winhttpdll name 'WinHttpCloseHandle';
+
+function WinHttpGetProxyForUrl;
+external winhttpdll name 'WinHttpGetProxyForUrl';
+
+end.

client/xmlwork.pas

+unit xmlwork;
+
+// модуль обработки XML
+// 2011 год - Любезный В. В.
+
+interface
+
+type
+
+ // тип атрибута XML
+ TXMLAttr = record
+             Name : ANSIString;        // наименование атрибута
+             Value : ANSIString;       // значение атрибута
+            end;
+
+ TXMLAttrArr = array of TXMLAttr;
+
+ // тип элемента XML
+ TXMLElement = class
+                Name  : ANSIString;                  // наименование элемента
+                Attrs : TXMLAttrArr;       // атрибуты
+                Value : ANSIString;                  // значение внутри элемента
+                Child : array of TXMLElement;    // дочерние элементы
+                constructor Create;
+                destructor Destroy;
+                function Parse : Boolean;        // анализ значения, формирование дочерних элементов
+               end;
+
+ // тип файла XML
+ TXMLFile = class
+             Attrs   : TXMLAttrArr;          // атрибуты файла
+             Data    : ANSIString;               // данные файла XML
+             Tag     : TXMLElement;          // корневой элемент XML
+             constructor Create;
+             destructor Destroy;
+             function Parse : Boolean;       // анализ данных, формирование дочерних элементов
+             function ReadFromFile (FileName : string) : Boolean; // чтение данных из файла XML
+            end;
+
+implementation
+
+uses SysUtils;
+
+// функция триммирования строки
+function trim (const Line : ANSIString) : ANSIString;
+var
+ r : ANSIString;
+ b : Boolean;
+begin
+ r := Line;
+ if (r <> '')
+  then begin
+        // с начала
+        repeat
+         b := False;
+         if r <> '' then if (r [1] = #13) or (r [1] = #10) or (r [1] = #32) or (r [1] = #9) then b := True;
+         if b then r := copy (r,2,Length (r)-1);
+        until b = False;
+        // с конца
+        repeat
+         b := False;
+         if r <> '' then if (r [Length (r)] = #13) or (r [Length (r)] = #10) or (r [Length (r)] = #32) or (r [Length (r)] = #9) then b := True;
+         if b then r := copy (r,1,Length (r)-1);
+        until b = False;
+       end;
+ trim := r;
+end;
+
+// функция вычисления позиции подстроки в строке, начиная со стартовой позиции
+function strpos (substr,str : ANSIString; startpos : LongInt) : LongInt;
+var
+ l,m : LongInt;
+begin
+ l := 0;
+ if startpos > Length (str)-Length (substr)+1 then Result := 0
+ else begin
+       for m := startpos to Length (str)-Length (substr)+1
+        do if (Copy (str,m,Length (substr)) = substr)
+         then begin
+               l := m;
+               Break;
+              end;
+       Result := l;
+      end;
+end;
+
+// функция выполнения предобработки с целью корректного чтения XML-файлов в разных вариациях
+// задачи:
+// 1. заменить символы с кодами 13, 10 и 9 на символ с кодом 32 (пробел);
+// 2. удалить пробелы перед >
+function preProcess (Data : ANSIString) : ANSIString;
+var
+ i,i1 : integer;
+ s    : ANSIString;
+begin
+ s := Data;
+ if s <> ''
+  then begin
+        for i := 1 to Length (s)
+         do if (s [i] = #13) or (s [i] = #10) or (s [i] = #9)
+          then s [i] := #32;
+        i := Pos (' >',s);
+        while i <> 0
+         do begin
+             i1 := i;
+             while (s [i1] = #32) and (i1 > 2) do Dec (i1);
+             s := Copy (s,1,i1) + Copy (s,i+1,Length (s)-i);
+             i := Pos (' >',s);
+            end;
+       end;
+ preProcess := s;
+end;
+
+constructor TXMLElement.Create;
+begin
+ SetLength (Attrs,0);
+end;
+
+destructor TXMLElement.Destroy;
+var
+ i : LongInt;
+begin
+ SetLength (Attrs,0);
+ if Length (Child) > 0 then for i := Low (Child) to High (Child) do Child [i].Destroy;
+ inherited Destroy;
+end;
+
+function parseAttrs (s : ANSIString) : TXMLAttrArr;
+var
+ n,v       : ANSIString;
+ a         : TXMLAttrArr;
+ w,x       : LongInt;
+ Quote,Equ : Boolean;
+begin
+ SetLength (a,0);
+ n := '';
+ v := '';
+ Quote := False;
+ Equ := False;
+ for w := 1 to Length (s)
+  do begin
+      if (Quote = False)
+       then begin
+             if s [w] = '=' then Equ := not Equ
+             else if s [w] = '"' then Quote := True
+             else if ((s [w] = ' ') or (s [w] = #13) or (s [w] = #10) or (s [w] = #9) and (Quote = False))
+              then begin
+                    // загоняем добытый атрибут
+                    x := High (a)+1;
+                    SetLength (a,x+1);
+                    a [x].Name:=n;
+                    a [x].Value:=v;
+                    n := '';
+                    v := '';
+                    Equ := False;
+                   end
+              else if Equ = False then n := n + s [w] else v := v + s [w];
+            end
+       else begin
+             if s [w] = '"' then Quote := False
+             else v := v + s [w];
+            end;
+     end;
+ if n<>''
+  then begin
+        x := High (a)+1;
+        SetLength (a,x+1);
+        a [x].Name:=n;
+        a [x].Value:=v;
+       end;
+ parseAttrs := a;
+end;
+
+function TXMLElement.Parse : Boolean;
+var
+ a,b,c,d           : ANSIString;
+ AttrArray         : TXMLAttrArr;
+ l,m,n             : LongInt;
+ Quote             : Boolean;
+ getAttrs,GetValue : Boolean;
+begin
+ // парсим данные
+ SetLength (Child,0);
+ a := trim (Value);
+ if a = '' then Parse := False
+ else if (a [1] <> '<') then Parse := False
+ else begin
+       l := 1;
+       repeat
+        // получаем в b имя будущего тэга
+        b := '';
+        m := 1;
+        repeat
+         b := b + a [l+m];
+         Inc (m);
+        until (a [l+m] = ' ') or (a [l+m] = '/') or (a [l+m] = '>');
+        // в c предполагается строка атрибутов
+        c := '';
+        // в d предполагается значение
+        d := '';
+        // в зависимости от наличия атрибутов и значения проставляем соотв. флаги
+        getAttrs := (a [l+m] = ' ');
+        getValue := (a [l+m] <> '/');
+        // если есть атрибуты, выделяем строку и получаем атрибуты
+        if getAttrs
+         then begin
+               Quote := False;
+               c := '';
+               Inc (m);
+               repeat
+                if a [l+m] = '"' then Quote := not Quote;
+                c := c + a [l+m];
+                Inc (m);
+               until ((a [l+m] = '>') or (a [l+m] = '/') and (Quote = False)) or (l+m > Length (a));
+               // если мы перебарщиваем с длиной, то валим
+               if l+m > Length (a)
+                then begin
+                      Parse := False;
+                      Exit;
+                     end
+                else begin
+                      // иначе продолжаем
+                      // получаем атрибуты
+                      AttrArray := parseAttrs (trim (c));
+                      // корректируем getValue
+                      if getValue then getValue := (a [l+m] <> '/');
+                     end;
+              end
+         else SetLength (AttrArray,0);
+        if getValue
+         then begin
+               // получаем значение
+               if a [l+m] = '>' then Inc (m);
+               // ищем по имени закрывающий тэг
+               n := strpos ('</'+b+'>',a,l+m);
+               // если закрывающего тэга нет, то валимся
+               if n = 0
+                then begin
+                      Parse := False;
+                      Exit;
+                     end
+                else begin
+                      // иначе получаем данные
+                      d := Copy (a,l+m,n-l-m);
+                      // и проставляем в m позицию закрывающего тэга
+                      Inc (m,Length (d));
+                      Inc (m,Length (b));
+                      Inc (m,2);
+                     end;
+              end
+         else Inc (m);
+        // устанавливаем положительный результат
+        Parse := True;
+        // добавляем то, что нам удалось добыть, и парсим чайлды
+        n := High (Child)+1;
+        SetLength (Child,n+1);
+        Child [n] := TXMLElement.Create;
+        Child [n].Name:=b;
+        Child [n].Attrs := AttrArray;
+        Child [n].Value:=d;
+        Child [n].Parse;
+        // заканчиваем
+        Inc (l,m);
+        Inc (l);
+        while ((a [l] = ' ') or (a [l] = #13) or (a [l] = #10) or (a [l] = #9)) and (l < Length (a)) do Inc (l);
+       until l >= Length (a);
+      end;
+end;
+
+constructor TXMLFile.Create;
+begin
+ SetLength (Attrs,0);
+end;
+
+destructor TXMLFile.Destroy;
+begin
+ SetLength (Attrs,0);
+ if Tag <> nil then Tag.Destroy;
+ inherited Destroy;
+end;
+
+function TXMLFile.Parse : Boolean;
+var
+ a,b,c,d           : ANSIString;
+ l,m               : LongInt;
+ Quote             : Boolean;
+ getAttrs,getValue : Boolean;
+begin
+ // очищаем память, если было предыдущее использование
+ SetLength (Attrs,0);
+ if Tag<>nil then Tag.Destroy;
+ // проверяем наличие данных
+ a := trim (Data);
+ if Length (a) < 8 then Parse := False
+ else if Copy (a,1,5) <> '<?xml' then Parse := False
+ else begin
+       l := strpos ('?>',a,6);
+       if l = 0 then Parse := False
+       else begin
+             // получаем строку атрибутов
+             b := copy (a,7,l-7);
+             // парсим
+             Attrs := parseAttrs (trim (b));
+             // получаем строку данных и сразу делаем её предобработку, чтобы не возиться с ней потом
+             b := trim (copy (a,l+2,Length (a)-l-1));
+             b := preProcess (b);
+             // хватаем из неё корневой тэг
+             if b [1] <> '<'
+              then begin
+                    Parse := False;
+                    Exit;
+                   end
+              else begin
+                    Tag := TXMLElement.Create;
+                    // парсим
+                    // начинаем с имени - его в c
+                    c := '';
+                    l := 2;
+                    repeat
+                     c := c + b [l];
+                     Inc (l);
+                    until (b [l] = ' ') or (b [l] = '/') or (b [l] = '>') or (l > Length (b));
+                    if l > Length (b) then Parse := False
+                    else begin
+                          // имя - в c
+                          // проверяем, надо ли получать значение и атрибуты
+                          getValue := (b [l] <> '/');
+                          getAttrs := (b [l] = ' ');
+                          // если надо получать атрибуты, то получаем
+                          if getAttrs
+                           then begin
+                                 d := '';
+                                 Inc (l);
+                                 Quote := False;
+                                 repeat
+                                  if b [l]='"' then Quote := not Quote;
+                                  d := d + b [l];
+                                  Inc (l);
+                                 until (((b [l] = '/') or (b [l] = '>')) and (Quote = False)) or (l > Length (b));
+                                 if l > Length (b)
+                                  then begin
+                                        Parse := False;
+                                        Exit;
+                                       end
+                                  else begin
+                                        Tag.Attrs := parseAttrs (trim (d));
+                                        // корректируем при необходимости getValue
+                                        if b [l] = '/'
+                                         then Inc (l);
+                                       end;
+                                 d := '';
+                                end;
+                          // если надо получить значение, то получаем
+                          if getValue
+                           then begin
+                                 // в d
+                                 d := '';
+                                 Inc (l);
+                                 m := strpos ('</'+c+'>',b,l);
+                                 if m = 0
+                                  then begin
+                                        Parse := False;
+                                        Exit;
+                                       end
+                                  else d := copy (b,l,m-l);
+                                end;
+                          // присваиваем полученное
+                          Tag.Name:=trim (c);
+                          Tag.Value:=trim (d);
+                          if Tag.Value <> '' then Tag.Parse;
+                          Parse := True;
+                         end;
+                   end;
+            end;
+      end;
+end;
+
+function TXMLFile.ReadFromFile (FileName : string) : Boolean;
+var
+ f      : file;
+ Buf    : array [1..64000] of ANSIChar;
+ Readed : integer;
+begin
+ try
+  AssignFile (f,FileName);
+  FileMode := fmOpenRead;
+  reset (f,1);
+  Data := '';
+  repeat
+   BlockRead (f,Buf [1],64000,Readed);
+   Data := Data + Copy (Buf,1,Readed);
+  until Readed < 64000;
+  CloseFile (f);
+  ReadFromFile := True;
+ except
+  ReadFromFile := False;
+ end;
+end;
+
+end.
+<?php
+// путь в файловой системе для сохранения картинок
+$path = "./";
+// URI к каталогу для сохранения картинок
+$linkpath = "http://www.example.com/sshots/";
+
+// если файла нет, выкидываем
+if (!isset ($_FILES ["pic"])) header ("HTTP/1.0 403 Forbidden");
+// если файл не является загруженным, тоже выкидываем
+else if (!is_uploaded_file ($_FILES ["pic"] ["tmp_name"])) header ("HTTP/1.0 403 Forbidden");
+// и если не png, тоже
+else if ($_FILES ["pic"] ["type"] != "image/png") header ("HTTP/1.0 403 Forbidden");
+else
+ {
+  // считываем файл
+  $s = file_get_contents ($_FILES ["pic"] ["tmp_name"]);
+  // генерим имя файла - md5 + размер
+  $fname = md5 ($s).strlen ($s).".png";
+  // пишем файл в каталог
+  file_put_contents ($path.$fname,$s);
+  // возвращаем xml со ссылкой на картинку
+  echo "<?xml version=\"1.0\" ?>\n";
+  echo "<picture link=\"".$linkpath.$fname."\"></picture>\n";
+ }
+?>

server/readme.txt

+Для развёртывания скрипта нужно:
+
+1. Создать каталог для скриншотов, доступный из Web;
+2. Прописать Web-путь и путь в файловой системе в load.php;
+3. Скопировать подготовленный load.php в web-каталог; путь к нему прописать в настройки клиентской программы.
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.