Langkah-langkah:
- Buat project Add-Ins
- Hapus frmAddIns (form default saat membuat project Addins)
- Tambahkan kode-kode di bawah ini:
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Option Explicit
Public Sub OKButton_Click()
AddResource 'and sure, some code too..
End Sub
Private Function AddResource() As Boolean
Dim newResourcee As VBComponent
Dim PathName As String
PathName = GetName(VBInstance.ActiveVBProject.Filename, PathNameOnly)
On Error GoTo ErrHandler
If Not IsProjectSaved Then
MsgBox "Simpan terlebih dahulu projectnya!", vbInformation, "Project belum disimpan"
Exit Function
End If
FileCopy App.Path & "\XP.manifest.res", PathName & "\XP.manifest.res"
Set newResourcee = VBInstance.ActiveVBProject.VBComponents.AddFile(PathName & "\XP.manifest.res")
InsertXPCode
AddModule "modManifestRes", "Public Declare Sub InitCommonControls Lib " & Chr(34) & "comctl32.dll" & Chr(34) & "()"
Exit Function
ErrHandler:
MsgBox Err.Description, vbCritical, "Warning"
End Function
Private Function IsProjectSaved() As Boolean
IsProjectSaved = Not (VBInstance.ActiveVBProject.Filename = "")
End Function
Private Sub InsertXPCode()
Dim CD As CodePane
Dim CM As CodeModule
Dim strName As String
strName = GetStartUpName
If GetStartUpName <> "Sub Main" Then
Set CD = VBInstance.ActiveVBProject.VBComponents(strName).CodeModule.CodePane
Set CM = VBInstance.ActiveVBProject.VBComponents(strName).CodeModule
Dim frm As VBIDE.VBForm
With VBInstance
With .ActiveVBProject.VBComponents(strName)
Set frm = .Designer
If .Type = vbext_ct_VBMDIForm Then
If Not IsExistProc("MDIForm_Initialize", CD) Then
MakeProcedure "Initialize", "MDIForm", CM
End If
CM.InsertLines CD.CodeModule.ProcBodyLine("MDIForm_Initialize", vbext_pk_Proc) + 1, " InitCommonControls"
ElseIf .Type = vbext_ct_VBForm Then
If Not IsExistProc("Form_Initialize", CD) Then
MakeProcedure "Initialize", "Form", CM
End If
CM.InsertLines CD.CodeModule.ProcBodyLine("Form_Initialize", vbext_pk_Proc) + 1, " InitCommonControls"
End If
End With
End With
Else
Set CD = VBInstance.ActiveVBProject.VBComponents(GetSubMain).CodeModule.CodePane
Set CM = VBInstance.ActiveVBProject.VBComponents(GetSubMain).CodeModule
CM.ReplaceLine CM.Members("main").CodeLocation, "Sub Main()" & vbCrLf & " InitCommonControls"
End If
End Sub
Private Function IsExistProc(Procname As String, oCodePane As CodePane) As Boolean
Dim i As Integer
For i = 1 To oCodePane.CodeModule.CountOfLines
If oCodePane.CodeModule.ProcOfLine(i, vbext_pk_Proc) <> "" Then
If Procname = oCodePane.CodeModule.ProcOfLine(i, vbext_pk_Proc) Then
IsExistProc = True
Exit For
End If
End If
Next i
End Function
Private Function MakeProcedure(EventName, ObjectName, oCodeModule As CodeModule)
oCodeModule.CreateEventProc EventName, ObjectName
End Function
Private Function GetStartUpName() As String
On Error GoTo ErrHandler
GetStartUpName = VBInstance.ActiveVBProject.VBComponents.StartUpObject.Name
Exit Function
ErrHandler:
GetStartUpName = "Sub Main"
End Function
Private Function GetSubMain() As String
Dim v As VBComponent
Dim l As Long, s As String
For Each v In VBInstance.ActiveVBProject.VBComponents
With v
If .Type = vbext_ct_StdModule Then
l = v.CodeModule.CountOfLines
If l > 0 Then
s = v.CodeModule.Lines(1, l)
If InStr(1, s, "sub main()", vbTextCompare) > 0 Then
GetSubMain = v.Name
Exit Function
End If
End If
End If
End With
Next
End Function
Private Function AddModule(ModulName As String, Optional strCode As String) As Boolean
Dim newModule As VBComponent
On Error GoTo ErrHandler
Set newModule = VBInstance.ActiveVBProject.VBComponents.Add(vbext_ct_StdModule)
With newModule
.Name = ModulName
.CodeModule.AddFromString strCode
End With
Exit Function
ErrHandler:
MsgBox Err.Description
End Function
- Tambahkan module ini, gantilah namanya menjadi modFileAndDirectory
- Ganti seluruh kode yang terdapat pada Connect.dsr dengan kode di bawah:
Option Explicit
Public FormDisplayed As Boolean
Public VBInstance As VBIDE.VBE
Dim mcbMenuCommandBar As Office.CommandBarControl
'Dim mfrmAddIn As New frmAddIn
Public WithEvents MenuHandler As CommandBarEvents 'command bar event handler
'Sub Hide()
'
' On Error Resume Next
'
' FormDisplayed = False
' mfrmAddIn.Hide
'
'End Sub
Sub Show()
' On Error Resume Next
' If mfrmAddIn Is Nothing Then
' Set mfrmAddIn = New frmAddIn
' End If
Set modAddIns.VBInstance = VBInstance
Set modAddIns.Connect = Me
' FormDisplayed = True
' mfrmAddIn.Show
OKButton_Click
End Sub
'------------------------------------------------------
'this method adds the Add-In to VB
'------------------------------------------------------
Private Sub AddinInstance_OnConnection(ByVal Application As Object, ByVal ConnectMode As AddInDesignerObjects.ext_ConnectMode, ByVal AddInInst As Object, custom() As Variant)
On Error GoTo error_handler
'save the vb instance
Set VBInstance = Application
'this is a good place to set a breakpoint and
'test various addin objects, properties and methods
Debug.Print VBInstance.FullName
If ConnectMode = ext_cm_External Then
'Used by the wizard toolbar to start this wizard
Me.Show
Else
Set mcbMenuCommandBar = AddToAddInCommandBar("XP-Theme")
'sink the event
Set Me.MenuHandler = VBInstance.Events.CommandBarEvents(mcbMenuCommandBar)
End If
If ConnectMode = ext_cm_AfterStartup Then
If GetSetting(App.Title, "Settings", "DisplayOnConnect", "0") = "1" Then
'set this to display the form on connect
Me.Show
End If
End If
Exit Sub
error_handler:
MsgBox Err.Description
End Sub
'------------------------------------------------------
'this method removes the Add-In from VB
'------------------------------------------------------
Private Sub AddinInstance_OnDisconnection(ByVal RemoveMode As AddInDesignerObjects.ext_DisconnectMode, custom() As Variant)
On Error Resume Next
'delete the command bar entry
mcbMenuCommandBar.Delete
'shut down the Add-In
If FormDisplayed Then
SaveSetting App.Title, "Settings", "DisplayOnConnect", "1"
FormDisplayed = False
Else
SaveSetting App.Title, "Settings", "DisplayOnConnect", "0"
End If
' Unload mfrmAddIn
' Set mfrmAddIn = Nothing
Set modAddIns.VBInstance = Nothing
Set modAddIns.Connect = Nothing
End Sub
Private Sub IDTExtensibility_OnStartupComplete(custom() As Variant)
If GetSetting(App.Title, "Settings", "DisplayOnConnect", "0") = "1" Then
'set this to display the form on connect
Me.Show
End If
End Sub
'this event fires when the menu is clicked in the IDE
Private Sub MenuHandler_Click(ByVal CommandBarControl As Object, handled As Boolean, CancelDefault As Boolean)
Me.Show
End Sub
Function AddToAddInCommandBar(sCaption As String) As Office.CommandBarControl
Dim cbMenuCommandBar As Office.CommandBarControl 'command bar object
Dim cbMenu As Object
On Error GoTo AddToAddInCommandBarErr
'see if we can find the Add-Ins menu
Set cbMenu = VBInstance.CommandBars("Add-Ins")
If cbMenu Is Nothing Then
'not available so we fail
Exit Function
End If
'add it to the command bar
Set cbMenuCommandBar = cbMenu.Controls.Add(1)
'set the caption
cbMenuCommandBar.Caption = sCaption
Set AddToAddInCommandBar = cbMenuCommandBar
Exit Function
AddToAddInCommandBarErr:
End Function
- Compile Project dan Register.
- Tambahkan XP.manifest.res (XP.manifest.res adalah resource manifest yang telah dicompile menggunakan RC.EXE) bisa Anda download disini.
- Satukah XP.manifest.res dengan DLL yang berasal dari project yang telah dicompile tadi.
- Jika ingin langsung menggunakan, download project jadinya di bawah ini:
