Boas,
Preciso de ajuda : No excel 2003 funciona mas em 2007 não. Abro o ficheiro, escolho o caminho para outro ficheiro no sentido de importar um desenho, depois ao clicar no botão para importar dá o erro run-time "Não é possível definir a propriedade
Formula da classe TextBox" :
O código do botão que importa o desenho :
Sub Load_ApprovalDwg_Button_Click()
'On Error GoTo handler
'Constants
Dim libname, libpathname As String
With Application
.DisplayAlerts = False
.ScreenUpdating = False
If Not DEBUGMODE Then .Interactive = False
End With
libname = "ApprovalDrawingLibrary.xls"
libpathname = ThisWorkbook.Sheets(CONSTANTS_SHEET).Range("LibraryLocation") & Application.PathSeparator & libname
If LoadDrawing("Approval Dwg", libpathname) Then
'HandrailBoltHoles
ApprovalDrawStair
positionHandrailApproval
ApprovalDeleteHoles
DoNotching
DoCutProfile
DoApprovalConcrete
DoApprovalOBR
End If
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.Interactive = True
End With
Exit Sub
handler:
MsgBox "Unexpected error when loading Approval Drawing"
End Sub
O código da função onde está o erro :
Sub UpdateDrawingLinks(apr As Boolean)
Dim msg As String
ActiveSheet.Range("A1").Select
' Change links to link to current workbook
Dim alinks As Variant
Dim i As Integer
alinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(alinks) Then
For i = 1 To UBound(alinks)
ActiveWorkbook.ChangeLink alinks(i), ActiveWorkbook.FullName, xlExcelLinks
Next i
End If
' Check whether there are any remaining links to other workbooks
' You should never get this error but during development sometimes this occurred
alinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(alinks) Then
MsgBox "** Warning **" & Chr(13) & "There are unresolved links to other spreadsheets!"
For i = 1 To UBound(alinks)
msg = msg & alinks(i) & " *** "
Next i
MsgBox msg
End If
' Reactive the formula that link the text boxes to worksheet cells
' This is required since the textboxes with named rang links did not always update to the current value in the cell
Dim sh, gsh As Shape, txtboxFormula As String
For Each sh In ActiveSheet.Shapes
If sh.Type = msoTextBox Then
' the shape is a text box
sh.Select ' select the object
'Note the .formula property seems to work with text boxes only if you select them individually
txtboxFormula = Selection.Formula
If txtboxFormula <> "" Then
' update the formula
Selection.Formula = txtboxFormula
Selection.Font.ColorIndex = 1 ' change colour to black
'If apr Then Selection.Font.Size = 10
'sh.TextFrame.AutoSize = msoTrue 'ensure the text box expands to the linked value
End If
ElseIf sh.Type = msoGroup Then
' shape is a group run through each shape in the group
'If apr Then Selection.Font.Size = 10
For Each gsh In sh.GroupItems
If gsh.Type = msoTextBox Then
' the shape is a text box
gsh.Select ' select the object
'Note the .formula property seems to work with text boxes only if you select them individually
txtboxFormula = Selection.Formula
If txtboxFormula <> "" Then
' update the formula
Selection.Formula = txtboxFormula
<----------ERRO DÁ AQUI--------------
Selection.Font.ColorIndex = 1 ' change colour to black
'If apr Then Selection.Font.Size = 10
'gsh.TextFrame.AutoSize = msoTrue 'ensure the text box expands to the linked value
End If
Else
'MsgBox "Other type"
End If
Next
End If
Next
Set sh = Nothing
ActiveSheet.Range("A1").Select
Exit Sub
errorHandler:
MsgBox "Unexpected Error when updating links"
End Sub
Obrigado pela ajuda, apesar de achar ser melhor enviar o ficheiro para perceberem melhor.
Abraços,
Jorge
