About Script

sorot karakter di tex tbox

2008-08-23T18:51:00.001-07:00

eventya atur aja mo got focus,click or etc

Nie sourcenya

Text1.setfocus
Sendkeys "{home}+{end}"

fungsi form jadi flat

2008-08-23T18:50:00.001-07:00

Option Explicit
Const GWL_EXSTYLE = (-20)
Const WS_EX_CLIENTEDGE = &H200
Const WS_EX_STATICEDGE = &H20000
Const SWP_FRAMECHANGED = &H20
Const SWP_NOZORDER = &H4

Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40

Private Declare Sub SetWindowPos Lib "user32" (ByVal HWND As Long, _
ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As _
Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
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

Public Sub FlatStyle(ByVal HWND As Long)
Dim oStyle As Long
oStyle = GetWindowLong(HWND, GWL_EXSTYLE)
oStyle = oStyle And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
SetWindowLong HWND, GWL_EXSTYLE, oStyle
SetWindowPos HWND, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or _
SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE
End Sub

Private Sub Form_Load()
'Sediakan beberapa objek spt (Picture1,List1,Text1,Command1, dll...)
'Panggil fungsi seperti ini dengan parameter HWND setiap objek

FlatStyle Form1.HWND
FlatStyle Command1.HWND
FlatStyle List1.HWND
FlatStyle Picture1.HWND
FlatStyle Text1.HWND

'apabila ingin otomatis untuk semua objek di form
'bisa pake fungsi berikut:

On Error Resume Next
Dim cc As Control
For Each cc In Me.Controls
FlatStyle cc.HWND
Next

'dsb....
'Gampang kan....selamat mencoba
End Sub

Simpan gambar ke database

2008-08-23T05:04:00.000-07:00

Untuk melakukan persiapan awal, kita buat suatu database. (Penulis disini menggunakan Ms.Access sebagai bahan contoh)

Persiapan Awal:
Nama file : dbaImage.mdb
Nama Table : Pegawai
Nama field Type Size
-------------------------
NRP Text 7
Photo OleObject

Setelah selesai melakukan persiapan awal kita buat Project Baru dan tambahakan Referency ADODB ke project kita. Dengan cara memilih menu Project » References » Microsoft ActiveX Data Object 2.1 Library (atau ADODB dengan versi yang lebih tinggi).

Selanjutnya kita buat syntax untuk meload Database tersebut
Pada Global Declaration kita tambahkan sebuah variable

Option Explicit
Dim DB As New ADODB.Connection

'*// Pada form_load tambahkan syntax untuk meload databasenya

Private Sub Form_Load()
DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;" & _
"Data Source=C:\dbaImage.mdb"
End Sub

'*// Selanjutnya kita buat fungsi untuk mengkonversi gambar kedalam _
bentuk data.

Function ConvImage(NamaFile As String, Byref ErrRet As Long) As Byte()
On Error GoTo Salah
Dim UkuranFile As Long
Dim imgData() As Byte
'*// mendapatkan besar file yang akan di load dengan fungsi FileLen
UkuranFile = FileLen(NamaFile)

'*// Periksa Besar File yang di load
If UkuranFile > 0 Then
'*// Lakukan ReDim variable array sesuai dengan ukuran file yang _
diload
ReDim imgData(UkuranFile) As Byte

'*// Nah disini kita memanipulasi gambar untuk dimasukan ke _
database. Sebelumnya kita load gambar tsb dari file, _
kemudian masukan Byte demi Byte ke variable array dengan _
metode GET

Open NamaFile For Binary As #1
Get #1, , imgData
Close #1
'*// Setelah berhasil mendapatkan data tsb, kita lakukan _
pemindahan data ke fungsi ConvImage
ConvImage = imgData

'*// Kemudian beri tanda dgn nilai 0, bahwa tidak ada Error
ErrRet = 0
Else
'*// Beri tanda, bahwa ada Error
ErrRet = 1
End If
Exit Function
Salah:
'*// Beri tanda, bahwa ada Error
ErrRet = Err.Number
End Function

'*// Selanjutnya Buat Fungsi untuk menampilkan gambar

Function TampilImage(imgData() As Byte, Byref ErrRet As Long) _
As Picture
On Error GoTo Salah
If UBound(imgData) Then '*// Cek besar data > 0
Dim hFile As String
'*// Periksa apakah file img.tmp ada pada directory C:
hFile = Dir("C:\img.tmp", vbNormal)
'*// Jika ada, kita hapus terlebih dahulu dengan fungsi Kill
If hFile <> "" Then Kill "C:\img.tmp"

'*// Selanjutnya kita buat file penampung gambar dengan data _
yang diterima dari variable imgData
Open "C:\img.tmp" For Binary As #1
Put #1, , imgData
Close #1
'*// Setelah file dibuat, kita coba untuk memindahkannya kedalam _
fungsi
Set TampilImage = LoadPicture("C:\img.tmp")
'*// Beri tanda bahwa file berhasil di load
ErrRet = 0
Else
'*// Beri tanda, bahwa ada Error
ErrRet = 1
End If
Exit Function
Salah:
'*// Beri tanda, bahwa ada Error
ErrRet = Err.Number
End Function

'*// Setelah dua fungsi diatas dibuat, kita coba dengan menyimpan _
sebuah data kedalam database.

Private Sub Command1_Click()
Dim ErrRet As Long, imgData() As Byte
Dim Rc As New ADODB.Recordset

'*// Melakukan pengisian variable imgData dengan menggunakan fungsi _
ConvImage dengan parameter yang dikirim. _
Jangan lupa rubah nama file gambar yang akan di load
imgData = ConvImage("C:\vbBeGo\lunatic.bmp", ErrRet)

'*// Dikarenakan disini kita menggunakan Type OleObject maka metode _
penyimpanan data tidak menggunakan Query melainkan langsung _
memanggil nama table nya.

Rc.Open "pegawai", DB, 3, 3
If ErrRet = 0 Then
'*// Buat data baru dengan menggunakan perintah AddNew
Rc.AddNew
'*// Isi pada field
Rc.Fields("NRP") = "001"
Rc.Fields("Photo").AppendChunk imgData()
'*// Simpan Data
Rc.Update
End If
Rc.Close
End Sub

'*// Setelah melakukan proses penyimpanan data, kita coba untuk _
menampilkannya.

Private Sub Command3_Click()
Dim ErrRet As Long, imgData As StdPicture
Dim Rc As New ADODB.Recordset

'*// Kita panggil data yang kita simpan tadi dengan menggunakan Query _
dengan NRP = 001
Rc.Open "Select * from Pegawai Where NRP='001'", DB, 3, 3

If Not Rc.EOF Then
Set imgData = TampilImage(Rc("Photo").GetChunk( _
Rc("Photo").ActualSize), ErrRet)
If ErrRet = 0 Then
'*// Kita load gambar dari file ke Object Image1
Set Image1.Picture = imgData
End If
End If
End Sub

Menjalankan Aplikasi Berdasarkan User Login 2

2008-08-23T03:57:00.000-07:00

Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION

Dim wUser As String
Dim wDomain As String
Dim wPassword As String
Dim wCommandLine As String
Dim wCurrentDir As String

Dim Result As Long

si.cb = Len(si)

wUser = StrConv(UserName + Chr$(0), vbUnicode)
wDomain = StrConv(DomainName + Chr$(0), vbUnicode)
wPassword = StrConv(Password + Chr$(0), vbUnicode)
wCommandLine = StrConv(CommandLine + Chr$(0), vbUnicode)
wCurrentDir = StrConv(CurrentDirectory + Chr$(0), vbUnicode)

Result = CreateProcessWithLogonW(wUser, wDomain, wPassword, _
LOGON_WITH_PROFILE, 0&, wCommandLine, _
CREATE_DEFAULT_ERROR_MODE, 0&, wCurrentDir, si, pi)
' CreateProcessWithLogonW() does not
If Result <> 0 Then
CloseHandle pi.hThread
CloseHandle pi.hProcess
W2KRunAsUser = 0
Else
W2KRunAsUser = Err.LastDllError
MsgBox "CreateProcessWithLogonW() failed with error " & Err.LastDllError, vbExclamation
End If

End Function

'********************************************************************
' RunAsUser for Windows NT 4.0
'********************************************************************

Public Function NT4RunAsUser(ByVal UserName As String, _
ByVal Password As String, _
ByVal DomainName As String, _
ByVal CommandLine As String, _
ByVal CurrentDirectory As String) As Long
Dim Result As Long
Dim hToken As Long
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION

Result = LogonUser(UserName, DomainName, Password, _
LOGON32_LOGON_INTERACTIVE, _
LOGON32_PROVIDER_DEFAULT, hToken)
If Result = 0 Then

NT4RunAsUser = Err.LastDllError
MsgBox "LogonUser() failed with error " & _
Err.LastDllError, vbExclamation

Exit Function
End If

si.cb = Len(si)
Result = CreateProcessAsUser(hToken, 0&, CommandLine, _
0&, 0&, False, _
CREATE_DEFAULT_ERROR_MODE, _
0&, CurrentDirectory, si, pi)
If Result = 0 Then
NT4RunAsUser = Err.LastDllError
MsgBox "CreateProcessAsUser() failed with error " & _
Err.LastDllError, vbExclamation
CloseHandle hToken
Exit Function
End If

CloseHandle hToken
CloseHandle pi.hThread
CloseHandle pi.hProcess
NT4RunAsUser = 0

End Function

Public Function RunAsUser(ByVal UserName As String, _
ByVal Password As String, _
ByVal DomainName As String, _
ByVal CommandLine As String, _
ByVal CurrentDirectory As String) As Long

Dim w2kOrAbove As Boolean
Dim osinfo As OSVERSIONINFO
Dim Result As Long
Dim uErrorMode As Long

' Determine if system is Windows 2000 or later
osinfo.dwOSVersionInfoSize = Len(osinfo)
osinfo.szCSDVersion = Space$(128)
GetVersionExA osinfo
w2kOrAbove = _
(osinfo.dwPlatformId = VER_PLATFORM_WIN32_NT And _
osinfo.dwMajorVersion >= 5)
If (w2kOrAbove) Then
Result = W2KRunAsUser(UserName, Password, DomainName, _
CommandLine, CurrentDirectory)
Else
Result = NT4RunAsUser(UserName, Password, DomainName, _
CommandLine, CurrentDirectory)
End If
RunAsUser = Result
End Function

Private Sub Command1_Click()
'Contoh Penggunaan
RunAsUser "vbbego", "admin", "", "Notepad.exe", ""
End Sub

Menjalankan Aplikasi Berdasarkan User Login 1

2008-08-22T23:17:00.000-07:00

Option Explicit

Private Const CREATE_DEFAULT_ERROR_MODE = &H4000000
Private Const LOGON_WITH_PROFILE = &H1
Private Const LOGON_NETCREDENTIALS_ONLY = &H2
Private Const LOGON32_LOGON_INTERACTIVE = 2
Private Const LOGON32_PROVIDER_DEFAULT = 0

Private Type STARTUPINFO
cb As Long
lpReserved As Long ' !!! Harus Long untuk Unicode string
lpDesktop As Long ' !!! Harus Long untuk Unicode string
lpTitle As Long ' !!! Harus Long untuk Unicode string
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type

Private Declare Function LogonUser Lib "advapi32.dll" Alias _
"LogonUserA" _
(ByVal lpszUsername As String, _
ByVal lpszDomain As String, _
ByVal lpszPassword As String, _
ByVal dwLogonType As Long, _
ByVal dwLogonProvider As Long, _
phToken As Long) As Long

Private Declare Function CreateProcessAsUser Lib "advapi32.dll" _
Alias "CreateProcessAsUserA" _
(ByVal hToken As Long, _
ByVal lpApplicationName As Long, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CreateProcessWithLogonW Lib "advapi32.dll" _
(ByVal lpUsername As String, _
ByVal lpDomain As String, _
ByVal lpPassword As String, _
ByVal dwLogonFlags As Long, _
ByVal lpApplicationName As Long, _
ByVal lpCommandLine As String, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESS_INFORMATION) As Long

Private Declare Function CloseHandle Lib "kernel32.dll" _
(ByVal hObject As Long) As Long

Private Declare Function SetErrorMode Lib "kernel32.dll" _
(ByVal uMode As Long) As Long

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

' Version Checking APIs
Private Declare Function GetVersionExA Lib "kernel32.dll" _
(lpVersionInformation As OSVERSIONINFO) As Integer

Private Const VER_PLATFORM_WIN32_NT = &H2

'********************************************************************

' RunAsUser for Windows 2000 and Later
'********************************************************************

Public Function W2KRunAsUser(ByVal UserName As String, _
ByVal Password As String, _
ByVal DomainName As String, _
ByVal CommandLine As String, _
ByVal CurrentDirectory As String) As Long

Set Wallpaper

2008-08-22T23:07:00.000-07:00

//Pada module !
Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Const SPI_SETDESKWALLPAPER = 20
//Pada form
Private sub coomand1_click()
Dim ChangeWP
ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0,app.path & “\gambar.jpg”, 0)
End Sub

Mendeteksi hardware(souncard)

2008-08-01T20:34:00.000-07:00

Private Sub Command1_Click()
If waveOutGetNumDevs() > 0 Then
MsgBox "SOUNCARD ADA"
Else
MsgBox "SOUNCARD TIDAK ADA"

End If
End Sub

Bikin folder pake API (Aplication Programmin interface)

2008-08-01T19:07:00.000-07:00

Document Selasa, Desember 25, 2007

Public Declare Function CreateDirectory Lib "kernel32" Alias _ "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes _
As SECURITY_ATTRIBUTES) As Long

Public Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Public Function buatfolder()
Dim namadir As String
Dim file As SECURITY_ATTRIBUTES
namadir = "Picture"
With file
.bInheritHandle = 1
.lpSecurityDescriptor = 0
.nLength = Len(namadir)
End With
CreateDirectory App.Path & "\" & "folderna", file
End Function