Her er den fulde source!
Jeg ved det kan virke lidt uoverskueligt men ... kig på det...
Conf-filen skal existere for at de virker, men man kan bare udfylde default-configurationen i koden, og skrive end conf-filen
På forhånd tak fordi i gad at kigge på det..
Option Explicit \'Sets that all variables has to be declared/dimensioned
Dim strLocalRoot As String
Dim strRemoteRoot As String
Dim logName As String
Dim strUsername As String
Dim strPassword As String
Dim strRemoteServer As String
Dim findString As String
Dim replaceString As String
Dim indexDate As Date
Dim waitDate As Date
Dim nextIndexDate As Date
Dim lngPauseSeconds As Long
Dim logOn As Boolean
Dim firstTime As Boolean
Dim blnRun As Boolean
Private Sub Form_Load()
\' The program tests if it should install/uninstall it self as a service, or if it have a bad input
If Command = \"-install\" Then
If NTService1.Install = True Then
MsgBox NTService1.DisplayName & \" installed!\", vbOKOnly
Else
MsgBox NTService1.DisplayName & \" not installed!\", vbOKOnly
End If
End
ElseIf Command = \"-uninstall\" Then
If NTService1.Uninstall = True Then
MsgBox NTService1.DisplayName & \" uninstalled!\", vbOKOnly
Else
MsgBox NTService1.DisplayName & \" not uninstalled!\", vbOKOnly
End If
End
ElseIf Command <> \"\" Then
MsgBox \"Bad input!\", vbOKOnly
End
End If
\' ... otherwise it starts it starts the service
NTService1.StartService
\' default configuration (get overritten by the conf-file)
strLocalRoot = \"c:\\testdir\"
strRemoteRoot = \"/testdir\"
logName = \"c:\\AUploadLog\" & Replace(Replace(Replace(Replace(Replace(CStr(Now), \" \", \"\"), \"/\", \"\"), \"\\\", \"\"), \":\", \"\"), \"-\", \"\") & \".txt\"
lngPauseSeconds = 3600
strUsername = \"MyUserName\"
strPassword = \"MyPassword\"
strRemoteServer = \"
www.theremoteserver.com\" firstTime = True
blnRun = True
logOn = False
findString = \"FindThisString\"
replaceString = \"AndReplaceItWithThis\"
nextIndexDate = Now
\' neverending loop
While True = True
getConfiguration
indexDate = nextIndexDate
nextIndexDate = Now
\' if firstTime = true then the program forces everything in the specified directory else only updates
If firstTime = True Then
firstTime = False
\' forced transfer
traverseFolder strLocalRoot, strRemoteRoot, True, indexDate
Else
\' only updates
traverseFolder strLocalRoot, strRemoteRoot, False, indexDate
End If
\' waiting routine
waitDate = Now
While CLng(DateDiff(\"s\", waitDate, Now)) < lngPauseSeconds And blnRun = True
DoEvents
Wend
DoEvents
Wend
End Sub
Sub traverseFolder(localDir As String, remoteDir As String, forceTransfer As Boolean, controlDate As Date)
Dim objFs, objF, objDir, aFiles, aFolders, objFile, objfolder
Dim intDataDiffLastCreated, intDataDiffLastModified, intDataDiffMaxLastModified As Integer
Dim errorScope As String
Dim tempForceTransfer As Boolean
Dim blnExeptionOccured As Boolean
On Error GoTo traverseFolder_error_handler \' when a error occures the procedure executes the errorhandler specified in the end of the procedure
tempForceTransfer = forceTransfer
blnExeptionOccured = False
\' test for a connection within 600 seconds from program startup, if failure the program stops further uploads and go to sleep
If getConnected(600) = False Then
writeLog Now & \" Servicen kunne ikke få forbindelse til ftp serveren, og venter derfor en periode\"
firstTime = True
Exit Sub
End If
\' errorScope is only used to see where in the procedure an error occures with a simpel description
errorScope = \"Start af TraverseFolder\"
If blnRun = True Then
Set objFs = CreateObject(\"Scripting.FileSystemObject\")
Set objDir = objFs.GetFolder(localDir)
Set objFs = Nothing
errorScope = \"Test om dir findes remote\"
\' testing if the remote directory exists
If Trim(remoteDir) <> \"\" Then
If sendFtpCmd(\"CD \"\"\" & remoteDir & \"\"\"\") <> 0 Then
\' ..if not try to make it
writeLog Now & \" Folderen \" & remoteDir & \" eksisterede ikke, prøver at oprette det\"
If sendFtpCmd(\"MKDIR \"\"\" & remoteDir & \"\"\"\") = 0 Then
writeLog Now & \" Folderen \" & remoteDir & \" blev oprettet\"
tempForceTransfer = True
Else
\' ... else write an error in the log
writeLog Now & \" Folderen \" & remoteDir & \" eksisterede ikke og blev ikke oprettet\"
blnExeptionOccured = True
firstTime = True
End If
End If
End If
\' if wasn\'t created there is no need to try upload the files and subfolders
If blnExeptionOccured = False Then
Set aFiles = objDir.Files
errorScope = \"Gennemløb af filer\"
\' for each file in the current local directory
For Each objFile In aFiles
\' ... find how many seconds ago the file last were modified or created
intDataDiffLastCreated = CLng(DateDiff(\"s\", objFile.DateCreated, Now))
intDataDiffLastModified = CLng(DateDiff(\"s\", objFile.DateLastModified, Now))
\' .. and find the number of seconds since bigenning of the previous run to compare it to
intDataDiffMaxLastModified = CLng(DateDiff(\"s\", controlDate, Now) + 30)
\' if the file has been created or modified since the start of the previous run (or the force boolean is true) upload the file
If intDataDiffLastCreated < intDataDiffMaxLastModified Or intDataDiffLastModified < intDataDiffMaxLastModified Or tempForceTransfer = True Then
sendFile localDir & \"\\\" & objFile.Name, remoteDir & \"/\" & objFile.Name
DoEvents
End If
Next
Set aFiles = Nothing
errorScope = \"Gennemløb af foldere\"
Set aFolders = objDir.Subfolders
Set objDir = Nothing
\' for each folder in the current local directory
For Each objfolder In aFolders
\' ... do the same as were done to the current local directory
traverseFolder localDir & \"\\\" & objfolder.Name, remoteDir & \"/\" & objfolder.Name, tempForceTransfer, controlDate
Next
Set aFolders = Nothing
End If
End If
DoEvents
Exit Sub
traverseFolder_error_handler:
writeLog Now & \" Error \" & Err.Number & Err.Description
writeLog Now & \" \" & \"traverseFolder_error_handler, errorScope=\" & errorScope
writeLog Now & \" \'\" & remoteDir & \"\'\"
firstTime = True
End Sub
Sub sendFile(sourceFile As String, destinationFile As String)
Dim objFs, objFSource, objFDestination, strSourceContent, strSourceContentRep
Dim errorScope As String
On Error GoTo sendFile_error_handler \' u know what this means
\' .. this too
errorScope = \"Start af funktion\"
If blnRun = True Then
\' copy the relevant file in to a temporary file
Set objFs = CreateObject(\"Scripting.FileSystemObject\")
objFs.CopyFile sourceFile, sourceFile & \"_temp\", True
SetAttr sourceFile & \"_temp\", vbNormal
errorScope = \"Replacement i fil indhold\"
\' if the relevant file is a text file search and replace the content and then clear and save the content into the temporary file
If InStr(1, sourceFile, \".asp\", vbTextCompare) <> 0 Or InStr(1, sourceFile, \".htm\", vbTextCompare) <> 0 Or InStr(1, sourceFile, \".txt\", vbTextCompare) <> 0 Then
Set objFDestination = objFs.OpenTextFile(sourceFile & \"_temp\", 2, -2)
Set objFSource = objFs.OpenTextFile(sourceFile, 1, 0)
If objFSource.AtEndOfStream <> True Then
strSourceContent = objFSource.ReadAll
Else
strSourceContent = \"\"
End If
If Trim(strSourceContent) <> \"\" Then
strSourceContentRep = Replace(strSourceContent, findString, replaceString, 1, -1, vbTextCompare)
Else
strSourceContentRep = \"\"
End If
objFDestination.Write (strSourceContentRep)
objFDestination.Close
End If
errorScope = \"Afsending af fil\"
\' put the temporary file to the remote server, but use the original name
If sendFtpCmd(\"PUT \"\"\" & sourceFile & \"_temp\" & \"\"\" \"\"\" & destinationFile & \"\"\"\") <> 0 Then
writeLog Now & \" Overførselen \" & sourceFile & \"->\" & destinationFile & \" mislykkedes\"
firstTime = True
End If
\' remove the temporary file
objFs.DeleteFile sourceFile & \"_temp\", 1
DoEvents
End If
DoEvents
Exit Sub
sendFile_error_handler:
writeLog Now & \" Error: \" & Err.Number & Err.Description
writeLog Now & \" \" & \"sendFile_error_handler, errorScope=\" & errorScope
writeLog Now & \" \'\" & destinationFile & \"\'\"
firstTime = True
End Sub
Sub writeLog(strLogginMessage As String)
Dim fs, f
If logOn = True Then
Set fs = CreateObject(\"Scripting.FileSystemObject\")
Set f = fs.OpenTextFile(logName, 8, True)
f.Write (strLogginMessage & vbCrLf)
f.Close
End If
DoEvents
End Sub
Function getConnected(lngTimeOutSeconds As Long)
Dim dateStart As Date
On Error GoTo getConnected_error_handler
dateStart = Now
While CLng(DateDiff(\"s\", dateStart, Now)) < lngTimeOutSeconds And sendFtpCmd(\"PWD\") <> 0
DoEvents
Wend
DoEvents
If sendFtpCmd(\"PWD\") = 0 Then
getConnected = True
Else
getConnected = False
End If
DoEvents
Exit Function
getConnected_error_handler:
writeLog Now & \" Error: \" & Err.Number & \" \" & Err.Description
writeLog Now & \" \" & \"getConnected_error_handler\"
End Function
Function sendFtpCmd(ftpCmd As String)
Dim feedBack As Long
On Error GoTo errorHndl
While Inet1.StillExecuting = True
DoEvents
Wend
\' connect to ftp-server
Inet1.URL = \"
ftp://\" & strRemoteServer
Inet1.UserName = strUsername
Inet1.Password = strPassword
Inet1.Execute , ftpCmd
While Inet1.StillExecuting = True
DoEvents
Wend
feedBack = Inet1.ResponseCode
\' disconnect from ftp-server
Inet1.Execute , \"QUIT\"
sendFtpCmd = feedBack
DoEvents
Exit Function
errorHndl:
writeLog Now & \" Error: \" & \" \" & Err.Number & Err.Description
writeLog Now & \" FTP: \" & CStr(Inet1.ResponseCode) & \" \" & Inet1.ResponseInfo
writeLog Now & \" FTP: \" & ftpCmd & \" failed\"
Err.Clear
sendFtpCmd = 1000
End Function
Sub getConfiguration()
Dim fs, f
Dim strLine As String
Dim strParameter As String
Dim strValue As String
Set fs = CreateObject(\"Scripting.FileSystemObject\")
Set f = fs.OpenTextFile(\"C:\\upload_extranet\\conf.txt\", 1, False)
Set fs = Nothing
Do
strLine = f.ReadLine
If LCase(Trim(strLine)) <> \"end\" Then
strParameter = Mid(strLine, InStr(1, strLine, \"[\") + 1, InStr(1, strLine, \"]\") - InStr(1, strLine, \"[\") - 1)
strValue = Mid(strLine, InStrRev(strLine, \"[\") + 1, InStrRev(strLine, \"]\") - InStrRev(strLine, \"[\") - 1)
Select Case LCase(strParameter)
Case \"strlocalroot\"
strLocalRoot = CStr(strValue)
Case \"strremoteroot\"
strRemoteRoot = CStr(strValue)
Case \"lngpauseseconds\"
lngPauseSeconds = CLng(strValue)
Case \"logon\"
logOn = CBool(strValue)
Case \"logname\"
logName = Replace(CStr(strValue), \"(_DATE_)\", Replace(Replace(Replace(Replace(Replace(CStr(Now), \" \", \"\"), \"/\", \"\"), \"\\\", \"\"), \":\", \"\"), \"-\", \"\"))
Case \"findstring\"
findString = CStr(strValue)
Case \"replacestring\"
replaceString = CStr(strValue)
Case \"username\"
strUsername = CStr(strValue)
Case \"password\"
strPassword = CStr(strValue)
Case \"remoteserver\"
strRemoteServer = CStr(strValue)
End Select
End If
Loop While LCase(Trim(strLine)) <> \"end\"
f.Close
Set f = Nothing
End Sub
Private Sub NTService1_Start(Success As Boolean)
On Error GoTo service_start_error_handler
blnRun = True
Success = True
Exit Sub
service_start_error_handler:
writeLog Now & \" \" & \"service_start_error_handler\"
End Sub
Private Sub NTService1_Stop()
On Error GoTo service_stop_error_handler
blnRun = False
Unload Me
Exit Sub
service_stop_error_handler:
writeLog Now & \" \" & \"service_stop_error_handler\"
End Sub
