Check For a File
Public Function FileExist(asPath as string) as Boolean
If UCase(Dir(asPath))=Ucase(trimPath(asPath)) then
FileExist=true
Else
FileExist=False
End If
End Function
Public Function TrimPath(ByVal asPath as string) as string
if Len(asPath)=0 then Exit Function
Dim x as integer
Do
x=Instr(asPath,”\”)
if x=0 then Exit Do
asPath=Right(asPath,Len(asPath)-x)
Loop
TrimPath=asPath
End Function
Private sub command1_Click()
if fileExist(Text1.text) then
Label1=”YES”
else
Label1=”NO”
End if
End Sub
Private sub form_Load()
End sub
Posted by Administrator in 08:58:16 | Permalink | No Comments »
Tuesday, July 1, 2008
Low and Upper Case
‘add 2 command buttons and 1 text
Private Sub Command1_Click()
Text1.Text = CapFirst$(Text1.Text)
End Sub
Private Sub Command2_Click()
Text1.Text = LCase$(Text1.Text)
End Sub
‘add 1 module
Declare Function CapFirst$ Lib “CAPFIRST.DLL” Alias “CAPFIRST” (ByVal St$)
Posted by Administrator in 07:11:50 | Permalink | No Comments »
Show Your IP Address
Add Microsoft Winsock Control 6.0 component
Insert 1 Textbox
Insert 2 Command Buttons Rename Caption as Display and Clear
Private Sub Command1_Click()
If Text1.Text = “” Then
Command1.Enabled = False
Text1.Text = Winsock1.LocalIP
Else
Command1.Enabled = True
End If
End Sub
Private Sub Command2_Click()
Text1.Text = “”
If Text1.Text = “” Then
Command1.Enabled = True
Else
Command1.Enabled = False
End If
End Sub
Private Sub Form_Load()
Text1.Text = “”
If Text1.Text = “” Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
Text1.Text = Winsock1.LocalIP
End Sub
Posted by Administrator in 07:10:59 | Permalink | Comments (2)
Saturday, May 17, 2008
Permutasi
Option Explicit
Dim id As Integer
Dim N As Integer
Dim perm() As Integer
Function Engine(i As Integer)
Dim t As Integer
Dim j As Integer
id = id + 1
perm(i) = id
If (id = N) Then stampaj
For j = 1 To N
If (perm(j) = 0) Then
Engine (j)
End If
DoEvents
Next j
id = id – 1
perm(i) = 0
End Function
Private Sub cmdClear_Click()
List1.Clear
End Sub
Private Sub cmdGen_Click()
If Val(txtLength.Text) > Len(txtChar.Text) Then
MsgBox “Jumlah Permutasi Salah”
Exit Sub
End If
If Len(txtChar.Text) = 0 Or (Val(txtLength.Text) = 0) Then Exit Sub
Dim i As Integer
N = Val(txtLength.Text)
ReDim perm(N)
For i = 1 To N
perm(i) = 0
Next i
If ChSave.Value = 1 Then
MsgBox “Disimpan pada hasil.txt”
Open App.Path + “\hasil.txt” For Output As #1
End If
Engine 0
If ChSave.Value = 1 Then Close #1
End Sub
Sub Form_Load()
On Error Resume Next
id = -1
End Sub
Sub stampaj()
Dim i As Integer
Dim result As String
result = “”
For i = 1 To N
result = result & CStr(Mid$(txtChar.Text, perm(i), 1))
Next i
List1.AddItem result
If ChSave.Value = 1 Then Print #1, result
End Sub
Posted by Administrator in 05:05:49 | Permalink | Comments (5)
Enkripsi Searah
Public Function Hash(ByVal text As String) As String
a = 1
For i = 1 To Len(text)
a = Sqr(a * i * Asc(Mid(text, i, 1))) ‘Numeric Hash
Next i
Rnd (-1)
Randomize a ’seed PRNG
For i = 1 To 16
Hash = Hash & Chr(Int(Rnd * 256))
Next i
End Function
Private Sub Form_Load()
MsgBox Hash(“EmZ-2509″) ‘Yang dihasilkan: ‰°’r¿¾ ©Ì¿ÂX*¤W
End
End Sub
Posted by Administrator in 04:58:18 | Permalink | Comments (1) »
Enkripsi
Function EncDec(inData As Variant, Optional inPW As Variant = “”) As Variant
On Error Resume Next
Dim arrSBox(0 To 255) As Integer
Dim arrPW(0 To 255) As Integer
Dim Bi As Integer, Bj As Integer
Dim mKey As Integer
Dim i As Integer, j As Integer
Dim x As Integer, y As Integer
Dim mCode As Byte, mCodeSeries As Variant
EncDec = “”
If Trim(inData) = “” Then
Exit Function
End If
If inPW <> “” Then
j = 1
For i = 0 To 255
arrPW(i) = Asc(Mid$(inPW, j, 1))
j = j + 1
If j > Len(inPW) Then
j = 1
End If
Next i
Else
For i = 0 To 255
arrPW(i) = 0
Next i
End If
For i = 0 To 255
arrSBox(i) = i
Next i
j = 0
For i = 0 To 255
j = (arrSBox(i) + arrPW(i)) Mod 256
x = arrSBox(i)
arrSBox(i) = arrSBox(j)
arrSBox(j) = x
Next i
mCodeSeries = “”
Bi = 0: Bj = 0
For i = 1 To Len(inData)
Bi = (Bi + 1) Mod 256
Bj = (Bj + arrSBox(Bi)) Mod 256
‘ Tukar
x = arrSBox(Bi)
arrSBox(Bi) = arrSBox(Bj)
arrSBox(Bj) = x
’siapkan kunci untuk XOR
mKey = arrSBox((arrSBox(Bi) + arrSBox(Bj)) Mod 256)
‘gunakan operasi XOR
mCode = Asc(Mid$(inData, i, 1)) Xor mKey
mCodeSeries = mCodeSeries & Chr(mCode)
Next i
EncDec = mCodeSeries
End Function
Private Sub Form_Load()
Dim Encrypt As String, Decrypt As String
Encrypt = EncDec(“admin”, “win”)
Decrypt = EncDec(“™D`>”, “win”)
MsgBox “Hasil enkripsi : ” & Encrypt & _
vbCrLf & “Hasil dekripsi : ” & Decrypt
End
End Sub
Posted by Administrator in 04:55:41 | Permalink | No Comments »
Wednesday, May 14, 2008
Menu Pop Up
Option Explicit
Private Declare Function SendMessage Lib “user32″ Alias _
“SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const LB_GETITEMRECT = &H198
Private Const LB_ERR = (-1)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Function GetRClickedItem(MyList As Control, _
X As Single, Y As Single) As Long
‘PURPOSE: Determine which item was right clicked in a list
‘box, from the list_box’s mouse down event. YOU MUST CALL THIS
‘FROM THE MOUSEDOWN EVENT, PASSING THE X AND Y VALUES FROM THAT
‘EVENT TO THIS FUNCTION
‘MYLIST: ListBox Control
‘X, Y: X and Y position from MyList_MouseDown
‘RETURNS: ListIndex of selected item, or -1 if
‘a) There is no selected item, or b) an error occurs.
Dim clickX As Long, clickY As Long
Dim lRet As Long
Dim CurRect As RECT
Dim l As Long
‘Control must be a listbox
If Not TypeOf MyList Is ListBox Then
GetRClickedItem = LB_ERR
Exit Function
End If
‘get x and y in pixels
clickX = X Screen.TwipsPerPixelX
clickY = Y Screen.TwipsPerPixelY
‘Check all items in the list to see if it was clicked on
For l = 0 To MyList.ListCount – 1
‘get current selection as rectangle
lRet = SendMessage(MyList.hwnd, LB_GETITEMRECT, l, CurRect)
‘If the position of the click is in the this list item
‘then that’s our Item
If (clickX >= CurRect.Left) And (clickX <= CurRect.Right) _ And (clickY >= CurRect.Top) And _
(clickY <= CurRect.Bottom) Then GetRClickedItem = l Exit Function End If Next l End Function Private Sub Form_Load() List1.AddItem “Merah” List1.AddItem “Kuning” List1.AddItem “Hijau” mnuPopUp.Visible = False End Sub Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lItem As Long If Button = vbRightButton Then lItem = GetRClickedItem(List1, X, Y) If lItem <> -1 Then
List1.ListIndex = lItem
PopupMenu mnuPopUp
End If
End If
End Sub
Posted by Administrator in 05:53:04 | Permalink | Comments (1) »
Load Picture
Private Sub Command1_Click()
With Me.CommonDialog1
.DialogTitle = “Ambil Gambar”
.Filter = “JPEG|*.jpg”
.ShowOpen
If .FileName <> “” Then
Set Me.Picture1.Picture = Nothing
Me.Picture1.Picture = LoadPicture(.FileName)
End If
End With
End Sub
‘Private Sub Form_Load()
‘Me.Picture1.Picture = LoadPicture(“D:\gbr_motor\bikes_honda_01.jpg”)
‘End Sub
Posted by Administrator in 04:28:16 | Permalink | No Comments »
Friday, May 9, 2008
Sleep With Visual Basic
Option Explicit
Private Declare Sub Sleep Lib “kernel32″ (ByVal dwMilliseconds As Long)
Private Sub Form_Click()
Me.Caption = “Sleeping”
Call Sleep(20000)
Me.Caption = “Awake”
End Sub
Private Sub Label1_Click()
Me.Caption = “Sleeping”
Call Sleep(20000)
Me.Caption = “Awake”
End Sub
Posted by Administrator in 08:18:13 | Permalink | No Comments »
Find Something
Form
Option Explicit
Private Declare Function GetWindowText Lib “user32″ Alias “GetWindowTextA” (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Sub cmdActivate_Click()
Dim nRet As Long
Dim Title As String
nRet = AppActivatePartial(Trim(txtTitle.Text), _
Val(frmMethod.Tag), CBool(chkCase.Value))
If nRet Then
lblResults.Caption = “Found: &&H” & Hex$(nRet)
Title = Space$(256)
nRet = GetWindowText(nRet, Title, Len(Title))
If nRet Then
lblResults.Caption = lblResults.Caption & _
“, “”" & Left$(Title, nRet) & “”"”
End If
Else
lblResults.Caption = “Search Failed”
End If
End Sub
Private Sub Form_Load()
txtTitle.Text = “”
lblResults.Caption = “”
optMethod(0).Value = True
End Sub
Private Sub optMethod_Click(Index As Integer)
frmMethod.Tag = Index
End Sub
Module
Option Explicit
Private Declare Function EnumWindows Lib “user32″ (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib “user32″ Alias “GetClassNameA” (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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 IsIconic Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib “user32″ (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib “user32″ (ByVal hWnd As Long) As Long
Private Const SW_RESTORE = 9
Private m_hWnd As Long
Private m_Method As FindWindowPartialTypes
Private m_CaseSens As Boolean
Private m_Visible As Boolean
Private m_AppTitle As String
Public Enum FindWindowPartialTypes
FwpStartsWith = 0
FwpContains = 1
FwpMatches = 2
End Enum
Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWindowPartialTypes = FwpStartsWith, Optional CaseSensitive As Boolean = False) As Long
Dim hWndApp As Long
hWndApp = FindWindowPartial(AppTitle, Method, CaseSensitive, True)
If hWndApp Then
If IsIconic(hWndApp) Then
Call ShowWindow(hWndApp, SW_RESTORE)
End If
Call SetForegroundWindow(hWndApp)
AppActivatePartial = hWndApp
End If
End Function
Public Function FindWindowPartial(AppTitle As String, _
Optional Method As FindWindowPartialTypes = FwpStartsWith, _
Optional CaseSensitive As Boolean = False, _
Optional MustBeVisible As Boolean = False) As Long
m_hWnd = 0
m_Method = Method
m_CaseSens = CaseSensitive
m_AppTitle = AppTitle
If m_CaseSens = False Then
m_AppTitle = UCase$(m_AppTitle)
End If
Call EnumWindows(AddressOf EnumWindowsProc, MustBeVisible)
FindWindowPartial = m_hWnd
End Function
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Static WindowText As String
Static nRet As Long
If lParam Then
If IsWindowVisible(hWnd) = False Then
EnumWindowsProc = True
Exit Function
End If
End If
WindowText = Space$(256)
nRet = GetWindowText(hWnd, WindowText, Len(WindowText))
If nRet Then
WindowText = Left$(WindowText, nRet)
If m_CaseSens = False Then
WindowText = UCase$(WindowText)
End If
Select Case m_Method
Case FwpStartsWith
If InStr(WindowText, m_AppTitle) = 1 Then
m_hWnd = hWnd
End If
Case FwpContains
If InStr(WindowText, m_AppTitle) <> 0 Then
m_hWnd = hWnd
End If
Case FwpMatches
If WindowText = m_AppTitle Then
m_hWnd = hWnd
End If
End Select
End If
EnumWindowsProc = (m_hWnd = 0)
End Function
Public Function FileExist(asPath as string) as Boolean
If UCase(Dir(asPath))=Ucase(trimPath(asPath)) then
FileExist=true
Else
FileExist=False
End If
End Function
Public Function TrimPath(ByVal asPath as string) as string
if Len(asPath)=0 then Exit Function
Dim x as integer
Do
x=Instr(asPath,”\”)
if x=0 then Exit Do
asPath=Right(asPath,Len(asPath)-x)
Loop
TrimPath=asPath
End Function
Private sub command1_Click()
if fileExist(Text1.text) then
Label1=”YES”
else
Label1=”NO”
End if
End Sub
Private sub form_Load()
End sub
Posted by Administrator in 08:58:16 | Permalink | No Comments »
Tuesday, July 1, 2008
Low and Upper Case
‘add 2 command buttons and 1 text
Private Sub Command1_Click()
Text1.Text = CapFirst$(Text1.Text)
End Sub
Private Sub Command2_Click()
Text1.Text = LCase$(Text1.Text)
End Sub
‘add 1 module
Declare Function CapFirst$ Lib “CAPFIRST.DLL” Alias “CAPFIRST” (ByVal St$)
Posted by Administrator in 07:11:50 | Permalink | No Comments »
Show Your IP Address
Add Microsoft Winsock Control 6.0 component
Insert 1 Textbox
Insert 2 Command Buttons Rename Caption as Display and Clear
Private Sub Command1_Click()
If Text1.Text = “” Then
Command1.Enabled = False
Text1.Text = Winsock1.LocalIP
Else
Command1.Enabled = True
End If
End Sub
Private Sub Command2_Click()
Text1.Text = “”
If Text1.Text = “” Then
Command1.Enabled = True
Else
Command1.Enabled = False
End If
End Sub
Private Sub Form_Load()
Text1.Text = “”
If Text1.Text = “” Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
Text1.Text = Winsock1.LocalIP
End Sub
Posted by Administrator in 07:10:59 | Permalink | Comments (2)
Saturday, May 17, 2008
Permutasi
Option Explicit
Dim id As Integer
Dim N As Integer
Dim perm() As Integer
Function Engine(i As Integer)
Dim t As Integer
Dim j As Integer
id = id + 1
perm(i) = id
If (id = N) Then stampaj
For j = 1 To N
If (perm(j) = 0) Then
Engine (j)
End If
DoEvents
Next j
id = id – 1
perm(i) = 0
End Function
Private Sub cmdClear_Click()
List1.Clear
End Sub
Private Sub cmdGen_Click()
If Val(txtLength.Text) > Len(txtChar.Text) Then
MsgBox “Jumlah Permutasi Salah”
Exit Sub
End If
If Len(txtChar.Text) = 0 Or (Val(txtLength.Text) = 0) Then Exit Sub
Dim i As Integer
N = Val(txtLength.Text)
ReDim perm(N)
For i = 1 To N
perm(i) = 0
Next i
If ChSave.Value = 1 Then
MsgBox “Disimpan pada hasil.txt”
Open App.Path + “\hasil.txt” For Output As #1
End If
Engine 0
If ChSave.Value = 1 Then Close #1
End Sub
Sub Form_Load()
On Error Resume Next
id = -1
End Sub
Sub stampaj()
Dim i As Integer
Dim result As String
result = “”
For i = 1 To N
result = result & CStr(Mid$(txtChar.Text, perm(i), 1))
Next i
List1.AddItem result
If ChSave.Value = 1 Then Print #1, result
End Sub
Posted by Administrator in 05:05:49 | Permalink | Comments (5)
Enkripsi Searah
Public Function Hash(ByVal text As String) As String
a = 1
For i = 1 To Len(text)
a = Sqr(a * i * Asc(Mid(text, i, 1))) ‘Numeric Hash
Next i
Rnd (-1)
Randomize a ’seed PRNG
For i = 1 To 16
Hash = Hash & Chr(Int(Rnd * 256))
Next i
End Function
Private Sub Form_Load()
MsgBox Hash(“EmZ-2509″) ‘Yang dihasilkan: ‰°’r¿¾ ©Ì¿ÂX*¤W
End
End Sub
Posted by Administrator in 04:58:18 | Permalink | Comments (1) »
Enkripsi
Function EncDec(inData As Variant, Optional inPW As Variant = “”) As Variant
On Error Resume Next
Dim arrSBox(0 To 255) As Integer
Dim arrPW(0 To 255) As Integer
Dim Bi As Integer, Bj As Integer
Dim mKey As Integer
Dim i As Integer, j As Integer
Dim x As Integer, y As Integer
Dim mCode As Byte, mCodeSeries As Variant
EncDec = “”
If Trim(inData) = “” Then
Exit Function
End If
If inPW <> “” Then
j = 1
For i = 0 To 255
arrPW(i) = Asc(Mid$(inPW, j, 1))
j = j + 1
If j > Len(inPW) Then
j = 1
End If
Next i
Else
For i = 0 To 255
arrPW(i) = 0
Next i
End If
For i = 0 To 255
arrSBox(i) = i
Next i
j = 0
For i = 0 To 255
j = (arrSBox(i) + arrPW(i)) Mod 256
x = arrSBox(i)
arrSBox(i) = arrSBox(j)
arrSBox(j) = x
Next i
mCodeSeries = “”
Bi = 0: Bj = 0
For i = 1 To Len(inData)
Bi = (Bi + 1) Mod 256
Bj = (Bj + arrSBox(Bi)) Mod 256
‘ Tukar
x = arrSBox(Bi)
arrSBox(Bi) = arrSBox(Bj)
arrSBox(Bj) = x
’siapkan kunci untuk XOR
mKey = arrSBox((arrSBox(Bi) + arrSBox(Bj)) Mod 256)
‘gunakan operasi XOR
mCode = Asc(Mid$(inData, i, 1)) Xor mKey
mCodeSeries = mCodeSeries & Chr(mCode)
Next i
EncDec = mCodeSeries
End Function
Private Sub Form_Load()
Dim Encrypt As String, Decrypt As String
Encrypt = EncDec(“admin”, “win”)
Decrypt = EncDec(“™D`>”, “win”)
MsgBox “Hasil enkripsi : ” & Encrypt & _
vbCrLf & “Hasil dekripsi : ” & Decrypt
End
End Sub
Posted by Administrator in 04:55:41 | Permalink | No Comments »
Wednesday, May 14, 2008
Menu Pop Up
Option Explicit
Private Declare Function SendMessage Lib “user32″ Alias _
“SendMessageA” (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Const LB_GETITEMRECT = &H198
Private Const LB_ERR = (-1)
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Function GetRClickedItem(MyList As Control, _
X As Single, Y As Single) As Long
‘PURPOSE: Determine which item was right clicked in a list
‘box, from the list_box’s mouse down event. YOU MUST CALL THIS
‘FROM THE MOUSEDOWN EVENT, PASSING THE X AND Y VALUES FROM THAT
‘EVENT TO THIS FUNCTION
‘MYLIST: ListBox Control
‘X, Y: X and Y position from MyList_MouseDown
‘RETURNS: ListIndex of selected item, or -1 if
‘a) There is no selected item, or b) an error occurs.
Dim clickX As Long, clickY As Long
Dim lRet As Long
Dim CurRect As RECT
Dim l As Long
‘Control must be a listbox
If Not TypeOf MyList Is ListBox Then
GetRClickedItem = LB_ERR
Exit Function
End If
‘get x and y in pixels
clickX = X Screen.TwipsPerPixelX
clickY = Y Screen.TwipsPerPixelY
‘Check all items in the list to see if it was clicked on
For l = 0 To MyList.ListCount – 1
‘get current selection as rectangle
lRet = SendMessage(MyList.hwnd, LB_GETITEMRECT, l, CurRect)
‘If the position of the click is in the this list item
‘then that’s our Item
If (clickX >= CurRect.Left) And (clickX <= CurRect.Right) _ And (clickY >= CurRect.Top) And _
(clickY <= CurRect.Bottom) Then GetRClickedItem = l Exit Function End If Next l End Function Private Sub Form_Load() List1.AddItem “Merah” List1.AddItem “Kuning” List1.AddItem “Hijau” mnuPopUp.Visible = False End Sub Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) Dim lItem As Long If Button = vbRightButton Then lItem = GetRClickedItem(List1, X, Y) If lItem <> -1 Then
List1.ListIndex = lItem
PopupMenu mnuPopUp
End If
End If
End Sub
Posted by Administrator in 05:53:04 | Permalink | Comments (1) »
Load Picture
Private Sub Command1_Click()
With Me.CommonDialog1
.DialogTitle = “Ambil Gambar”
.Filter = “JPEG|*.jpg”
.ShowOpen
If .FileName <> “” Then
Set Me.Picture1.Picture = Nothing
Me.Picture1.Picture = LoadPicture(.FileName)
End If
End With
End Sub
‘Private Sub Form_Load()
‘Me.Picture1.Picture = LoadPicture(“D:\gbr_motor\bikes_honda_01.jpg”)
‘End Sub
Posted by Administrator in 04:28:16 | Permalink | No Comments »
Friday, May 9, 2008
Sleep With Visual Basic
Option Explicit
Private Declare Sub Sleep Lib “kernel32″ (ByVal dwMilliseconds As Long)
Private Sub Form_Click()
Me.Caption = “Sleeping”
Call Sleep(20000)
Me.Caption = “Awake”
End Sub
Private Sub Label1_Click()
Me.Caption = “Sleeping”
Call Sleep(20000)
Me.Caption = “Awake”
End Sub
Posted by Administrator in 08:18:13 | Permalink | No Comments »
Find Something
Form
Option Explicit
Private Declare Function GetWindowText Lib “user32″ Alias “GetWindowTextA” (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Sub cmdActivate_Click()
Dim nRet As Long
Dim Title As String
nRet = AppActivatePartial(Trim(txtTitle.Text), _
Val(frmMethod.Tag), CBool(chkCase.Value))
If nRet Then
lblResults.Caption = “Found: &&H” & Hex$(nRet)
Title = Space$(256)
nRet = GetWindowText(nRet, Title, Len(Title))
If nRet Then
lblResults.Caption = lblResults.Caption & _
“, “”" & Left$(Title, nRet) & “”"”
End If
Else
lblResults.Caption = “Search Failed”
End If
End Sub
Private Sub Form_Load()
txtTitle.Text = “”
lblResults.Caption = “”
optMethod(0).Value = True
End Sub
Private Sub optMethod_Click(Index As Integer)
frmMethod.Tag = Index
End Sub
Module
Option Explicit
Private Declare Function EnumWindows Lib “user32″ (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function GetClassName Lib “user32″ Alias “GetClassNameA” (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
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 IsIconic Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function IsWindowVisible Lib “user32″ (ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib “user32″ (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function SetForegroundWindow Lib “user32″ (ByVal hWnd As Long) As Long
Private Const SW_RESTORE = 9
Private m_hWnd As Long
Private m_Method As FindWindowPartialTypes
Private m_CaseSens As Boolean
Private m_Visible As Boolean
Private m_AppTitle As String
Public Enum FindWindowPartialTypes
FwpStartsWith = 0
FwpContains = 1
FwpMatches = 2
End Enum
Public Function AppActivatePartial(AppTitle As String, Optional Method As FindWindowPartialTypes = FwpStartsWith, Optional CaseSensitive As Boolean = False) As Long
Dim hWndApp As Long
hWndApp = FindWindowPartial(AppTitle, Method, CaseSensitive, True)
If hWndApp Then
If IsIconic(hWndApp) Then
Call ShowWindow(hWndApp, SW_RESTORE)
End If
Call SetForegroundWindow(hWndApp)
AppActivatePartial = hWndApp
End If
End Function
Public Function FindWindowPartial(AppTitle As String, _
Optional Method As FindWindowPartialTypes = FwpStartsWith, _
Optional CaseSensitive As Boolean = False, _
Optional MustBeVisible As Boolean = False) As Long
m_hWnd = 0
m_Method = Method
m_CaseSens = CaseSensitive
m_AppTitle = AppTitle
If m_CaseSens = False Then
m_AppTitle = UCase$(m_AppTitle)
End If
Call EnumWindows(AddressOf EnumWindowsProc, MustBeVisible)
FindWindowPartial = m_hWnd
End Function
Private Function EnumWindowsProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
Static WindowText As String
Static nRet As Long
If lParam Then
If IsWindowVisible(hWnd) = False Then
EnumWindowsProc = True
Exit Function
End If
End If
WindowText = Space$(256)
nRet = GetWindowText(hWnd, WindowText, Len(WindowText))
If nRet Then
WindowText = Left$(WindowText, nRet)
If m_CaseSens = False Then
WindowText = UCase$(WindowText)
End If
Select Case m_Method
Case FwpStartsWith
If InStr(WindowText, m_AppTitle) = 1 Then
m_hWnd = hWnd
End If
Case FwpContains
If InStr(WindowText, m_AppTitle) <> 0 Then
m_hWnd = hWnd
End If
Case FwpMatches
If WindowText = m_AppTitle Then
m_hWnd = hWnd
End If
End Select
End If
EnumWindowsProc = (m_hWnd = 0)
End Function