REM ***** BASIC *****
option explicit
' --------------------------------------------------------------------
' Module "aMain", procédure "sub main"
' pour compatibilité avec mon raccourci clavier (CTRL MAJ M)
' --------------------------------------------------------------------
sub main()
acIncrementSave_v2
end sub
' Définir ici le nom du sous-répertoire des sauvegardes
const SOUS_REP_SAVE = "zxSaveIncr"
' --------------------------------------------------------- 23/08/2009
' Sauvegarder ce document sous un nom composé de :
' <nom_de_ce_doc> + "_" + <numéro_de_sauvegarde>
' --------------------------------------------------------------------
' VERSION 2. - Le numéro de sauvegarde est obtenu ici par
' récupération du numéro de la précédente sauvegarde incrémentée.
' --------------------------------------------------------------------
' DEPENDANCES :
' Fonctions acGetFileExt, acGetFilesList, acDecoupePath, acThisRep
' acCreRep
' --------------------------------------------------------------------
sub acIncrementSave_v2()
dim oDoc as object
dim tArgs(0) as new com.sun.star.beans.PropertyValue
dim sUrl1 as string, sUrl2 as string
dim ficExt as string, ficNom as string
dim repDoc as string, repSauv as string
dim buf as string, cpt as integer
dim iRet as integer, iVersion as integer
' Vérifier l'accès au répertoire des sauvegardes
iRet = acCreRep(acThisRep, SOUS_REP_SAVE)
if iRet = -1 then
msgBox("ECHEC création répertoire """ & SOUS_REP_SAVE & """" _
& "Ce répertoire n'existe pas, et ne peut pas être créé." _
& "Créez-le manuellement avant de recommencer.", 16, _
"#### Fonction acCreRep ####")
exit sub ' >>>>>>> SORTIE >>>>>>>
end if
oDoc = thiscomponent
repDoc = acThisRep
repSauv = repDoc & SOUS_REP_SAVE
ficNom = acGetFileName(oDoc.getUrl)
ficExt = acGetFileExt(oDoc.getUrl)
' Chemin des fichiers déjà sauvegardés, à rechercher
buf = convertFromUrl(repSauv & "/" & ficNom)
' Numéro de la dernière sauvegarde
iVersion = acGetIncrement(buf)
if (iVersion = 0) then
' msgBox("Aucune sauvegarde incrémentée, on part de zéro")
else
' msgBox("Index de la nouvelle sauvegarde : " & iVersion)
end if
sUrl2 = repSauv & "/" & ficNom _
& "_" & cStr(iVersion) & "." & ficExt
oDoc.storeToUrl(sUrl2, tArgs())
msgBox("Document sauvegardé sous " & chr(13) _
& acDecoupePath(convertFromUrl(sUrl2), 50)
end sub
'---------------------------------------------------------- 20/08/2009
' Cherche les fichiers 'nomFic' + "_" + 'valeur'
' Retourne la valeur maxi incrémentée de 1
'---------------------------------------------------------------------
function acGetIncrement(nomFic) as integer
dim bufTmp as string
dim selDeb as integer, selFin as integer
dim iRef as integer, i as integer
dim sNum as string
iRef = -1
nomFic = nomFic & "_*"
bufTmp = dir(nomFic, 0)
do while (len(bufTmp))
'chercher "_" à partir de la fin
for i = len(bufTmp) to 1 step -1
if (mid(bufTmp,i,1) = "_") then
selDeb = i+1
exit for
end if
next i
selFin = instr(selDeb, bufTmp, ".")
sNum = mid(bufTmp,selDeb, selFin-(selDeb-1))
i = val(sNum)
if (i > iRef) then iRef = i
' Au suivant
bufTmp = dir()
loop
acGetIncrement = iRef +1
end function
'---------------------------------------------------------------------
' Vérifier l'accès au répertoire des sauvegardes
'---------------------------------------------------------------------
sub verifSousRep()
dim iRet as integer
iRet = acCreRep(acThisRep, SOUS_REP_SAVE)
if iRet = -1 then
msgBox("ECHEC création répertoire """ & SOUS_REP_SAVE & """", 16, _
"* acCreRep *")
elseif iRet = 0 then
msgBox("Le répertoire """ & SOUS_REP_SAVE & """ existe déjà !",, _
"* acCreRep *")
elseif iRet = 1 then
msgBox("Répertoire """ & SOUS_REP_SAVE & """ créé !",, _
"* acCreRep *")
else
msgBox("Status retourné """ & iRet & """ inattendu !",, _
"* acCreRep *")
end if
end sub
'******************************************************* 07/11/08 ***
'*** Retourne l'extension du fichier, sans le point
'*** Ex. : buf = acGetFileExt(oDoc.getUrl)
'********************************************************************
function acGetFileExt(sUrl As String) As String
Dim cpt As Integer
Const POINT = "."
for cpt = Len(sUrl) to 1 step -1
if Mid(sUrl, cpt, 1) = POINT then
acGetFileExt = Mid(sUrl, cpt+1)
exit function
end if
next cpt
' Si pas de POINT, on retourne tout
acGetFileExt = sUrl
end function
'******************************************************* 07/11/08 ***
'*** Retourne le nom du fichier avec son extension
'*** Ex. : buf = acGetFileName(oDoc.getUrl)
'********************************************************************
function acGetFileName(sUrl As String) As String
Dim cpt As Integer
Const SLASH = "/"
for cpt = Len(sUrl) to 1 step -1
if Mid(sUrl, cpt, 1) = SLASH then
acGetFileName = Mid(sUrl, cpt +1)
exit function
end if
next cpt
' Si pas de SLASH, on retourne tout
acGetFileName = sUrl
end function
'---------------------------------------------------------- 12/07/2009
' Retourne bufIn avec les codes de contrôle balisés
' --------------------------------------------------------------------
function acDumpBuf(bufIn as string) as string
dim cpt as long
dim car as string
dim bufOut as string
for cpt = 1 to len(bufIn)
car = mid(bufIn,cpt,1)
if ((car < " ") or (car > "~")) then
bufOut = bufOut & "<" & asc(car) & ">"
else
bufOut = bufOut & car
end if
next cpt
acDumpBuf = bufOut
end function
' --------------------------------------------------------- 12/07/2009
' Découpe un chemin afin de pouvoir
' l'afficher ensuite sur deux (ou trois) lignes
' --------------------------------------------------------------------
function acDecoupePath(sPath as string, iMax as integer) as string
dim cpt as integer, cptSep as integer, lgr as integer
dim tPos() as integer, iCoupe as integer
dim buf as string, bufTmp as string, bufOut as string
if (len(sPath) = 0) then exit function
acDecoupePath = convertFromUrl(sPath) ' Par défaut
' Pour avoir un affichage propre,
' je reconvertis dans la syntaxe de l'OS
' et j'ajoute un séparateur de fin pour le découpage
buf = convertFromUrl(sPath) & getPathSeparator
' Mémoriser positions des séparateurs dans tPos()
for cpt = 1 to len(buf)
bufTmp = mid(buf,cpt,1)
if ((bufTmp = "/") or (bufTmp = "\")) then
cptSep = cptSep + 1
redim preserve tPos(cptSep)
tPos(cptSep) = cpt
end if
next cpt
iCoupe = 1
for cpt = lBound(tPos) to uBound(tPos)
lgr = 1 + tPos(cpt) - iCoupe
if (lgr > iMax) then
' Longueur dépassée, retour au séparateur précédent
lgr = 1 + tPos(cpt-1) - iCoupe
if (lgr < 1) then exit function ' >>>>>>> SORTIE >>>>>>>
bufTmp = mid(buf, iCoupe, lgr-1) & chr(13) & " "
bufOut = bufOut & bufTmp
iCoupe = tPos(cpt-1)
end if
next cpt
' Ajouter ce qui reste
bufOut = bufOut & mid(buf, iCoupe, tPos(cptSep)-iCoupe)
acDecoupePath = bufOut
end function
' --------------------------------------------------------- 24/08/2009
' Retourne l'Url du répertoire de ce document
' y compris le dernier séparateur (/)
' --------------------------------------------------------------------
function acThisRep() As String
dim oDoc as object ' 24/08/09
dim sPath as string, buf As string
dim cpt as integer
const SLASH = "/"
oDoc = thisComponent ' 24/08/09
buf = "" ' *
sPath = oDoc.getUrl ' *
for cpt = Len(sPath) to 1 step -1
if Mid(sPath, cpt, 1) = SLASH then
buf = Left(sPath, cpt)
exit for
end if
next
acThisRep = buf
end function
' --------------------------------------------------------- 23/08/2009
' Créer le répertoire sRep2 dans sRep
' --------------------------------------------------------------------
function acCreRep(sRep as string, sRep2 as string) as integer
dim buf as string
buf = dir(sRep & sRep2,16)
if (buf = "") then
on error goto errMkDir
mkDir sRep & sRep2
on error goto 0
acCreRep = 1 ' sRep2 créé
else
acCreRep = 0 ' sRep2 existe déjà
end if
exit function
errMkDir:
on error goto 0
acCreRep = -1 ' Echec
exit function
end function
