Transliteration("http://serversql:81/RS_SPID/Pages/ReportViewer.aspx?%2fСправкаЕкатeринбург%2fActTbc&rs:Format=PDF&rs:Command=Render&date1=1990-01-01&date2=2015-01-01&terr=Алапаевск")

USE [hiv_data]
GO
/****** Object:  StoredProcedure [dbo].[repsave]    Script Date: 04/08/2013 15:06:36 ******/
SET ANSI_NULLS ON
GO
SET QUOTED_IDENTIFIER ON
GO

ALTER PROCEDURE [dbo].[repsave](@filename as nvarchar(max), @reportpath as nvarchar(max),@params as nvarchar(max))
AS
begin
SET NOCOUNT ON

declare @tempFileName as nvarchar(max)
select @tempFileName='test'+replace(cast(cast(getdate()as decimal(11,5))  as nvarchar(max)),'.','_')+'.rss'
declare @tempPar as nvarchar(max)
declare @comm1 as varchar(3000)
declare @comm2 as varchar(3000)

select @tempPar='Public Sub Main()
	Dim format as string = "PDF"
	Dim fileName as String = "'+@filename+'.pdf"
	Dim reportPath as String = "'+@reportpath+'"
	Dim historyID as string = Nothing
	Dim deviceInfo as string = Nothing
	Dim extension as string = Nothing
	Dim encoding as string
	Dim mimeType as string
	Dim warnings() AS Warning = Nothing
	Dim streamIDs() as string = Nothing
	Dim results() as Byte
	Dim execInfo As New ExecutionInfo
	Dim execHeader As New ExecutionHeader()
	Dim SessionId As String
	Dim credentials As DataSourceCredentials() = Nothing
	Dim showHideToggle As String = Nothing
	Dim reportHistoryParameters As ParameterValue() = Nothing
	'+ @params +'
	rs.ExecutionHeaderValue = execHeader
	execInfo = rs.LoadReport(reportPath, historyID)
	rs.SetExecutionParameters(parameters, "en-us")
	SessionId = rs.ExecutionHeaderValue.ExecutionID
	results = rs.Render(format,  deviceInfo, extension, mimeType, encoding,  warnings, streamIDs)
	execInfo = rs.GetExecutionInfo()
	Dim stream  As FileStream = File.OpenWrite(fileName)
	stream.Write(results, 0, results.Length)
	stream.Close()

	End Sub'
	
	EXEC	hiv_data.[dbo].[spWriteStringToFile] @tempPar,'c:\test',@tempFileName
	select @comm1='rs -i c:\test\'+@tempFileName+' -s http://192.168.0.2:81/rs_spid -e exec2005 -u ***  -p ***'
	select @comm2='del c:\test\'+@tempFileName
	EXEC xp_cmdshell @comm1,no_output 

	EXEC xp_cmdshell @comm2 ,no_output 
	end

Private Sub Кнопка7_Click()
Dim cmd As ADODB.Command
Dim p As ADODB.Parameter
Dim rst As Recordset
Dim con As ADODB.Connection
Dim ctext As String
Dim param As String

Set con = New ADODB.Connection
Set p = New ADODB.Parameter
Set cmd = New ADODB.Command
Set arst = New ADODB.Recordset

con.Open ("Provider=Microsoft.Access.OLEDB.10.0;Persist Security Info=true;Data Source=***;User ID=***;password=***;Initial Catalog=***;Data Provider=SQLOLEDB.1;Language=english;App=trash")

cmd.ActiveConnection = con
cmd.CommandTimeout = 3000
cmd.CommandType = adCmdText
ProgressBar1.Min = 1
ProgressBar1.Visible = True
DoEvents

If Поле0 = "000000" Then
ctext = "SELECT dbo_ACTUAL_TERR_UCHET.kod6 FROM (spis2 LEFT JOIN PD ON spis2.pid = PD.PID) LEFT JOIN dbo_ACTUAL_TERR_UCHET ON PD.First_pid = dbo_ACTUAL_TERR_UCHET.pid " & _
" WHERE (((spis2.Ddiagn) >= #" & Format(Поле2, "mm\/dd\/yyyy") & "# And (spis2.Ddiagn) <= #" & Format(Поле4, "mm\/dd\/yyyy") & "#)) " & _
" GROUP BY dbo_ACTUAL_TERR_UCHET.kod6"
Debug.Print ctext
Set rst = CodeDb.OpenRecordset(ctext, dbOpenDynaset, dbSeeChanges)
If rst.RecordCount > 0 Then
Dim i As Integer
rst.MoveLast
        
