Deux petites fonctions + Api de microsoft pour commondialog.
1) McExportCSV :
Exporte au format CSV en se basant sur le format de la cellule. Si c'est
du texte il met "C'est du texte" !!
2) mcOuvreCsv :
Ouvre un fichier CSV. Part du principe que si le texte est entre double quote ("), c'est du texte !!
3) clsCommonDialogAPI(c'est un module de classe à part...)
De microsoft... j'ai modifié deux trois trucs...
@ bientôt, Vic
Source / Exemple :
'--------------------------------------
'McExportCSV
'
Sub McExportCSV()
Dim objF As Worksheet
Dim lngCellules As Long
Dim lngColonnes As Long
Dim i As Long
Dim R As Range
Dim j As Long
Dim fCond As FormatCondition
Dim strCSV As String
Dim sPath As String
Set objF = Excel.ActiveSheet
sPath = ThisWorkbook.Path & "\" & objF.Name & ".csv"
lngColonnes = objF.UsedRange.Columns.Count
lngCellules = objF.UsedRange.Rows.Count
For i = 1 To lngCellules
For j = 1 To lngColonnes
Set R = objF.Cells(i, j)
If R.NumberFormat = "@" Then
strCSV = strCSV & Chr(34) & R.Value & _
Chr(34) & IIf(j < lngColonnes, ";", "")
Else
strCSV = strCSV & IIf(R.NumberFormat <> _
"General", Format(R.Value, R.NumberFormat), _
R.Value) & IIf(j < lngColonnes, ";", "")
End If
Next
strCSV = strCSV & IIf(i < lngCellules, vbCrLf, "")
Next
If Len(strCSV) > 0 Then
Open sPath For Output As #1
Print #1, strCSV
Close #1
MsgBox "L'exportation c'est bien déroulé"
Else
MsgBox "Il n'y a aucune donnée dans la feuille active"
End If
Set R = Nothing
Set fCond = Nothing
Set objF = Nothing
End Sub
'--------------------------------------
'mcOuvreCsv
'
Sub mcOuvreCsv()
Dim Cdlg As New clsCommonDialogAPI
Dim lngFormHwnd As Long
Dim lngAppInstance As Long
Dim strInitDir As String
Dim strFileFilter As String
Dim strDialogName As String
Dim sPath As String
Dim lngResult As Long
Dim sLigne As String
Dim sTableau() As String
Dim objF As Worksheet
Dim R As Range
Dim fCond As FormatCondition
Dim i As Integer
Dim j As Integer
strInitDir = "C:\"
strFileFilter = "Fichier CSV (*.csv)" & _
Chr(0) & "*.csv" & Chr(0)
strDialogName = "Importer un fichier CSV"
lngResult = Cdlg.OpenFileDialog(lngFormHwnd, _
lngAppInstance, strInitDir, strFileFilter, _
strDialogName)
If Cdlg.GetStatus = True Then
sPath = Cdlg.GetName
Set objF = ThisWorkbook.ActiveSheet
Open sPath For Input As #1
i = 0
Do While Not EOF(1)
Line Input #1, sLigne
sTableau = Split(sLigne, ";")
i = i + 1 'nouvelle ligne
For j = 0 To UBound(sTableau)
objF.Cells(i, j + 1).Value = _
Replace(sTableau(j), """", "")
If InStr(sTableau(j), """") > 0 Then
Set R = objF.Cells(i, j + 1)
R.NumberFormat = "@"
Else
End If
Next
Loop
Close #1
Set Cdlg = Nothing
Set objF = Nothing
Set R = Nothing
Set fCond = Nothing
Else
MsgBox "Aucun fichier sélectionné..."
End If
End Sub
'----------------------------------------------------------
'
' DANS UN MODULE DE CLASSE : clsCommonDialogAPI
'----------------------------------------------------------
Option Explicit
Private Declare Function GetOpenFileName Lib _
"comdlg32.dll" Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib _
"comdlg32.dll" Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private mstrFileName As String
Private mblnStatus As Boolean
Public Property Let GetName(strName As String)
mstrFileName = strName
End Property
Public Property Get GetName() As String
GetName = mstrFileName
End Property
Public Property Let GetStatus(blnStatus As Boolean)
mblnStatus = blnStatus
End Property
Public Property Get GetStatus() As Boolean
GetStatus = mblnStatus
End Property
Public Function OpenFileDialog(lngFormHwnd As Long, _
lngAppInstance As Long, strInitDir As String, _
strFileFilter As String, Optional strOpenDialogName As String = _
"Ouvrir un fichier") As Long
Dim OpenFile As OPENFILENAME
Dim X As Long
With OpenFile
.lStructSize = Len(OpenFile)
.hwndOwner = lngFormHwnd
.hInstance = lngAppInstance
.lpstrFilter = strFileFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(OpenFile.lpstrFile) - 1
.lpstrFileTitle = OpenFile.lpstrFile
.nMaxFileTitle = OpenFile.nMaxFile
.lpstrInitialDir = strInitDir
.lpstrTitle = strOpenDialogName
.Flags = 0
End With
X = GetOpenFileName(OpenFile)
If X = 0 Then
mstrFileName = "none"
mblnStatus = False
Else
mstrFileName = Trim(OpenFile.lpstrFile)
mblnStatus = True
End If
End Function
Public Function SaveFileDialog(lngFormHwnd As Long, _
lngAppInstance As Long, strInitDir As String, _
strFileFilter As String) As Long
Dim SaveFile As OPENFILENAME
Dim X As Long
With SaveFile
.lStructSize = Len(SaveFile)
.hwndOwner = lngFormHwnd
.hInstance = lngAppInstance
.lpstrFilter = strFileFilter
.nFilterIndex = 1
.lpstrFile = String(257, 0)
.nMaxFile = Len(SaveFile.lpstrFile) - 1
.lpstrFileTitle = SaveFile.lpstrFile
.nMaxFileTitle = SaveFile.nMaxFile
.lpstrInitialDir = strInitDir
.lpstrTitle = "Save File"
.Flags = 0
End With
X = GetSaveFileName(SaveFile)
If X = 0 Then
mstrFileName = "none"
mblnStatus = False
Else
mstrFileName = Trim(SaveFile.lpstrFile)
mblnStatus = True
End If
End Function
Conclusion :
Voilà ma contribution dominicale, @ Bientôt.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.