'PAR-ohjelman päivitysskripti, 5.3.2021 - TK

const hae_uusin_malli = true 'koitetaanko hakea uusin versio netistä ennen päivittämistä, älä laita jos haluat käyttää uudempaa kuin jakelussa olevaa mallia
const hae_uusimmat_tilastot = true 'koitetaanko hakea uusimmat tilastotiedostot netistä ennen päivittämistä

const tilastoversiotiedot = "https://par-jarjestelma.fi/resurssit/versiotiedot/tilastoversiot_6.5.txt"
const par_versiotsekki = "https://par-jarjestelma.fi/resurssit/versiotiedot/versio.txt"
const par_uusin_asiakkaanmalli = "https://par-jarjestelma.fi/resurssit/versiotiedot/uusin_tiedosto.txt"
const ikoni_base64 = "https://par-jarjestelma.fi/resurssit/versiotiedot/PARikoni_base64.txt"


dim objFSO
dim nykyinen_kansio, asmallifilu

Set objFSO = CreateObject("Scripting.FileSystemObject")
nykyinen_kansio = objFSO.GetParentFolderName(WScript.ScriptFullName) & "\"

if hae_uusin_malli = true then asmallifilu = hae_asiakkaanmalli(nykyinen_kansio)
if hae_uusimmat_tilastot = true then uusi_tilasto_saatavilla(nykyinen_kansio)

'jos meillä ei ole tiedossa uutta asiakkaanmalli-tiedostoa vieläkään, koitetaan etsiä tuorein nykyisestä kansiosta
if asmallifilu = "" then
	asmallifilu = hae_kansiosta_uusin_malli(nykyinen_kansio)
end if

if asmallifilu <> "" then 'jos meillä on asiakkaanmalli-tiedosto tiedossa
	tee_uusi_parkirjautuminen nykyinen_kansio & "\" & asmallifilu, nykyinen_kansio
end if

msgbox "Valmis"

'/main

'tehdään uusi PAR-kirjautuminen.xlsm -tiedoston ja lopuksi vbs-tiedoston
function tee_uusi_parkirjautuminen(uus_par_filu, polku) 

dim xlobj 'excel-objekti
dim xlbck_ed, xlbck_uu 'tiedosto-objektit
dim polku2

msgbox "tehdään uusi PAR kirjautuminen -tiedosto"

set xlapp = CreateObject("Excel.Application") 'avataan uusi Excel-instanssi
Set xlbck_uu = xlapp.Workbooks.Open(uus_par_filu) 'avataan asiakkaanmalli

xlbck_uu.activate 'aktivoidaan asiakkaanmallitiedosto

'haetaan asetukset edellisestä par kirjautuminen -tiedostosta
xlapp.Run "hae_asetukset_edellisesta"

xlbck_uu.Sheets("asetukset").Range("A1").Value = "1" 'merkitään 1 soluun A1 merkiksi siitä, että kyseessä on nyt kirjautumistiedosto

xlapp.DisplayAlerts = False 'ei kysytä kysymyksiä tallentaessa

xlbck_uu.BuiltinDocumentProperties("Title") = "Versio " & xlbck_uu.Sheets("asetukset").Range("B7") & "." & xlbck_uu.Sheets("asetukset").Range("B8") & "." & xlbck_uu.Sheets("asetukset").Range("B9") 

If Right(polku, 1) <> xlapp.PathSeparator Then polku = polku & xlapp.PathSeparator 'jos polussa ei ole \ -merkkiä lopussa, lisätään se nyt

Tallnimi = polku & xlapp.Sheets("asetukset").Range("B1") 'tallennuspolku ja nimi

polku2 = xlapp.Sheets("asetukset").Range("B11") 'toinen polku, jota käytetään käytössä
If Right(polku2, 1) <> xlapp.PathSeparator Then polku2 = polku2 & xlapp.PathSeparator

xlbck_uu.Sheets("Asetukset").Range("B10").Value = polku2 & ".xltm"
xlbck_uu.SaveAs Tallnimi & ".xltm", 53

