- Tham gia
- 13/6/06
- Bài viết
- 4,652
- Được thích
- 10,142
- Giới tính
- Nam
- Nghề nghiệp
- Giáo viên, CEO tại Bluesofts
Mình thấy nhiều bạn cài đặt Addin làm trong Excel, phương pháp này không được tốt lắm vì nó mang tình phụ thuộc vào mức "Security" của Excel.
Mình viết một chương trình cài đặt Addins cho Excel trên VB6 mọi người tham khảo. Nếu ai đó hoàn thiện được nó hơn thì post lên nhé!
Mình viết một chương trình cài đặt Addins cho Excel trên VB6 mọi người tham khảo. Nếu ai đó hoàn thiện được nó hơn thì post lên nhé!
Mã:
Const strClassApp As String = "Excel.Application"
Const strAddinsPath As String = "My AddIns"
Enum enuCreateObject
coError = 0
coCreate = 1
coGetInstance = 2
End Enum
'-------------------------------------
Sub Main()
On Error GoTo RaiseErr
Dim ExcelApp As Excel.Application
Dim InfoCr As enuCreateObject
Dim strPath As String, AddinsList As String
InfoCr = GetApp(strClassApp, ExcelApp)
If InfoCr = coError Then
MsgBox "Loi nhan dieu khien cua Excel (Instance).", vbCritical
Exit Sub
End If
If InfoCr = coCreate Then
ExcelApp.Workbooks.Add
ExcelApp.Visible = False
End If
strPath = App.Path & "\" & strAddinsPath
AddinsList = InstallAddIns(ExcelApp, strPath, "xla")
AddinsList = AddinsList & InstallAddIns(ExcelApp, strPath, "xll")
If Len(AddinsList) = 0 Then
MsgBox "Cai AddIns cho Excel khong thanh cong.", vbCritical
Else
MsgBox "Cac Addins da duoc cai dat vao Excel:" & AddinsList _
, vbInformation, _
"Cai dat thanh cong!"
End If
RaiseErr:
If Not ExcelApp Is Nothing Then
If InfoCr = coCreate Then
ExcelApp.Quit
End If
Set ExcelApp = Nothing
End If
If Err.Number = 0 Then Exit Sub
MsgBox Err.Number & ": " & Err.Description, vbCritical, "Error: Sub Main"
End Sub
'-------------------------------------
Private Function GetApp(strClass As String, ByRef ObjApp As Object) As enuCreateObject
On Error GoTo CreateApp
GetApp = coGetInstance
Set ObjApp = GetObject(, strClassApp)
Exit Function
CreateApp:
On Error GoTo RaiseErr
GetApp = coCreate
Set ObjApp = CreateObject(strClassApp)
Exit Function
RaiseErr:
GetApp = coError
End Function
'-------------------------------------
Private Function InstallAddIns(ByVal ExcelApp As Excel.Application, ByVal AddInsPath As String, ByVal TypeOfFile As String) As String
On Error Resume Next
Dim MyFileAddIn As String
MyFileAddIn = Dir(AddInsPath & "\*." & TypeOfFile) ' Retrieve the first entry.
Do While MyFileAddIn <> "" ' Start the loop.
MyFileAddIn = InstallAddIn(ExcelApp, AddInsPath & "\" & MyFileAddIn)
If MyFileAddIn <> "" Then
InstallAddIns = InstallAddIns & Chr(13) & MyFileAddIn
End If
MyFileAddIn = Dir ' Get next entry.
Loop
End Function
'-------------------------------------
Private Function InstallAddIn(ByVal ExcelApp As Excel.Application, strFileAddin As String) As String
On Error GoTo RaiseErr
Dim objAddin As Excel.AddIn
InstallAddIn = ""
Set objAddin = ExcelApp.AddIns.Add(FileName:=strFileAddin)
'Debug.Print objAddin.FullName
If UCase(objAddin.FullName) <> UCase(strFileAddin) Then
MsgBox "Da co mot Addin cung ten """ & objAddin.Name & """ duoc cai dat theo dia chi (duong dan) """ & objAddin.Path & """." & Chr(13) & _
"Ban hay vao Excel, trong menu Tools->Add-Ins...hay kiem tra lai.", _
vbExclamation
'// TODO...
Else
objAddin.Installed = True
InstallAddIn = objAddin.FullName
End If
Set objAddin = Nothing
Exit Function
RaiseErr:
MsgBox Err.Number & ": " & Err.Description, vbCritical, "Error: Sub InstallAddIn"
End Function
'-------------------------------------
