Erreur compilation type défini par l'utilisateur non défini [Fermé]

Signaler
-
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
-
Bonjour à tous,

je recup un bd filemaker pro 5.5 pour integration sous excel
j'ai le message ci-dessous et je n'arrive pas à me dépatouiller, pouvez vous m'aider.

Dim FMApp As FMPRO50Lib.Application
Dim FMDocs As FMPRO50Lib.Documents
Dim FMActiveDoc As FMPRO50Lib.Document
Dim DBConn As ADODB.Connection
Dim dbfields As Collection
Dim FMFields As Collection

Private Const DB_DATE_FICHE = "Lot Date"
Private Const DB_LOT_FICHE = "Lot Fiche"
Private Const DB_CODE_ARTICLE = "Code Article"
Private Const DB_DESCR = "Description"
Private Const DB_POIDS = "Poids"
Private Const DB_LOT_ARTICLE = "Lot Article"
Private Const DB_PRIX = "Nuance"
Private Const DB_QTE = "Quantité"


Private FMSEP As String

Public Sub FMOpen()
Set FMApp = New FMPRO50Lib.Application
Set FMDocs = FMApp.Documents
End Sub

Private Function FMDocOpen(fileName As String) As FMPRO50Lib.Document
Set FMDocOpen = FMDocs.Open(fileName, "")
End Function

Private Sub FMDocClose(ByRef doc As FMPRO50Lib.Document)
doc.Close
Set doc = Nothing
End Sub

Private Sub FMClose()
FMDocs.Close
Set FMDocs = Nothing
FMApp.Quit
Set FMApp = Nothing
End Sub

Public Sub FMImport()
initFieldsLists
FMSEP = Chr(29)
DBOpen
FMOpen
Dim doc As FMPRO50Lib.Document
Dim fileName As String
Dim tableName As String
fileName = configGetValue("FMFAB")
Set doc = FMDocOpen(fileName)

doc.DoFMScript ("Export_FAB")
While FMApp.ScriptStatus <> 0
DoEvents
Wend
FMDocClose doc
FMClose

Dim hdl As Integer
Dim buffer As String

hdl = FreeFile
Open ThisWorkbook.Path & "\Export_FAB.tab" For Input As hdl
Dim fields() As String
While Not EOF(hdl)
Line Input #hdl, buffer
fields = Split(buffer, vbTab)
FMProcessRecord fields
Wend
Close hdl
DBClose
End Sub

Private Sub FMProcessRecord(fields() As String)
Static lastFiche As String
Static lastDate As String
Dim codes() As String
Dim descrs() As String
Dim poids() As String
Dim lots() As String
Dim prix() As String
Dim qte() As String
Dim fdate As String
Dim flot As String
Dim rs As New Recordset
Dim fieldsname As Variant
Dim ifield
If fields(0) = "" Then Exit Sub
While Asc(fields(0)) > 122: fields(0) = Mid(fields(0), 2): Wend
If StrComp(Trim(fields(0)), "SUITE", vbTextCompare) = 0 Or Trim(fields(0)) = "" Then
fdate = lastDate
flot = lastFiche
Else
fdate = Replace(Left(fields(0), 10), ".", "/")
lastDate = fdate
flot = fields(1)
lastFiche = flot
rs.Open "DELETE * FROM LotLignes WHERE [Lot Fiche]='" & flot & "'", DBConn, adOpenDynamic, adLockOptimistic
End If
Dim nb As Integer
codes = Split(fields(2), FMSEP)
nb = UBound(codes)
descrs = Split(fields(4), FMSEP)
poids = Split(fields(6), FMSEP)
lots = Split(fields(3), FMSEP)
prix = Split(fields(5), FMSEP)
qte = Split(fields(7), FMSEP)

fieldsname = Array(DB_DATE_FICHE, DB_LOT_FICHE, DB_CODE_ARTICLE, DB_DESCR, DB_POIDS, DB_LOT_ARTICLE, DB_PRIX, DB_QTE)

