Application des modifications des paramètres régionaux en vba pour enregistrement en .csv ?

Version imprimable

Bonjour à toutes et à tous,

Je rencontre actuellement un point bloquant dans un fichier excel codé en vba.

Contexte : Le fichier .xlsm utilisé doit enregistrer un fichier créé par le programme en .csv avec comme séparateur le ";"

Solution première apportée : Local:=True
Code:

1 2 ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, CreateBackup:=False, local:=True
Problème rencontré : Utilisateurs ayant déjà auparavent configuré leurs paramètres régionaux manuellement en anglais et ne pouvant pas modifier les paramètres régionaux des machines utilisées ...

Solution deuxième apportée : Modification des paramètres régionaux automatiquement à partir du vba
Code:

1 2 3 4 5 6 7 8 9 Option Explicit Private Const LOCALE_SLIST = &HC Private Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long sub ChangementCSV () SetLocaleInfo LOCALE_USER_DEFAULT, LOCALE_SLIST, ";" ActiveWorkbook.SaveAs Filename:=nomFichier, FileFormat:=xlCSV, CreateBackup:=False, local:=True End Sub
Problème rencontré :

les modifications sont prises en compte sur le panneau de configuration / Région et langue / Paramètres supplémentaires / Séparateur de liste
MAIS aucun changement lorsque le programme est lancé lors de la création du csv. Il garde le dernier délimiteur entré manuellement par l'utilisateur dans le panneau de config'

Par contre, dès que changement manuel dans le panneau de configuration, pas de problème pour le programme qui le prend en compte.

J'ai pensé à un problème d'application des modifications mais honnêtement je ne sais plus quoi faire !

Merci beaucoup d'avance pour vos solutions/messages

03/05/2016, 22h56
eriiic

Bonjour,

à tenter : ouvrir par vba une autre session excel et créer ton fichier dedans en espérant qu'elle prenne en compte la nouvelle configuration.
eric

Bonjour,
Une solution qui ne passe pas par le panneau de config :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Sub Export()
Dim Plage As Object, oL As Object, oC As Object, FileN$, Sep$, Tmp$
FileN = "aaaa" 'nom du fichier à créer
Sep = ";"
With Worksheets(1)
    Set Plage = .Range("A1:A5") 'plage à enregistrer
End With
Open FileN & ".csv" For Output As #1
    For Each oL In Plage.Rows
        Tmp = ""
        For Each oC In oL.Cells
            Tmp = Tmp & CStr(oC.Text) & Sep
        Next
        Print #1, Tmp
    Next
Close
End Sub

A+

04/05/2016, 11h05
Nuff_Liff

Bonjour à vous deux,

Je vous remercie déjà de vos réponse.

Pas de changement après ouverture d'une nouvelle session par le vba ... je ne vois toujours pas comment appliquer ces changements faits par vba ...

Mais problème résolu et adapté avec la solution de galopin01 :). Ca marche parfaitement, merci beaucoup !

Bonjour,

un peut tard mais bon!

Code:

1
2
3
4
5
6
7
8
9
10
Sub test()
Dim txt As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile("C:\Users\rdurupt\Desktop\new.csv", 1)
txt = NewFichier.ReadAll
NewFichier.Close
txt = Replace(txt, ";", vbTab)
ClipBoard_SetData txt
ActiveCell.PasteSpecial xlPasteAll
End Sub

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
#If VBA7 Then
 Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As Long
 Private Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
 Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
 Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As Long
 Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#Else
 Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
 Private Declare Function CloseClipboard Lib "User32" () As Long
 Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
 Private Declare Function EmptyClipboard Lib "User32" () As Long
 Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
 Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
 Private Declare Function GetClipboardData Lib "User32" (ByVal wFormat As Long) As Long
#End If
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
 
Sub test()
Dim txt As String
Set fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = fso.OpenTextFile("C:\Users\rdurupt\Desktop\new.csv", 1)
txt = NewFichier.ReadAll
NewFichier.Close
txt = Replace(txt, ";", vbTab)
ClipBoard_SetData txt
ActiveCell.PasteSpecial xlPasteAll
End Sub
Function ClipBoard_GetData() As String
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
 
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
 
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
 
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function
Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long
 
   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
 
   ' Lock the block to get a far pointer
   ' to this memory.
   lpGlobalMemory = GlobalLock(hGlobalMemory)
 
   ' Copy the string to this global memory.
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If
 
   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If
 
   ' Clear the Clipboard.
   X = EmptyClipboard()
 
   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 
   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If
 
   End Function