Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long
Private Sub XpB5_Click()
On Error GoTo oshibka
Dim FileNum As Integer
Dim txt As String
Dim ncftp As String
ncftp = "C:\Program Files\NcFTP\ncftpput.exe"
FileNum = FreeFile
txt = "@ECHO OFF" + vbCrLf
txt = txt + "set archive=" + """C:\obmen\archive\""" + vbCrLf
txt = txt + "set obmen=" + """C:\obmen\zayav\""" + vbCrLf
txt = txt + "set tempfld=" + """C:\obmen\temp\""" + vbCrLf
txt = txt + "set dd=%DATE:~0,2%" + vbCrLf
txt = txt + "set mm=%DATE:~3,2%" + vbCrLf
txt = txt + "set yyyy=%DATE:~8,2%" + vbCrLf
txt = txt + "set imya=%dd%%mm%%yyyy%" + vbCrLf
txt = txt + "IF NOT EXIST %obmen%zayav.dbf goto end" + vbCrLf
txt = txt + "copy %obmen%zayav.dbf %tempfld%lenina%imya%(1).dbf" + vbCrLf
txt = txt + "ECHO !!!!!ОТПРАВЛЯЮТСЯ ФАЙЛЫ!!!!!!!!!!!!ОТПРАВЛЯЮТСЯ ФАЙЛЫ!!!!!!" + vbCrLf
If Check1.Value =  1  Then
txt = txt + """" & ncftp & """ -F -u celitel -p echo. 91.210.0.0 /zayav C:\obmen\temp\lenina%imya%(1).dbf" + vbCrLf
End If
If Check2.Value =  1  Then
txt = txt + """" & ncftp & """ -F -u celitel -p echo. 91.205.0.0 /zayav C:\obmen\temp\lenina%imya%(1).dbf" + vbCrLf
End If
txt = txt + "If errorlevel 1 ECHO !!!!!ЗАЯВКА НЕ ОТПРАВЛЕНА ПРОВЕРЬТЕ ИНТЕРНЕТ!!!!!!!! & goto end2" + vbCrLf
txt = txt + "del %tempfld%*.* /q" + vbCrLf
txt = txt + "cls" + vbCrLf
txt = txt + "ECHO !!!ЗАКАЗ ОТПРАВЛЕН УСПЕШНО!!!!" + vbCrLf
txt = txt + "ECHO !!!СЕЙЧАС ЗАЯВКА БУДЕТ ДОБАВЛЕНА В АРХИВ!!!!" + vbCrLf
txt = txt + "ECHO !!!!!НАЖМИТЕ ЛЮБУЮ КНОПКУ!!!!" + vbCrLf
txt = txt + "pause" + vbCrLf
txt = txt + "copy %obmen%zayav.dbf %archive%os%imya%.dbf" + vbCrLf
txt = txt + "goto :EOF" + vbCrLf
txt = txt + ":end" + vbCrLf
txt = txt + "ECHO !!!!!НЕТ ЗАЯВКИ ДЛЯ ОТПРАВКИ!!!!!!" + vbCrLf
txt = txt + "pause" + vbCrLf
txt = txt + "goto :EOF" + vbCrLf
txt = txt + ":end2" + vbCrLf
txt = txt + "del %tempfld%*.* /q" + vbCrLf
txt = txt + "pause" + vbCrLf
txt = txt + "del c:\obmen\obmen.bat /q"
   
OutputStr$ = Space$(Len(txt)) ' ВНИМАНИЕ НА ЭТУ СТРОЧКУ
code& = CharToOem(txt, OutputStr$)  '
'Print code&: Print txt: Print OutputStr$
   
Open "c:\obmen\text.txt" For Output As FileNum
Print #FileNum, OutputStr$
Close #FileNum

FileCopy "c:\obmen\text.txt", "c:\obmen\obmen.bat"
Kill ("C:\obmen\text.txt")
'Shell "cmd /c C:\obmen\obmen.bat"

ShellExecute  0 , vbNullString, "C:\obmen\obmen.bat", _
      vbNullString, vbNullString, vbNormalFocus
 Exit Sub
oshibka:

message2 = MsgBox("НЕТ НАСТРОЕК", vbOKOnly, "ОШИБКА")
 Exit Sub
            
End Sub

Option Explicit
' API
Private Declare Function CharToOem Lib "user32" Alias "CharToOemA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function OemToChar Lib "user32" Alias "OemToCharA" (ByVal lpszSrc As String, ByVal lpszDst As String) As Long
Private Declare Function ShellExecute Lib "shell32.dll" _
    Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
    ByVal lpOperation As String, _
    ByVal lpFile As String, _
    ByVal lpParameters As String, _
    ByVal lpDirectory As String, _
    ByVal nShowCmd As Long) As Long