rs.Open "LotLignes", DBConn, adOpenKeyset, adLockOptimistic

Dim values As Variant
Dim i As Integer
Dim fpoids As String, flots As String, fdescrs As String, fprix As String, fqte As Double

For i = 0 To UBound(codes)
If Trim(codes(i)) <> "" Then
If i > UBound(descrs) Then fdescrs = "" Else fdescrs = Trim(descrs(i))
If i > UBound(poids) Then fpoids = "" Else fpoids = Trim(poids(i))
If i > UBound(lots) Then flots = "" Else flots = Trim(lots(i))
If i > UBound(prix) Then fprix = "" Else fprix = Trim(prix(i))
If i > UBound(qte) Then
fqte = "0"
ElseIf Trim(qte(i)) = "" Then
fqte = "0"
Else
fqte = CleanQte(qte(i))
End If

values = Array(CDate(fdate), flot, Trim(codes(i)), _
CStr(fdescrs), _
CStr(fpoids), _
CStr(flots), _
CStr(fprix), _
CDbl(fqte))
rs.AddNew fieldsname, values
rs.Update
End If
Next
rs.Close
End Sub
Private Function CleanQte(value As String) As String
Dim i As Integer
Dim result As String
Dim c As Integer
Dim h As Boolean

h = False
For i = 1 To Len(value)
c = Asc(Mid(value, i, 1))
If (c >= 48 And c <= 57) Then
result = result & Chr(c)
ElseIf c = 46 And h = False Then
result = result & "."
h = True
End If
Next
If result = "" Then result = "0"
CleanQte = result
End Function
Private Function configGetValue(key As String) As String
Dim tabConf As Range
Set tabConf = Range("TabConfig")
Dim c As Range
Set c = tabConf.Columns(1).Find(key)
configGetValue = tabConf.Cells(c.row, 3)
End Function

Private Sub configSetValue(key As String, value As Variant)
Dim tabConf As Range
Set tabConf = Range("TabConfig")
Dim c As Range
Set c = tabConf.Columns(1).Find(key)
tabConf.Cells(c.row - 1, 3).value = value
End Sub

Private Sub initFieldsLists()
Set FMFields = New Collection
Set dbfields = New Collection
FieldsListsAdd configGetValue("FMDATE"), DB_DATE_FICHE
FieldsListsAdd configGetValue("FMLOTFICHE"), DB_LOT_FICHE
FieldsListsAdd configGetValue("FMARTICLE"), DB_CODE_ARTICLE
FieldsListsAdd configGetValue("FMDESCR"), DB_DESCR
FieldsListsAdd configGetValue("FMPOIDS"), DB_POIDS
FieldsListsAdd configGetValue("FMLOTACTION"), DB_LOT_ARTICLE
FieldsListsAdd configGetValue("FMPRIX"), DB_PRIX
FieldsListsAdd configGetValue("FMQTE"), DB_QTE
End Sub

Private Sub FieldsListsAdd(FMField As String, DBField As String)
FMFields.Add FMField, DBField
dbfields.Add DBField, FMField
End Sub

Private Function configGetLastFiche()
configGetLastFiche = configGetValue("FMLASTFICHE")
End Function

Private Sub configSetLastFiche(value As String)
configSetValue "FMLASTFICHE", value
End Sub


Private Sub DBOpen()
Set DBConn = New ADODB.Connection
Dim Dsn As String
Dsn = "DRIVER=Microsoft Access Driver (*.mdb, *.accdb);" & vbCrLf & _
"DBQ=" & ThisWorkbook.Path & "\" & configGetValue("DBMDB")
DBConn.Open Dsn
End Sub

Private Sub DBClose()
DBConn.Close
Set DBConn = Nothing
End Sub

Public Sub FMImportUI()
Load UserForm1
UserForm1.Show
End Sub



merci

7 réponses

