Sunday, May 22, 2011

Manifest Injector - 1 kali Klik Untuk XP Style - Tools VB6

Setelah kita memahami cara menambah module, menambahkan kode, mengubah Startup Object, maka sekarang kita akan membuat sebuah tools sederhana yang bermanfaat dan akan banyak digunakan yaitu Manifest Injector sebuah generator kode sederhana.
Langkah-langkah:
  • Buat project Add-Ins
  • Hapus frmAddIns (form default saat membuat project Addins)
  • Tambahkan kode-kode di bawah ini:
-modAddIns
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:
Connect.dsr
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: