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:

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

Menguji Kode Project Add-Ins Tanpa Compile - Add-Ins VB6

Menjelaskan mengenai cara menguji kode yang terdapat pada sebuah Addins tanpa compile - Apabila kita hanya bermaksud menguji, melihat kinerja serta men-debug sebuah project Addins tanpa bermaksud mengcompilenya menjadi sebuah DLL, maka yang harus kita lakukan adalah menjalankan (run) project Addin tersebut dengan mengklik tombol run atau tombol keyboard F5 (biarkan), selanjutnya buka Aplikasi baru (terpisah dari project Addin yang telah dijalankan) dan buatlah sebuah project baru (Standard Exe misalnya), klik menu Add-Ins, maka pada sub menu akan terdapat menu My Addin.

Efek samping menjalankan project addins tanpa compile:
  1. MessageBox (apabila project addins tersebut menampilkan MessageBox) tidak akan tampil ke depan.
  2. Kecepatan eksekusi kode berkurang antara 25 - 100 kali (sangat signifikan)
  3. dan lain sebagainya.
READ MORE - Menguji Kode Project Add-Ins Tanpa Compile - Add-Ins VB6

Menambah Module Yang Disertai Kode Melalui VB6 Add-Ins

Menjelaskan mengenai cara menambah module melalui Visual Basic 6 Add-Ins - Sebelumnya saya telah memposting mengenai cara menambah Form, Menu, CommandButton, menambah referensi komponen OCX dan DLL melalui pemrograman Add-Ins, maka untuk melengkapi mengenai cara membuat robot software atau generator code tentulah harus dapat menambahkan Module, Class, UserControl, Resource, dsb.

Untuk menjalankan kode di bawah, ikuti langkah-langkah berikut:
  1. Buat project Add-Ins baru dengan cara Klik File, klik New Project, klik Addin
  2. Gantilah seluruh kode yang terdapat pada frmAddin dengan kode di bawah
  3. Lakukan compile dengan cara klik File, klik Make MyAddin.dll
  4. Simpan project, dan tutuplah aplikasi Visual Basic 6

Public VBInstance As VBIDE.VBE 
Public Connect As Connect

Option Explicit

Private Sub
CancelButton_Click()
Connect.Hide
End Sub

Private Sub
OKButton_Click()
AddModule "moDatabase", ConnectionCode
End Sub

Public 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

Private Function
ConnectionCode() As String
Dim
sMsg As String
sMsg = sMsg & "" & vbCrLf
sMsg = sMsg & "Public conn As ADODB.Connection" & vbCrLf
sMsg = sMsg & "" & vbCrLf
sMsg = sMsg & "Public Function OpenDatabase(Filename As String) As Boolean" & vbCrLf
sMsg = sMsg & "" & vbCrLf
sMsg = sMsg & " Dim c As String" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & " On Error GoTo ErrHandler" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & " c = " & Chr(34) & "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & Chr(34) & " & Filename" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & " Set conn = New ADODB.Connection" & vbCrLf
sMsg = sMsg & " conn.ConnectionString = c" & vbCrLf
sMsg = sMsg & " conn.Open" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & " OpenDatabase = True" & vbCrLf
sMsg = sMsg & " Exit Function" & vbCrLf
sMsg = sMsg & "" & vbCrLf
sMsg = sMsg & "ErrHandler:" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & " OpenDatabase = False" & vbCrLf
sMsg = sMsg & " " & vbCrLf
sMsg = sMsg & "End Function" & vbCrLf
ConnectionCode = sMsg
End Function

Untuk mengakses MyAddin.dll, buka project baru klik Add-in Addin Manager.... klik My Add-in, selanjutnya tekanlah tombol OK dan lihatlah hasilnya.
READ MORE - Menambah Module Yang Disertai Kode Melalui VB6 Add-Ins

Friday, April 22, 2011

Module Untuk Memperoleh Nama File, Extension, Path - VB6

Karena bingung memberi judul, akhirnya judulnya seperti di atas. Module ini digunakan untuk memperoleh (return/get) nama dari PathName lengkap, apakah yang akan diambil extensionnya saja, filenamenya saja, path tanpa filename. Adapun kodenya sebagai berikut:
Option Explicit 

Public Enum
eFilename
ExtentionOnly = 0 'contoh .exe, .zip, dll
FileNameOnly = 1 'update.exe, notify.exe, file.zip
PathNameOnly = 2 'c:\program files\anti virus
WithOutExtention = 3 'update, notify (tanpa .exe)
End Enum

Public Function
GetName(Filename As String, str As eFilename) As String
Dim
vArray As Variant, sDelimiter As String, e As String, v() As String
If
Filename = "" Then Exit Function
Select Case
str
Case ExtentionOnly
sDelimiter = "."
Case FileNameOnly
sDelimiter = "\"
Case PathNameOnly
vArray = Split(Filename, "\")
GetName = Mid(Filename, 1, Len(Filename) - Len(vArray(UBound(vArray))) - 1)
Exit Function
Case
WithOutExtention
vArray = Split(Filename, "\")
e = vArray(UBound(vArray))
v() = Split(e, ".")
GetName = v(0)
Exit Function
End Select
vArray = Split(Filename, sDelimiter)
GetName = vArray(UBound(vArray))
End Function
Contoh penggunaan kode di atas:
Private Sub Command1_Click() 
msgbox GetName ("C:\Program Files\UI\Update.exe",FileNameOnly) 'jika ingin memperoleh filenamenya saja, dll.
End Sub
READ MORE - Module Untuk Memperoleh Nama File, Extension, Path - VB6