VPF::Создание ярлыка для удаленного подключения

vovksextra

Дата 4.10.2010, 12:11 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

Вообщем при помощи RasSetEntryPropertiesW я создал подключение с необходимыми параметрами.

Теперь осталось решить две задачи:

1. Сделать это подключение подключением по умолчанию.
2. Вынести ярлык на рабочий стол....

Нужна реализация под XP и win7.

Или плохо искал или еще кой чего. Но зашел в ступор.

Буду рад за подсказку.

vovksextra

Дата 4.10.2010, 15:12 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

Сам спросил ...сам ответил

По второму пункту нашел быстрое решение http://forum.script-coding.info/viewtopic.php?id=1596 (в win 7 не работает ((( )

2-й пост понравился )

По-поводу первого пункта. Подумаю еще..

Ну вот и все и нашел - спасибо всем )

Windows XP or later: The Remote Access Service (RAS) supports default Internet connections. RAS supports a default Internet connection that is global to the local computer, and in addition, supports a default Internet connection for each user.
The name of the global default Internet connection is stored in the registry below the following registry key:
HKEY_LOCAL_MACHINE\Software\Microsoft\Ras Autodial\Default
The value that stores the name of the connection is:
DefaultInternet
This value is of type REG_SZ.
The global default Internet connection must be configured as a "For all users" connection in the Connections Folder user interface.
The name of the per-user default Internet connection is stored in the registry below the following registry key:
HKEY_CURRENT_USER\Software\Microsoft\Ras Autodial\Default
The value that stores the name of the connection is:
DefaultInternet
This value is of type REG_SZ.

Это сообщение отредактировал(а) vovksextra - 4.10.2010, 22:25

vovksextra

Дата 4.10.2010, 23:40 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

И все же вопрос с ярлыком остается открытым...

vovksextra

Дата 5.10.2010, 09:44 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

Ну вот "родил" создание ярлыка.

Сама функция:

Код


function CreateLinkDesktop(const FName: string): boolean;
const
  CSIDL_CONNECTIONS = $31;
var
  pShell, ShellFolder: IShellFolder;
  spidl: PITEMIDLIST;
  pidl: PITEMIDLIST;
  npidl: PITEMIDLIST;
  PMalloc: IMalloc;
  sName: string;
  EnumIDList: IEnumIDList;
  pceltFetched: ULONG;
  lpName: TStrRet;
  Folder: string;
  li: TLinkInfo;
begin
  result := false;

  try
    SHGetDesktopFolder(ShellFolder);
    SHGetSpecialFolderLocation(0, CSIDL_CONNECTIONS, spidl);
    SHGetMalloc(PMalloc);
    ShellFolder.BindToObject(spidl, nil, IID_IShellFolder, Pointer(pShell));
    pShell.EnumObjects(0, SHCONTF_NONFOLDERS or SHCONTF_FOLDERS, EnumIDList);

    while (EnumIDList.Next(1, pidl, pceltFetched) = S_ok) do
    begin
      pceltFetched := 0;
      lpName.uType := 0;
      pShell.GetDisplayNameOf(pidl, SHGDN_INCLUDE_NONFILESYS, lpName);
      sName := lpName.pOleStr;

      if AnsiCompareText(sName, FName) = 0 then
      begin

        npidl := ILCombine(spidl, pidl);

        Folder := GetSpecialFolderPath(CSIDL_DESKTOPDIRECTORY);
        FillChar(li, SizeOf(li), 0);
        li.ClsID := npidl;
        li.Description := FName;
        li.HotKey := 0;
        li.ShowState := ssMaximized;

        result := CreateLinkEx(FName, Folder, li);

      end;

    end;
  finally
    pMalloc._Release;
    pMalloc := nil;
  end;

end;

Функцию CreateLinkEx, взял отсюда http://svn.softwarepublico.gov.br/trac/cac...ker.pas?rev=633

И еще понадобится

function ILCombine(pidl1, pidl2: PItemIDList): PItemIDList; stdcall; external
'shell32.dll' name 'ILCombine';

Естественно добавить uses ShellApi, shlobj, ActiveX;

Код не причесывал. Небыло времени. Если кто проявит желание оформить все в виде отдельного модуля, будет всем полезно.

Вот еще кой чего

Код


function SetDefaultRemoteConnection(const AName: string; const ADefault:
  boolean): boolean;
var
  Registry: TRegistry;
  FName: string;
