Hej
Jeg kører et vbs script til at oploade data til en hjemmeside,mit problem er at hver gang scriptet kører popper den xml fil den laver op(lokalt) hvad kan jeg gøre ved det
Scriptet:
'Based on vbsFTP.vbs - FTP upload tool using DOS FTP (DOS window suppressed).
Option Explicit : Dim strDirectory, strFile, FTPaddr, UserName, Password,
ShowSuccess, doFTP, RelPath, Ftpextra, useBBox
strDirectory = "C:\"
strFile = "data.xml"
' Suppress Popup if upload succeeded (True or False, no quotes):
ShowSuccess = True
' Do you want to FTP the file to a website? (True or False, no quotes):
doFTP = True
' Do you want to restrict the output to the screen lat/long?
useBBox = False
' You only need to set these values if you have doFTP = True
' FTP address for your web site, eg "ftp.myISP.com"
FTPaddr = "xxxxx"
' FTP username for your site:
UserName = "xxxxx"
' FTP password for your site:
Password = "xxxxx"
' subdirectory on FTP site to put data.xml file
RelPath = ""
' Extra command to send to ftp server, eg "passive"
Ftpextra = ""
writexml()
Dim Title, fso, f, ck, ws, InFile, ftp, OutFile
Dim arOutLines, IconType, MsgTimer, Sent, errFTP
If doFTP Then
Title = "vbShip"
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
InFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
Set ftp = fso.OpenTextFile(InFile, 2, True)
OutFile = fso.GetSpecialFolder(2) & "\" & fso.GetTempName
arOutlines = Array()
FTPfile()
End If
WScript.Quit
'---------Functions----------
Function tidy(sData)
Dim l, s, pos, valid, out
' We dont want to allow <>'"!
valid =
"abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890:*.,;()+-=@#/?
"
out = ""
for l = 1 To Len(sData)
s = Mid(sData, l, 1)
pos = InStr(valid, s)
If pos = 0 Then
s = " "
End If
out = out & s
Next
tidy = Trim(out)
End Function
Function myround(f, dp)
Dim out
out = Round(f, dp)
myround = Replace(out, ",", ".", 1, 1)
End Function
'---------Subs----------
Sub writexml()
' Option Explicit
Dim objFSO, objFolder, objTextFile, objFile
' Create the File System Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
' Check that the strDirectory folder exists
If objFSO.FolderExists(strDirectory) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFolder = objFSO.CreateFolder(strDirectory)
End If
If objFSO.FileExists(strDirectory & strFile) Then
Set objFolder = objFSO.GetFolder(strDirectory)
Else
Set objFile = objFSO.CreateTextFile(strDirectory & strFile)
Wscript.Echo "Just created " & strDirectory & strFile
End If
set objFile = nothing
set objFolder = nothing
' OpenTextFile Method needs a Const value
' ForAppending = 8 ForReading = 1, ForWriting = 2
Set objTextFile = objFSO.OpenTextFile(strDirectory & strFile, 2, True)
Dim i, shipinfo, MyObject, ais, xml
Dim mmsi, lat, lon, name, aistype, imo, callsign, dest, eta, speed, course,
status, length, width, draft, mtime
Dim deltax, deltay, scale, angle
Dim maxlat, minlat, maxlon, minlon, doShip
Set MyObject = GetObject(,"ShipPlotter.Document")
maxlat = MyObject.GetMaxLat()
minlat = MyObject.GetMinLat()
maxlon = MyObject.GetMaxLon()
minlon = MyObject.GetMinLon()
objTextFile.WriteLine "<markers>"
i = 0
while i < MyObject.GetShipCount()
' GetShipData(long mmsi, short datafield) - VARIANT - get a data
parameter for the ship with the given MMSI number. The type of the returned
value depends on the value of the datafield argument. Permitted values for
the datafield argument are :
'0 name (BSTR)
'1 latitude (double)
'2 longitude (double)
'3 course (float)
'4 speed (float)
'5 heading (float)
'6 rot (dummy) (float)
'7 status (uchar)
'8 accuracy (dummy)(uchar)
'9 type (uchar)
'10 draught (float)
'11 length (short)
'12 destination (BSTR)
'13 call sign (BSTR)
'14 IMO number (ulong)
'15 ETA (BSTR)
'16 beam (short)
'17 length for’ard of the GPS mast (short)
'18 width to port of the GPS mast (short)
'19 date and time of last report (BSTR)
mmsi = MyObject.GetShipMMSI(i)
lat = MyObject.GetShipData(mmsi, 1)
lon = MyObject.GetShipData(mmsi, 2)
doShip = True
If useBBox And (lon < minlon Or lon > maxlon Or _
lat < minlat Or lat > maxlat) Then
doShip = False
End if
lat = myround(lat, 3)
lon = myround(lon, 3)
name = tidy(MyObject.GetShipData(mmsi, 0))
aistype = MyObject.GetShipData(mmsi, 9)
imo = MyObject.GetShipData(mmsi, 14)
callsign = tidy(MyObject.GetShipData(mmsi, 13))
dest = tidy(MyObject.GetShipData(mmsi, 12))
eta = tidy(MyObject.GetShipData(mmsi, 15))
speed = MyObject.GetShipData(mmsi, 4)
course = MyObject.GetShipData(mmsi, 3)
status = MyObject.GetShipData(mmsi, 7)
length = MyObject.GetShipData(mmsi, 11)
width = MyObject.GetShipData(mmsi, 16)
draft = MyObject.GetShipData(mmsi, 10)
mtime = MyObject.GetShipData(mmsi, 19)
ais = mmsi & "!" _
& imo & "!" _
& callsign & "!" _
& dest & "!" _
& eta & "!" _
& speed & "!" _
& course & "!" _
& status & "!" _
& length & "!" _
& width & "!" _
& draft & "!" _
& mtime
If speed > 0.1 And speed < 80 Then
scale = 3 * speed / 1.9438445 / 1000 ' knots -> m/s
angle = course / 180 * 3.14159
deltax = myround(scale * Sin(angle), 3)
deltay = myround(scale * Cos(angle), 3)
Else
deltax = 0
deltay = 0
End if
xml = "<marker lat='" & lat & "' lon='" & lon & _
"' name='" & name & "' dx='" & deltax & "' dy='" & deltay _
& "' type='" & aistype & "' ais='" & ais & "'/>"
If doShip Then
objTextFile.WriteLine xml
End If
i = i + 1
wend
objTextFile.WriteLine "</markers>"
objTextFile.Close
' Bonus or cosmetic section to launch explorer to check file
If err.number = vbEmpty then
If ShowSuccess Then
Dim objShell
Set objShell = CreateObject("WScript.Shell")
objShell.run ("Explorer" &" " & strDirectory & strFile )
End If
Else
WScript.echo "VBScript Error: " & err.number
End If
End Sub
Sub FTPfile()
WriteScript() 'Write the FTP script
'Upload the file
ws.Run "%comspec% /c ftp -i -s:" & InFile & " >" & OutFile, 0, True
GetResults() ' Results of transfer
' Report failure or success
If ShowSuccess Then
ws.Popup Join(arOutLines, vbcrlf), MsgTimer, Title, IconType
Else
If errFTP Then
ws.Popup Join(arOutLines, vbcrlf), MsgTimer, Title, IconType
End If
End If
Cleanup() 'Release objects and exit
End Sub
Sub WriteScript()
Dim i, Trans
With ftp
.WriteLine "open " & FTPaddr
.WriteLine UserName
.WriteLine Password
.WriteLine "bell"
If RelPath <> "" Then .WriteLine "cd " & chr(34) & RelPath & chr(34)
.WriteLine "ascii"
If Ftpextra <> "" Then .WriteLine Ftpextra
.WriteLine "put " & chr(34) & strDirectory & strFile & chr(34)
.WriteLine "close"
.WriteLine "bye"
.Close
End With
End Sub
Sub GetResults()
Dim i, OutPut, ThisLine
errFTP = False
IconType = 64
MsgTimer = 3
ReDim Preserve arOutLines(0)
arOutLines(0) = Title & vbcrlf & vbcrlf & "ERROR DURING UPLOAD: " & vbcrlf
i = 0
Set OutPut = fso.OpenTextFile(OutFile, 1)
Do While Not OutPut.AtEndOfStream
ThisLine = OutPut.ReadLine
'FTP error codes are 4xx or 5xx
If CStr(Left(ThisLine, 1)) = CStr(4) Or CStr(Left(ThisLine, 1)) = CStr(5)
Then
i = i + 1
ReDim Preserve arOutLines(i)
arOutLines(i) = ThisLine
errFTP = True
IconType = 48 + 4096
MsgTimer = 0
End If
Loop
OutPut.Close
If errFTP Then
i = i + 1
ReDim Preserve arOutLines(i)
arOutLines(i) = "File(s) not uploaded:" & vbcrlf
Else
ReDim Preserve arOutLines(0)
arOutLines(0) = Title & vbcrlf & vbcrlf & _
"File(s) uploaded successfully:" & vbcrlf
End If
End Sub
Sub Cleanup()
On Error Resume Next
fso.DeleteFile InFile, True
fso.DeleteFile OutFile, True
Set fso = Nothing
Set ws = Nothing
Set ftp = Nothing
Erase arOutlines
WScript.Quit
End Sub
|