Discussion :

[Midel81]

Bonjour,
J'utilise la macro CreateActiveFile (écrite par un membre du forum) qui fonctionne très bien d'habitude mais là j'ai un pb avec le fichier joint.
Je n'arrive pas à trouver pourquoi, pourriez-vous m'aider ?
Merci d'avance

[Jean-Philippe André]

Salut,

ne pouvant télécharger les fichiers de type xlsm, pourrais-tu nous en dire plus sur ton soucis stp ?

Quel est le code utilisé (à copier ici dans les balises CODE) ? quelle est l'erreur que tu rencontres ? etc.

[Midel81]

Merci Jean-Philippe,

Visual Basic m'annonce :

"Erreur d'exécution '13':
Incompatibilité de type"

Préfères-tu les données du fichier Excel sous un autre format ?

Voici le code de la macro

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub CreateAllFiles()
  CreateKML Worksheets("LineString")
  CreateKML Worksheets("Point")
  CreateKML Worksheets("Polygon")
End Sub
 
Sub CreateActiveFile()
  CreateKML ActiveSheet
End Sub
 
Sub CreateKML(Optional sh As Worksheet)
  Dim xml As String
  Dim xmls As String
  Dim Header As String
  Dim Footer As String
  Dim DataCell As Range
  Dim HeaderCell As Range
  Dim Space As String
  Dim fs As Object
  Dim PathName As String
 
  Space = vbLf
  PathName = ThisWorkbook.Path & "\" & ActiveWorkbook.Name & ".kml"
 
  Header = "<?xml version=""1.0"" encoding=""utf-8""?>" & Space & "<kml xmlns=""http://www.opengis.net/kml/2.2"">" & Space & "<Document>" & Space
  Footer = "</Document>" & Space & "</kml>"
 
  xmls = Header
  Set DataCell = sh.Range("a2")
  Do While DataCell.Value <> ""
    xml = "<Placemark>" & Space
    xml = xml & "<name>" & DataCell(1, 1).Value & "</name>" & Space
    If sh.Name = "Polygon" Then
      xml = xml & "<" & sh.Name & ">" & Space & "<outerBoundaryIs>" & Space & _
        "<LinearRing>" & Space & "<coordinates>" & DataCell(1, 2) & _
        "</coordinates>" & Space & "</LinearRing>" & Space & _
        "</outerBoundaryIs>" & Space & "</" & sh.Name & ">" & Space
    Else
      xml = xml & "<" & sh.Name & ">" & Space & "<coordinates>" & DataCell(1, 2) & _
        "</coordinates>" & Space & "</" & sh.Name & ">" & Space
    End If
    xml = xml & "<ExtendedData>" & Space
    For Each HeaderCell In sh.Range(sh.Range("c1"), sh.Range("a1").End(xlToRight))
      xml = xml & "<Data name=""" & HeaderCell.Value & """>" & Space & _
      "<value>" & DataCell(1, HeaderCell.Column).Value & "</value>" & Space & "</Data>" & Space
    Next
    xml = xml & "</ExtendedData>" & vbCr & "</Placemark>" & Space
    xmls = xmls & xml
    Set DataCell = DataCell(2)
  Loop
  xmls = xmls & Footer
 
  If Dir(PathName) <> "" Then Kill PathName
  Set fs = CreateObject("ADODB.Stream")
  With fs
    .Type = 2
    .Charset = "utf-8"
    .Open
    .writetext xmls
 
    .savetofile PathName
  End With
  Set fs = Nothing
End Sub

[Midel81]

J'ai oublié, la macro s'arrête sur :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
      xml = xml & "<Data name=""" & HeaderCell.Value & """>" & Space & _
      "<value>" & DataCell(1, HeaderCell.Column).Value & "</value>" & Space & "</Data>" & Space

[Midel81]

J'ai finalement fini par trouver les erreurs dans mon fichier xlsm.
Merci à tous