Base Code: by Ekkehard.Horner & adapted by me
I
found
the
code,
thanks all. Dim oShell, frequency, sFile
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim oSrcDir : Set oSrcDir = goFS.GetFolder("C:\Temp1")
Dim sDstDir : sDstDir = "C:\Temp2"
Dim oFile, nInc, sNFSpec
Set oShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("C:\Temp1")
Set fc = f.Files
frequency = 10 * 1000
Const cnMax = 99
WScript.Sleep frequency
theDate = Year(Now()) _
& Right(String(2,"0") & month(Now()),2) _
& Right(String(2,"0") & Day(Now()),2)
For Each f1 in fc
If right(lcase(f1.name),4) = ".pdf" then
theBaseName = fso.GetBaseName(f1.name)
theExtension = fso.GetExtensionName(f1.Name)
f1.Move(fso.GetParentFolderName(f1.path) & "\" & theBaseName & "_" & EID & "_" & theDate & "." & theExtension)
End If
Next
For Each oFile In oSrcDir.Files
If right(lcase(oFile.name),4) = ".pdf" Then
nInc = 0
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Do While goFS.FileExists(sNFSpec) And nInc <= cnMax
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Loop
If nInc > cnMax Then
Else
oFile.Move sNFSpec
End If
End If
Next
Wend
}
Dim oShell, frequency, sFile
Dim goFS : Set goFS = CreateObject("Scripting.FileSystemObject")
Dim oSrcDir : Set oSrcDir = goFS.GetFolder("C:\Temp1")
Dim sDstDir : sDstDir = "C:\Temp2"
Dim oFile, nInc, sNFSpec
Set oShell = CreateObject("WScript.Shell")
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFolder("C:\Temp1")
Set fc = f.Files
frequency = 10 * 1000
Const cnMax = 99
WScript.Sleep frequency
theDate = Year(Now()) _
& Right(String(2,"0") & month(Now()),2) _
& Right(String(2,"0") & Day(Now()),2)
For Each f1 in fc
If right(lcase(f1.name),4) = ".pdf" then
theBaseName = fso.GetBaseName(f1.name)
theExtension = fso.GetExtensionName(f1.Name)
f1.Move(fso.GetParentFolderName(f1.path) & "\" & theBaseName & "_" & EID & "_" & theDate & "." & theExtension)
End If
Next
For Each oFile In oSrcDir.Files
If right(lcase(oFile.name),4) = ".pdf" Then
nInc = 0
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Do While goFS.FileExists(sNFSpec) And nInc <= cnMax
sNFSpec = getNewFSpec(oFile.Name, sDstDir, nInc)
Loop
If nInc > cnMax Then
Else
oFile.Move sNFSpec
End If
End If
Next
Wend
}
The most simple solution would be to run your task from another script which itself run "forever" (an abstraction).
Dim oShell, frequency, sFile
Set oShell = CreateObject("WScript.Shell")
frequency = 10 * 1000 '10 Seconds (just for example)
sFile = "task.vbs" 'the script you want to run
While True 'make infinite cycle
WScript.Sleep frequency
oShell.Run sFile
Wend
The solution Panayot Karabakalov proposed could also be integrated into the existing script:
'...
While True
For Each oFile In oSrcDir.Files
'...
Next
WScript.Sleep 30000 'milliseconds
Wend
'...
Another variant would be to use an unconditional Do ... Loop instead of While True ... Wend:
'...
Do
For Each oFile In oSrcDir.Files
'...
Next
WScript.Sleep 30000 'milliseconds
Loop
'...
Related
I`m having a problem with the connection from the client to the server. when more than 4 people from the same ip try to connect to the server the client start flashing and you have to end the process from the task manager . And also if can be setup how many clients per device .. Thanks
This is a 2d mmorpg game called Xiaspora . The game will not be used for generating money its just for fun with my friends and their friends .
Client winsock
Dim Reconnect As Boolean
Sub Connect()
Dim serveraddress As String
Dim serverport As String
If Start.Client.State = 0 Then
ReadInfoText serveraddress, serverport
Start.Client.Connect serveraddress, serverport
End If
End Sub
Sub Disconnect()
Start.ConnectTestTimer.Enabled = False
AddPrivChatText 3, "Disconnected... Attempting to Reconnect"
If Reconnect = True Then
Start.Client.Close
Start.Client.Connect
Else
CloseProgram
End If
End Sub
Sub SendMessage(Message As String)
If Start.Client.State = 7 Then
Start.Client.SendData Message & Chr(13)
End If
End Sub
Sub SendChatMessage(Message As String)
Dim check As Integer
Dim checkmessage As String
If Len(Message) = 0 Then Exit Sub
If Mid(Message, 1, 4) = ":g::" Then
SendMessage "4," & Message
Exit Sub
End If
If Mid(Message, 1, 4) = ":G::" Then
SendMessage "4," & Message
Exit Sub
End If
checkmessage = Mid(Message, 1, 30)
Do
check = check + 1
If Mid(checkmessage, check, 2) = "::" Then Exit Do
Loop Until check = Len(checkmessage)
If check = Len(checkmessage) Then
SendMessage "4," & Message
Else
SendMessage "5," & Mid(Message, 1, check - 1) & "," & Mid(Message, check + 2)
End If
End Sub
Sub SetReloginTrue()
Reconnect = True
End Sub
Sub SetReloginFalse()
Reconnect = False
End Sub
Function Relogin() As Boolean
Relogin = Reconnect
End Function
Option Explicit
Dim intWCount As Integer 'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
'WriteSub "Winsock-addserverlogtext" & Message
If Len(Main.ServerLogText.Text) > 15000 Then
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Mid(Main.ServerLogText.Text, 1, 14000)
Else
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Main.ServerLogText.Text
End If
End Sub
Sub StartServer()
Dim ThePort As String
ReadInfoText ThePort
Main.Server(0).LocalPort = ThePort
Main.Server(0).Listen
AddServerLogText "Server Now Running on Port " & ThePort
End Sub
Sub CloseCon(Index As Integer)
On Error Resume Next
If Index = 0 Then Exit Sub
LogOutProcedure Index
WriteSub "Winsock-closecon"
Main.Server(Index).Close
Unload Main.EngageTimer(Index)
AddServerLogText Index & ": Closed"
PacketCheck(Index) = 0
End Sub
Sub ConnectionRequestCon(ByVal requestID As Long)
On Error Resume Next
Dim check As Integer
Dim LoggedOn As Integer
Dim NewIndex As Integer
Dim RandomCheck As Integer
NewIndex = GetFreeIndex
LogOutProcedure NewIndex
RandomizeConLandLaunch NewIndex
Load Main.Server(NewIndex)
Load Main.EngageTimer(NewIndex)
Main.Server(NewIndex).Accept requestID
AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
RandomCheck = RandomNumber(1000, 30000)
SetConAuthNumber NewIndex, RandomCheck
Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
DoEvents
Do
check = check + 1
If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
Loop Until check = Main.Server.Count
If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
WriteSub "Winsock-getfreeindex"
On Error Resume Next
Dim check As Long
For check = 1 To Main.Server.Count
If Main.Server(check).State <> 9 Then
Main.Server(check).Close
GetFreeIndex = check
Exit Function
End If
If check > Main.Server.Count Then
GetFreeIndex = Main.Server.Count + 1
Exit Function
End If
Next
intWCount = intWCount + 1
GetFreeIndex = intWCount
End Function
Sub GetDataCon(Index As Integer)
WriteSub "Winsock-getdatacon"
Dim themax As Integer
Dim ndata As String
Dim check As Integer
Dim curloc As Integer
Main.Server(Index).GetData ndata
Dim num As Integer
num = FreeFile
Open "lastpack.txt" For Output As num
Print #num, Date & " " & Time & " " & ndata
Close num
themax = MaxPack(ndata)
Do
check = check + 1
PacketCheck(Index) = PacketCheck(Index) + 1
If PacketCheck(Index) = 50 Then
CloseCon Index
Exit Sub
End If
If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata, curloc)
Loop Until check >= themax
If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
WriteSub "Winsock-privmsg"
On Error GoTo FuCK
If ToCon = 0 Then Exit Sub
If Main.Server(ToCon).State = 7 Then
If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " & Message 'Only During Problems
If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " & Message ' If you have problems
'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
Main.Server(ToCon).SendData Message & Chr(13)
DoEvents
End If
Exit Sub
FuCK:
AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
Dim check As Integer
Do
check = check + 1
If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
If PacketCheck(check) < 0 Then PacketCheck(check) = 0
Loop Until check >= Main.Server.Count
End Sub
Server Winsock
Option Explicit
Dim intWCount As Integer 'Number of winsocks in the array
Dim PacketCheck(3200) As Integer
Sub AddServerLogText(Message As String)
'WriteSub "Winsock-addserverlogtext" & Message
If Len(Main.ServerLogText.Text) > 15000 Then
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Mid(Main.ServerLogText.Text, 1, 14000)
Else
Main.ServerLogText.Text = Date & " " & Time & " " & Message & vbCrLf & Main.ServerLogText.Text
End If
End Sub
Sub StartServer()
Dim ThePort As String
ReadInfoText ThePort
Main.Server(0).LocalPort = ThePort
Main.Server(0).Listen
AddServerLogText "Server Now Running on Port " & ThePort
End Sub
Sub CloseCon(Index As Integer)
On Error Resume Next
If Index = 0 Then Exit Sub
LogOutProcedure Index
WriteSub "Winsock-closecon"
Main.Server(Index).Close
Unload Main.EngageTimer(Index)
AddServerLogText Index & ": Closed"
PacketCheck(Index) = 0
End Sub
Sub ConnectionRequestCon(ByVal requestID As Long)
On Error Resume Next
Dim check As Integer
Dim LoggedOn As Integer
Dim NewIndex As Integer
Dim RandomCheck As Integer
NewIndex = GetFreeIndex
LogOutProcedure NewIndex
RandomizeConLandLaunch NewIndex
Load Main.Server(NewIndex)
Load Main.EngageTimer(NewIndex)
Main.Server(NewIndex).Accept requestID
AddServerLogText NewIndex & ": Connected [" & Main.Server(NewIndex).RemoteHostIP & "]"
RandomCheck = RandomNumber(1000, 30000)
SetConAuthNumber NewIndex, RandomCheck
Main.Server(NewIndex).SendData "1,Welcome To Xiaspora - " & TotalLogedInUsers & " Users Online" & Chr(13) & "34," & RandomCheck & Chr(13)
DoEvents
Do
check = check + 1
If Main.Server(check).State = 7 And Main.Server(check).RemoteHostIP = Main.Server(NewIndex).RemoteHostIP Then LoggedOn = LoggedOn + 1
Loop Until check = Main.Server.Count
If LoggedOn >= 6 Then CloseCon NewIndex
End Sub
Function GetFreeIndex() As Integer
WriteSub "Winsock-getfreeindex"
On Error Resume Next
Dim check As Long
For check = 1 To Main.Server.Count
If Main.Server(check).State <> 9 Then
Main.Server(check).Close
GetFreeIndex = check
Exit Function
End If
If check > Main.Server.Count Then
GetFreeIndex = Main.Server.Count + 1
Exit Function
End If
Next
intWCount = intWCount + 1
GetFreeIndex = intWCount
End Function
Sub GetDataCon(Index As Integer)
WriteSub "Winsock-getdatacon"
Dim themax As Integer
Dim ndata As String
Dim check As Integer
Dim curloc As Integer
Main.Server(Index).GetData ndata
Dim num As Integer
num = FreeFile
Open "lastpack.txt" For Output As num
Print #num, Date & " " & Time & " " & ndata
Close num
themax = MaxPack(ndata)
Do
check = check + 1
PacketCheck(Index) = PacketCheck(Index) + 1
If PacketCheck(Index) = 50 Then
CloseCon Index
Exit Sub
End If
If PacketCheck(Index) < 20 Then CheckMode Index, ReadPackS(ndata, curloc)
Loop Until check >= themax
If themax > 1 Then PacketCheck(Index) = PacketCheck(Index) - 1
End Sub
Sub PrivMsg(ToCon As Integer, Message As String)
WriteSub "Winsock-privmsg"
On Error GoTo FuCK
If ToCon = 0 Then Exit Sub
If Main.Server(ToCon).State = 7 Then
If GetConDebug(ToCon) = True Then AddServerLogText ToCon & ": Snt - " & Message 'Only During Problems
If GetConDebugFull(ToCon) = True Then WriteDebugLog ToCon, "Snt - " & Message ' If you have problems
'AddServerLogText ToCon & ": Snt - " & Message '--Temp Debug Purposes
Main.Server(ToCon).SendData Message & Chr(13)
DoEvents
End If
Exit Sub
FuCK:
AddServerLogText ToCon & ": Snt - ERROR ERROR ERROR " & Message
LogOutProcedure ToCon
End Sub
Sub PacketCheckReduce()
Dim check As Integer
Do
check = check + 1
If PacketCheck(check) > 0 Then PacketCheck(check) = PacketCheck(check) - 2
If PacketCheck(check) < 0 Then PacketCheck(check) = 0
Loop Until check >= Main.Server.Count
End Sub
I am having problems on recursing through the outlook mail folders.
Function listsubfolders(folParent)
'If folParent.Folders.count = 0 Then
'WScript.Echo folParent.name
'Else
For Each subfolder In folParent.Folders
tempstr = folParent.name & ">" & listsubfolders(subfolder)
WScript.Echo tempstr
Next
'End If
End Function
Here is an example how to list all subfolders into folder using recursion.
Option Explicit
Dim fso,ws,RootFolder,LogFile
Set fso = CreateObject("Scripting.FileSystemObject")
Set ws = CreateObject("WScript.Shell")
LogFile = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "txt"
If fso.FileExists(LogFile) Then
fso.DeleteFile(LogFile)
End If
Set RootFolder = fso.GetFolder(Browse4Folder())
Call ListSubFolders(RootFolder)
ws.run DblQuote(LogFile)
'**********************************************************************************************
Sub ListSubFolders(Folder)
Dim Subfolder
Set Folder = fso.GetFolder(Folder)
For Each Subfolder in Folder.SubFolders
Call WriteLog(Subfolder.Path)
Call ListSubFolders(Subfolder.Path) 'Call Recursive Sub
Next
End Sub
'**********************************************************************************************
Sub WriteLog(strText)
Dim fs,ts,LogFile
Const ForAppending = 8
LogFile = Left(Wscript.ScriptFullName, InstrRev(Wscript.ScriptFullName, ".")) & "txt"
Set fs = CreateObject("Scripting.FileSystemObject")
Set ts = fs.OpenTextFile(LogFile,ForAppending,True)
ts.WriteLine strText
ts.Close
End Sub
'**********************************************************************************************
Function Browse4Folder()
Dim objShell,objFolder,Message
Message = "Please select a folder in order to scan into it and its subfolders"
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0,Message,1,"c:\Programs")
If objFolder Is Nothing Then
Wscript.Quit
End If
Browse4Folder = objFolder.self.path
end Function
'**********************************************************************************************
Function DblQuote(Str)
DblQuote = Chr(34) & Str & Chr(34)
End Function
'**********************************************************************************************
I have created a Form in MSAccess 2010 and when running I am getting following error :
The select statement includes a reserved word or an argument name that is misspelled or missing, or the punctuation is incorrect.
The name of my Database is Accessexp
Here is my code:
Private Sub SearchButton_Click()
Dim dbs As Database
Dim rs As Recordset
Dim qdf As QueryDef
Dim productName As String
Dim lastNQuarters As String
Dim strSql As String
Dim columns As String
Dim compstr As String
Dim curstr As String
Dim timestr As String
Dim tablestr As String
Dim sumstr As String
Dim varItem As Variant
Dim compcount As Integer
Dim colcount As Integer
Dim errorcount As Integer
Dim Monthvalue As String
Set dbs = CurrentDb()
errorcount = 0
colcount = 0
lastNQuarters = Me!quarterbox.Value
tablestr = ""
timestr = Me!Monthbox.Value
MsgBox (timestr)
tablestr = "Q" & lastNQuarters
For Each varItem In Me!columnlist.ItemsSelected
If Me!columnlist.ItemData(varItem) <> "---" Then
columns = columns & "," & Chr(34) & Me!columnlist.ItemData(varItem) & Chr(34)
colcount = colcount + 1
End If
Next varItem
compcount = 0
For Each varItem In Me!practicelist.ItemsSelected
compstr = compstr & "," & Chr(34) & Me!practicelist.ItemData(varItem) & Chr(34)
compcount = compcount + 1
Next varItem
If compcount = 0 Then MsgBox ("Warning: No Practice Selected"): errorcount = errorcount + 1
If colcount = 0 Then MsgBox ("Warning: No Practice Selected"): errorcount = errorcount + 1
If errorcount = 0 Then
lastNQuarters = Me!quarterbox.Value
strSql = "Select " & columns & ", " & tablestr & " from Accessexp where Accessexp.[Quarter] = " & tablestr & " and Accessexp.[Month] = " & timestr & ";"
MsgBox (strSql)
Set rs = dbs.OpenRecordset(strSql, dbOpenSnapshot)
With dbs
Set qdf = .CreateQueryDef("QueryOutput", strSql)
DoCmd.OpenQuery "QueryOutput"
.QueryDefs.Delete "QueryOutput"
End With
dbs.Close
qdf.Close
End If
End Sub
My query is coming like this :
Select ,"Revenue Blended","Revenue Direct" Q4
from Accessexp
where Accessexp.[Quarter] = Q4 and Accessexp.[Month] = April;
Is there any other way to seperate values with commas and not putting in begining
After you've built your string with the leading comma just use
columns = Mid(columns, 2)
to trim off the first character.
Other notes:
Wrap your column names in square brackets, not double quotes
String literals need to be enclosed in quotes.
Your resulting query string should look more like this:
Select [Revenue Blended],[Revenue Direct]
from Accessexp
where Accessexp.[Quarter] = 'Q4' and Accessexp.[Month] = 'April';
Try this updated Code.
Private Sub SearchButton_Click()
Dim dbs As Database, rs As Recordset
Dim qdf As QueryDef
Dim productName As String, lastNQuarters As String
Dim strSql As String, columns As String, compstr As String
Dim curstr As String, timestr As String, tablestr As String
Dim sumstr As String, varItem As Variant
Dim compcount As Integer, colcount As Integer, errorcount As Integer
Dim Monthvalue As String
Set dbs = CurrentDb()
errorcount = 0
colcount = 0
lastNQuarters = Me!quarterbox.Value
tablestr = ""
timestr = Me!Monthbox.Value
MsgBox timestr
tablestr = "Q" & lastNQuarters
For Each varItem In Me!columnlist.ItemsSelected
If Me!columnlist.ItemData(varItem) <> "---" Then
columns = columns & "[" & Me!columnlist.ItemData(varItem) & "],"
colcount = colcount + 1
End If
Next
compcount = 0
For Each varItem In Me!practicelist.ItemsSelected
compstr = compstr & "[" & Me!practicelist.ItemData(varItem) & "],"
compcount = compcount + 1
Next
If compcount = 0 Then
MsgBox ("Warning: No Practice Selected")
errorcount = errorcount + 1
Else
compstr = Left(compstr, Len(compstr)-1)
End If
If colcount = 0 Then
MsgBox ("Warning: No Practice Selected")
errorcount = errorcount + 1
Else
columns = Left(columns, Len(columns)-1)
End If
If errorcount = 0 Then
lastNQuarters = Me!quarterbox.Value
strSql = "SELECT " & columns & " FROM Accessexp WHERE Accessexp.[Quarter] = '" & tablestr & "'" & _
" AND Accessexp.[Month] = '" & timestr & "';"
MsgBox (strSql)
Set rs = dbs.OpenRecordset(strSql, dbOpenSnapshot)
With dbs
Set qdf = .CreateQueryDef("QueryOutput", strSql)
DoCmd.OpenQuery "QueryOutput"
'.QueryDefs.Delete "QueryOutput"
End With
dbs.Close
qdf.Close
End If
End Sub
How to modify a VB script to archive event logs? I found one VB script working just fine to archive event logs to a network share folder, but I am not sure where to modify the VB script to:
Only collect system, application and security logs not all logs
How to make these archive logs with month, date and year and save them to the same folder daily and not overwrite them.
You need to change this line ("Select * from Win32_NTEventLogFile") Example
("Select * from Win32_NTEventLogFile where LogFileName='Application'")
Add in filter for the logs you wish to backup see http://social.technet.microsoft.com/Forums/scriptcenter/en-US/febbb896-e7fb-42c6-9b1b-6f3e3b293b22/event-viewer-log-script-only-working-for-application-event-log
OR
http://www.activexperts.com/activmonitor/windowsmanagement/scripts/logs/event/
This should help you.
See the following altered code for your requirements, will output required logs and save to a different folder each day.
VBS
Dim strComputer, objDir2
Dim current: current = Now
Dim strDateStamp: strDateStamp = dateStamp(current)
strComputer = "YourServer"
objDir2 = "Your File Server Path" & strDateStamp
Dim objDir1: objDir1 = "\\" & strComputer & "\c$\EVT"
clearEVTLogs = "No"
Set filesys=CreateObject("Scripting.FileSystemObject")
If Not filesys.FolderExists(objDir1) Then
createDir(objDir1)
If Not filesys.FolderExists(objDir2) Then
createDir(objDir2)
End If
strPath = objDir2 & "\"
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate, (Backup, Security)}!\\" _
& strComputer & "\root\cimv2")
Set colLogFiles = objWMIService.ExecQuery _
("Select * from Win32_NTEventLogFile where LogFileName='Application' Or LogFileName='Security' Or LogFileName='System'")
For Each objLogfile In colLogFiles
strCopyFile = strDateStamp & "_" & strComputer & "_" _
& objLogFile.LogFileName & ".evt"
strBackupFile = "c:\EVT\" & strDateStamp & "_" _
& strComputer & "_" & objLogFile.LogFileName & ".evt"
strBackupLog = objLogFile.BackupEventLog _
(strBackupFile)
Call copyAFile(objDir1, strPath, strCopyFile)
If clearEVTLogs = "Yes" Then
objLogFile.ClearEventLog()
End If
Next
Function dateStamp(ByVal dt)
Dim y, m, d
y = Year(dt)
m = Month(dt)
If Len(m) = 1 Then m = "0" & m
d = Day(dt)
If Len(d) = 1 Then d = "0" & d
dateStamp = y & m & d
End Function
Function copyAFile( Byval strSourceFolder, Byval strTargetFolder, _
Byval strFileName)
Dim objFSO, booOverWrite, strResult
Set objFSO = CreateObject( "Scripting.FileSystemObject")
If objFSO.FileExists( strSourceFolder & "\" & strFileName) _
And UCase( strSourceFolder) <> UCase( strTargetFolder) Then
If objFSO.FolderExists( strTargetFolder) Then
Else
strResult = "The destination folder does not exist!"
'copyAFile = strResult
Exit Function
End If
If objFSO.FileExists( strTargetFolder & "\" & strFileName) Then
strResult = "The file exists, overwritten"
booOverWrite = vbTrue
Else
strResult = "The file does not exist, created"
booOverWrite = vbFalse
End If
objFSO.CopyFile strSourceFolder & "\" _
& strFileName, strTargetFolder & "\", booOverWrite
Else
strResult = "The source file does not exist, or " _
& "identical Source and Target folders!"
End If
End Function
Function createDir(strDir)
Set filesys=CreateObject("Scripting.FileSystemObject")
Set objFSO = CreateObject("Scripting.FileSystemObject")
wscript.echo strDir
If Not filesys.FolderExists(strDir) Then
Set objFolder = objFSO.CreateFolder(strDir)
End If
End Function
Would I just use MSXML and import as binary? Or is there another more efficient way?
There are gigs and gigs of JPEGs to fetch.
I have written something in the past, the code below will save remote image on the server disk. It's classic ASP and pretty efficient:
<%
Const CONTENT_FOLDER_NAME = "StoredContents"
Dim strImageUrl
strImageUrl = "http://www.gravatar.com/avatar/8c488f9c3d3da5bb756507179a3d53fd?s=32&d=identicon&r=PG"
Call SaveOnServer(strImageUrl, "bill_avatar.jpg")
Sub SaveOnServer(url, strFileName)
Dim strRawData, objFSO, objFile
Dim strFilePath, strFolderPath, strError
strRawData = GetBinarySource(url, strError)
If Len(strError)>0 Then
Response.Write("<span style=""color: red;"">Failed to get binary source. Error:<br />" & strError & "</span>")
Else
strFolderPath = Server.MapPath(CONTENT_FOLDER_NAME)
Set objFSO = Server.CreateObject("Scripting.FileSystemObject")
If Not(objFSO.FolderExists(strFolderPath)) Then
objFSO.CreateFolder(strFolderPath)
End If
If Len(strFileName)=0 Then
strFileName = GetCleanName(url)
End If
strFilePath = Server.MapPath(CONTENT_FOLDER_NAME & "/" & strFileName)
Set objFile = objFSO.CreateTextFile(strFilePath)
objFile.Write(RSBinaryToString(strRawData))
objFile.Close
Set objFile = Nothing
Set objFSO = Nothing
Response.Write("<h3>Stored contents of " & url & ", total of <span style=""color: blue;"">" & LenB(strRawData) & "</span> bytes</h3>")
Response.Write("<a href=""" & CONTENT_FOLDER_NAME & "/" & strFileName & """ target=""_blank""><span style=""color: blue;"">" &_
strFileName & "</span></a>")
End If
End Sub
Function RSBinaryToString(xBinary)
''# Antonin Foller, http://www.motobit.com
''# RSBinaryToString converts binary data (VT_UI1 | VT_ARRAY Or MultiByte string)
''# to a string (BSTR) using ADO recordset
Dim Binary
'' #MultiByte data must be converted To VT_UI1 | VT_ARRAY first.
If vartype(xBinary)=8 Then Binary = MultiByteToBinary(xBinary) Else Binary = xBinary
Dim RS, LBinary
Const adLongVarChar = 201
Set RS = CreateObject("ADODB.Recordset")
LBinary = LenB(Binary)
If LBinary>0 Then
RS.Fields.Append "mBinary", adLongVarChar, LBinary
RS.Open
RS.AddNew
RS("mBinary").AppendChunk Binary
RS.Update
RSBinaryToString = RS("mBinary")
Else
RSBinaryToString = ""
End If
End Function
Function MultiByteToBinary(MultiByte)
''# © 2000 Antonin Foller, http://www.motobit.com
''# MultiByteToBinary converts multibyte string To real binary data (VT_UI1 | VT_ARRAY)
''# Using recordset
Dim RS, LMultiByte, Binary
Const adLongVarBinary = 205
Set RS = CreateObject("ADODB.Recordset")
LMultiByte = LenB(MultiByte)
If LMultiByte>0 Then
RS.Fields.Append "mBinary", adLongVarBinary, LMultiByte
RS.Open
RS.AddNew
RS("mBinary").AppendChunk MultiByte & ChrB(0)
RS.Update
Binary = RS("mBinary").GetChunk(LMultiByte)
End If
MultiByteToBinary = Binary
End Function
Function GetBinarySource(url, ByRef strError)
Dim objXML
Set objXML=Server.CreateObject("Microsoft.XMLHTTP")
GetBinarySource=""
strError = ""
On Error Resume Next
objXML.Open "GET", url, False
objXML.Send
If Err.Number<>0 Then
Err.Clear
Set objXML = Server.CreateObject("MSXML2.ServerXMLHTTP")
objXML.Open "GET", url, False
objXML.Send
If Err.Number<>0 Then
strError = "Error " & Err.Number & ": " & Err.Description
Err.Clear
Exit Function
End If
End If
On Error Goto 0
GetBinarySource=objXML.ResponseBody
Set objXML=Nothing
End Function
Function GetCleanName(s)
Dim result, x, c
Dim arrTemp
arrTemp = Split(s, "/")
If UBound(arrTemp)>0 Then
For x=0 To UBound(arrTemp)-1
result = result & GetCleanName(arrTemp(x)) & "_"
Next
result = result & GetPageName(s)
Else
For x=1 To Len(s)
c = Mid(s, x, 1)
If IsValidChar(c) Then
result = result & c
Else
result = result & "_"
End If
Next
End If
Erase arrTemp
GetCleanName = result
End Function
Function IsValidChar(c)
IsValidChar = (c >= "a" And c <= "z") Or (c >= "A" And c <= "Z") Or (IsNumeric(c))
End Function
Function GetPageName(strUrl)
If Len(strUrl)>0 Then
GetPageName=Mid(strUrl, InStrRev(strUrl, "/")+1, Len(strUrl))
Else
GetPageName=""
End If
End Function
%>
Just call SaveOnServer sub routine passing the URL and desired file name, you can also omit the file name and in that case, the file name will be taken from the URL itself.
The server folder is defined as constant and will be in the same place as .asp file.
Here is the gist of how to download and save files in script:-
Function DownloadAndSave(sourceUrl, destinationFile)
Dim req : Set req = CreateObject("WinHttp.WinHttpRequest.5.1")
req.Open "GET", sourceUrl, false
req.Send
Dim stream : Set stream = CreateObject("ADODB.Stream")
stream.Type = 1 ''# adTypeBinary
stream.Open
stream.Write req.ResponseBody
stream.SaveToFile destinationFile, 2
stream.Close
End Function