Sunday, June 17, 2012

Menutup Aplikasi Lain Berdasarkan Caption Menggunakan VB6

Mengenai cara menutup (close) aplikasi lain/luar berdasarkan caption yang ditentukan menggunakan Visual Basic 6.0 - Bagaimana kode menutup aplikasi lain menggunakan VB6 ini, bisa Anda simak kodenya di bawah ini:
Option Explicit

Private Const PROCESS_ALL_ACCESS = &H1F0FFF
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hwnd As Long) As Long
Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wFlag As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal process As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal process As Long, ByVal uExitCode As Long) As Long

'Code that does the work
Public Function EndApplication(ByRef caption As String, ByRef frm As Form) As Boolean
Dim hwnd As Long
Dim appInstance As Long
Dim process As Long
Dim processID
Dim result As Boolean
Dim exitCode As Long
Dim returnValue As Long

On Error GoTo Error

If Trim(caption) = "" Then Exit Function
Do
hwnd = FindWindowByTitle(caption, frm)
If hwnd = 0 Then Exit Do
appInstance = GetWindowThreadProcessId(hwnd, processID)
'Get a handle for the process we're looking for
process = OpenProcess(PROCESS_ALL_ACCESS, 0&, processID)
If process <> 0 Then
'Next get our exit code (for use later)
GetExitCodeProcess process, exitCode
'Check for an exit code of 9 (zero)
If exitCode <> 0 Then
'It's not zero so close the window
returnValue = TerminateProcess(process, exitCode)
If result = False Then result = returnValue > 0
End If
End If
Loop
EndApplication = result
Error:
' MsgBox (Err.Number & ": " & Err.Description)
End Function

Private Function FindWindowByTitle(ByRef str As String, ByRef frm As Form) As Long
Dim handle As Long
Dim caption As String
Dim sTitle As String

handle = frm.hwnd
sTitle = LCase(str)
Do
DoEvents
If handle = 0 Then Exit Do
caption = LCase$(GetWindowCaption(handle))

If InStr(caption, sTitle) Then
FindWindowByTitle = handle
Exit Do
Else
FindWindowByTitle = 0
End If
handle = GetNextWindow(handle, 2)
Loop
End Function

Private Function GetWindowCaption(ByRef handle As Long) As String
Dim str As String
Dim length As Long

length& = GetWindowTextLength(handle)
str = String(length, 0)
Call GetWindowText(handle, str, length + 1)
GetWindowCaption = str
End Function
Contoh penggunaan kode di atas:
Private Sub Command1_Click()
Shell "Regedit", vbNormalFocus 'membuka regedit.exe
End Sub

Private Sub Command2_Click()
EndApplication "Registry Editor", Me 'menutup regedit.exe yang memiliki caption 'Registry Editor'
End Sub
READ MORE - Menutup Aplikasi Lain Berdasarkan Caption Menggunakan VB6

Manipulasi ShowInTaskBar Pada Form

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_APPWINDOW = &H40000

Private Function ShowInTheTaskbar(frm As Form, b As Boolean)
Dim l As Long
frm.Hide
l = IIf(b, Not WS_EX_APPWINDOW, WS_EX_APPWINDOW)
SetWindowLong frm.hWnd, GWL_EXSTYLE, (GetWindowLong(hWnd, GWL_EXSTYLE) And l)
frm.Show
End Function

Private Sub Check1_Click()
ShowInTheTaskbar Me, Check1.Value = 1 'toggle
End Sub
READ MORE - Manipulasi ShowInTaskBar Pada Form

XML VB6 - Mencari Node Tertentu Menggunakan XPath

Public Function SearchForNodes(ByVal strXML As String, ByVal strTag As String, ByVal strSearchText As String) As DOMDocument
'Will Search an XML String for a Tag-value pair and return
'the entire node containing that pair in the form
'of a DOM Document: 'REQUIRES REFERENCE TO MSXML
'EXAMPLE: 'Dim objXMLDoc As New DOMDocument
'Dim objXMLFound As DOMDocument 'Dim strXML As String
'Load XML from file 'If objXMLDoc.Load("C:\My Documents\MyXMLFile.xml") Then
'strXML = objXMLDoc.xml 'Search for a tag that looks like this in the xml:
'583 'Set objXMLFound = SearchForNodes(strXML, "User_ID", "583")
'Display the Node that was found 'Debug.Print objXMLFound.xml
'End If
Dim lngIterator As Long
Dim strResults As String
Dim objXMLSearchDocument As DOMDocument
Dim objXMLSearchElements As IXMLDOMSelection
Dim objXMLSearchElement As IXMLDOMElement
Dim strXPath As String
strResults = ""
Set objXMLSearchDocument = New DOMDocument
objXMLSearchDocument.async = False
objXMLSearchDocument.setProperty "SelectionLanguage", "XPath"
Call objXMLSearchDocument.loadXML(strXML)
Set objXMLSearchElements = objXMLSearchDocument.getElementsByTagName(strTag)
If objXMLSearchElements.length > 0 Then
Set objXMLSearchElement = objXMLSearchElements.Item(0)
Do Until Len(objXMLSearchElement.parentNode.baseName) = 0
strXPath = "/" + objXMLSearchElement.parentNode.baseName + strXPath
Set objXMLSearchElement = objXMLSearchElement.parentNode
Loop
Set objXMLSearchElement = Nothing
strXPath = strXPath + "[" + strTag + " = '" + strSearchText + "']"
End If
Set objXMLSearchElements = Nothing
If Len(strXPath) > 0 Then
Set objXMLSearchElements = objXMLSearchDocument.selectNodes(strXPath)