begin
  result := false;
  Registry := TRegistry.Create;
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;
    if Registry.OpenKey('Software\Microsoft\RAS AutoDial\Default', true) then
    begin
      if ADefault then
        Registry.WriteString('DefaultInternet', AName)
      else
      begin
        FName := Registry.ReadString('DefaultInternet');
        if FName = AName then
          Registry.DeleteValue('DefaultInternet');
      end;
      Registry.CloseKey;
      result := true;
    end;
  finally
    Registry.Free;
  end;
end;

Это сообщение отредактировал(а) vovksextra - 5.10.2010, 09:48

Maks1509

Дата 5.10.2010, 11:26 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 54
Регистрация: 22.8.2007
Где: г. Тольятти

Репутация: 2
Всего: 5

У меня такой способ, работающий в 2000, XP, Vista, 7:

Код


  function GetNextItemID(pidl: PItemIDList): PItemIDList;
  var
    cb: DWORD;
  begin
    Result := nil;
    if (pidl = nil) then
      Exit;
    cb := pidl.mkid.cb;
    if (cb = 0) then
      Exit;
    pidl := PItemIDList(Cardinal(pidl) + cb);
    if (pidl.mkid.cb <> 0) then
      Result := pidl;
  end;

  //

  function GetPIDSize(pidl: PItemIDList): DWORD;
  begin
    Result := 0;
    if (pidl <> nil) then
    begin
      Result := SizeOf(pidl.mkid.cb);
      while (pidl <> nil) do
      begin
        Inc(Result, pidl.mkid.cb);
        pidl := GetNextItemID(pidl);
      end;
    end;
  end;

  //

  function IsDesktopFolder(pidl: PItemIDList): Boolean;
  begin
    if Assigned(pidl) then
      Result := (pidl.mkid.cb = 0)
    else
      Result := FALSE;
  end;

  //

  function ConcatPIDL(destpidl, srcpidl: PItemIDList): PItemIDList;
  var
    cb1: DWORD;
    cb2: DWORD;
    pmc: IMalloc;
    hr : HRESULT;
  begin
    Result := nil;
    hr := SHGetMalloc(pmc);
    if SUCCEEDED(hr) then
    begin
      cb1 := 0;
      cb2 := 0;
      if Assigned(destpidl) then
      begin
        if not IsDesktopFolder(destpidl) then
          cb1 := GetPIDSize(destpidl) - SizeOf(destpidl^.mkid.cb);
      end;
      if Assigned(srcpidl) then
        cb2 := GetPIDSize(srcpidl);
      Result := pmc.Alloc(cb1 + cb2);
      if Assigned(Result) then
      begin
        if Assigned(destpidl) then
          CopyMemory(Result, destpidl, cb1);
        if Assigned(srcpidl) then
          CopyMemory(Pointer(DWORD(Result) + cb1), srcpidl, cb2);
      end;
      pmc := nil;
    end;
  end;

  //

  procedure CreateShellVpnLink(pszEntry: WideString);
  var
    pMalloc    : IMalloc;
    Desktop    : IShellFolder;
    pidlDesktop: PItemIDList;
    pszPath    : Array [0..MAX_PATH-1] of WideChar;
    pidlConnect: PItemIDList;
    Network    : IShellFolder;
    Items      : IEnumIDList;
    pidl2      : PItemIDList;
    dwFetched  : Cardinal;
    Connection : STRRET;
    ObjectName : WideString;
    pfLink     : IUnknown;
    isLink     : IShellLink;
    ipFile     : IPersistFile;
    pidl3      : PItemIDList;
    szFileName : WideString;
  begin
    CoInitialize(nil);
    try
      // acquire shell's allocator
      if (SHGetMalloc(pMalloc) = S_OK) then
      try
        // acquire shell namespace root folder
        if (SHGetDesktopFolder(Desktop) = S_OK) then
        try
          if (SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidlDesktop) = S_OK) then
          try
            ZeroMemory(@pszPath, SizeOf(pszPath));
            SHGetPathFromIDListW(pidlDesktop, @pszPath);
            if (SHGetSpecialFolderLocation(0, CSIDL_CONNECTIONS, pidlConnect) = S_OK) then
            try
              Desktop.BindToObject(pidlConnect, nil, IID_IShellFolder, Network);
              Network.EnumObjects(0, SHCONTF_NONFOLDERS, Items);
              while (Items.Next(1, pidl2, dwFetched) = S_OK) do
              try
                if (dwFetched > 0) and Assigned(pidl2) then
                try
                  Network.GetDisplayNameOf(pidl2, SHGDN_NORMAL, Connection);
                  ObjectName := Connection.pOleStr;
                  if (lstrcmpiW(@ObjectName[1], @pszEntry[1]) = 0) then
                  try
                    CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IUnknown, pfLink);
                    isLink := pfLink as IShellLink;
                    ipFile := pfLink as IPersistFile;
                    pidl3 := ConcatPIDL(pidlConnect, pidl2);
                    isLink.SetIDList(pidl3);
                    szFileName := FormatW('%s\%s.lnk', [ExcludeTrailingPathDelimiterW(pszPath), pszEntry]);
                    ipFile.Save(@szFileName[1], FALSE);
                    pMalloc.Free(pidl3);
                  finally
                    {
                    pfLink := nil;
                    isLink := nil;
                    ipFile := nil;
                    }
                  end;
                finally
                  pMalloc.Free(pidl2); // release folder
                end;
              finally
              end;
            finally
              Network := nil;
              pMalloc.Free(pidlConnect); // release folder
            end;
          finally
            pMalloc.Free(pidlDesktop); // release folder
          end;
        finally
          Desktop := nil; // release shell namespace root folder
        end;
      finally
        pMalloc := nil; // release shell's allocator
      end;
    finally
      CoUninitialize;
    end;
  end;

