Passer de Excel 97/2003 à 2016 avec des macro
H
Bonjour,
J'ai un fichier Excel servant à générés des rapports sur word qui est assez complexe, il fonctionne sur les ancien PC mais pas sur les nouveaux.
Il me met que l'objet n'est pas présent sur cette machine.
A quoi doit je faire attention ? :
ub CompléterHorizon(ByRef TableauSondage As Word.Range, ByVal ProfondeurLimiteSupHorizonDm As Integer, ByVal EpaisseurDm, ByVal Horizon As Variant, ByVal Structure As Variant, ByVal Perméabilité As Variant, ByVal TauxMO As Variant, ByVal Pierrosité As Variant, ByVal Hydromorphie As Variant, ByVal IndexCouleurExcel As Variant)
Static Décalage As Integer
If ProfondeurLimiteSupHorizonDm = 0 Then
Décalage = 0
End If
'Récupération des données nécessaires pour remplir le tableau
Description = Générer_description_horizon(Horizon, Structure, Perméabilité, TauxMO, Pierrosité, Hydromorphie, IndexCouleurExcel)
Call DétermineImage(Horizon, Structure, IndexCouleurExcel, Pierrosité, Hydromorphie)
If Horizon = "R" Then
Couleur = 38
TexteEpaisseurHorizon = "A partir de " & Chr(7) & ProfondeurLimiteSupHorizonDm * 10 & " cm"
Else
Couleur = IndexCouleurExcel
TexteEpaisseurHorizon = "Entre " & ProfondeurLimiteSupHorizonDm * 10 & " et " & (ProfondeurLimiteSupHorizonDm + EpaisseurDm) * 10 & " cm"
End If
'Remplissage du tableau
Taille = TaillePolice(EpaisseurDm, Len(Description))
For i = 1 To EpaisseurDm
If Horizon <> "R" Or (Horizon = "R" And i = 1) Then
TableauSondage.Columns(1).Cells(ProfondeurLimiteSupHorizonDm + i + 1).Range.InlineShapes.AddPicture Filename:=CheminImages & Image1 & ExtensionImages, linkToFile:=False, saveWithDocument:=True
TableauSondage.Columns(1).Cells(ProfondeurLimiteSupHorizonDm + i + 1).Range.InlineShapes.AddPicture Filename:=CheminImages & Image2 & ExtensionImages, linkToFile:=False, saveWithDocument:=True
TableauSondage.Columns(1).Cells(ProfondeurLimiteSupHorizonDm + i + 1).Range.InlineShapes.AddPicture Filename:=CheminImages & Image3 & ExtensionImages, linkToFile:=False, saveWithDocument:=True
TableauSondage.Columns(1).Cells(ProfondeurLimiteSupHorizonDm + i + 1).Shading.BackgroundPatternColor = ThisWorkbook.Colors(Couleur)
End If
If i = 1 Then TableauSondage.Columns(2).Cells(ProfondeurLimiteSupHorizonDm + i + 1 - Décalage).Range.Text = TexteEpaisseurHorizon
TableauSondage.Columns(3).Cells(ProfondeurLimiteSupHorizonDm + i + 1 - Décalage).Range.Font.Size = Taille
If i = 1 Then TableauSondage.Columns(3).Cells(ProfondeurLimiteSupHorizonDm + i + 1 - Décalage).Range.Text = Description
Next i
If EpaisseurDm > 1 Then
TableauSondage.Columns(2).Cells(ProfondeurLimiteSupHorizonDm + 2 - Décalage).Merge MergeTo:=TableauSondage.Columns(2).Cells(ProfondeurLimiteSupHorizonDm + EpaisseurDm + 1 - Décalage)
TableauSondage.Columns(3).Cells(ProfondeurLimiteSupHorizonDm + 2 - Décalage).Merge MergeTo:=TableauSondage.Columns(3).Cells(ProfondeurLimiteSupHorizonDm + EpaisseurDm + 1 - Décalage)
End If
Décalage = Décalage + EpaisseurDm - 1
End SubBonjour,
vérifie que la référence à Word est cochée (sous la bonne version)
ps/ en passant par la fenêtre "Référence" décoche les "MANQUANT"
H
Bonjour,
En décochant les manquant voici ce que excel m'indique :
'Option Explicit
'Pour ajuster la liste déroulante des noms du classeurs sur le nom le plus long :
Private Declare Function FindWindowA& Lib "user32" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Function FindWindowExA& Lib "user32" (ByVal hWnd1&, ByVal hWnd2&, ByVal lpsz1$, ByVal lpsz2$)
Private Declare Function GetWindowDC& Lib "user32" (ByVal hwnd&)
Private Declare Function GetTextExtentPoint32A& Lib "gdi32" (ByVal hDC&, ByVal lpsz$, ByVal cbString&, lpSize As POINTAPI)
Private Declare Function SendMessageA& Lib "user32" (ByVal hwnd&, ByVal wMsg&, ByVal wParam&, ByVal lParam&)
Private Type POINTAPI
x As Long
y As Long
End Type
'Pour modifier le nombre d'items affichés :
Private Declare Function GetClientRect& Lib "user32" (ByVal hwnd&, lpRect As RECT)
Private Declare Function MoveWindow& Lib "user32" (ByVal hwnd&, ByVal x&, ByVal y&, ByVal nWidth&, ByVal nHeight&, ByVal bRepaint&)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Sub AdjustComboNames()
If ActiveWorkbook.Names.Count = 0 Then Exit Sub
Dim hwnd&, iName$, i%, hDC&, Txt As POINTAPI, MaxLen&
hwnd = FindWindowA(vbNullString, Application.Caption)
hwnd = FindWindowExA(hwnd, ByVal 0&, "EXCEL;", vbNullString)
hwnd = FindWindowExA(hwnd, ByVal 0&, "ComboBox", vbNullString)
hDC = GetWindowDC(hwnd)
For i = 1 To ActiveWorkbook.Names.Count
iName = ActiveWorkbook.Names(i).Name
GetTextExtentPoint32A hDC, iName, Len(iName), Txt
If Txt.x > MaxLen Then MaxLen = Txt.x
Next i
' Ajuste la largeur sur le nom le plus long
SendMessageA hwnd, &H160, MaxLen, 0
' Nombre de ligne à afficher
Dim Nb As Byte: Nb = 10
Dim R As RECT: GetClientRect hwnd, R
With R
R.Bottom = Txt.y * (Nb + 2)
MoveWindow hwnd, .Left, .Top, .Right - .Left, (.Bottom - .Top), 1
End With
End Sub
Public Sub Afficher_feuilles_paramètres()
Call Initialisation
Application.ScreenUpdating = False
F_TEST.Visible = xlSheetVisible
F_Horizons.Visible = xlSheetVisible
F_Structure.Visible = xlSheetVisible
F_Hydromorphies.Visible = xlSheetVisible
F_Couleurs.Visible = xlSheetVisible
F_Perméabilité.Visible = xlSheetVisible
F_TauxMO.Visible = xlSheetVisible
F_Pierrosité.Visible = xlSheetVisible
F_SERP.Visible = xlSheetVisible
F_Config.Visible = xlSheetVisible
Application.ScreenUpdating = True
End Sub
Public Sub Masquer_feuilles_paramètres()
Call Initialisation
F_TEST.Visible = xlSheetHidden
F_Horizons.Visible = xlSheetHidden
F_Structure.Visible = xlSheetHidden
F_Hydromorphies.Visible = xlSheetHidden
F_Couleurs.Visible = xlSheetHidden
F_Perméabilité.Visible = xlSheetHidden
F_TauxMO.Visible = xlSheetHidden
F_Pierrosité.Visible = xlSheetHidden
F_SERP.Visible = xlSheetHidden
F_Config.Visible = xlSheetHidden
End Sub