'*******************************************************************
Private Sub Form_Load()
' используем для файлов
Dim fso As Scripting.FileSystemObject, ts As TextStream
Dim txt As String
Dim savefolder As String, dmaster As String, ncftp As String
Dim mydate As Date
Dim OutputStr As String, code As Integer
Dim s As Shell
'*******************************************************************
' используем shell
' не забываем подключить Microsoft shell controls
' открываем диск С
Set s = New Shell
s.Explore ("C:\")
Set s = Nothing
'*******************************************************************
mydate = Date -  1 
'*******************************************************************
savefolder = "C:\Downloads\"
txt = ""
'*******************************************************************
dmaster = "C:\Program Files\Download Master\dmaster.exe"
txt = "@ECHO OFF" + vbCrLf
' подставляем вчерашнюю дату в ваш url
txt = txt + """" + dmaster + """ http://cbr.ru/scripts/XML_daily.asp?date_req=" + Str(mydate) + " savepath= """ _
+ savefolder + """  filename=XML_daily_1.asp" + vbCrLf
txt = txt + "ECHO !!!!!Ждем конца закачки файла!!!!" + vbCrLf
txt = txt + "pause" + vbCrLf
txt = txt + "If errorlevel 1 ECHO !!!!!ФАЙЛ НЕ ЗАКАЧЕН!!!!!!!! & goto end" + vbCrLf
txt = txt + "call ncftp.bat" + vbCrLf
txt = txt + ":end" + vbCrLf
txt = txt + "pause"
'*******************************************************************
OutputStr = Space$(Len(txt)) ' ВНИМАНИЕ НА ЭТУ СТРОЧКУ
code = CharToOem(txt, OutputStr)
'*******************************************************************
' не забываем подключить Microsoft Scripting Runtime
Set fso = New Scripting.FileSystemObject
Set ts = fso.OpenTextFile("c:\dmaster.txt", ForWriting, True)
' записываем в файл
ts.Write OutputStr
'закрываем файл
ts.Close
Set ts = Nothing
fso.CopyFile "C:\dmaster.txt", "C:\dmaster.bat"
fso.DeleteFile "C:\dmaster.txt", True
'*******************************************************************
txt = ""
ncftp = "C:\Program Files\NcFTP\ncftpput.exe"
'*******************************************************************
txt = "@ECHO OFF" + vbCrLf
' ftpaddress - ваш адрес ftp
' ftpfolder - папка на ftp куда будете записывать файл
' localfolder - папка па вашем компе (например С:\downloads)
' localfile - файл который хотите записать (например dmaster.exe)
txt = txt + """" & ncftp & """ -F -u login -p password ftpaddress /ftpfolder localfolder\localfile" + vbCrLf
txt = txt + "If errorlevel 1 ECHO !!!!!ФАЙЛ НЕ ЗАКАЧЕН!!!!!!!!" + vbCrLf
'*******************************************************************
OutputStr = Space$(Len(txt)) ' ВНИМАНИЕ НА ЭТУ СТРОЧКУ
code = CharToOem(txt, OutputStr)
'*******************************************************************
' не забываем подключить Microsoft Scripting Runtime
Set fso = New Scripting.FileSystemObject
Set ts = fso.OpenTextFile("c:\ncftp.txt", ForWriting, True)
' записываем в файл
ts.Write OutputStr
'закрываем файл
ts.Close
fso.CopyFile "C:\ncftp.txt", "C:\ncftp.bat"
fso.DeleteFile "C:\ncftp.txt", True
'*******************************************************************
Set ts = Nothing
Set fso = Nothing
'запускаем bat файл
'ShellExecute 0, vbNullString, "C:\dmaster.bat", _
      'vbNullString, vbNullString, vbNormalFocus
End Sub

FUNCTION SymChange$ (Text$, NewCode$, OldCode$)
'
'  Перекодировка символов  OldCode$ -> NewCode$:
'  в переменной Text$ все символы набора OldCode$
'  заменяются на соответствующие символы набора NewCode$
'
'  ВНИМАНИЕ!
'  Должно выполняться условие:  LEN(NewCode$)=LEN(OldCode$)
'——————————————-
     Sym$ = Text$: Ltext% = LEN(Text$)
     IF Ltext% >  0  THEN
       FOR i% =  1  TO Ltext%
         k% = INSTR(OldCode$, MID$(Text$, i%,  1 ))
         IF k% >  0  THEN 
           MID$(Sym$, i%,  1 ) = MID$(NewCode$, k%,  1 )
         END IF
       NEXT i%
     END IF
     SymChange$ = Sym$
END FUNCTION