Download: LaVolpe's Manifest Creator.
Cara menggunakan:
- Ekstrak file, double klik install.bat untuk meregistrasikan komponen
- Buka project baru, atau project yang telah Anda buat.
- Klik menu Add-Ins >> ManifestCreator >> Create Manifest.
Sebuah catatan pribadi mengenai bahasa arab, syair arab klasik, Visual Basic 6.0, dan Blogging.
KeyAscii = IIf((KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8, KeyAscii, 0)
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = IIf((KeyAscii > 47 And KeyAscii < 58) Or KeyAscii = 8, KeyAscii, 0)
End Sub
Public Function GetDecimalSymbol() As IntegerApabila digabungkan dengan posting sebelumnya, maka dapat diperoleh validasi entry untuk numeric yang memperbolehkan angka di belakang koma, tapi bagaimana cara menggabungkannya?
'akan memperoleh 44 untuk koma (,) dan 46 untuk (.) dan lain sebagainya.
GetDecimalSymbol = Asc(Mid$(1 / 2, 2, 1))
End Function
Selain Codejock dan Active Skin, skin form yang dibuat oleh Leandro Ascierto (argentina) ini layak sekali untuk dipertimbangkan. Memiliki banyak contoh skin, kurang lebih ada 16 skin. Apabila kita belum puas dengan tampilannya, kita bisa membuat custom skin, karena projectnya (terpisah) dilengkapi dengan fasilitas editor untuk membuat custom skin.
Skin form (open source dan lengkap beserta contohnya) dapat Anda download di: http://www.leandroascierto.com.
Selain skin form, di situs miliknya, kita akan mendapati resource-resource berupa uc(User Control) yang berkualitas.
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Option Explicit
Dim strCon As String
Private Sub cboTables_Click()
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = DBase
Dim c As ADOX.Column
lstAll.Clear
For Each c In cat.Tables(GetTabelValidName(cboTables.Text)).Columns
lstAll.AddItem c.Name
Next
If lstAll.ListCount > 0 Then lstAll.ListIndex = 0
Set cat = Nothing
End Sub
Private Function GetTabelValidName(strName As String) As String
Dim s() As String
s = Split(strName, " : ")
GetTabelValidName = s(1)
End Function
Private Sub cmdConnect_Click()
On Error GoTo ErrHandler
strCon = getADOConnectionString()
If strCon = "" Then Exit Sub
txtCon.Text = strCon
If OpenDataBase(strCon) = True Then
FillComboWithTables
End If
Exit Sub
ErrHandler:
MsgBox Err.Number & vbNewLine & Err.Description, vbExclamation + vbOKOnly, "Connection Error"
lstAll.Clear
cboTables.Clear
End Sub
Private Function FillComboWithTables()
Set cat = New ADOX.Catalog
Set cat.ActiveConnection = DBase
Dim i As Integer
cboTables.Clear
lstAll.Clear
For i = 0 To cat.Tables.Count - 1
If cat.Tables(i).Type <> "SYSTEM TABLE" And cat.Tables(i).Type <> "ACCESS TABLE" Then
If cat.Tables(i).Type = "TABLE" Then
cboTables.AddItem "Table : " & cat.Tables(i).Name
Else
cboTables.AddItem "query : " & cat.Tables(i).Name
End If
End If
Next i
Set cat = Nothing
End Function
Private Sub Command1_Click()
AddFormAndControls Replace(GetTabelValidName(cboTables.Text), " ", "_"), GetTabelValidName(cboTables.Text)
End Sub
Private Function AddFormAndControls(f As String, c As String)
On Error Resume Next
Dim frm As VBIDE.VBComponent
Dim ctl As VBControl
Dim frmCurrent As VBForm
Dim i As Integer, x As Integer, y As Integer, k As Integer
Set frm = VBInstance.ActiveVBProject.VBComponents.Add(vbext_ct_VBForm)
Set frmCurrent = VBInstance.SelectedVBComponent.Designer
For i = 0 To lstAll.ListCount - 1
'kode di bawah ini untuk menambah TextBox
Set ctl = frmCurrent.VBControls.Add("VB.TextBox")
With ctl
.Properties("Name") = "txt" & Replace(lstAll.List(i), " ", "_")
If i = 0 Then
.Properties("Top") = 500
x = 500
Else
x = x + 400 'spasi (jarak) untuk TextBox
End If
.Properties("Top") = x
.Properties("Left") = 2500
.Properties("Width") = 4000
.Properties("Height") = 330
.Properties("Text") = lstAll.List(i)
'.properties dan lain-lain, disesuaikan kebutuhan
End With
If i = lstAll.ListCount - 1 Then
y = x + 2000 'Form Height
k = x + 900 'CommandButton Top
End If
'kode di bawah ini untuk menambah label
Set ctl = frmCurrent.VBControls.Add("VB.Label")
With ctl
.Properties("Name") = lstAll.List(i)
.Properties("Top") = x
.Properties("Left") = 465
.Properties("Width") = 2000
.Properties("Height") = 255
.Properties("Caption") = lstAll.List(i)
.Properties("BackStyle") = 0 'transparent
'.properties dan lain-lain, disesuaikan kebutuhan
End With
Next
Set ctl = frmCurrent.VBControls.Add("VB.CommandButton")
With ctl
.Properties("Name") = "cmdUpdate"
.Properties("Top") = k
.Properties("Left") = 5040
.Properties("Width") = 1455
.Properties("Height") = 375
.Properties("Caption") = "&Update"
'.properties dan lain-lain, disesuaikan kebutuhan
End With
Set ctl = frmCurrent.VBControls.Add("VB.CommandButton")
With ctl
.Properties("Name") = "cmdCancel"
.Properties("Top") = k
.Properties("Left") = 3480
.Properties("Width") = 1455
.Properties("Height") = 375
.Properties("Caption") = "&Cancel"
'.properties dan lain-lain, disesuaikan kebutuhan
End With
InsertOCX "{2CDCDF4C-4914-4DBC-99CB-12359BE472E1}"
Set ctl = frmCurrent.VBControls.Add("Liner.cLiner")
With ctl
.Properties("Top") = k - 300
.Properties("Left") = -5
.Properties("Width") = 7000
.Properties("Height") = 30
End With
With frm
.Properties("Name") = "frm" & f
.Properties("Width") = 7155
.Properties("Caption") = c
.Properties("Height") = y
End With
'--------------------------------------------------------------------------------------------------
'tambahkan kontrol lain-lain ThirdParty OCX
'tambahkan pula kode-kode yang sesuai
'maaf, belum dibuatkan....
'--------------------------------------------------------------------------------------------------
End Function
Public Function InsertOCX(ProgID As String) As Boolean
On Error GoTo ErrHandler
'Add OCX
VBInstance.ActiveVBProject.AddToolboxProgID ProgID
InsertOCX = True
Exit Function
ErrHandler:
InsertOCX = False
End Function
Option ExplicitKode pada modDataLinks: silakan copy dan pastekan dari tautan di samping module data links.
Public DBase As New ADODB.Connection
Public cat As ADOX.Catalog
Function OpenDataBase(sFilename As String) As Boolean
'// Membuat koneksi ke database
Set DBase = New ADODB.Connection
With DBase
.CursorLocation = adUseClient
.Open "Provider= Microsoft.Jet.OLEDB.4.0;Persist security info=False;Data Source=" & sFilename & ";Jet OLEDB:Database;"
End With
OpenDataBase = True
End Function
If ConnectMode = ext_cm_External Then
'Used by the wizard toolbar to start this wizard
Me.Show
Else
Set mcbMenuCommandBar = AddToAddInCommandBar("My AddIn")
'sink the event
Set Me.MenuHandler = VBInstance.Events.CommandBarEvents(mcbMenuCommandBar)
End If
Public VBInstance As VBIDE.VBEWalaupun kode di atas tampak sederhana, akan tetapi ia akan sangat berguna, kira-kira untuk apa?
Public Connect As Connect
Option Explicit
Private Sub OKButton_Click()
EnumAllMembers
End Sub
Private Function EnumAllMembers()
Dim m As Member
Dim t As String
List1.Clear
For Each m In VBInstance.SelectedVBComponent.CodeModule.Members
Select Case m.Type
Case vbext_MemberType.vbext_mt_Const
t = "Constanta"
Case vbext_MemberType.vbext_mt_Event
t = "Event"
Case vbext_MemberType.vbext_mt_Method
t = "Method"
Case vbext_MemberType.vbext_mt_Property
t = "Property"
Case vbext_MemberType.vbext_mt_Variable
t = "Variable"
End Select
List1.AddItem "Nama: " & m.Name & vbTab & vbTab & "Type: " & t & vbTab & vbTab & "Scope: " & m.Scope
Next
End Function
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
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
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
Option ExplicitContoh penggunaan kode di atas:
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
Private Sub Command1_Click()
msgbox GetName ("C:\Program Files\UI\Update.exe",FileNameOnly) 'jika ingin memperoleh filenamenya saja, dll.
End Sub
'tambahkan kode di bawah ke dalam form frmMain
Private Sub Form_Load()
BukaData App.Path & "\database\en-id.txt", List2
End Sub
Private Sub List1_Click()
Text3.Text = List1.Text
End Sub
Private Sub List2_Click()
If List2.ListIndex <> -1 Then
Text2.Text = Replace(DataEn(List2.ListIndex), vbTab, " = ")
End If
End Sub
Private Sub Text1_DblClick()
Text3.Text = Trim(Text1.SelText)
End Sub
Private Sub Text3_Change()
Dim i As Integer
If Text3.Text = "" Then
List2.ListIndex = -1
Text2.Text = ""
Exit Sub
End If
i = List2.ListIndex
If List2.Text = "" Then List2.ListIndex = i
Dim retValue As Long
retValue = SendMessage(List2.hWnd, LB_FINDSTRING, -1, ByVal Text3.Text)
If retValue > -1 Then
List2.TopIndex = retValue
Else
List2.TopIndex = i
End If
List2.ListIndex = List2.TopIndex
End Sub
Option Explicit
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Const LB_ADDSTRING = &H180
Public Const LB_FINDSTRING = &H18F
Public Const LB_FINDSTRINGEXACT = &H1A2
Public DataEn() As String
Public LokasiData As String
Sub BukaData(FileName As String, lst As ListBox)
Dim Temp As String
Dim i As Long
lst.Parent.Visible = False
Open FileName For Binary As #1
Temp = Space$(LOF(1))
Get #1, , Temp
Close #1
Temp = Replace(Temp, vbCrLf & "" & vbCrLf, vbCrLf)
DataEn = Split(Temp, vbCrLf)
lst.Clear
For i = 0 To UBound(DataEn) - 1
SendMessage lst.hWnd, LB_ADDSTRING, 0, ByVal CStr(Split(DataEn(i), vbTab)(0))
Next
lst.ListIndex = 0
lst.Parent.Visible = True
End Sub
Sub Main()sehingga menjadi:
InitCommonControls
frmMain.Show
End Sub
Sub Main()Uji Coba
InitCommonControls 'XP Style inisialisasi
frmSplash.Show 'tampilkan splash form terlebih dahulu
frmSplash.Refresh 'refresh agar tampilannya benar
Load frmMain 'load seluruh kode dalam tampilan utama
frmMain.Show 'tampilkan form utama
Unload frmSplash 'tutup splash form
End Sub
Private Sub Form_Load()Sehingga menjadi:
BukaData App.Path & "\database\en-id.txt", List2
End Sub
Private Sub Form_Load()Tambahkan kode di bawah ini pada frmMain:
GetPositionsFromRegistry Me 'ini untuk posisi form yang diambil dari registry
BukaData App.Path & "\database\en-id.txt", List2
End Sub
Private Sub Form_Unload(Cancel As Integer)Uji Coba
SavePositionsInRegistry Me ' menyimpan posisi ke dalam registry
End Sub
'simpan (copy dan pastekan) kode di bawah ini dalam frmMainUji Coba:
Option Explicit
Dim strFromClipboard As String
Private Sub Timer1_Timer()
Dim s As String
s = Clipboard.GetText
If s <> strFromClipboard Then
strFromClipboard = s
Text1.Text = strFromClipboard
End If
End Sub
Option ExplicitUji Coba:
Private Declare Function EmptyClipboard Lib "user32" ) As Long 'API Function
Dim strFromClipboard As String
'---------------------------------------------------------------------------------
' Copy text dari clipboard dan masukan ke dalam objek TextBox
' dengan men-trigger secara kontinyu menggunakan bantuan timer
'---------------------------------------------------------------------------------
Private Sub Timer1_Timer()
On Error GoTo ErrHandler 'apabila error loncat ke Handle Error
Dim s As String
s = Clipboard.GetText 'baris ini terkadang error |Error Number = 521|
If s <> strFromClipboard Then
ParsingText s, List1
strFromClipboard = s
Text1.Text = strFromClipboard
End If
Exit Sub
ErrHandler:
'Handle Error
If Err.Number = 521 Then 'Can't open the clipboard
Text1.Text = ""
EmptyClipboard 'paksa kosongkan clipboard dengan Fungsi API
Resume Next 'loncat lagi ke baris atas dan lanjutkan eksekusi membaca kode)
End If
End Sub
'--------------------------------------------------------------------------------
' dua event List1_Click() dan Text_DblClick()
' dengan kode sementara, hanya untuk mengecek dan melihat hasilnya saja
'--------------------------------------------------------------------------------
Private Sub List1_Click()
Text2.Text = "Menterjemahkan : " & List1.Text & " ==> ke dalam bahasa Inggris"
End Sub
Private Sub Text1_DblClick()
Text2.Text = "Menterjemahkan : " & Text1.SelText & " ==> ke dalam bahasa Inggris"
End Sub
'---------------------------------------------------------------------------------
' Fungsi untuk Parse uraikan) kalimat ke dalam text dan masukan ke ListBox
'---------------------------------------------------------------------------------
Private Sub ParsingText(s As String, lst As ListBox)
Dim strText As String
Dim y() As String
Dim i As Integer
Dim b As String
lst.Clear
strText = s
strText = Replace(strText, " ", vbCrLf)
y = Split(strText, vbCrLf)
For i = LBound(y) To UBound(y)
b = Trim(y(i))
If IsValidWord(b) Then
lst.AddItem y(i)
End If
Next
End Sub
'-------------------------------------------------------------------------------
' Fungsi untuk memfilter karakter yang tidak valid diterjemahkan
'-------------------------------------------------------------------------------
Private Function IsValidWord(s As String) As Boolean
Dim x As String
Dim z As String
z = "= - , . % *" 'tambahkan karakter tidak valid untuk diterjemahkan disini
x = s
If Len(x) = 0 Then Exit Function
If InStr(1, z, s) > 0 Then Exit Function
IsValidWord = True
End Function
'-------------------------------------------------------------------------------
' == End All Of Code ==
'-------------------------------------------------------------------------------
'simpan kode di bawah pada module modMainUji Coba:
Option Explicit
Public Declare Sub InitCommonControls Lib "Comctl32" )
Sub Main()
InitCommonControls
frmMain.Show
End Sub
وَمُفْرَدًا يَأتِي وَيَأتِي جُمْلَهْ ... حَاوِيَةً مَعْنَى الّذِي سِيْقَتْ لَهْ
وَمُفْرَدَنْ يَأتِيْ وَيَأتِي جُمْلَهْ ... حَاوِيَتَنْ مَعْنَى لْلَذِيْ سِيْقَتْ لَهْ
وَمُفْرَدَنْ- يَأتِيْ وَيَأ-تِي جُمْلَهْ ... حَاوِيَتَنْ -مَعْنَى لْلَذِيْ- سِيْقَتْ لَهْ
مَفَاعِلُنْ - مُسْتَفْعِلُنْ - مَفْعُوْلُنْ ... مُفْتَعِلُنْ - مُسْتَفْعِلُنْ - مَفْعُوْلُنْ
المخبونة - السالمة - المقطوعة ... المطويّة - السالمة - المقطوع
وَإِنْ تَكُنْ إِيَّاهُ مَعْنًى اكْتَفَى ... بِهَا كَنُطْقِي الله حَسْبِي وَكَفَى
وَإِنْ تَكُنْ إِيْيَاهُ مَعْنَن كْتَفَى ... بِهَا كَنُطْقِ لْلاهُ حَسْبِي وَكَفَى
وَإِنْ تَكُنْ- إِيْيَاهُ مَعْ-نَن كْتَفَى ... بِهَا كَنُطْ-قِ لْلاهُ حَسْ-بِي وَكَفَى
مَفَاعِلُنْ - مُسْتَفْعِلُنْ - مَفَاعِلُنْ ... مَفَاعِلُنْ - مُسْتَفْعِلُنْ - مُفْتَعِلُنْ
المخبونة - السالمة - المخبونة ... المخبونة - السالمة - المطويّ
وَالمُفْرَدُ الجَامِدُ فَارِغٌ وَإِنْ ... يُشْتَقَّ فَهْوَ ذُو ضَمِيْرٍ مُسْتَكِنْ
وَلْمُفْرَدُ لْجَامِدُ فَارِغُنْ وَإِنْ ... يُشْتَقْقَ فَهْوَ ذُو ضَمِيْرِنْ مُسْتَكِنْ
وَلْمُفْرَدُ لْ-جَامِدُ فَا-رِغُنْ وَإِنْ ... يُشْتَقْقَ فَهْ-وَ ذُو ضَمِيْ-رِنْ مُسْتَكِنْ
مُسْتَفْعِلُنْ - مُفْتَعِلُنْ - مَفَاعِلُنْ ... مُسْتَفْعِلُنْ - مَفَاعِلُنْ - مُسْتَفْعِلُنْ
السالمة - المطويّة - المخبونة ... السالمة - المخبونة - الصحيح
وَأَبْرِزَنْهُ مُطْلَقًا حَيْثُ تَلاَ ... مَا لَيْسَ مَعْنَاهُ لَهُ مُحَصَّلاَ
وَأَبْرِزَنْهُ مُطْلَقَنْ حَيْثُ تَلاَ ... مَا لَيْسَ مَعْنَاهُ لَهُو مُحَصْصَلاَ
وَأَبْرِزَنْ-هُ مُطْلَقَنْ-حَيْثُ تَلاَ ... مَا لَيْسَ مَعْ-نَاهُ لَهُو-مُحَصْصَلاَ
مَفَاعِلُنْ - مَفَاعِلُنْ - مُفْتَعِلُنْ ... مُسْتَفْعِلُنْ - مُفْتَعِلُنْ - مَفَاعِلُنْ
المخبونة - المخبونة - المطويّة ... السالمة - المطويّة - المخبون
Pada mulanya text melebihi lebar textbox |
Sekarang text sesuai dengan lebar textbox |
Option Explicit '----------------------------------------------------------------------- 'http://khoiriyyah.blogspot.com 'By Asep Hibban Ibnu Surur) '----------------------------------------------------------------------- Private Sub Command1_Click() Dim ctl As Object For Each ctl In Me.Controls If TypeName(ctl) = "TextBox" Then AutoFitTextBox ctl End If Next End SubSelengkapnya bisa Anda download pada link di bawah ini:
وَالخَبَرُ الجُزْءُ المُتِمُّ الفَائِدَهْ ... كَالله بَرٌّ والأَيَادِي شَاهِدَهْ
وَلْخَبَرُ لْجُزْءُ لْمُتِمْمُ لْفَائِدَهْ ... كَلْلاهُ بَرْرُنْ وَلأَيَادِيْ شَاهِدَهْ
وَلْخَبَرُ لْ-جُزْءُ لْمُتِمْ-مُ لْفَائِدَهْ ... كَلْلاهُ بَرْ-رُنْ وَلأَيَا-دِيْ شَاهِدَهْ
مُفْتَعِلُنْ - مُسْتَفْعِلُنْ - مُسْتَفْعِلُنْ ... مُسْتَفْعِلُنْ - مُسْتَفْعِلُنْ - مُسْتَفْعِلُنْ
المطويّة - السالمة - الصحيحة ... السالمة - السالمة - الصحيح
وَرَفَعُوْا مُبْتَدَاءً بِالإِبْتِدَا ... كَذَاكَ رَفْعُ خَبَرٍ بِالمُبْتَدَا
وَقِسْ وَكَاسْتِفْهَامٍ النَّفْيُ وَقَدْ ... يَجُوزُ نَحْوُ فَائِزٌ أُولُو الرَّشَدْ
وَأَوَّلٌ مُبْتَدَأٌ وَالثَّانِي ... فَاعِلٌ اغْنَى فِي أَسَارٍ ذَانِ
مُبْتَدَأٌ زَيْدٌ وَعَاذِرٌ خَبَرْ ... إِنْ قُلْتَ زَيْدٌ عَاذِرٌ مَنِ اعْتَذَرْ
'------------------------------------------------------------------------------- 'http://khoiriyyah.blogspot.com 'Asep Hibban '------------------------------------------------------------------------------- Public VBInstance As VBIDE.VBE Public Connect As Connect Option Explicit Public Function InsertOCX(ProgID As String) As Boolean On Error GoTo ErrHandler 'Add OCX VBInstance.ActiveVBProject.AddToolboxProgID ProgID InsertOCX = True Exit Function ErrHandler: InsertOCX = False End Function Public Function InsertReferences(GUID As String, Mayor As Long, Minor As Long) As Boolean On Error GoTo ErrHandler 'Add dll references VBInstance.ActiveVBProject.References.AddFromGuid GUID, Mayor, Minor InsertReferences = True ErrHandler: InsertReferences = False End Function Private Sub Command1_Click() 'Add ListView to VB6 project InsertOCX "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" 'Add TreeView InsertOCX "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" 'Add MSFlexGrid InsertOCX "{0ECD9B60-23AA-11D0-B351-00A0C9055D8E}" End Sub Private Sub Command2_Click() 'Add scrun.dll Microsoft Scripting Runtime) InsertReferences "{420B2830-E718-11CF-893D-00A0C9054228}", 1#, 0 'Add msado15.dll Microsoft ActiveX Data Objects 2.8 Library) InsertReferences "{2A75196C-D9EB-4129-B803-931327F72D5C}", 2, 8 End SubAdapun cara menggunakan kode di atas telah saya bahas disini dan disini. Semoga bermanfaat.
Option Explicit Private Sub Form_Load() Dim i, a, b, c, s As String 'Kode selanjutnya End SubPenulisan variable seperti di atas seakan-akan menunjukan bahwa i, a, b, c memiliki tipe data string, Padahal dalam kenyataanya variable i, a, b, c di atas memiliki type data variant, hanya variable s saja dari contoh di atas yang memiliki type data string. Darimana kita mengetahuinya? mari kita lanjutkan.... rubahlah kode di atas sehingga menjadi:
Option Explicit Private Sub Form_Load() Dim i, a, b, c, s As String 'Kode selanjutnya ... 'TypeName digunakan untuk mengetahui data type sebuah variable Debug.Print TypeName(i) 'Empty -> data type variant Debug.Print TypeName(b) 'Empty -> data type variant Debug.Print TypeName(c) 'Empty -> data type variant Debug.Print TypeName(s) 'String -> data type string End Sub
Option ExplicitContoh pemanggilan prosedur fungsi di atas:
Public Function SaveWebPageToMHTFile(url As String, filepath As String)
On Error GoTo ErrHandler
Dim msg As New CDO.Message
Dim stm As New ADODB.Stream
msg.MimeFormatted = True
msg.CreateMHTMLBody url, CDO.CdoMHTMLFlags.cdoSuppressNone, "", ""
'//Pilih charset yang sesuai
stm.Charset = "utf-8"
Set stm = msg.GetStream()
stm.SaveToFile filepath, ADODB.SaveOptionsEnum.adSaveCreateOverWrite
Set msg = Nothing
stm.Close
Exit Function
ErrHandler:
MsgBox Err.Description
End Function
Private Sub Command1_Click()
'//Coba menyimpan file dalam bentuk MHTML </i>
SaveWebPageToMHTFile "http://www.planet-source-code.com/vb/default.asp?lngWId=1", "c:\psc.MHTML"
End Sub
'----------------------------------------------------------------------------------Contoh pemanggilan prosedure di atas:
'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
Private Sub Command1_Click()
SetChromeHomepage "http://khoiriyyah.blogspot.com"
End Sub