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