Bon alors j'ai nettoyé mon code,le voici sans commentaire:
Public Sub Recup_Prop_Click()
Dim pMxDoc As IMxDocument
Dim pMap As IMap
Dim pParFLayer As IFeatureLayer
Dim pParFeature As IFeature
Dim pParSelection As IFeatureSelection
Dim pParSelectionset As ISelectionSet
Dim pParCursor As IFeatureCursor
Dim pIDPROP As String
Dim pPropNom As String
Dim pFichierProp As TextStream
Set pMxDoc = ThisDocument
Set pMap = pMxDoc.FocusMap
Set pParFLayer = FindLayerByName(pMap, "Parcelle" )
Set pParSelection = pParFLayer
Set pParSelectionset = pParSelection.SelectionSet
pParSelectionset.Search Nothing, False, pParCursor
Call CreationFichier(pFichierProp)
Set pParFeature = pParCursor.NextFeature
Do While Not pParFeature Is Nothing
pIDPROP = pParFeature.Value(pParFeature.Class.FindField("IDPROP" ))
Call NomProprio(pIDPROP, pPropNom)
Call EcritureFichier(pPropNom, pFichierProp)
Set pParFeature = pParCursor.NextFeature
Loop
End Sub
Function NomProprio(pIDPROP As String, pPropNom As String)
Dim pMxDoc As IMxDocument
Dim pStTabColl As IStandaloneTableCollection
Dim pPropTab As ITable
Dim pTableDef As ITableDefinition
Dim i As Integer
Dim test As Integer
Dim pRow As IRow
Dim pPropCursor As ICursor
Dim pPropIndex As String
'Dim pPropNom As String
Set pMxDoc = ThisDocument
Set pStTabColl = pMxDoc.ActiveView
If pStTabColl.StandaloneTableCount = 0 Then
MsgBox "Veuillez ajouter la table proprio"
Exit Function
End If
test = 0
For i = 0 To pStTabColl.StandaloneTableCount - 1
If pStTabColl.StandaloneTable(i).Name = "proprio" Then
Set pPropTab = pStTabColl.StandaloneTable(i)
Set pTableDef = pPropTab
test = 1
Exit For
End If
Next i
If test = 0 Then
MsgBox "Veuillez ajouter la table proprio"
Exit Function
End If
pPropIndex = pPropTab.FindField("DDENOM" )
Set pPropCursor = pPropTab.Search(Nothing, True)
Set pRow = pPropCursor.NextRow
pTableDef.DefinitionExpression = "[IDPROP] = '" + pIDPROP + "'"
Do While Not pRow Is Nothing
pPropNom = pRow.Value(pPropIndex
Set pRow = pPropCursor.NextRow
Loop
End Function
Function CreationFichier(pFichierProp As TextStream) As TextStream
Dim fso As FileSystemObject
Dim pFileProp As String
'Dim pFichierProp As TextStream
Set fso = CreateObject("Scripting.FileSystemObject" )
pFileProp = "D:\Test\Prog\Thibault\fichier_proprio.txt"
If fso.FileExists(pFileProp) Then
MsgBox "le fichier existe déjà", vbExclamation
End If
Set pFichierProp = fso.CreateTextFile("D:\Test\Prog\Thibault\fichier_proprio.txt", True)
Set CreationFichier = pFichierProp
End Function
Function EcritureFichier(pPropNom As String, pFichierProp As TextStream)
With pFichierProp
.WriteLine = "Numéro de parcelle - Identifiant propriétaire - Nom du propriétaire"
.WriteLine " - - " & pPropNom
End With
End Function
J'ai essayé avec ce que tu m'as indiqué paul hood mais rien n'y fait,j'ai le msg fonction ou variable attendue à ma dernière ligne quand je veux écrire dans le fichier. Est ce que ça ne vient pas de l'objet pFichierProp en lui-même qui est un textStream?
Pour Tegu pFichierProp est un textStream créé dans un FSO.