[vba] cmt forcer excel a enregistrer a l'emplacement c:\windows\test ?

cmt forcer excel a enregistrer a l'emplacement c:\windows\test ? [vba] - VB/VBA/VBS - Programmation

Marsh Posté le 28-05-2005 à 19:01:56    

Bonjour a tous!
voila en fait j'aimerai savoir comment faire pour forcer excel a sauvegarder un classeur a un emplacement prédéfini comme par exemple c:\windows\test
 
?  
merci d'avance

Reply

Marsh Posté le 28-05-2005 à 19:01:56   

Reply

Marsh Posté le 28-05-2005 à 21:11:16    

sans passer par fichier -> enregistrer sous :)
car en fait je veux obliger l'utilisateur a enregistrer son travail a un emplacement bien precis (en l'occurence sur un reseau)
help...

Reply

Marsh Posté le 28-05-2005 à 21:49:37    

j'utilise deja ce code qui m'ouvre une fenetre... une sorte d'explorer quoi et ou je valide le dossier ou je souhaite mettre mon fichier mais je veux desactiver la possibilité d'utiliser "fichier enregistrer sous"
 

Code :
  1. Dim Dossier_choisi As String
  2. Private Type BrowseInfo
  3. hWndOwner As Long
  4. pIDLRoot As Long
  5. pszDisplayName As Long
  6. lpszTitle As Long
  7. ulFlags As Long
  8. lpfnCallback As Long
  9. lParam As Long
  10. iImage As Long
  11. End Type
  12. Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
  13. Private Declare Function lstrcat Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
  14. Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
  15. Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
  16. Sub Parcourir()
  17. Dim Rien As Integer
  18. Dim Liste As Long
  19. Dim Resultat As String
  20. Dim Browse_info As BrowseInfo
  21. With Browse_info
  22. ' .hWndOwner = Me.hWnd
  23. .lpszTitle = lstrcat("Choix du dossier à analyser", "" )
  24. .ulFlags = 1
  25. End With
  26. Liste = SHBrowseForFolder(Browse_info)
  27. If Liste Then
  28. Resultat = String$(260, 0)
  29. SHGetPathFromIDList Liste, Resultat
  30. CoTaskMemFree Liste
  31. Rien = InStr(Resultat, vbNullChar)
  32. If Rien Then
  33. Dossier_choisi = Left$(Resultat, Rien - 1)
  34. MsgBox "Le dossier choisi est :" & vbNewLine & Dossier_choisi, vbInformation
  35. ActiveWorkbook.SaveAs Filename:=Dossier_choisi & "\" & "suivi_de_l_activite"
  36. End If
  37. End If
  38. End Sub
  39. Private Sub ecrire(A_ecrire As String, Optional Gras As Boolean, Optional Couleur As Long)
  40. Etat.SelStart = Len(Etat)
  41. Etat.SelBold = Gras
  42. If Not (IsMissing(Couleur)) Then
  43. Etat.SelColor = Couleur
  44. Else
  45. Etat.SelColor = vbBlack
  46. End If
  47. Etat.SelText = A_ecrire & vbNewLine
  48. Etat.SelBold = False
  49. Etat.SelColor = vbBlack
  50. End Sub
  51. Public Function explorer(ByVal Chemin As String)
  52. On Error Resume Next
  53. Dim id_1 As Integer
  54. Dim id_2 As Integer
  55. Dim id_3 As Integer
  56. Dim ids() As String
  57. Dim dossier_courant As String
  58. If Dir(Chemin, vbDirectory) = "" Then
  59. Exit Function
  60. End If
  61. dossier_courant = Dir(Chemin, vbDirectory)
  62. Do While dossier_courant <> ""
  63. If dossier_courant <> "." And dossier_courant <> ".." Then
  64. If (GetAttr(Chemin & dossier_courant) And vbDirectory) <> 0 Then
  65. id_1 = id_1 + 1
  66. End If
  67. End If
  68. dossier_courant = Dir
  69. Loop
  70. ReDim ids(id_1)
  71. dossier_courant = Dir(Chemin, vbDirectory)
  72. Do While dossier_courant <> ""
  73. If dossier_courant <> "." And dossier_courant <> ".." Then
  74. If (GetAttr(Chemin & dossier_courant) And vbDirectory) <> 0 Then
  75. id_2 = id_2 + 1
  76. ids(id_2) = dossier_courant
  77. If Afficher_sous_dossiers.Value <> 0 Then
  78. ecrire dossier_courant, True
  79. End If
  80. Else
  81. ecrire dossier_courant
  82. End If
  83. End If
  84. dossier_courant = Dir
  85. Loop
  86. For id_3 = 1 To id_1
  87. If Sous_dossiers.Value <> 0 Then
  88. explorer Chemin & ids(id_3) & "\"
  89. End If
  90. Next
  91. End Function
  92. Private Sub Parti_Click()
  93. If Dossier_choisi = "" Then
  94. MsgBox "Vous devez sélectionner un dossier à analyser.", vbExclamation
  95. Exit Sub
  96. End If
  97. If Right(Dossier_choisi, 1) <> "\" Then
  98. Dossier_choisi = Dossier_choisi & "\"
  99. End If
  100. Parcourir.Enabled = False
  101. Sous_dossiers.Enabled = False
  102. Afficher_sous_dossiers.Enabled = False
  103. Parti.Enabled = False
  104. Etat.Text = ""
  105. ecrire "C'est parti dans " & Dossier_choisi, True, vbBlue
  106. explorer Dossier_choisi
  107. ecrire "C'est fini !", True, vbBlue
  108. Parcourir.Enabled = True
  109. Sous_dossiers.Enabled = True
  110. Afficher_sous_dossiers.Enabled = True
  111. Parti.Enabled = True
  112. End Sub


Reply

Marsh Posté le 29-05-2005 à 14:53:08    

Le problème va être de savoir comment est libellée la ligne "Enregistrer sous..."
Ce sera différent en fonction de la langue de l'utilisateur.
 
Si le menu Fichier est dans sa disposition d'origine (Excel 2000), "Enregistrer sous..." est en 5e position.
 
On peut donc appliquer le code suivant pour supprimer cette option:

Application.CommandBars("File" ).Controls(5).Delete


Pour remettre l'option dans le menu (ne pas oublier!), la commande est moins ambiguë:

Application.CommandBars("File" ).Controls.Add Type:=msoControlButton, ID:= _
        748, Before:=5


Message édité par AlainTech le 29-05-2005 à 14:53:49

---------------
Si on vous donne une info qui marche, DITES-LE!!!! ------ Si vous trouvez seul, AUSSI, votre solution peut servir à d'autres! ------ Je dois la majorité de mes connaissances à mes erreurs!
Reply

Sujets relatifs:

Leave a Replay

Make sure you enter the(*)required information where indicate.HTML code is not allowed