Форум программистов [Powered by Invision Power Board]

Код


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;

Код


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;

Код


  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;

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

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

Код


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:27)

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