A l'aide de la macro ci-dessous j'effectue une sauvegarde sur une clé USB dédiée. Je m'aperçois que certaines personnes qui utilisent le logiciel oublient de connecter la clé malgré les mises en garde que j'ai noté sur :
- le Bouton "Connecter la clé USB nommée Sauvegarde..."
- la MsgBox qui s'ouvre "IMPORTANT...".
Aussi je voudrais , si c'est possible, avoir une boucle à la fermeture de la MsgBox qui reprendrait la macro à la ligne 0 et cela tant que la clé n'est pas connectée. J'ai déjà supprimé le "Exit sub" ligne 44 qui améliore mon résultat puis j'ai introduit ligne 46 la commande suivante "On Error GoTo 0" mais cela ne donne aucun résultat.
Si une solution existe auriez-vous une idée de la manière dont je dois m'y prendre ?
Merci de votre aide.
Éric
Code : Tout sélectionner
REM ***** BASIC ***** Nouvelle version sauvegarde vers clé USB
option explicit
' Définir ici les noms nécessaires au chemin de la clé USB et le nom du sous-répertoire des sauvegardes
'sous la forme media/nom_ordinateur/nom_clé_USB et le sous répertoire de sauvegarde
Global Const REP_MEDIA = "media" 'sous Ubuntu ce nom regroupe l'ensemble des clés USB ou disque externes...
'Récupération du nom_ordinateur avec la fonction Environ : repUser = Environ ("USER") voir ci-dessous
Global Const REP_USB = "Sauvegarde" ' nom de la clé USB
Global Const SOUS_REP_SAVE = "SaveGestion" 'Répertoire de sauvegarde sur la clé USB
' --------------------------------------------------------- 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 repUser as string
dim buf as string, cpt as integer
dim iRet as integer, iVersion as integer
repUser = Environ ("USER") ' récupération du nom de l'ordinateur
' Vérifier l'accès au répertoire des sauvegardes
iRet = acCreRep(Rep_Media & "/" & RepUser & "/" & Rep_USB & "/", SOUS_REP_SAVE) 'chemin de la sauvegarde
if iRet = -1 then
msgBox(Chr(10) & Chr(10) & Chr(10) & "IMPORTANT IMPORTANT IMPORTANT IMPORTANT IMPORTANT" & Chr(10) & Chr(10) _
& " La clé USB intitulée 'SAUVEGARDE' n'est pas connectée." & Chr(10) & Chr(10) _
& " BRANCHEZ-LA " & Chr(10) & Chr(10) _
& " patientez jusqu'à l'ouverture de la clé puis cliquez sur OK" & Chr(10) & Chr(10) _
& Chr(10) & Chr(10) _
& " Merci.")
' exit sub ' >>>>>>> SORTIE >>>>>>>
end if
' On Error GoTo 0
oDoc = thiscomponent
repDoc = Rep_Media & "/" & RepUser & "/" & Rep_USB & "/" 'chemin de la clé USB
repSauv = repDoc & SOUS_REP_SAVE
ficNom = acGetFileName(oDoc.getParent.getUrl)
ficExt = acGetFileExt(oDoc.getParent.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())' ancienne formule ***************
oDoc.Parent.storeToUrl(sUrl2, tArgs()) ' nouvelle formule
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(Rep_Media & "/" & RepUser & "/" & Rep_USB & "/", 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 = thisDatabaseDocument ' 18.3.2020
buf = "" ' *
sPath = oDoc.getUrl ' 18.3.2020
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