ProgressBar1.Max = rst.RecordCount + 1
ProgressBar1.Value = 1
        
For i = 1 To rst.RecordCount
ProgressBar1.Value = ProgressBar1.Value + 1
param = ""
param = param & "Dim parameters(2) As ParameterValue" & vbCr
param = param & "parameters(0) = New ParameterValue()" & vbCr
param = param & "parameters(0).NAME = ""terr""" & vbCr
param = param & "parameters(0).Value = """ & rst!kod6 & """" & vbCr
param = param & "parameters(1) = New ParameterValue()" & vbCr
param = param & "parameters(1).NAME = ""d1""" & vbCr
param = param & "parameters(1).Value = """ & Format(Поле2, "mm.dd.yyyy") & """" & vbCr
param = param & "parameters(2) = New ParameterValue()" & vbCr
param = param & "parameters(2).NAME = ""d2""" & vbCr
param = param & "parameters(2).Value =""" & Format(Поле4, "mm.dd.yyyy") & """" & vbCr
text = "EXEC  [dbo].[repsave] 'E:\...\MAIL_LIST\" & rst!kod6 & "_Список_зарегистрированных " & "'" & _
", '/SPID_Reports/REGCGIE','" & param & "'"
Debug.Print ctext
cmd.CommandText = ctext
Set arst = cmd.Execute(, , adAsyncFetch)
DoEvents
rst.MovePrevious
Next i
Else
MsgBox "На указанную дату нет данных."
Exit Sub
End If
Else
ProgressBar1.Max = 1
ProgressBar1.Value = 1
param = ""
param = param & "Dim parameters(2) As ParameterValue" & vbCr
param = param & "parameters(0) = New ParameterValue()" & vbCr
param = param & "parameters(0).NAME = ""terr""" & vbCr
param = param & "parameters(0).Value = """ & Поле0 & """" & vbCr
param = param & "parameters(1) = New ParameterValue()" & vbCr
param = param & "parameters(1).NAME = ""d1""" & vbCr
param = param & "parameters(1).Value = """ & Format(Поле2, "dd.mm.yyyy") & """" & vbCr
param = param & "parameters(2) = New ParameterValue()" & vbCr
param = param & "parameters(2).NAME = ""d2""" & vbCr
param = param & "parameters(2).Value =""" & Format(Поле4, "dd.mm.yyyy") & """" & vbCr
ctext = "EXEC  [dbo].[repsave] 'E:\...\MAIL_LIST\" & Поле0 & "_Список_зарегистрированных " & "'" & _
", '/SPID_Reports/REGCGIE','" & param & "'"
Debug.Print ctext
cmd.CommandText = ctext
Set arst = cmd.Execute()
End If
ProgressBar1.Visible = False
con.Close
End Sub

Private Sub Кнопка7_Click()
Dim full_url As String, strFile_path As String, file_name As String
full_url = "http://serversql:81/RS_SPID?/SPID_Reports/REGCGIE&rc:Parametrs=false&rs:Command=Render&rs:format=PDF" & _
"&d1=" & Format(Поле2, "yyyy-mm-dd") & "&d2=" & Format(Поле4, "yyyy-mm-dd") & "&terr=" & Поле0
DoIt full_url, "\\serversql\SoFT_UPDATES\Clinique_N\MAIL_LIST", Поле0 & "_Список_зарегистрированных.pdf"
MsgBox "Из отчета выгружен файл для:" & Поле0.Column(1)
con.Close

End Sub

Sub DoIt(urlname As String, foldername As String, Filename As String)

    Const adTypeBinary = 1
    Const adSaveCreateNotExist = 1
    Const TemporaryFolder = 2
    Dim oStream ' ADODB.Stream
    Dim oFSO    ' Scripting.FileSystemObject
    Dim xml     ' Microsoft.XMLHTTP
    Dim sURL
    Dim oFil
    Dim sImagePath

    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Set xml = CreateObject("Microsoft.XMLHTTP")
    Set oStream = CreateObject("Adodb.Stream")
     
    sURL = urlname
    sImagePath = foldername & "\" & Filename
    xml.Open "GET", sURL, False
    xml.send

    oStream.type = adTypeBinary
    oStream.Open
    oStream.write xml.responseBody

    oStream.SaveToFile sImagePath, adSaveCreateOverWrite
    oStream.Close
    Set oFil = oFSO.GetFile(sImagePath)
    Set oStream = Nothing
    Set xml = Nothing
    Set oFSO = Nothing
    Set oFil = Nothing
End Sub