'tehdään uusi vbs-tiedosto
tee_vbs_filu polku, polku2

xlapp.run "loppusulku"
end function

'---

'haetaan halutusta kansiosta uusin asiakkaanmalli-tiedosto
function hae_kansiosta_uusin_malli(kansio)
dim filuar, filukur
dim paras_vastine, paras_pvm
dim nyk_pvm

filuar = hae_tiedostolistaus(kansio)

for filukur = lbound(filuar) to ubound(filuar)
	if instr(filuar(filukur),"AsiakkaanMalli ") = 1 then
		nyk_pvm = mid(filuar(filukur),16,19)
		if onko_uusi_pvm_uudempi (paras_pvm, nyk_pvm) = true then
			paras_vastine = filuar(filukur)
			paras_pvm = nyk_pvm
		end if
	end if
next

hae_kansiosta_uusin_malli = paras_vastine

end function

'tehdään vertailu näin hankalasti, kun mallin päiväys voi olla eri muodossa kuin tietokoneen päiväys
function onko_uusi_pvm_uudempi(vanhapvm, uusi_pvm)
dim v_arr, u_arr, arkur

if len(uusi_pvm) <> 19 then exit function 'ei leikitä jos väärän kokoinen päivämäärä uutena
if vanhapvm <> "" then 
		     'vuodet             kuukaudet          päivät             tunnit              minuutit            sekuntit
v_arr = array(mid(vanhapvm,7,4), mid(vanhapvm,4,2), mid(vanhapvm,1,2), mid(vanhapvm,12,2), mid(vanhapvm,15,2), mid(vanhapvm,18,2))
u_arr = array(mid(uusi_pvm,7,4), mid(uusi_pvm,4,2), mid(uusi_pvm,1,2), mid(uusi_pvm,12,2), mid(uusi_pvm,15,2), mid(uusi_pvm,18,2))

	for arkur = lbound(v_arr) to ubound(v_arr)
		'käydään eritelty päiväys kohta kohdalta läpi
		if u_arr(arkur) > v_arr(arkur) then 'uusi on uudempi
			onko_uusi_pvm_uudempi = true
		elseif u_arr(arkur) < v_arr(arkur) then 'uusi on vanhempi
			onko_uusi_pvm_uudempi = false
		end if
	next
	
else 'vanhapäivämäärä on tyhjä, joten uusi voittaa automaattisesti
	onko_uusi_pvm_uudempi = true
end if

end function


Function hae_asiakkaanmalli(kohdekansio)
on error resume next

Dim versiotieto, linkki, tiedosto
dim hae_malli 
Dim filustr, filukur	

dim puolkur

versiotieto = uuden_version_tiedot(par_uusin_asiakkaanmalli)

If versiotieto = "" Then Exit Function
If InStr(versiotieto, ";") = 0 Then Exit Function

tiedosto = Split(versiotieto, ";")(0)
linkki = "" & Split(versiotieto, ";")(1)

hae_asiakkaanmalli = tiedosto

hae_malli = true

filustr = hae_tiedostolistaus(kohdekansio)

for filukur = lbound(filustr) to ubound(filustr)
	
	If LCase(filustr(filukur)) = LCase(tiedosto) Then
		hae_malli = false
		Exit for
	End If
next

If linkki <> "" And hae_malli = true Then
	'MsgBox Find_first_message("ladataan_uusi_tilastotiedosto"), vbInformation, GLOBAL_PAR_OTSIKKO
	
	msgbox "uusi versio löydetty, koitetaan ladataan se"

	If Lataa_tiedosto_www(linkki, kohdekansio & tiedosto) = tiedosto Then
		'onnistui
	End If
End If

End Function

'---

'hae uusimmat tilastotiedostot nykyiseen hakemistoon
Function uusi_tilasto_saatavilla(tilastokansio)
on error resume next

Dim versiotieto, tilastolinkki
dim hae_tilasto 
Dim filustr, filukur	

