Saturday, February 26, 2011

VB6.0 - Set Google Chrome Default Home Site Programmatically

Mendefaultkan home site IE (Internet Explorer) atau Mozilla Firefox secara pemrograman mungkin kita sudah mengetahuinya, tapi bagaimana dengan Google Chrome yang tergolong relatif masih muda untuk saat ini (2011).

Masalah mendefaultkan Google Chrome home page, hanyalah masalah merubah 1 baris kode yang terdapat pada file preferences yang terdapat pada folder: .... \Local Settings\Application Data\Google\Chrome\User Data\Default.

Atau tepatnya merubah 1 baris kode yang terdapat pada gambar di bawah ini:

Gambar 1  Kode yang dirubah pada file preferences
Di bawah ini merupakan kode untuk mendefaultkan home page Google Chrome. Letakan kode ini pada module.

'---------------------------------------------------------------------------------- 
'From: http://khoiriyyah.blogspot.com
'By: Asep Hibban
'----------------------------------------------------------------------------------
Option Explicit

Public Sub
SetChromeHomepage(URL As String)

Dim
strPath As String, strProfile As String
Dim
strContent As String, strReplace As String
Dim
regex As RegExp, strSystemDrive As String

strPath = Environ("SystemDrive") & Environ("HOMEPATH")
strPath = strPath & "\Local Settings\Application Data\Google\Chrome\User Data\Default"
strProfile = Dir(strPath, vbDirectory)
Debug.Print strPath
If Len(strPath) Then
strPath = strPath & "\Preferences"
strReplace = Chr(34) & "homepage" & Chr(34) & ": " & Chr(34) & URL & Chr(34) & ","
strContent = fGetFileContents(strPath)
Set regex = New RegExp
If InStr(1, strContent, Chr(34) & "homepage" & Chr(34)) = 0 Then
strContent = strContent & vbCrLf & Chr(34) & "homepage" & Chr(34) & ": " & Chr(34) & URL & Chr(34) & ","
sPutStringToFile strContent, strPath
Exit Sub
ElseIf
InStr(1, strContent, strReplace) Then
Exit Sub
End If
'tidak bisa direplace menggunakan replace biasa
'maka kita gunakan regular expressions untuk keperluan ini
regex.Pattern = Chr(34) & "homepage" & Chr(34) & ": .*)"

strContent = regex.Replace(strContent, strReplace)
strContent = Replace(strContent, Chr(34) & "homepage_is_newtabpage" & Chr(34) & ": true,", vbCrLf & Chr(34) & "homepage_is_newtabpage" & Chr(34) & ": false,")
sPutStringToFile strContent, strPath

End If
End Sub

Public Function
fGetFileContents(strPath As String) As String
Dim
hFile As Integer
Dim
strFileContent As String


If
Len(Dir(strPath)) = 0 Then Exit Function

On Error GoTo
ErrGetFile
hFile = FreeFile

Open
strPath For Binary As #hFile
strFileContent = Space(LOF(hFile))
Get #hFile, , strFileContent
Close #hFile

fGetFileContents = strFileContent
Exit Function

ErrGetFile:

Close
MsgBox Err.Description, vbCritical, "GetFileContents"

End Function

Public Sub
sPutStringToFile(strContent As String, strPath As String)
Dim hFile As Integer

'If file exists delete it.
On Error Resume Next
Kill
strPath
On Error GoTo ErrPutString

'Write file
hFile = FreeFile
Open
strPath For Binary As #hFile
Put #hFile, , strContent
Close #hFile

Exit Sub

ErrPutString:

Close #hFile
MsgBox Err.Description, vbCritical, "PutStringToFile"

End Sub
Contoh pemanggilan prosedure di atas:
Private Sub Command1_Click() 
SetChromeHomepage "http://khoiriyyah.blogspot.com"
End Sub