Problema com Criação de Pasta

Boa tarde, eu tenho um código em que se abre um Dialog e se a pasta existe ela se abre dentro de um servidor e se não exister tal diretório cria se uma pasta no diretório designado. Porém só abre no diretório certo quando já tem a pasta criada e não cria outra quando abro com outro fornecedor.

Segue o Código:

dir:=''\\\\\\\\adsorocaps\\\\sis\\\\fornecedores\\\\''+idfornecedor+pasta;
OpenDialog1.InitialDir:=dir;
if OpenDialog1.Execute then
begin
if not DirectoryExists(dir)then
begin
if not CreateDir(dir) then
begin
ForceDirectories(dir);
end;
if CopyFile(PChar(OpenDialog1.FileName), PChar(dir+ExtractFileName(OpenDialog1.FileName)), True) then
ShowMessage(''Arquivo gravado com sucesso!'');
caminho:=OpenDialog1.FileName;
end;
end;