dim puolkur

versiotieto = uuden_version_tiedot(tilastoversiotiedot)

If versiotieto = "" Then Exit Function
If InStr(versiotieto, ";") = 0 Then Exit Function

filustr = hae_tiedostolistaus(tilastokansio)

'0 = etsivät, 1 = pajat
for puolkur = 0 to 1

	tilastoversio = Split(versiotieto, ";")(0 + puolkur)
	If UBound(Split(versiotieto, ";")) > 1 + puolkur Then
		tilastolinkki = Split(versiotieto, ";")(2 + puolkur)
	End If

	hae_tilasto = true

	for filukur = lbound(filustr) to ubound(filustr)
		
		If LCase(filustr(filukur)) = LCase(tilastoversio) Then
			hae_tilasto = false
			Exit for
		End If
	next
	'msgbox tilastolinkki & ", " & tilastokansio & ", " &  tilastoversio

	If tilastolinkki <> "" And hae_tilasto = true Then
		'MsgBox Find_first_message("ladataan_uusi_tilastotiedosto"), vbInformation, GLOBAL_PAR_OTSIKKO
		msgbox "Uudempi tilastotiedosto " & iif(puolkur = 0, "ET", "TY") & " on olemassa, koitetaan ladataan se"
		If Lataa_tiedosto_www(tilastolinkki, tilastokansio & tilastoversio) = uusi_tilasto_saatavilla Then
			'onnistui
		End If
	End If

next

End Function


'lataa pyydetty tiedosto urlin perusteella
Function Lataa_tiedosto_www(url, kohdetiedosto)
on error resume next

Dim WinHttpReq
Dim ostream 

Set WinHttpReq = CreateObject("MSXML2.ServerXMLHTTP")

WinHttpReq.Open "GET", url, False
WinHttpReq.send

If WinHttpReq.status = 200 Then
    Set ostream = CreateObject("ADODB.Stream")
    ostream.Open
    ostream.Type = 1
    ostream.Write WinHttpReq.responsebody
    ostream.SaveToFile kohdetiedosto, 2 ' 1 = no overwrite, 2 = overwrite
    ostream.Close
End If

