Xl8table() : importe une feuille d'un classeur excel 97 dans une table visual foxpro

Commenter

Contenu du snippet

  • Les noms des champs sont lus dans la première ligne de la feuille
  • Les colonnes sont importées en caractères
  • Les colonnes masquées ne sont pas importées
  • Les colonnes servant à une concaténation sont tronquées

Retourne l'adresse de la table créée ou erreur en clair

Source / Exemple : 





	PROCEDURE XL8Table	&& Importe une feuille d'un Classeur Excel 97 dans une table


    		
  •  Les noms des champs sont lus dans la première ligne de la feuille

    • 		
  •  Les colonnes sont importées en caractères

    • 		
  •  Les colonnes masquées ne sont pas importées

    • 		
  •  Les colonnes servant à une concaténation sont tronquées

	LPARAMETERS ;
		tcXLWBAddr, ; && Adresse du MASQUE de classeur Excel contenant la feuille à importer
		tcSheet, ; && [feuille n°1] Nom de la feuille à importer
		tlNonVerifDernVers,;	&& [.F.] Ne pas prendre la dernière version du classeur Excel
		;							&& si @, indique en retour si la table a été rafraîchie
		tlImportForce && [.F.] Importer même si le classeur est plus ancien que la table

	LOCAL lcResult	&& Adresse de la table créée ou message d'erreur
	m.lcResult = Space(0)

	IF Vartype(m.tcXLWBAddr) = 'C'


    		
  •  Régler les valeurs par défaut des paramètres

		LOCAL lcSheet, llNonVerifDernVers
		m.llNonVerifDernVers = Iif(Vartype(m.tlNonVerifDernVers) = 'L', m.tlNonVerifDernVers, .F.)
		m.lcSheet = Iif (Vartype(m.tcSheet)='C', Upper(m.tcSheet), Space(0))
		m.llImportForce = Iif(Vartype(m.tlImportForce)=='L', m.tlImportForce, .F.)


    		
  •  Si un classeur existe selon le masque spécifié

		LOCAL lcXLWBAddr
		m.lcXLWBAddr = IIF (m.llNonVerifDernVers, m.tcXLWBAddr, cFileFreshest(m.tcXLWBAddr))
		IF File(m.lcXLWBAddr)


    			
  •  Déterminer l'adresse de la table destination

			LOCAL lcXLWBPath, lcDBFStem, lcDBFAddr
			m.lcXLWBPath = Addbs(JustPath(m.lcXLWBAddr))
			m.lcDBFStem = Iif (Empty(m.lcSheet), JustStem(m.tcXLWBAddr), m.lcSheet)
			m.lcDBFAddr = m.lcXLWBPath +  ForceExt(m.lcDBFStem, EXT_DBF)


    			
  •  Si import systématique ou classeur plus récent que la table

			LOCAL llImport
			m.llImport = m.llImportForce .OR. Nvl(lFileFresher (m.lcDBFAddr, m.lcXLWBAddr), .T.)
			m.lcResult = m.lcDBFAddr
			IF m.llImport


    				
  •  Si le classeur n'est pas couramment ouvert

				LOCAL lnHandle
				m.lnHandle = Fopen(m.lcXLWBAddr, 1)
				m.llImport = m.lnHandle > 0 ;
				 OR (Set('ASSERT') == 'ON' AND 6 = ;
								 MessageBox("L'importation de données depuis le classeur " + m.lcXLWBAddr + " est impossible car il est ouvert par Excel" + CRLF + ;
									"Pour continuer l'importation, veuillez fermer le classeur et cliquer sur 'oui'" + CRLF + ;
									"Pour abandonner l'importation, cliquez sur 'non'" + CRLF + ;
									"Continuer ?", 4+16))
				Fclose(m.lnHandle)
				IF m.llImport


    					
  •  Si la feuille peut être importée

					LOCAL lcDefault, lnSelect, llSheet
					m.lcDefault = Set('Default') + CurDir () 	&&	Unité de disque + Dossier
					m.lnSelect = Select(0)
					m.llSheet = .T.
					SET DEFAULT TO (m.lcXLWBPath) && Obligé de changer le default car l'import doit placer la nouvelle table dedans
					SELECT 0	&&	Première zone libre où se placera la table créée
					IF Empty(m.lcSheet)
						IMPORT FROM (m.lcXLWBAddr) TYPE XL8
					ELSE
						LOCAL lcError
						m.lcError = On('Error')
						ON ERROR m.llSheet = .F.
						IMPORT FROM (m.lcXLWBAddr) TYPE XL8 Sheet (m.lcSheet)
						ON ERROR &lcError
					ENDIF
					SET DEFAULT TO (m.lcDefault)
					IF m.llSheet

						LOCAL lcAlias
						m.lcAlias = Alias()


    						
  •  Renommer les champs par le contenu de la premiere ligne du tableau

						IF XL8Table_ModiStru (m.lcAlias)


    							
  •  Renommer la table selon le nom de la feuille ou du classeur spécifiés

							LOCAL lcDBFImportAddr
							m.lcDBFImportAddr = cTableAddress(m.lcAlias)
							USE IN (m.lcAlias)
							IF Upper (m.lcDBFImportAddr) # Upper (m.lcDBFAddr)


    								
  •  Effacer la précédente le cas échéant

								IF File (m.lcDBFAddr)
									DELETE FILE (m.lcDBFAddr)
								ENDIF
								RENAME (m.lcDBFImportAddr) to (m.lcDBFAddr)
							ENDIF
						ELSE
							m.lcResult = "XL8Table() : Impossible de nommer les champs selon le contenu de la première ligne de la feuille " + m.lcSheet + " du classeur " + m.lcXLWBAddr
						ENDIF
					ELSE
						m.lcResult = "XL8Table() : Importation impossible car la feuille " + m.lcSheet + " n'existe pas dans le classeur " + m.lcXLWBAddr
					ENDIF
					SELECT (m.lnSelect)
				ELSE
					m.lcResult = "XL8Table() : Importation impossible car le classeur " + m.lcXLWBAddr + " était ouvert."
				ENDIF
			ENDIF
			m.tlNonVerifDernVers = m.llImport && indique si la feuille a été importée
		ELSE
			m.lcResult = "XL8Table() : Importation impossible car aucun classeur n'existe selon le masque spécifié :" + Alltrim(tcXLWBAddr)
		ENDIF
	ELSE
		m.lcResult = "XL8Table() : Veuillez spécifier un masque de classeur XL en première paramètre"
	ENDIF
	ASSERT File(m.lcResult) MESSAGE m.lcResult

	RETURN m.lcResult



	Procedure XL8Table_ModiStru	&& Renomme les champs selon la première ligne de la feuille XL
	LPARAMETERS tcAlias	&& Alias de la table importée d'Excel

	LOCAL llResult

	LOCAL tcAlias
	IF Used(m.tcAlias) ;
	 AND IsExclusive(m.tcAlias)

		LOCAL lnSelect
		m.lnSelect = Select(0)
		SELECT (m.tcAlias)


    		
  •  Lire la structure de la table

		LOCAL lnChps
		LOCAL ARRAY laCh[1], laChNouv[1]
		m.lnChps = AFields(m.laCh)


    		
  •  Lire le premier enregistrement contenant les noms de champs

		GO 1
		SCATTER TO laChNouv

		LOCAL ;
			lnChp, ;	&&	ne pas utiliser 'i' qui est un nom de colonne XL
			lcChNouv, ;
			lcChAnc, ;
			lnChpId, ;
			lcChpId

		FOR m.lnChp = 1 to m.lnChps

			m.lcChAnc = laCh[m.lnChp, 1]
			m.lcChNouv = laChNouv[m.lnChp]
			m.lcChNouv = IIF (Vartype(m.lcChNouv) == 'C', Upper(Alltrim(m.lcChNouv)), space(0))


    			
  •  Si le nouveau nom est vide, supprimer la colonne

			If Empty(m.lcChNouv)
				Alter table (m.tcAlias) drop column (m.lcChAnc)


    			
  •  Sinon (nouveau nom non vide)

			ELSE


    				
  •  Si le champ est numérique, le passer en caractères et supprimer les espaces en tête

				IF m.laCh[m.lnChp, 2] == 'N'
					ALTER TABLE (m.tcAlias) ALTER COLUMN (m.lcChAnc) C (m.laCh[m.lnChp,3] + 1 + m.laCh[m.lnChp,4])
					REPLACE ALL (m.lcChAnc) with Ltrim(Evaluate(m.lcChAnc))
					m.laCh[m.lnChp, 2] = 'C'
				ENDIF


    				
  •  Normaliser le nom de champ

				m.lcChNouv = cVFPName(m.lcChNouv, 10)


    				
  •  Si le nom du champ existe déjà, lui donner un suffixe numérique

				m.lnChpId = 0
				DO WHILE Ascan(m.laCh, m.lcChNouv, 1, -1, 1, 2+4) > 0
					m.lnChpId = m.lnChpId + 1
					m.lcChpId = Alltrim(Str(m.lnChpId))
					m.lcChNouv = substr(m.lcChNouv, 1, 10-Len(m.lcChpId)) + m.lcChpId
				ENDDO


    				
  •  Renommer le champ

				ALTER TABLE (m.tcAlias) RENAME COLUMN (m.lcChAnc) to (m.lcChNouv)

			ENDIF
			laCh[m.lnChp, 1] = m.lcChNouv

		ENDFOR


    		
  •  Supprimer le premier enregistrement contenant les noms de champs

		GO 1
		DELETE
		PACK
		DELETE FILE (ForceExt(cTableAddress(m.tcAlias), 'BAK'))

		SELECT (m.lnSelect)
		m.llResult = .T.
	ENDIF

	RETURN m.llResult



	FUNCTION lFileFresher	&& Un fichier est plus récent qu'un autre
	LPARAMETERS ;
		tcFile1Addr, ; && Adresse du fichier de base
		tcFile2Addr		&& Adresse du fichier à comparer
	LOCAL llResult
	m.llResult = NULL


    	
  •  Si les deux fichiers existent

	IF Vartype(m.tcFile1Addr)=='C' ;
	 AND File (m.tcFile1Addr) ;
	 AND Vartype(m.tcFile2Addr)=='C' ;
	 AND File (m.tcFile2Addr) 

		m.llResult = Fdate (m.tcFile2Addr, 1) > Fdate (m.tcFile1Addr, 1)
	ENDIF

	RETURN m.llResult



	FUNCTION cVFPName	&& Nom valide pour VFP, avec longueur limitée si nécessaire
	LPARAMETERS ;
		tcVFPName, ; && Nom VFP à valider
		tnLength && [len(tcVFPName)] Longueur maximale du nom (par ex. 10 pour un nom de champ de table libre)

	LOCAL lcResult
	m.lcResult = space(0)
	
	IF Vartype(m.tcVFPName) = 'C' ;
	 AND ! Empty(m.tcVFPName)


    		
  •  Remove accents

		LOCAL lcVFPName
		m.lcVFPName = cEuroANSI(alltrim (m.tcVFPName)) 


    		
  •  Start with underscore if first is a digit

		m.lcVFPName = Iif(IsDigit(m.lcVFPName), UNDERSCORE, Space(0)) + m.lcVFPName


    		
  •  Turn characters neither digit or letter to underscore

		LOCAL lnCar, lcCar
		FOR m.lnCar = 1 TO Len(m.lcVFPName)
			m.lcCar = Substrc(m.lcVFPName, m.lnCar, 1)
			m.lcCar = Iif(isDigit(m.lcCar) or IsAlpha(m.lcCar), ;
						 m.lcCar, UNDERSCORE)
			m.lcResult = m.lcResult + Upper(m.lcCar)
		ENDFOR


    		
  •  Remove duplicate underscores

		m.lcResult = cRepCharDel (m.lcResult, UNDERSCORE)
		m.lcResult = Iif(m.lcResult==UNDERSCORE, Space(0), m.lcResult)


    		
  •  Trim right is required

		IF Vartype(m.tnLength) = 'N' ;
		 AND m.tnLength > 0
			m.lcResult = Leftc(m.lcResult, m.tnLength)
		ENDIF

	ENDIF

	RETURN m.lcResult


    	
  •  -----------------------------------------------------------------

	PROCEDURE cVFPName_Test
	? Sys(16)
	? cVFPName ('%cartable/poiré') == '_CARTABLE_POIRE'
	? cVFPName ('2cartable.poiré') == '_2CARTABLE_POIRE'
	? cVFPName ('2cartable.:poiré') == '_2CARTABLE_POIRE'
	? cVFPName ('2cartable.:poiré', 9) == Leftc('_2CARTABLE_POIRE', 9)
	? cVFPName ('150') == '_150'


    	
  •  -------------------------------------------------------------

	FUNCTION cEuroANSI	&& Chaine de caractères désaccentuée
	LPARAMETERS tcEuropean && Chaine de caractères accentuée
	local lcResult && Chaine de caractères désaccentuée
	m.lcResult = space(0)

	IF Vartype(m.tcEuropean) = 'C' ;
	 AND !Empty(m.tcEuropean) ;
	 AND !IsNull(m.tcEuropean)


    	 	
  •  Restore translation strings

	 	IF NOT Vartype(m.European) == 'C' ;
	 	OR NOT Vartype(m.EuroANSI ) == 'C'
			PUBLIC European, EuroANSI 
			RESTORE FROM (Home()+'european.mem') ADDITIVE
		ENDIF


    	 	
  •  Translate

		m.lcResult = Sys(15, m.EuroANSI, m.tcEuropean)


  • 		m.lcResult = Chrtran(m.tcEuropean, m.European, m.EuroANSI)

	ENDIF

	RETURN m.lcResult


    	
  •  -----------------------------------------------------------------

	PROCEDURE cEuroANSI_Test
	? Sys(16)
	RELEASE European, EuroANSI 
	? cEuroANSI (.T.) = space(0)
	? cEuroANSI (space(0)) = space(0)
	? cEuroANSI (null) = space(0)
	? cEuroANSI ('hébété') = 'hebete'
	? cEuroANSI ('àäâéèêëioòùû') = 'aaaeeeeioouu'
	? cEuroANSI ('ÀÄÂÉÈÊËIOÒÙÛ') = 'AAAEEEEIOOUU'

Conclusion :


J'ai pu oublier des fonctions appelées ... Si c'est le cas merci de me les signaler.
S'inscrire maintenant

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.

Du même auteur (AbaqueInside)