mistralincoming
XLDnaute Junior
bonjour au forum
j'ai la macro suivante:
Public ReponseMsgBox As Variant
Public Const NomDuCheminDestin$ = "C:\Users\Mistral-Incoming\Documents\Projet Mistral\Fournisseurs\PHOTOS FOURNISSEURS\"
Public Sub ButtonNewDossier() pour créer à chaque fois qu'un nom est saisi automatiquement un dossier ou ranger les photos
' test s'il y a un nom de dossier dans la cellule "nom" !?
NomDuDossierNew$ = Trim(Range("nom"))
If NomDuDossierNew$ = "" Then MsgBox "Aucun nom de dossier dans la cellule nommée [nom] !?", vbExclamation, "Erreur": Exit Sub
' confirmation
M$ = "Chemin de destination:" & vbLf & NomDuCheminDestin$ & vbLf & vbLf & _
Créer le sous dossier [ & NomDuDossierNew$ & " ] ?"
ReponseMsgBox = MsgBox(M$, vbExclamation + vbYesNo + vbDefaultButton2, "Création nouveau sous dossier")
If ReponseMsgBox <> vbYes Then Exit Sub
' suite... pour création
On Error GoTo ErrDossier
' test si NomDuCheminDestin$ existe !?
Chemin$ = NomDuCheminDestin$: If Right(Chemin$, 1) = "\" Then Chemin$ = Left(Chemin$, Len(Chemin$) - 1)
If Dir(Chemin$, vbDirectory) = "" Then MsgBox Chemin$ & vbLf & "... n'existe pas !?", vbCritical, "Erreur chemin": Exit Sub
' test si sous dossier existe !?
DossierNew$ = NomDuCheminDestin$: If Right(NomDuCheminDestin$, 1) <> "\" Then DossierNew$ = NomDuCheminDestin$ & "\"
Rep$ = Dir(DossierNew$, vbDirectory) 'Extrait première entrée
Do While Rep$ <> ""
If Rep$ <> "." And Rep$ <> ".." Then
If (GetAttr(DossierNew$ & Rep$) And vbDirectory) = vbDirectory Then 'test si dossier !?
If LCase(Rep$) = LCase(NomDuDossierNew$) Then MsgBox "Le sous dossier [ " & NomDuDossierNew$ & " ] existe déjà !": Exit Sub
End If
End If
Rep$ = Dir 'Extrait entrée suivante
Loop
' création
CreationNew$ = NomDuCheminDestin$: If Right(NomDuCheminDestin$, 1) <> "\" Then CreationNew$ = NomDuCheminDestin$ & "\"
CreationNew$ = CreationNew$ & NomDuDossierNew$
MkDir CreationNew$
MsgBox "Dossier [ " & NomDuDossierNew$ & " ] créé !"
On Error GoTo 0: Exit Sub ' fin quitte
ErrDossier: '-------------------------------------------
M$ = "Erreur n°" & Str(Err.Number) & " générée par " & Err.Source & vbLf & Err.Description
MsgBox M$, vbCritical, "Erreur", Err.HelpFile, Err.HelpContext
On Error GoTo 0
End Sub
je cherche à y intégrer lorsque un dossier est à créer (réponse msg box ok) la macro suivante:
Sub lienhypertexte()
'
' lienhypertexte Macro
' Macro enregistrée le 14/03/2008 par mistralincoming
'
'
Range("C7:M8").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Selection.Hyperlinks.Delete
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"PHOTOS FOURNISSEURS/matis"
Range("C9:M55").Select
End Sub
"PHOTOS FOURNISSEURS/matis" mais de façon automatique
qui peux m'aider
merci
j'ai la macro suivante:
Public ReponseMsgBox As Variant
Public Const NomDuCheminDestin$ = "C:\Users\Mistral-Incoming\Documents\Projet Mistral\Fournisseurs\PHOTOS FOURNISSEURS\"
Public Sub ButtonNewDossier() pour créer à chaque fois qu'un nom est saisi automatiquement un dossier ou ranger les photos
' test s'il y a un nom de dossier dans la cellule "nom" !?
NomDuDossierNew$ = Trim(Range("nom"))
If NomDuDossierNew$ = "" Then MsgBox "Aucun nom de dossier dans la cellule nommée [nom] !?", vbExclamation, "Erreur": Exit Sub
' confirmation
M$ = "Chemin de destination:" & vbLf & NomDuCheminDestin$ & vbLf & vbLf & _
Créer le sous dossier [ & NomDuDossierNew$ & " ] ?"
ReponseMsgBox = MsgBox(M$, vbExclamation + vbYesNo + vbDefaultButton2, "Création nouveau sous dossier")
If ReponseMsgBox <> vbYes Then Exit Sub
' suite... pour création
On Error GoTo ErrDossier
' test si NomDuCheminDestin$ existe !?
Chemin$ = NomDuCheminDestin$: If Right(Chemin$, 1) = "\" Then Chemin$ = Left(Chemin$, Len(Chemin$) - 1)
If Dir(Chemin$, vbDirectory) = "" Then MsgBox Chemin$ & vbLf & "... n'existe pas !?", vbCritical, "Erreur chemin": Exit Sub
' test si sous dossier existe !?
DossierNew$ = NomDuCheminDestin$: If Right(NomDuCheminDestin$, 1) <> "\" Then DossierNew$ = NomDuCheminDestin$ & "\"
Rep$ = Dir(DossierNew$, vbDirectory) 'Extrait première entrée
Do While Rep$ <> ""
If Rep$ <> "." And Rep$ <> ".." Then
If (GetAttr(DossierNew$ & Rep$) And vbDirectory) = vbDirectory Then 'test si dossier !?
If LCase(Rep$) = LCase(NomDuDossierNew$) Then MsgBox "Le sous dossier [ " & NomDuDossierNew$ & " ] existe déjà !": Exit Sub
End If
End If
Rep$ = Dir 'Extrait entrée suivante
Loop
' création
CreationNew$ = NomDuCheminDestin$: If Right(NomDuCheminDestin$, 1) <> "\" Then CreationNew$ = NomDuCheminDestin$ & "\"
CreationNew$ = CreationNew$ & NomDuDossierNew$
MkDir CreationNew$
MsgBox "Dossier [ " & NomDuDossierNew$ & " ] créé !"
On Error GoTo 0: Exit Sub ' fin quitte
ErrDossier: '-------------------------------------------
M$ = "Erreur n°" & Str(Err.Number) & " générée par " & Err.Source & vbLf & Err.Description
MsgBox M$, vbCritical, "Erreur", Err.HelpFile, Err.HelpContext
On Error GoTo 0
End Sub
je cherche à y intégrer lorsque un dossier est à créer (réponse msg box ok) la macro suivante:
Sub lienhypertexte()
'
' lienhypertexte Macro
' Macro enregistrée le 14/03/2008 par mistralincoming
'
'
Range("C7:M8").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Selection.Hyperlinks.Delete
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"PHOTOS FOURNISSEURS/matis"
Range("C9:M55").Select
End Sub
"PHOTOS FOURNISSEURS/matis" mais de façon automatique
qui peux m'aider
merci
