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