If objXMLSearchElements.length > 0 Then
For lngIterator = 0 To (objXMLSearchElements.length - 1)
strResults = strResults + objXMLSearchElements.Item(lngIterator).xml
Next lngIterator
End If
Set objXMLSearchElements = Nothing
End If
Set objXMLSearchDocument = Nothing
strResults = strResults + "
"
Set objXMLSearchDocument = New DOMDocument
objXMLSearchDocument.async = False
Call objXMLSearchDocument.loadXML(strResults)
Set SearchForNodes = objXMLSearchDocument
Set objXMLSearchDocument = Nothing
End Function
READ MORE - XML VB6 - Mencari Node Tertentu Menggunakan XPath

Spin Artikel Bahasa Indonesia

Apa yang dimaksud artikel spin/spin artikel/article spinner? bisa Anda baca di sini. Dengan kata lain artikel spin adalah mengganti kata dengan menggunakan sinonim dari kata tersebut secara besar-besaran. Tujuannya? Mengecoh mesin pencari agar artikel yang kita duplikatkan (copy paste) berubah menjadi sebuah konten unik menurut pengamatan robot/mesin pencari (bukan menurut pengamatan manusia). Contoh:

Saya akan pergi ke pasar. berubah menjadi
Ana berencana berangkat ke pasar. atau
Ane mau pergi ke pasar. atau
Aku berencana pergi ke pasar. atau
Gue akan berangkat ke pasar. atau
gw mo pergi ke pasar. atau
dan seterusnya. dan seterusnya.

Bukankah seluruh kalimat di atas tersebut unik menurut versi mesin pencari? Nah, bagaimana menurut versi manusia (saya dan Anda)?

Spin artikel bisa dikategorikan sebagai sebuah teknik SEO yang sedikit hitam yang dapat menyebabkan banyaknya duplikasi konten/sampah menurut pengamatan manusia. Tetapi dalam dunia sales online/reseller/affeliate hal ini tidak bisa dihindari. Ya saya ulangi, dalam dunia sales online hal ini tidak bisa dihindari. Satu produk dengan merk yang sama dijual oleh ribuah atau jutaan orang secara online.

Di bawah ini merupakan contoh kode spin artikel bahasa indonesia dengan menggunakan 5 kata dan sinonimnya (seharusnya 5000 kata beserta sinonimnya), yakni saya, pergi, blogger, gmail, akan.
Option Explicit 

Private Function
ChooseWord(choice As Variant, bWord, Optional bUnik As Boolean) As String

Dim i As Integer
Dim
strSpin() As String, strChooseWord As String
strSpin = Split(choice, ",")
If Not bUnik Then
Randomize
i =
CInt((UBound(strSpin) * Rnd) + 1)
strChooseWord = strSpin(i - 1)
Else
Do
Randomize
i =
CInt((UBound(strSpin) * Rnd) + 1)
strChooseWord = strSpin(i - 1)
Loop While strChooseWord = bWord
End If
ChooseWord = strChooseWord

End Function

Private Sub
cmdDoSpin_Click()
Dim strResult As String
Dim
strSource As String
strResult = txtResult.Text
strSource = txtSource.Text

strResult = LCase(strSource)

Dim
arrWord() As String
ReDim
arrWord(4) 'gantilah menjadi 40, 400, atau 4000
'apabila algoritmanya telah dimodif dan mantap maka
'tambahkan sinonim menjadi 40, 400, atau 4000
arrWord(0) = "saya, aku, ane, ana"
arrWord(1) = "pergi, berangkat"
arrWord(2) = " akan, berencana"
arrWord(3) = "blogger, blogspot, blog milik google (blogspot)"
arrWord(4) = "gmail, gmail.com, google mail, layanan email milik google (gmail)"
'--------------------------------------------------------
Dim i As Integer, k As Integer

For i =
LBound(arrWord) To UBound(arrWord)
Dim strSpin() As String
strSpin = Split(arrWord(i), ",")
For k = LBound(strSpin) To UBound(strSpin)
If InStr(1, strSource, strSpin(k)) > 0 Then
strResult = Replace(strResult, strSpin(k), ChooseWord(arrWord(i), strSpin(k), Check1.Value = 1))
Exit For
End If
Next
Next
txtResult.Text = Trim$(strResult)
End Sub

Cobalah Anda kembangkan. Semoga kode spin artikel bahasa indonesia di atas bermanfaat. Terima kasih atas kunjungannya.
READ MORE - Spin Artikel Bahasa Indonesia