1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
|
' --------------------------------------------------------------------------------------------------------------
'
' Add a custom property to an existing Excel file. The list of properties can be found in the File - Custom
' menu of Excel
'
' --------------------------------------------------------------------------------------------------------------
Public Sub AddCustomDocumentProperties(ByVal sXLSFileName As String, ByVal sCustomDocumentProperty As String, ByVal vValue As Variant)
Const msoPropertyTypeText = 4
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Set xlApp = CreateObject("Excel.Application")
With xlApp
' Be sure that Excel is ready
Do While Not .Ready: DoEvents: Loop
Set xlBook = .Workbooks.Open(FileName:=sXLSFileName, ReadOnly:=False, AddToMRU:=False)
On Error Resume Next
xlBook.CustomDocumentProperties(sCustomDocumentProperty).Value = vValue
If Err.Number <> 0 Then
xlBook.CustomDocumentProperties.Add Name:=sCustomDocumentProperty, LinkToContent:=False, Value:=vValue, _
Type:=msoPropertyTypeText
End If
On Error GoTo 0
xlBook.Close SaveChanges:=acSaveYes
Set xlBook = Nothing
End With
xlApp.Quit
Set xlApp = Nothing
End Sub |
Partager