'simpan kode di bawah pada module
Option Explicit
Private Declare Function CreateDC& Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal hdc As Long)
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
'simpan kode di bawah pada form
'Timer.Interval = 1
'Picture1.AutoRedraw = True
'Option Explicit
Dim pt As POINTAPI
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = True
Picture1.MousePointer = vbCrosshair
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Timer1.Enabled = False
Picture1.MousePointer = vbDefault
End Sub
Private Sub Timer1_Timer()
Dim screendc As Long
GetCursorPos pt
screendc = CreateDC("DISPLAY", "", "", 0&)
Picture1.BackColor = GetPixel(screendc, pt.X, pt.Y)
Text1.Text = "#" & Hex(GetPixel(screendc, pt.X, pt.Y))
DeleteDC (screendc)
End Sub
Sunday, June 17, 2012
Aplikasi Untuk Melihat Warna Yang Ada Di bawah Pointer
Membuat Assosiasi Untuk Sebuah File
Option Explicit
'==========================================================================
' Parameters
' Required Extension (Str) ie ".exe"
' Required FileType (Str) ie "VB.Form"
' Required FileTYpeName (Str) ie. "Visual Basic Form"
' Required Action (Str) ie. "Open" or "Edit"
' Required AppPath (Str) ie. "C:\Myapp"
' Optional Switch (Str) ie. "/u" Default = ""
' Optional SetIcon (Bol) Default = False
' Optional DefaultIcon (Str) ie. "C:\Myapp,0"
' Optional PromptOnError (Bol) Default = False
' HOW IT WORKS
' Extension(Str) Default = FileType(Str)
' FileType(Str) Default = FileTypeName(Str)
' "DefaultIcon" Default = DefaultIcon(Str)
' "shell"
' Action(Str)
' "command" Default = AppPath(Str) & switch(Str) & " %1"
'================================================================
' Private Sub cmdCreateAsso_Click()
' CreateFileAss ".wrs", "Warisan File", "Warisan File", "open", "c:\Warisan.exe", , True, "C:\Warisan.exe", True
' End Sub
'================================================================
' Private Konstanta dalam local
Private Const REG_SZ As Long = 1
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const ERROR_SUCCESS = 0
Private Const KEY_ALL_ACCESS = &H3F
Private Const REG_OPTION_NON_VOLATILE = 0
Private PromptOnErr As Boolean
' Global API deklarasi yang berhubungan dengan registry
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long
Public Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long
Public Function CreateFileAss(Extension As String, FileType As String, FileTypeName As String, Action As String, AppPath As String, Optional Switch As String = "", Optional SetIcon As Boolean = False, Optional DefaultIcon As String, Optional PromptOnError As Boolean = False) As Boolean
On Error GoTo ErrorHandler:
PromptOnErr = PromptOnError
' Cek keberadaan AppPath
If Dir(AppPath, vbNormal) = "" Then
If PromptOnError Then MsgBox "The application path '" & _
AppPath & "' cannot be found.", _
vbCritical + vbOKOnly, "DLL/OCX Register"
CreateFileAss = False
Exit Function
End If
Dim ERROR_CHARS As String: ERROR_CHARS = "\/:*?<>|" & Chr(34)
Dim I As Integer
If Asc(Extension) <> 46 Then Extension = "." & Extension
' Cek bahwa extension mempunyai "." di depannya
' Cek apabila ada karakter yang invalid dalam ekstension
For I = 1 To Len(Extension)
If InStr(1, ERROR_CHARS, Mid(Extension, I, 1), vbTextCompare) Then
If PromptOnError Then MsgBox "The file extension '" & Extension & "' contains an illegal char (\/:*?<>|" & Chr(34) & ").", vbCritical + vbOKOnly, "DLL/OCX Register"
CreateFileAss = False
Exit Function
End If
Next
If Switch <> "" Then Switch = " " & Trim(Switch)
Action = FileType & "\shell\" & Action & "\command"
Call CreateSubKey(HKEY_CLASSES_ROOT, Extension) ' membuat ekstension .xxx key
Call CreateSubKey(HKEY_CLASSES_ROOT, Action) ' Membuat action key
If SetIcon Then
Call CreateSubKey(HKEY_CLASSES_ROOT, (FileType & "\DefaultIcon")) ' Membuat ikon default key
If DefaultIcon = "" Then
' Set default ikon Euy..
Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(AppPath & ",0"))
Else
Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType & "\DefaultIcon", Trim(DefaultIcon))
End If
End If
Call SetKeyDefault(HKEY_CLASSES_ROOT, Extension, FileType) ' Set .xxx key default
Call SetKeyDefault(HKEY_CLASSES_ROOT, FileType, FileTypeName) ' Set file type default
Call SetKeyDefault(HKEY_CLASSES_ROOT, Action, AppPath & Switch & " %1") ' Set Command line
CreateFileAss = True
Exit Function
ErrorHandler:
If PromptOnError Then MsgBox "An error occured while attempting to create the file extension '" & Extension & "'.", vbCritical + vbOKOnly, "DLL/OCX Register"
CreateFileAss = False
End Function
'================================================
' FUNGSI UNTUK MEMBUAT SUBKEY BARU
'================================================
Private Function CreateSubKey(RootKey As Long, NewKey As String) As Boolean
Dim hKey As Long, regReply As Long
regReply = RegCreateKeyEx(RootKey, NewKey, _
0&, "", REG_OPTION_NON_VOLATILE, KEY_ALL_ACCESS, 0&, hKey, 0&)
If regReply <> ERROR_SUCCESS Then
If PromptOnErr Then MsgBox "An error occured while attempting to to create a registery key.", vbCritical + vbOKOnly, "DLL/OCX Register"
CreateSubKey = False
Else
CreateSubKey = True
End If
Call RegCloseKey(hKey)
End Function
'===================================================
' FUNGSI UNTUK MENSET NILAI DEFAULT
'===================================================
Private Function SetKeyDefault(RootKey As Long, Address As String, Value As String) As Boolean
Dim regReply As Long, hKey As Long
regReply = RegOpenKeyEx(RootKey, Address, 0, KEY_ALL_ACCESS, hKey)
If regReply <> ERROR_SUCCESS Then
If PromptOnErr Then MsgBox "An error occured while attempting to access the registery.", vbCritical + vbOKOnly, "DLL/OCX Register"
SetKeyDefault = False
Exit Function
End If
Value = Value & Chr(0)
regReply = RegSetValueExString(hKey, "", 0&, REG_SZ, Value, Len(Value))
If regReply <> ERROR_SUCCESS Then
If PromptOnErr Then MsgBox "An error occured while attempting to set key default value.", vbCritical + vbOKOnly, "DLL/OCX Register"
SetKeyDefault = False
Else
SetKeyDefault = True
End If
Call RegCloseKey(hKey)
End Function
Membikin Menu Multi Kolom (Win32) - (API Call)
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_STRING = &H0&
Private Const MF_HELP = &H4000&
Private Const MFS_DEFAULT = &H1000&
Private Const MIIM_ID = &H2
Private Const MIIM_SUBMENU = &H4
Private Const MIIM_TYPE = &H10
Private Const MIIM_DATA = &H20
Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemInfo Lib "user32" Alias "GetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal B As Boolean, lpMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Sub Command1_Click()
Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
Dim BuffStr As String * 80
hMenu = GetMenu(Me.hwnd)
BuffStr = Space(80)
With mnuItemInfo
.cbSize = Len(mnuItemInfo)
.dwTypeData = BuffStr & Chr(0)
.fType = MF_STRING
.cch = Len(mnuItemInfo.dwTypeData)
.fState = MFS_DEFAULT
.fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
End With
hSubMenu = GetSubMenu(hMenu, 0)
If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
Else
mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBARBREAK
If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
End If
End If
DrawMenuBar (Me.hwnd)
End Sub
Private Sub Form_Load()
Dim mnuItemInfo As MENUITEMINFO, hMenu As Long, hSubMenu As Long
Dim BuffStr As String * 80
hMenu = GetMenu(Me.hwnd)
BuffStr = Space(80)
With mnuItemInfo
.cbSize = Len(mnuItemInfo)
.dwTypeData = BuffStr & Chr(0)
.fType = MF_STRING
.cch = Len(mnuItemInfo.dwTypeData)
.fState = MFS_DEFAULT
.fMask = MIIM_ID Or MIIM_DATA Or MIIM_TYPE Or MIIM_SUBMENU
End With
hSubMenu = GetSubMenu(hMenu, 1)
If GetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
MsgBox "GetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
Else
mnuItemInfo.fType = mnuItemInfo.fType Or MF_MENUBREAK
If SetMenuItemInfo(hSubMenu, 2, True, mnuItemInfo) = 0 Then
MsgBox "SetMenuItemInfo failed. Error: " & Err.LastDllError, , "Error"
End If
End If
DrawMenuBar (Me.hwnd)
End Sub
Membikin Area Transparan Obyek Geometri - (API Call)
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
Private Function fMakeATranspArea(AreaType As String, pCordinate() As Long) As Boolean
Const RGN_DIFF = 4
Dim lOriginalForm As Long
Dim ltheHole As Long
Dim lNewForm As Long
Dim lFwidth As Single
Dim lFHeight As Single
Dim lborder_width As Single
Dim ltitle_height As Single
On Error GoTo Trap
lFwidth = ScaleX(Width, vbTwips, vbPixels)
lFHeight = ScaleY(Height, vbTwips, vbPixels)
lOriginalForm = CreateRectRgn(0, 0, lFwidth, lFHeight)
lborder_width = (lFHeight - ScaleWidth) / 2
ltitle_height = lFHeight - lborder_width - ScaleHeight
Select Case AreaType
Case "Elliptic"
ltheHole = CreateEllipticRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RectAngle"
ltheHole = CreateRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4))
Case "RoundRect"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(5), pCordinate(6))
Case "Circle"
ltheHole = CreateRoundRectRgn(pCordinate(1), pCordinate(2), pCordinate(3), pCordinate(4), pCordinate(3), pCordinate(4))
Case Else
MsgBox "Unknown Shape!!"
Exit Function
End Select
lNewForm = CreateRectRgn(0, 0, 0, 0)
CombineRgn lNewForm, lOriginalForm, _
ltheHole, RGN_DIFF
SetWindowRgn hWnd, lNewForm, True
Me.Refresh
fMakeATranspArea = True
Exit Function
Trap:
MsgBox "error Occurred. Error # " & Err.Number & ", " & Err.Description
End Function
Private Sub Command1_Click()
Dim lParam(1 To 6) As Long
lParam(1) = 100
lParam(2) = 100
lParam(3) = 250
lParam(4) = 250
lParam(5) = 50
lParam(6) = 50
Call fMakeATranspArea("Circle", lParam())
End Sub
Subscribe to:
Posts
(
Atom
)