Lataa_tiedosto_www = CStr(Split(kohdetiedosto, "\")(UBound(Split(kohdetiedosto, "\"))))

End Function


'hakee annetun linkin vastauksen
Function uuden_version_tiedot(linkki)
on error resume next
	Dim oHttp
     
    Set oHttp = CreateObject("MSXML2.ServerXMLHTTP")
    
    oHttp.Open "GET", linkki, False
    oHttp.send
    
    If oHttp.status >= 400 And oHttp.status <= 599 Then
        uuden_version_tiedot = ""
        
    Else
        uuden_version_tiedot = oHttp.responsetext
    End If


End Function



'tekee tiedostolistauksen array-muotoon halutusta kansiosta
Function hae_tiedostolistaus(inputDirectoryToScanForFile)

dim fso, files, folder
Dim filuar(), arkur
Dim strfile

Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(inputDirectoryToScanForFile)
Set files = folder.Files

'strfile = Dir(inputDirectoryToScanForFile & "*" & filenameCriteria)


ReDim filuar(0)
    
arkur = 0
for each filu in files
    
    ReDim Preserve filuar(arkur)
    filuar(arkur) = filu.name
    arkur = arkur + 1
    
next

hae_tiedostolistaus = filuar

End Function

'tehdään PAR kirjatuminen.vbs -tiedosto. Se tehdään tässä tapauksessa nykyiseen kansioon, mutta itse pikakuvake voi osoittaa muualle
Sub tee_vbs_filu(kohdekansio, polku) 'toiminto luo uuden PAR-kirjatuminen.vbs -tiedoston
dim fso
Dim koodi 
Dim versio
Dim filu, filuobj

'DoEvents
versio = "1.3"
filu = kohdekansio & "PAR kirjautuminen.vbs"
Set fso = CreateObject("Scripting.FileSystemObject")

tee_filu = True


    koodi = "'" & versio & Chr(13)
    
    '1.3 koodi.
    koodi = koodi & "Dim PAR_versio, paivita, scriptdir, khakem, tpoyta, xlbook, xlapp" & Chr(13) & _
            "   PAR_versio = """ & Now() & """" & Chr(13) & _
            "   TMP_kansio = """ & Replace(Replace(Replace(polku, ":", ""), "\", ""), "/", "") & """" & Chr(13) & _
            "   on error resume next" & Chr(13) & _
            "   Set fso = CreateObject(""Scripting.Filesystemobject"")" & Chr(13) & _
            "   Set objWShell = CreateObject(""WSCript.shell"")" & Chr(13) & _
            "   khakem = objWShell.expandEnvironmentStrings(""%APPDATA%"") & ""\PAR""" & Chr(13) & _
            "   tpoyta = objWShell.SpecialFolders(""Desktop"")" & Chr(13) & _
            "   'oletetaan, että tätä ajetaan samasta kansiosta, missä PAR kirjautuminenkin on" & Chr(13) & _
            "   scriptdir = fso.GetParentFolderName(WScript.ScriptFullName)" & Chr(13) & _
            "   If fso.FolderExists(khakem) = False Then fso.CreateFolder (khakem)" & Chr(13) & _
            "   If fso.FolderExists(khakem & ""\"" & TMP_kansio) = False Then fso.CreateFolder (khakem & ""\"" & TMP_kansio)" & Chr(13) & _
            "   khakem = khakem & ""\"" & TMP_kansio" & Chr(13) & _
            "   paivita = teehae_versiotxt(khakem, PAR_versio, fso)" & Chr(13) & _
            "   If paivita = True Then 'kopiodaan par kirjautuminen -tiedosto myös" & Chr(13) & _
            "       If fso.FileExists(khakem & ""\PAR kirjautuminen.xltm"") = True Then Kill khakem & ""\PAR kirjautuminen.xltm""" & Chr(13) & _
            "       fso.copyfile scriptdir & ""\PAR kirjautuminen.xltm"", khakem & ""\"", True" & Chr(13) & _
            "       'tehdään pikakuvake" & Chr(13) & _
            "       If fso.FileExists(khakem & ""\PAR.ico"") = False Then tee_ikoni khakem, fso, scriptdir" & Chr(13) & _
            "       tee_pikakuvake khakem, scriptdir, tpoyta, TMP_kansio" & Chr(13) & _
            "   End If" & Chr(13)
            
    koodi = koodi & "'käynnistetään kirjautuminen" & Chr(13) & _
            "   set xlapp = CreateObject(""Excel.Application"")" & Chr(13) & _
            "   Set xlbook = xlapp.Workbooks.Open(khakem & ""\PAR kirjautuminen.xltm"")" & Chr(13) & _
            "   xlapp.Visible = True" & Chr(13) & _
            "   on error Resume Next" & Chr(13) & _
            "   xlapp.Run ""auto_open"" 'palauttaa virheilmotuksen, mutta toimii" & Chr(13)

            
    koodi = koodi & "Function teehae_versiotxt(hakemisto, nykversio, fso)" & Chr(13) & _
            "   Dim filu, luo_filu, versio" & Chr(13) & _
            "   If fso.FileExists(hakemisto & ""\versio.txt"") = True Then" & Chr(13) & _
            "       Set filu = fso.opentextfile(hakemisto & ""\versio.txt"", 1, False, -1)" & Chr(13) & _
            "       versio = filu.ReadLine" & Chr(13) & _
            "       filu.Close" & Chr(13) & _
            "       teehae_versiotxt = versio" & Chr(13) & _
            "       If cstr(versio) <> cstr(nykversio) Then" & Chr(13) & _
            "           teehae_versiotxt = True" & Chr(13) & _
            "           luo_filu = True" & Chr(13) & _
            "       Else" & Chr(13) & _
            "           teehae_versiotxt = False" & Chr(13) & _
            "       End If" & Chr(13) & _
            "   Else 'versio-tiedostoa ei löydy" & Chr(13) & _
            "       teehae_versiotxt = True" & Chr(13) & _
            "       luo_filu = True" & Chr(13) & _
            "   End If" & Chr(13) & _
            "   If luo_filu = True Then" & Chr(13) & _
            "       Set filu = fso.createTextFile(hakemisto & ""\versio.txt"", True, True)" & Chr(13) & _
            "       filu.writeline (nykversio)" & Chr(13) & _
            "       filu.Close" & Chr(13) & _
            "   End If" & Chr(13) & _
            "End Function" & Chr(13)
            
            'tee pikakuvake
    koodi = koodi & "Sub tee_pikakuvake(appdatahakemisto, etaasema, tpoyta, appdata_hakem_lisa)" & Chr(13) & _
            "   Set oWS = WScript.CreateObject(""WScript.Shell"")" & Chr(13) & _
            "   Set linkki = oWS.CreateShortcut(tpoyta & ""\PAR ("" & appdata_hakem_lisa & "").lnk"")" & Chr(13) & _
            "   linkki.TargetPath = etaasema & ""\PAR kirjautuminen.vbs""" & Chr(13) & _
            "   linkki.IconLocation = appdatahakemisto & ""\PAR.ico""" & Chr(13) & _
            "   linkki.Save" & Chr(13) & _
            "End Sub" & Chr(13)
            
            'tee_ikoni
    koodi = koodi & "Sub tee_ikoni(hakemisto, fso, verkkohakem)" & Chr(13) & _
            "   Dim outputFile" & Chr(13) & _
            "   outputFile = hakemisto & ""\PAR.ico""" & Chr(13) & _
            "   If fso.FileExists(outputFile) = False Then 'ei tehdä ikonia, jos se on jo olemassa" & Chr(13) & _
            "       if fso.FileExists(verkkohakem & ""\Ikoni\PAR.ico"") = true then" & Chr(13) & _
            "           fso.copyfile verkkohakem & ""\Ikoni\PAR.ico"", hakemisto & ""\"", True" & Chr(13) & _
            "       else 'koetetaan hakea ikonidata netistä" & Chr(13) & _
            "           Set oXML = CreateObject(""Msxml2.DOMDocument"")" & Chr(13) & _
            "           Set oNode = oXML.CreateElement(""base64"")" & Chr(13) & _
            "           oNode.DataType = ""bin.base64""" & Chr(13) & _
            "           oNode.text = anna_ikonin_data" & Chr(13) & _
            "           If oNode.text <> """" Then" & Chr(13) & _
            "               Set BinaryStream = CreateObject(""ADODB.Stream"")" & Chr(13) & _
            "               BinaryStream.Type = 1 'adTypeBinary" & Chr(13) & _
            "               BinaryStream.Open" & Chr(13) & _
            "               BinaryStream.Write oNode.nodeTypedValue" & Chr(13) & _
            "               BinaryStream.SaveToFile outputFile" & Chr(13) & _
            "           End If" & Chr(13) & _
            "       End If" & Chr(13) & _
            "   End If" & Chr(13) & _
            "End Sub" & Chr(13)
            
            'anna ikonin data
    koodi = koodi & "Function anna_ikonin_data()" & Chr(13) & _
            "   Dim url, req" & Chr(13) & _
            "   url = """ & ikoni_base64 & """" & Chr(13) & _
            "   Set req = CreateObject(""MSXML2.ServerXMLHTTP"") " & Chr(13) & _
            "   req.Open ""GET"", url, False" & Chr(13) & _
            "   req.send" & Chr(13) & _
            "   If req.status = 200 Then" & Chr(13) & _
            "       anna_ikonin_data = req.responseText" & Chr(13) & _
            "   End If" & Chr(13) & _
            "End Function'"
			
Set filuobj = fso.createTextFile(filu, True, True)
filuobj.write koodi
filuobj.Close

end sub