vovksextra

Дата 5.10.2010, 11:49 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

Цитата(Maks1509 @ 5.10.2010, 11:26)

У меня такой способ, работающий в 2000, XP, Vista, 7:

Спасибо )

И еще вопрос. Мне нужно послать системное уведомление о том что изменились настройки сетевые. Как это можно реализовать.

Maks1509

Дата 6.10.2010, 16:27 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

Профиль
Группа: Участник
Сообщений: 54
Регистрация: 22.8.2007
Где: г. Тольятти

Репутация: 2
Всего: 5

Хотя нет, поверил на виртуальной машине где установлена Windows 2000, возникает AV при создании ярлыка, не могу найти ошибку в коде, но почему-то кажется что где-то что-то не освобождаю из указателей или как-то связано с деинициализацией COM. Вот код для установки подключения по умолчанию.

Код


function CreateDefault(pszEntryName: WideString): LRESULT;
const
  pszSubKey: LPWSTR = 'SOFTWARE\Microsoft\RAS AutoDial\Default';
  pszValue : LPWSTR = 'DefaultInternet';
  dwDesired: Array [Boolean] of DWORD = (0, KEY_WOW64_64KEY);
var
  dwRet  : DWORD;
  regKey : HKEY;
  cbData : DWORD;
  Dispos : DWORD;
  function IsOnWow64: Boolean;
  var
    IsWow64Process: function(hProcess: THandle; var Wow64Process : BOOL): BOOL; stdcall;
    Wow64Process: BOOL;
  begin
   Result := False;
   IsWow64Process := GetProcAddress(GetModuleHandle(Kernel32), 'IsWow64Process');
   if Assigned(IsWow64Process) then
     if IsWow64Process(GetCurrentProcess, Wow64Process) then
       Result := Wow64Process;
  end;
begin
  Result := 0;
  dwRet := RegCreateKeyExW(HKEY_LOCAL_MACHINE, pszSubKey, 0, nil,
    REG_OPTION_NON_VOLATILE, KEY_WRITE or dwDesired[IsOnWow64], nil, regKey, @Dispos);
  if (dwRet <> ERROR_SUCCESS) then
    dwRet := RegOpenKeyExW(HKEY_LOCAL_MACHINE, pszSubKey, 0, KEY_WRITE or
      dwDesired[IsOnWow64], regKey);
  if (dwRet = ERROR_SUCCESS) then
  begin
    cbData := (lstrlenW(LPWSTR(pszEntryName)) + 1) * SizeOf(WideChar);
    Result := RegSetValueExW(regKey, pszValue, 0, REG_SZ, LPWSTR(pszEntryName),
      cbData);
    RegCloseKey(regKey);
  end;
end;

Это сообщение отредактировал(а) Maks1509 - 6.10.2010, 16:30

vovksextra

Дата 7.10.2010, 00:29 (ссылка)

(нет голосов)

Загрузка ...

Новичок

Профиль
Группа: Участник
Сообщений: 29
Регистрация: 15.2.2008

Репутация: нет
Всего: нет

Цитата(Maks1509 @ 6.10.2010, 16:27)

Вот код для установки подключения по умолчанию.

Ну с этим то я разобрался.

А теперь как сказать системе что я внес изменения в реестр, так что будь добра и прими это к сведению.

А то в реестре параметр изменили, а в открытом окошке где видны сетевые подключения, не видно галочки на том соединении, которое мы сделали по умолчанию.

Только не предлагать искать хендл окна и т.п. )

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| Delphi: Сети \| Следующая тема »