Messages postés
16173
Date d'inscription
lundi 12 septembre 2005
Statut
Contributeur
Dernière intervention
14 juillet 2020
2 994
Bonjour

Merci de mettre tes codes entre les balises <> pour une meilleure lisibilité: tu fais un copier du code original puis


Tu ne nous dit pas sur quelle ligne se déclenche l'erreur : elle doit ^tre surlignée en jaune

tu écris
je recup un bd filemaker pro 5.5 pour integration sous excel
Tu te connectes à une base access ?

as tu coché les références ADODB dans l'éditeur VBA (outils-références)?
Microsoft activeX data objects 2.N (N:dépend version Excel)
et
Microsoft activeX data objects Recorset


mais ton code est très difficile à lire....

Je n'ai pas vu la suppression de la collection
set lacollection=nothing

enfin on ne voit peu de restitution de données dans Excel....



Michel
Bonjour, merci de m'aider a résoudre mon pbm.
je ne me connecte pas à une base access
je recup les données de FM vers excel pour traiter mes informations, articles, lots, détails... afin de connaitre les qtés fabriqué pour chaque article au mois ou à l'année

je suis novice, je récup le bb qui a été créé par mon prédécesseur et qui ne fonctionne plus à la suite d'un changement de PC.

Réf ADODB coché :
visual basic for applications
Microsoft excel 15.0 object Library
OLE automation
Microsoft office 15.0 object Library
micsrosoft activex data objects 2.7 Library
Microsoft forms 2.0 object Library
MANQUANT : filemaker pro 5.0 type Library (je l'ai décoché mais tjs meme message)


Dim FMApp As FMPRO50Lib.Application
Dim FMDocs As FMPRO50Lib.Documents
Dim FMActiveDoc As FMPRO50Lib.Document
Dim DBConn As ADODB.Connection
Dim dbfields As Collection
Dim FMFields As Collection

Private Const DB_DATE_FICHE = "Lot Date"
Private Const DB_LOT_FICHE = "Lot Fiche"
Private Const DB_CODE_ARTICLE = "Code Article"
Private Const DB_DESCR = "Description"
Private Const DB_POIDS = "Poids"
Private Const DB_LOT_ARTICLE = "Lot Article"
Private Const DB_PRIX = "Nuance"
Private Const DB_QTE = "Quantité"


Private FMSEP As String

Public Sub FMOpen()
Set FMApp = New FMPRO50Lib.Application
Set FMDocs = FMApp.Documents
End Sub

Private Function FMDocOpen(fileName As String) As FMPRO50Lib.Document
Set FMDocOpen = FMDocs.Open(fileName, "")
End Function

Private Sub FMDocClose(ByRef doc As FMPRO50Lib.Document)
doc.Close
Set doc = Nothing
End Sub

Private Sub FMClose()
FMDocs.Close
Set FMDocs = Nothing
FMApp.Quit
Set FMApp = Nothing
End Sub

Public Sub FMImport()
initFieldsLists
FMSEP = Chr(29)
DBOpen
FMOpen
Dim doc As FMPRO50Lib.Document
Dim fileName As String
Dim tableName As String
fileName = configGetValue("FMFAB")
Set doc = FMDocOpen(fileName)

doc.DoFMScript ("Export_FAB")
While FMApp.ScriptStatus <> 0
DoEvents
Wend
FMDocClose doc
FMClose

Dim hdl As Integer
Dim buffer As String

hdl = FreeFile
Open ThisWorkbook.Path & "\Export_FAB.tab" For Input As hdl
Dim fields() As String
While Not EOF(hdl)
Line Input #hdl, buffer
fields = Split(buffer, vbTab)
FMProcessRecord fields
Wend
Close hdl
DBClose
End Sub

Private Sub FMProcessRecord(fields() As String)
Static lastFiche As String
Static lastDate As String
Dim codes() As String
Dim descrs() As String
Dim poids() As String
Dim lots() As String
Dim prix() As String
Dim qte() As String
Dim fdate As String
Dim flot As String
Dim rs As New Recordset
Dim fieldsname As Variant
Dim ifield
If fields(0) = "" Then Exit Sub
While Asc(fields(0)) > 122: fields(0) = Mid(fields(0), 2): Wend
If StrComp(Trim(fields(0)), "SUITE", vbTextCompare) = 0 Or Trim(fields(0)) = "" Then
fdate = lastDate
flot = lastFiche
Else
fdate = Replace(Left(fields(0), 10), ".", "/")
lastDate = fdate
flot = fields(1)
lastFiche = flot
rs.Open "DELETE * FROM LotLignes WHERE [Lot Fiche]='" & flot & "'", DBConn, adOpenDynamic, adLockOptimistic
End If
Dim nb As Integer
codes = Split(fields(2), FMSEP)
nb = UBound(codes)
descrs = Split(fields(4), FMSEP)
poids = Split(fields(6), FMSEP)
lots = Split(fields(3), FMSEP)
prix = Split(fields(5), FMSEP)
qte = Split(fields(7), FMSEP)

fieldsname = Array(DB_DATE_FICHE, DB_LOT_FICHE, DB_CODE_ARTICLE, DB_DESCR, DB_POIDS, DB_LOT_ARTICLE, DB_PRIX, DB_QTE)

rs.Open "LotLignes", DBConn, adOpenKeyset, adLockOptimistic

Dim values As Variant
Dim i As Integer
Dim fpoids As String, flots As String, fdescrs As String, fprix As String, fqte As Double

For i = 0 To UBound(codes)
If Trim(codes(i)) <> "" Then
If i > UBound(descrs) Then fdescrs = "" Else fdescrs = Trim(descrs(i))
If i > UBound(poids) Then fpoids = "" Else fpoids = Trim(poids(i))
If i > UBound(lots) Then flots = "" Else flots = Trim(lots(i))
If i > UBound(prix) Then fprix = "" Else fprix = Trim(prix(i))
If i > UBound(qte) Then
fqte = "0"
ElseIf Trim(qte(i)) = "" Then
fqte = "0"
Else
fqte = CleanQte(qte(i))
End If

values = Array(CDate(fdate), flot, Trim(codes(i)), _
CStr(fdescrs), _
CStr(fpoids), _
CStr(flots), _
CStr(fprix), _
CDbl(fqte))
rs.AddNew fieldsname, values
rs.Update
End If
Next
rs.Close
End Sub
Private Function CleanQte(value As String) As String
Dim i As Integer
Dim result As String
Dim c As Integer
Dim h As Boolean

h = False
For i = 1 To Len(value)
c = Asc(Mid(value, i, 1))
If (c >= 48 And c <= 57) Then
result = result & Chr(c)
ElseIf c = 46 And h = False Then
result = result & "."
h = True
End If
Next
If result = "" Then result = "0"
CleanQte = result
End Function
Private Function configGetValue(key As String) As String
Dim tabConf As Range
Set tabConf = Range("TabConfig")
Dim c As Range
Set c = tabConf.Columns(1).Find(key)
configGetValue = tabConf.Cells(c.row, 3)
End Function

Private Sub configSetValue(key As String, value As Variant)
Dim tabConf As Range
Set tabConf = Range("TabConfig")
Dim c As Range
Set c = tabConf.Columns(1).Find(key)
tabConf.Cells(c.row - 1, 3).value = value
End Sub

Private Sub initFieldsLists()
Set FMFields = New Collection
Set dbfields = New Collection
FieldsListsAdd configGetValue("FMDATE"), DB_DATE_FICHE
FieldsListsAdd configGetValue("FMLOTFICHE"), DB_LOT_FICHE
FieldsListsAdd configGetValue("FMARTICLE"), DB_CODE_ARTICLE
FieldsListsAdd configGetValue("FMDESCR"), DB_DESCR
FieldsListsAdd configGetValue("FMPOIDS"), DB_POIDS
FieldsListsAdd configGetValue("FMLOTACTION"), DB_LOT_ARTICLE
FieldsListsAdd configGetValue("FMPRIX"), DB_PRIX
FieldsListsAdd configGetValue("FMQTE"), DB_QTE
End Sub

Private Sub FieldsListsAdd(FMField As String, DBField As String)
FMFields.Add FMField, DBField
dbfields.Add DBField, FMField
End Sub

Private Function configGetLastFiche()
configGetLastFiche = configGetValue("FMLASTFICHE")
End Function

Private Sub configSetLastFiche(value As String)
configSetValue "FMLASTFICHE", value
End Sub


Private Sub DBOpen()
Set DBConn = New ADODB.Connection
Dim Dsn As String
Dsn = "DRIVER=Microsoft Access Driver (*.mdb, *.accdb);" & vbCrLf & _
"DBQ=" & ThisWorkbook.Path & "\" & configGetValue("DBMDB")
DBConn.Open Dsn
End Sub

Private Sub DBClose()
DBConn.Close
Set DBConn = Nothing
End Sub

Public Sub FMImportUI()
Load UserForm1
UserForm1.Show
End Sub
personne pour m'aider :):):):)
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Bonjour,


MANQUANT : filemaker pro 5.0 type Library (je l'ai décoché mais tjs meme message) c'est peut_etre la que cela peche, est-ce que filemaker a ete installe sur le nouveau PC et quel OS avez-vous ???

Decocher la ref manquante ne résout pas vraiment le probleme, vu qu'il la faut pour que ca marche
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Bonjour,

Sur quelle lignes de programme il y a erreur ???
Justement, je sais pas. Aucune ligne en jaune
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Re,

Question: comment le programme est lance ??? un bouton sur une feuille, par une userform ???

Pouvez-vous mettre des points d'arret dans le programme pour connaitre le deroulement du programme
Bjr,
c'est un bouton sur une feuille Excel.
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Bonjour,

et ce bouton lance quoi ?? une macro, ouvre une Userform
le bouton lance une userform
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Re,

pour voir ou est l'erreur, il faut lancer directement l'userform en partant de le fenetre VBA. double click sur Userform et lancer par le triangle sous Insertion (menu en haut) et la vous verrez la ligne en jaune
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
CommandButton1.Enabled = False
FMImport
CommandButton1.Enabled = True
Application.ScreenUpdating = True
Unload UserForm1

End Sub

1ère ligne en jaune....
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Re,

J'ai un W8 64bits et j'ai installe FM pro 11 sans probleme et il tourne en 32bits

Avez-vous lancer FileMaker pro 5.5 sur ce seven pour savoir si compatible ou pas. Si il est installe, faut tester

Pouvez_vous faire une recopie d'ecran de la fenetre reference des ref en F
BONJOUR,

j'ai installé un filemaker plus récent et comme vous, j'ai la réf pro 7.0 Library qui est miraculement apparue, mais tjs message erreur compilation...
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Re,

Avez-vous pense a changer FMPRO50Lib par FMPRO70Lib parce que ce n'est plus le meme nom dans tout le code ????
merci, je n'ai effectivement plus le message. mais une nouvelle erreur sur le code ligne soulignée



Private Sub DBOpen()
Set DBConn = New ADODB.Connection
Dim Dsn As String
Dsn = "DRIVER=Microsoft Access Driver (*.mdb, *.accdb);" & vbCrLf & _
"DBQ=" & ThisWorkbook.Path & "\" & configGetValue("DBMDB")
DBConn.Open Dsn
End Sub
Messages postés
15244
Date d'inscription
dimanche 25 novembre 2007
Statut
Membre
Dernière intervention
21 juillet 2020
1 314
Bonjour,

Chaine de connexion:

Dsn = "DRIVER={Microsoft Access Driver (*.mdb, *.accdb)};DBQ=" & ThisWorkbook.Path & "\" & configGetValue("DBMDB")