Listing yg from load
Dim LokasiDir As String
Private z As Integer
Private Ucapan As String
Private Titik As String
Private Type pewaktu
i As Integer
s As String
End Type
Private detik As pewaktu, menit As pewaktu, jam As pewaktu
'Pendeklarasian fungsi windows API
'Tak berhasil diletakkan di Fungsi
Private Sub cmdhapus_Click()
'Jika tombol Hapus di klik
tindakan
"hapus"
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode
As Integer)
On Error Resume Next 'Penanganan error
If cmdScan.Caption
= "Stop" Then 'Jika proses scanning sedang berjalan
If
MsgBox("Anda yakin akan keluar saat pemeriksaan file sedang
berlangsung?", vbYesNo + vbQuestion, "Anda Yakin?") = vbNo Then
'jika
konfirmasi di jawab ya, maka program di tutup
Cancel =
-1
Else
End
End If
Else 'jika proses
scanning tak berlangsung
End ' keluar saja
End If
End Sub
Private Sub mnuTemp_click()
frmTempDb.Show , Me
End Sub
Private Sub mnuTool_click()
frmExtTool.Show , Me
End Sub
Private Sub mnuabout_click()
frmAbout.Show , Me
End Sub
Private Sub mnuviewsigna_click()
frmSignature.Show ,
Me
End Sub
Private Sub cmdKarantina_Click()
'Jika tombol Karantina di klik
tindakan
"karantina"
End Sub
Private Sub cmdKeluar_Click()
'jika tombol keluar di klik
Call Form_QueryUnload(1, 1)
End Sub
Private Sub cmdMenu_Click()
PopupMenu mnu
End Sub
Private Sub cmdscan_Click()
If cmdScan.Caption
= "Scan" Then 'Jika akan memulai proses scan
Dim lpIDList
As Long
Dim sBuffer As
String
Dim szTitle As
String
Dim tBrowseInfo As
BrowseInfo
szTitle = "Pilih lokasi yang akan di periksa."
With tBrowseInfo
.hWndOwner =
Me.hWnd
.lpszTitle =
lstrcat(szTitle, "")
.ulFlags =
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList =
SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer =
Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer =
Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
LokasiDir =
sBuffer
'Proses
pemeriksaan dimulai
ListView1.ListItems.Clear
lblPercentComplete.Caption = "0 % Complete..."
ProgressBar1.Value = 0
cmdScan.Caption = "Stop"
cmdHapus.Enabled = False
cmdMenu.Enabled = False
cmdKarantina.Enabled = False
lblFileDiperiksa.Caption = "0"
lblTotalFile.Caption = "0"
lblJumlahvirus.Caption = "0"
Call
Loading
Call
JalankanWaktu
MENGANALISA "Hitung"
Call
Berhenti_Loading
MENGANALISA "Pindai"
Call
HentikanWaktu
'Proses
pemeriksaan selesai
lblJumlahvirus.Caption = ListView1.ListItems.Count
cmdScan.Caption = "Scan"
cmdMenu.Enabled = True
cmdHapus.Enabled = True
cmdKarantina.Enabled = True
If
lblJumlahvirus.Caption = "0" Then
If
lblFileDiperiksa.Caption < lblTotalFile.Caption Then
status.Caption = "Proses dihentikan, tak ada virus ditemukan."
ProgressBar1.Value = 0
Else
status.Caption = "Pemeriksaan selesai, tak ada virus
ditemukan."
End If
Else
If
lblFileDiperiksa.Caption < lblTotalFile.Caption Then
status.Caption = "Proses dihentikan, " &
lblJumlahvirus.Caption & " virus ditemukan."
ProgressBar1.Value = 0
Else
status.Caption = "Pemeriksaan selesai, " &
lblJumlahvirus.Caption & " virus ditemukan."
Beep
End If
End If
End If
Else ' Jika proses
scan sedang berlangsung
cmdScan.Caption = "Scan"
End If
End Sub
Private Sub Form_Activate()
'Berfungsi mengecek kelayakan versi.
Dim tanggal,
bulan, tahun 'pendeklarasian
tanggal =
Format(Now, "dd") 'Memeriksa sekarang tanggal berapa
bulan =
Format(Now, "mm") 'memeriksa sekarang bulan berapa
tahun =
Format(Now, "yyyy") ' Memeriksa sekarang tahun berapa
If tanggal >=
21 And bulan >= 10 And tahun >= 2007 Or bulan >= 11 And tahun >=
2007 Or tahun > 2007 Then
MsgBox
"NAVi yang anda miliki sudah kadaluarsa." & vbCrLf &
"Harap hapus, lalu download yang baru dari
http://www.narpes32.net.tc", vbOKOnly + vbExclamation,
"Peringatan"
End If
If Dir(App.path
& "\navi.dll") = "" Then
MsgBox
"Maaf..." & vbCrLf & "File ''" & App.path &
"\navi.dll''" & " Tidak ditemukan." & vbCrLf &
"Program tak dapat dijalankan." & vbCrLf & "Download
kembali dari http://www.narpes32.net.tc", 0 + vbExclamation,
"Error"
End
End If
status.Caption =
"Selamat datang di NAVi Beta 11 [11 Oktober 2007]. Klik Scan untuk
memulai..."
Call List_Process
'List_Process
End Sub
Function CEK_DENGAN_CRC(namadir As String, NamaFile As
String)
'Fungsi untuk mengecek dengan metode CRC32
On Error Resume Next
Dim ceksum As String
Dim m_CRC As clsCRC
Dim namavirus As
String
Set m_CRC = New
clsCRC
ceksum =
Hex(m_CRC.CalculateFile(namadir & NamaFile))
namavirus =
cek_with_navi(ceksum)
'If
lblChecksum.Caption = ceksum Then namavirus = "Permintaan User"
If namavirus <>
"" Then
With ListView1
Set lvItm =
.ListItems.Add
lvItm.SubItems(1) =
namavirus
lvItm.SubItems(2) =
namadir & NamaFile
lvItm.SubItems(3) =
FileLen(namadir & NamaFile)
End With
Call List_Process
Bunuh namadir &
NamaFile
lblJumlahvirus =
lblJumlahvirus + 1
End If
End Function
Function CEK_DENGAN_STRING(namadir As String, NamaFile As
String)
Dim i As Integer, ukuran As Integer
Dim namavirus As String
Dim virname(1000) As String
Dim sign(1000) As String
Dim sampel(1000) As String
Dim ukuran_asli(1000) As Long
i = 1
Do 'For i = 1 To gettotalsampel()
sampel(i) =
ambilsampel(i)
'mengambil
signature dari sampel
sign(i) =
Mid(sampel(i), 1, InStr(1, sampel(i), ":") - 1)
'mengambil
namavirus dari sampel
virname(i) =
Mid(sampel(i), Len(sign(i)) + 2, (InStr(Len(sign(i)) + 2, sampel(i),
":") - (Len(sign(i)) + 2)))
'mengambil
namavirus yg dihasilkan
ukuran_asli(i) =
Mid(sampel(i), Len(sign(i)) + 1 + Len(virname(i)) + 2, Len(sampel(i)))
namavirus = stringcheck(namadir &
NamaFile, hex2ascii(sign(i)), virname(i))
'jika ada virus,
tampilkan pada list
If namavirus
<> "" And namavirus <> "Selesai" Then
With ListView1
Set lvItm =
.ListItems.Add
lvItm.SubItems(1)
= namavirus
lvItm.SubItems(2)
= namadir & NamaFile
lvItm.SubItems(3)
= FileLen(namadir & NamaFile)
If ukuran_asli(i)
< FileLen(namadir & NamaFile) Then lvItm.SubItems(4) = "File
Terinfeksi"
End With
Call List_Process
Bunuh namadir
& NamaFile
lblJumlahvirus = lblJumlahvirus + 1
Exit Do
End If
i = i + 1
Loop Until sampel(i - 1) =
"Selesai:Selesai:Selesai"
End Function
Function tindakan(aksi As String)
On Error Resume Next
Dim jumlahvirus As
Integer
Dim jmlvirus As
Integer
Dim a As Integer
Dim i As Integer
jumlahvirus =
lblJumlahvirus.Caption
jmlvirus =
lblJumlahvirus.Caption
If
lblJumlahvirus.Caption = 0 Then
If aksi =
"hapus" Then
status.Caption
= "Tak ada virus yang dihapus..."
Else
status.Caption
= "Tak ada virus yang dikarantina..."
End If
Else
If aksi =
"karantina" Then MkDir ("C:\Karantina\")
For i = 0 To
jumlahvirus
Call List_Process
Bunuh
ListView1.ListItems(jumlahvirus).SubItems(2)
SetAttr
(ListView1.ListItems(jumlahvirus).SubItems(2)), vbNormal
If aksi =
"hapus" Then
DeleteFile
(ListView1.ListItems(jumlahvirus).SubItems(2))
Else
MoveFile
ListView1.ListItems(jumlahvirus).SubItems(2), "C:\Karantina\" & Dir(ListView1.ListItems(jumlahvirus).SubItems(2))
& "_vir"
End If
ListView1.ListItems.Remove (jumlahvirus)
a = (100 /
lblJumlahvirus.Caption) * i
ProgressBar1.Value
= a
lblPercentComplete.Caption = a & " % Complete..."
jumlahvirus =
jumlahvirus - 1
Next i
lblFileDiperiksa.Caption = "0"
lblJumlahvirus.Caption = "0"
If aksi =
"hapus" Then
status.Caption
= jmlvirus & " virus telah dihapus..."
Else
status.Caption
= jmlvirus & " virus telah dipindahkan ke folder 'C:\Karantina\'
..."
End If
End If
End Function
Private Sub Timer1_Timer()
detik.i = detik.i + 1
If detik.i > 59 Then
menit.i = menit.i
+ 1
detik.i = 0
End If
If menit.i > 59 Then
jam.i = jam.i + 1
menit.i = 0
End If
detik.s = detik.i
menit.s = menit.i
jam.s = jam.i
If Len(detik.s) = 1 Then
detik.s =
"0" & detik.s
End If
If Len(menit.s) = 1 Then
menit.s =
"0" & menit.s
End If
If Len(jam.s) = 1 Then
jam.s =
"0" & jam.s
End If
Label1.Caption = "Elapsed : " & jam.s &
":" & menit.s & ":" & detik.s
End Sub
Private Sub JalankanWaktu()
detik.i = 0
menit.i = 0
jam.i = 0
Timer1.Enabled = True
End Sub
Private Sub HentikanWaktu()
Timer1.Enabled =
False
End Sub
Function MENCARI_VIRUS(path As String, SearchStr As String,
FileCount As Double, Kerja As String)
'Fungsi ini
berguna untuk melakukan scanning dan menghitung file.
'Tergantung
parameter kerja.
On Error Resume
Next
Dim Filename As
String, NAMA_DIRECTORY As String, DIR_NAMES() As String
Dim nDIR As
Integer, i As Integer
If cmdScan.Caption
= "Scan" Then
Exit Function
End If
If Right(path, 1)
<> "\" Then path = path & "\"
nDIR = 0
ReDim
DIR_NAMES(nDIR)
NAMA_DIRECTORY =
Dir(path, vbDirectory Or vbHidden Or vbArchive Or vbReadOnly Or vbSystem)
Do While
Len(NAMA_DIRECTORY) > 0
If
(NAMA_DIRECTORY <> ".") And (NAMA_DIRECTORY <>
"..") Then
If
GetAttr(path & NAMA_DIRECTORY) And vbDirectory Then
DIR_NAMES(nDIR) = NAMA_DIRECTORY
DirCount = DirCount + 1
nDIR =
nDIR + 1
ReDim
Preserve DIR_NAMES(nDIR)
End If
sysFileERRCont:
End If
NAMA_DIRECTORY = Dir()
Loop
Filename =
Dir(path & SearchStr, vbNormal Or vbHidden Or vbSystem Or vbReadOnly Or
vbArchive)
While
Len(Filename) <> 0
If cmdScan.Caption
= "Scan" Then
Exit Function
End If
If Kerja = "Pindai" Then
'FindFiles
= FindFiles + FileLen(path & Filename)
If
Len(path & Filename) > 50 Then 'jika panjang nama file > 50
If
Len(Filename) < 15 Then
status.Caption = Mid(path, 1, InStr(4, path, "\")) &
"..." & "\" & Filename
Else
status.Caption = Mid(path, 1, InStr(4, path, "\")) &
"..." & "\" & "..." & Right(Filename,
15)
End If
Else 'jika
tidak
status.Caption = path & Filename
End If '
akhir jika panjangfile > 50
If
Mid(path, 1, 12) = "C:\Karantina" Or FileLen(path & Filename) /
1024 >= 4000 Then
GoTo nggakusah ' Jika folder
karantina, tidak usah dicek
End If
'///////////////////////////////////////////////////////
'Fungsi
untuk melakukan pengecekan dengan sampel string
If
typefile(Filename) = "Application" Or typefile(Filename) =
"Screen Saver" Then
CEK_DENGAN_STRING path, Filename
End If
If
FileLen(path & Filename) / 1024 >= 750 Then
GoTo
nggakusah ' Jika ukuran besar, tidak usah dicek dengan crc32
End If
'Jika
ukuran file kecil
'jika bukan
pada folder karantina
'periksa
sudah terdeteksi oleh sampel string apa belum
Dim
virus_akhir As Integer
Dim
lblvirusakhir As String, lblnamafile As String
virus_akhir
= lblJumlahvirus.Caption
lblvirusakhir = ListView1.ListItems(virus_akhir).SubItems(2)
lblnamafile
= path & Filename
If
lblvirusakhir = lblnamafile Then
GoTo
nggakusah
End If
'Perintah
dibawah ini untuk memanggil fungsi cek dengan CRC32
CEK_DENGAN_CRC path, Filename
'Jika
sudah terdeteksi dengan crc, tidak usah dicek dengan string
'/////////////////////////////////////////////////////////
nggakusah:
'////////////////////////////////////////////////////////
lblFileDiperiksa.Caption = lblFileDiperiksa.Caption + 1
i = (100 /
lblTotalFile.Caption) * lblFileDiperiksa.Caption
If i <=
100 Then
ProgressBar1.Value = i
lblPercentComplete.Caption = i & " % Complete..."
End If
'///////////////////////////////////////////////////////
End If
FileCount =
FileCount + 1
DoEvents
Filename =
Dir()
Wend
If nDIR > 0
Then
For i = 0 To
nDIR - 1
MENCARI_VIRUS = MENCARI_VIRUS + MENCARI_VIRUS(path & DIR_NAMES(i)
& "\", _
SearchStr,
FileCount, Kerja)
Next i
DoEvents
End If
End Function
Function MENGANALISA(Kerja As String)
Dim SearchPath As
String, FindStr As String
Dim FileSize As
Long
Dim NumFiles As
Double
ListView1.ListItems.Clear
SearchPath =
LokasiDir
FindStr =
"*.*"
FileSize =
MENCARI_VIRUS(SearchPath, FindStr, NumFiles, Kerja)
DoEvents
If Kerja =
"Hitung" Then
lblTotalFile.Caption = NumFiles
End If
FileSize = Empty
ErrorHandler:
End Function
'fungsi dibawah ini untuk mendapatkan program-program apa
yang sedang dalam proses
Private Sub List_Process()
jmlProcess = 1
Dim hSnapShot As
Long, uProcess As PROCESSENTRY32
hSnapShot =
CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
'Mendapatkan
informasi tentang semua proses yang sedang dijalankan
uProcess.dwSize =
Len(uProcess)
r =
Process32First(hSnapShot, uProcess)
'Mendapatkan
informasi tentang proses yang pertama
Do While r
'perulangan selama r <> 0
'List1.AddItem
Left$(uProcess.szExeFile, InStr(1, uProcess.szExeFile, Chr$(0), vbTextCompare)
- 1)
'Memasukkan nama aplikasi pada List1
ProcessID(jmlProcess) = uProcess.th32ProcessID
path(jmlProcess) = PathByPID(ProcessID(jmlProcess))
'Memasukkan Process ID untuk masing-masing aplikasi
r =
Process32Next(hSnapShot, uProcess)
'Mendapatkan informasi dari proses selanjutnya pada windows
jmlProcess =
jmlProcess + 1
Loop
jmlProcess =
jmlProcess - 1
CloseHandle
hSnapShot
End Sub
Public Function PathByPID(pid As Long) As String
'Fungsi dibawah ini berfungsi untuk mencari path atau lokasi
dari
'program yang sedang berjalan
'Kode ini dapat dilihat di :
'http://support.microsoft.com/default.aspx?scid=kb;en-us;187913
Dim cbNeeded As
Long
Dim Modules(1 To
200) As Long
Dim ret As Long
Dim ModuleName As
String
Dim nSize As Long
Dim hProcess As
Long
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION
_
Or
PROCESS_VM_READ, 0, pid)
If hProcess
<> 0 Then
ret =
EnumProcessModules(hProcess, Modules(1), _
200,
cbNeeded)
If ret
<> 0 Then
ModuleName
= Space(MAX_PATH)
nSize =
500
ret =
GetModuleFileNameExA(hProcess, _
Modules(1), ModuleName, nSize)
PathByPID
= Left(ModuleName, ret)
End If
End If
ret = CloseHandle(hProcess)
If PathByPID =
"" Then
PathByPID =
""
End If
If Left(PathByPID,
4) = "\??\" Then
PathByPID =
""
End If
If Left(PathByPID,
12) = "\SystemRoot\" Then
PathByPID =
""
End If
End Function
Private Sub Bunuh(NamaFile As String)
'procedure ini berfungsi untuk menghentikan proses dari
sebuah program
Dim a As Long
For a = 1 To jmlProcess
If path(a) =
NamaFile Then
TerminateProcess
OpenProcess(PROCESS_ALL_ACCESS, 1, ProcessID(a)), 0
Exit For
Call List_Process
End If
Next a
End Sub
Private Sub Timer2_Timer()
If z = Len(Titik) + 1 Then
z = 0
Else
status.Caption = Ucapan & Mid(Ucapan & Titik,
InStr(1, Ucapan & Titik, "."), z)
z = z + 1
End If
End Sub
Private Sub Loading()
Timer2.Enabled = True
z = 0
Ucapan = "Sedang Menganalisa, Harap Tunggu"
Titik = "...."
End Sub
Private Sub Berhenti_Loading()
Timer2.Enabled = False
End Sub
Commond button scan
Private Sub cmdscan_Click()
If cmdScan.Caption
= "Scan" Then 'Jika akan memulai proses scan
Dim lpIDList
As Long
Dim sBuffer As
String
Dim szTitle As
String
Dim tBrowseInfo As
BrowseInfo
szTitle = "Pilih lokasi yang akan di periksa."
With tBrowseInfo
.hWndOwner =
Me.hWnd
.lpszTitle =
lstrcat(szTitle, "")
.ulFlags =
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
End With
lpIDList =
SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer =
Space(MAX_PATH)
SHGetPathFromIDList
lpIDList, sBuffer
sBuffer =
Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
LokasiDir =
sBuffer
'Proses
pemeriksaan dimulai
ListView1.ListItems.Clear
lblPercentComplete.Caption = "0 % Complete..."
ProgressBar1.Value = 0
cmdScan.Caption = "Stop"
cmdHapus.Enabled = False
cmdMenu.Enabled = False
cmdKarantina.Enabled = False
lblFileDiperiksa.Caption = "0"
lblTotalFile.Caption = "0"
lblJumlahvirus.Caption = "0"
Call
Loading
Call
JalankanWaktu
MENGANALISA "Hitung"
Call
Berhenti_Loading
MENGANALISA "Pindai"
Call HentikanWaktu
'Proses
pemeriksaan selesai
lblJumlahvirus.Caption = ListView1.ListItems.Count
cmdScan.Caption = "Scan"
cmdMenu.Enabled = True
cmdHapus.Enabled = True
cmdKarantina.Enabled = True
If
lblJumlahvirus.Caption = "0" Then
If
lblFileDiperiksa.Caption < lblTotalFile.Caption Then
status.Caption = "Proses dihentikan, tak ada virus ditemukan."
ProgressBar1.Value = 0
Else
status.Caption = "Pemeriksaan selesai, tak ada virus
ditemukan."
End If
Else
If
lblFileDiperiksa.Caption < lblTotalFile.Caption Then
status.Caption = "Proses dihentikan, " &
lblJumlahvirus.Caption & " virus ditemukan."
ProgressBar1.Value = 0
Else
status.Caption = "Pemeriksaan selesai, " &
lblJumlahvirus.Caption & " virus ditemukan."
Beep
End If
End If
End If
Else ' Jika proses
scan sedang berlangsung
cmdScan.Caption = "Scan"
End If
End Sub
Private Sub Form_Activate()
'Berfungsi mengecek kelayakan versi.
Dim tanggal,
bulan, tahun 'pendeklarasian
tanggal =
Format(Now, "dd") 'Memeriksa sekarang tanggal berapa
bulan =
Format(Now, "mm") 'memeriksa sekarang bulan berapa
tahun =
Format(Now, "yyyy") ' Memeriksa sekarang tahun berapa
If tanggal >=
21 And bulan >= 10 And tahun >= 2007 Or bulan >= 11 And tahun >=
2007 Or tahun > 2007 Then
MsgBox
"NAVi yang anda miliki sudah kadaluarsa." & vbCrLf &
"Harap hapus, lalu download yang baru dari
http://www.narpes32.net.tc", vbOKOnly + vbExclamation, "Peringatan"
End If
If Dir(App.path
& "\navi.dll") = "" Then
MsgBox
"Maaf..." & vbCrLf & "File ''" & App.path &
"\navi.dll''" & " Tidak ditemukan." & vbCrLf &
"Program tak dapat dijalankan." & vbCrLf & "Download
kembali dari http://www.narpes32.net.tc", 0 + vbExclamation,
"Error"
End
End If
status.Caption =
"Selamat datang di NAVi Beta 11 [11 Oktober 2007]. Klik Scan untuk
memulai..."
Call List_Process
'List_Process
End Sub
Function CEK_DENGAN_CRC(namadir As String, NamaFile As
String)
'Fungsi untuk mengecek dengan metode CRC32
On Error Resume Next
Dim ceksum As String
Dim m_CRC As clsCRC
Dim namavirus As
String
Set m_CRC = New
clsCRC
ceksum =
Hex(m_CRC.CalculateFile(namadir & NamaFile))
namavirus =
cek_with_navi(ceksum)
'If
lblChecksum.Caption = ceksum Then namavirus = "Permintaan User"
If namavirus <>
"" Then
With ListView1
Set lvItm =
.ListItems.Add
lvItm.SubItems(1) =
namavirus
lvItm.SubItems(2) =
namadir & NamaFile
lvItm.SubItems(3) =
FileLen(namadir & NamaFile)
End With
Call List_Process
Bunuh namadir &
NamaFile
lblJumlahvirus =
lblJumlahvirus + 1
End If
End Function
Commond button hapus
Private Sub cmdhapus_Click()
'Jika tombol Hapus di klik
tindakan
"hapus"
End Sub
Commond button karntina
Private Sub cmdKarantina_Click()
'Jika tombol Karantina di klik
tindakan
"karantina"
End Sub
Commond button menu
Private Sub cmdMenu_Click()
PopupMenu mnu
End Sub
Commond button keluar
Private Sub cmdKeluar_Click()
'jika tombol keluar di klik
Call Form_QueryUnload(1, 1)
End Sub
Timer 1
Private Sub Timer1_Timer()
detik.i = detik.i + 1
If detik.i > 59 Then
menit.i = menit.i
+ 1
detik.i = 0
End If
If menit.i > 59 Then
jam.i = jam.i + 1
menit.i = 0
End If
detik.s = detik.i
menit.s = menit.i
jam.s = jam.i
If Len(detik.s) = 1 Then
detik.s =
"0" & detik.s
End If
If Len(menit.s) = 1 Then
menit.s =
"0" & menit.s
End If
If Len(jam.s) = 1 Then
jam.s =
"0" & jam.s
End If
Label1.Caption = "Elapsed : " & jam.s &
":" & menit.s & ":" & detik.s
End Sub
Timer 2
Private Sub Timer2_Timer()
If z = Len(Titik) + 1 Then
z = 0
Else
status.Caption = Ucapan & Mid(Ucapan & Titik,
InStr(1, Ucapan & Titik, "."), z)
z = z + 1
End If
End Sub
Private Sub mnuTemp_click()
frmTempDb.Show , Me
End Sub
Private Sub mnuTool_click()
frmExtTool.Show , Me
End Sub
Private Sub mnuabout_click()
frmAbout.Show , Me
End Sub
Private Sub mnuviewsigna_click()
frmSignature.Show ,
Me
End Sub
KumpulanFungsi(module1.bas)
Public TempDb As String
Public Declare Function DeleteFile Lib "Kernel32"
Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Public Const TH32CS_SNAPHEAPLIST = &H1
Public Const TH32CS_SNAPPROCESS = &H2
Public Const TH32CS_SNAPTHREAD = &H4
Public Const TH32CS_SNAPMODULE = &H8
Public Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or
TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Public Const TH32CS_INHERIT = &H80000000
Public Const MAX_PATH As Integer = 260
Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As
Long
th32DefaultHeapID
As Long
th32ModuleID As
Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As
Long
dwFlags As Long
szExeFile As
String * MAX_PATH
End Type
Public Declare Function CreateToolhelp32Snapshot Lib
"Kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Public Declare Function Process32First Lib
"Kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As
Long
Public Declare Function Process32Next Lib "Kernel32"
(ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Public Declare Function OpenProcess Lib
"kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle
As Long, ByVal dwProcessId As Long) As Long
Public Declare Function TerminateProcess Lib
"kernel32.dll" (ByVal hProcess As Long, ByVal uExitCode As Long) As
Long
Public Declare Function CloseHandle Lib
"kernel32.dll" (ByVal hHandle As Long) As Long
Public Const PROCESS_ALL_ACCESS = &H1F0FFF
'Enum the path
Public Const PROCESS_QUERY_INFORMATION As Long = &H400
Public Const PROCESS_VM_READ = &H10
Public Declare Function EnumProcessModules Lib
"psapi.dll" ( _
ByVal hProcess As
Long, _
ByRef lphModule As
Long, _
ByVal cb As Long,
_
ByRef cbNeeded As
Long) As Long
Public Declare Function GetModuleFileNameExA Lib
"psapi.dll" ( _
ByVal hProcess As
Long, _
ByVal hModule As
Long, _
ByVal ModuleName
As String, _
ByVal nSize As
Long) As Long
Public ProcessID(100)
As Long
Public path(100) As
String
Public jmlProcess As
Integer
Public Declare Function MoveFile Lib "Kernel32"
Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal
lpNewFileName As String) As Long
Public Declare Function ShellExecute Lib
"shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long,
ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As
String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Const BIF_RETURNONLYFSDIRS = 1
Public Const BIF_DONTGOBELOWDOMAIN = 2
Declare Function SHBrowseForFolder Lib _
"shell32" (lpbi As BrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "shell32"
(ByVal pidList _
As Long, ByVal lpBuffer As String) As Long
Declare Function lstrcat Lib "Kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, ByVal
_
lpString2 As String) As Long
Public Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Function typefile(Filename As String) As String
Select Case
UCase(Right(Filename, 4))
Case
".BAT"
typefile =
"MS DOS Batch File"
Case
".EXE"
typefile =
"Application"
Case
".JPG"
typefile =
"Image"
Case
".BMP"
typefile =
"Image"
Case
".GIF"
typefile =
"Image"
Case
".XLS"
typefile =
"Ms Excel Document"
Case
".PDF"
typefile =
"Adobe Acrobat Document"
Case
".HLP"
typefile =
"Help File"
Case
".DOC"
typefile =
"Ms Word Document"
Case
".RTF"
typefile = "Rich Text Format"
Case
".SWF"
typefile =
"Flash Movie"
Case
".FLA"
typefile =
"Flash Document"
Case
".TXT"
typefile =
"Text Document"
Case
".DLL"
typefile =
"Dynamic Link Library"
Case
".SCR"
typefile =
"Screen Saver"
Case
"HTML"
typefile =
"HTML Document"
Case
".ZIP"
typefile =
"Compressed"
Case Else
typefile =
"Tak diketahui."
End Select
End Function
'Fungsi untuk mendapatkan informasi tentang packer
Function get_Packer(MyPath As String) As String
Dim sampel(100) As String
Dim signa(100) As String
Dim PackerName(100) As String
Dim i As Integer
i = 1
Do 'Jika sampel i sebelumnya adalah Selesai:Selesai maka
berhenti looping
sampel(i) =
ambil_sampel_packer(i) 'sampel i adalah hasil dari fungsi ambil sampel packer
signa(i) =
Mid(sampel(i), 1, InStr(1, sampel(i), ":") - 1)
PackerName(i) =
Mid(sampel(i), InStr(1, sampel(i), ":") + 1, Len(sampel(i)) -
InStr(1, sampel(i), ":") + 1)
hasil = stringcheck(MyPath,
hex2ascii(signa(i)), PackerName(i))
If hasil <>
"" And hasil <> "Selesai" Then 'Jika hasil tidak =
"" atau tidak = "Selesai"
get_Packer =
hasil 'Kembalikan Hasilnya
Exit Do
'Berhenti Looping
End If
get_Packer =
"Tiada"
i = i + 1
Loop Until sampel(i - 1) = "Selesai:Selesai" '
akhir dari looping
End Function
Function get_Compiler(MyPath As String) As String
Dim sampel(100) As String
Dim signa(100) As String
Dim CompilerName(100) As String
Dim i As Integer
i = 1
Do 'Jika sampel i sebelumnya adalah Selesai:Selesai maka
berhenti looping
sampel(i) =
ambil_sampel_compiler(i) 'sampel i adalah hasil dari fungsi ambil sampel packer
signa(i) =
Mid(sampel(i), 1, InStr(1, sampel(i), ":") - 1)
CompilerName(i) =
Mid(sampel(i), InStr(1, sampel(i), ":") + 1, Len(sampel(i)) -
InStr(1, sampel(i), ":") + 1)
hasil =
stringcheck(MyPath, hex2ascii(signa(i)), CompilerName(i))
If hasil <>
"" And hasil <> "Selesai" Then 'Jika hasil tidak =
"" atau tidak = "Selesai"
get_Compiler = hasil 'Kembalikan Hasilnya
Exit Do
'Berhenti Looping
End If
get_Compiler =
"Tak Diketahui"
i = i + 1
Loop Until sampel(i - 1) = "Selesai:Selesai" '
akhir dari looping
End Function
'Fungsi untuk membuka file database
Function cek_with_navi(ceksum As String) As String
Dim sampel As String
Dim signa As String
Dim virname As String
cek_with_navi = ""
Open App.path & "\NAVi.dll" For Input As #1
'namafile database adalah NAVi.dll
Do 'perintah
looping
Input #1, sampel
'masukan dari file adalah sampel
signa =
Mid(sampel, 1, InStr(1, sampel, ":") - 1) 'mengambil signature dari
sampel yang masuk
virname =
Mid(sampel, InStr(1, sampel, ":") + 1, Len(sampel) - (Len(signa) +
1)) 'mengambil namavirus dari sampel yang masuk
If signa = ceksum
Then 'jika signature dan ceksum sama
cek_with_navi
= virname 'ada virus dan berikan namavirus
Exit Do 'lalu
keluar dari loping
End If
Loop Until sampel
= "Selesai:Selesai" 'Jika sampel selesai maka berhenti looping
Close #1
If TempDb = ceksum Then
cek_with_navi
= "Permintaan User"
End If
'///////////////////////////////////////////////////////////////
'end of virus update
End Function
StringSignature(module3.bas)
'Fungsi yang menyimpan sampel string virus
Function ambilsampel(i As Integer)
Dim sampel(1000)
As String 'sampel sebagai array
sampel(1) =
"CA68A137541AED769C3F:w32.service.exe:17920"
sampel(2) =
"60AA606F4DD82135B73D:w32.Burmecia:100"
sampel(3) =
"2C245947F84623478D28:w32.KSpoold:285184"
sampel(4) =
"15e01040008d4dc88d55d851526a02:w32.TunggulKawung.C:175104"
sampel(5) =
"78b5549268a94cfe224200fa6fa17aef:w32.Service.exe:17920"
sampel(6) =
"e8b3b6fbff8945f033d2:w32.spooler:448000"
sampel(7) =
"Selesai:Selesai:Selesai" 'Akhir dari array
ambilsampel =
sampel(i) 'Hasil yang dikeluarkan untuk dicek kembali
End Function 'Akhir dari fungsi
Function stringcheck(MyPath As String, hexstring As String,
namavirus As String)
'Fungsi untuk mencocokkan string sampel dan string pada file
stringcheck =
""
Dim filedata As
String
Dim a As Integer
Open MyPath For
Binary As #1
filedata =
Space$(LOF(1))
Get #1, ,
filedata
If InStr(1,
filedata, hexstring) > 0 Then
stringcheck = namavirus
Else
stringcheck = ""
End If
'akhir dari fungsi
Close #1
End Function
Function hex2ascii(ByVal hextext As String) As String
'Fungsi untuk menterjemahkan dari hexadecimal ke dalam
string biasa
On Error Resume
Next
Dim Y As Integer
Dim num As String
Dim Value As
String
For Y = 1 To
Len(hextext)
num =
Mid(hextext, Y, 2)
Value = Value
& Chr(Val("&h" & num))
Y = Y + 1
Next Y
hex2ascii = Value
End Function
'Fungsi yang berisi sampel dari packernya.
Function ambil_sampel_packer(i As Integer)
Dim sampel(100) As
String
sampel(1) =
"0000004d4557:MEW"
sampel(2) =
"555058210c09:UPX"
sampel(3) =
"c02e61737061636b00:Aspack"
sampel(4) =
"89085045436f6d70616374:PECompact"
sampel(5) =
"Selesai:Selesai"
ambil_sampel_packer = sampel(i) 'hasil yang diberikan
End Function
'Akhir dari Fungsi
'Fungsi yang berisi sampel dari compiler
Function ambil_sampel_compiler(i As Integer)
Dim sampel(100) As
String
sampel(1) =
"0000004d535642564d36302e444c4c000000:MS Visual Basic 6.0"
sampel(2) =
"5700650064000300540068007500030046007200690003005300610074:Borland Delphi
7"
sampel(3) =
"000000004d6963726f736f66742056697375616c20432b2b2052756e74696d65:MS
Visual C++"
sampel(4) =
"Selesai:Selesai"
ambil_sampel_compiler = sampel(i) 'hasil yang diberikan
End Function 'Ahir dari fungsi
'Akhir dari fungsi
mod_version(mod_version.bas)
'Option Explicit
Private Const MAX_PATH As Integer = 1000
Private Declare Function GetFileVersionInfo Lib
"Version.dll" Alias "GetFileVersionInfoA" (ByVal
lptstrFilename As String, ByVal dwhandle As Long, ByVal dwlen As Long, lpData
As Any) As Long
Private Declare Function GetFileVersionInfoSize Lib
"Version.dll" Alias "GetFileVersionInfoSizeA" (ByVal
lptstrFilename As String, lpdwHandle As Long) As Long
Private Declare Function VerQueryValue Lib
"Version.dll" Alias "VerQueryValueA" (pBlock As Any, ByVal
lpSubBlock As String, lplpBuffer As Any, puLen As Long) As Long
Private Declare Sub MoveMemory Lib "kernel32"
Alias "RtlMoveMemory" (dest As Any, ByVal Source As Long, ByVal
Length As Long)
Private Declare Function lstrcpy Lib "kernel32"
Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long)
As Long
Dim productname As String
Public Function GetVerHeader(fpn As String) As String
Dim lngBufferlen&, lngDummy&, lngRc&,
lngVerPointer&, lngHexNumber&, i%
Dim bytBuffer() As Byte, bytBuff(255) As Byte, strBuffer$,
strLangCharset$, strVersionInfo As String, strTemp$
lngBufferlen =
GetFileVersionInfoSize(fpn$, 0)
If lngBufferlen
> 0 Then
ReDim
bytBuffer(lngBufferlen)
lngRc =
GetFileVersionInfo(fpn$, 0&, lngBufferlen, bytBuffer(0))
If lngRc
<> 0 Then
lngRc =
VerQueryValue(bytBuffer(0), "\VarFileInfo\Translation",
lngVerPointer, lngBufferlen)
If lngRc
<> 0 Then
MoveMemory
bytBuff(0), lngVerPointer, lngBufferlen
lngHexNumber = bytBuff(2) + bytBuff(3) * &H100 + bytBuff(0) *
&H10000 + bytBuff(1) * &H1000000
strLangCharset = Hex(lngHexNumber)
Do While
Len(strLangCharset) < 8
strLangCharset = "0" & strLangCharset
Loop
strVersionInfo = "ProductName"
strBuffer = String$(255, 0)
strTemp
= "\StringFileInfo\" & strLangCharset & "\" &
strVersionInfo
lngRc =
VerQueryValue(bytBuffer(0), strTemp, lngVerPointer, lngBufferlen)
If
lngRc <> 0 Then
lstrcpy strBuffer, lngVerPointer
strBuffer = Mid$(strBuffer, 1, InStr(strBuffer, Chr(0)) - 1)
strVersionInfo = strBuffer
Else
strVersionInfo = "N/A"
End If
End If
End If
End If
GetVerHeader =
strVersionInfo
End Function
Class module
cCommonDialog(cCommonDialog.cls)
Option Explicit
Public Enum EErrorCommonDialog
eeBaseCommonDialog
= 13450 ' CommonDialog
End Enum
Private Declare Function lstrlen Lib "kernel32"
Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GlobalAlloc Lib
"kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalCompact Lib
"kernel32" (ByVal dwMinFree As Long) As Long
Private Declare Function GlobalFree Lib "kernel32"
(ByVal hMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32"
(ByVal hMem As Long) As Long
Private Declare Function GlobalReAlloc Lib
"kernel32" (ByVal hMem As Long, ByVal dwBytes As Long, ByVal wFlags
As Long) As Long
Private Declare Function GlobalSize Lib "kernel32"
(ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib
"kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32"
Alias "RtlMoveMemory" ( _
lpvDest As Any,
lpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryStr Lib "kernel32"
Alias "RtlMoveMemory" ( _
lpvDest As Any,
ByVal lpvSource As String, ByVal cbCopy As Long)
Private Const MAX_PATH = 260
Private Const MAX_FILE = 260
Private Type OPENFILENAME
lStructSize As
Long ' Filled with UDT size
hWndOwner As
Long ' Tied to Owner
hInstance As
Long ' Ignored (used only by
templates)
lpstrFilter As
String ' Tied to Filter
lpstrCustomFilter
As String ' Ignored (exercise for
reader)
nMaxCustFilter As
Long ' Ignored (exercise for
reader)
nFilterIndex As
Long ' Tied to FilterIndex
lpstrFile As
String ' Tied to FileName
nMaxFile As
Long ' Handled internally
lpstrFileTitle As
String ' Tied to FileTitle
nMaxFileTitle As
Long ' Handled internally
lpstrInitialDir As
String ' Tied to InitDir
lpstrTitle As
String ' Tied to DlgTitle
flags As Long ' Tied to Flags
nFileOffset As
Integer ' Ignored (exercise for
reader)
nFileExtension As
Integer ' Ignored (exercise for
reader)
lpstrDefExt As
String ' Tied to DefaultExt
lCustData As
Long ' Ignored (needed for
hooks)
lpfnHook As
Long ' Ignored (good luck
with hooks)
lpTemplateName As
Long ' Ignored (good luck with
templates)
End Type
Private Declare Function GetOpenFileName Lib "COMDLG32"
_
Alias
"GetOpenFileNameA" (file As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib
"COMDLG32" _
Alias
"GetSaveFileNameA" (file As OPENFILENAME) As Long
Private Declare Function GetFileTitle Lib
"COMDLG32" _
Alias
"GetFileTitleA" (ByVal szFile As String, _
ByVal szTitle As
String, ByVal cbBuf As Long) As Long
Public Enum EOpenFile
OFN_READONLY =
&H1
OFN_OVERWRITEPROMPT = &H2
OFN_HIDEREADONLY =
&H4
OFN_NOCHANGEDIR =
&H8
OFN_SHOWHELP =
&H10
OFN_ENABLEHOOK =
&H20
OFN_ENABLETEMPLATE
= &H40
OFN_ENABLETEMPLATEHANDLE = &H80
OFN_NOVALIDATE =
&H100
OFN_ALLOWMULTISELECT = &H200
OFN_EXTENSIONDIFFERENT = &H400
OFN_PATHMUSTEXIST
= &H800
OFN_FILEMUSTEXIST
= &H1000
OFN_CREATEPROMPT = &H2000
OFN_SHAREAWARE =
&H4000
OFN_NOREADONLYRETURN = &H8000&
OFN_NOTESTFILECREATE = &H10000
OFN_NONETWORKBUTTON = &H20000
OFN_NOLONGNAMES =
&H40000
OFN_EXPLORER =
&H80000
OFN_NODEREFERENCELINKS = &H100000
OFN_LONGNAMES =
&H200000
End Enum
Private Type TCHOOSECOLOR
lStructSize As
Long
hWndOwner As Long
hInstance As Long
rgbResult As Long
lpCustColors As
Long
flags As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As
Long
End Type
Private Declare Function ChooseColor Lib
"COMDLG32.DLL" _
Alias
"ChooseColorA" (Color As TCHOOSECOLOR) As Long
Public Enum EChooseColor
CC_RGBInit =
&H1
CC_FullOpen =
&H2
CC_PreventFullOpen
= &H4
CC_ColorShowHelp =
&H8
' Win95 only
CC_SolidColor =
&H80
CC_AnyColor =
&H100
' End Win95 only
CC_ENABLEHOOK =
&H10
CC_ENABLETEMPLATE
= &H20
CC_EnableTemplateHandle = &H40
End Enum
Private Declare Function GetSysColor Lib "USER32"
(ByVal nIndex As Long) As Long
Private Type TCHOOSEFONT
lStructSize As
Long ' Filled with UDT size
hWndOwner As
Long ' Caller's window handle
hdc As Long ' Printer DC/IC or NULL
lpLogFont As
Long ' Pointer to LOGFONT
iPointSize As
Long ' 10 * size in points of
font
flags As Long ' Type flags
rgbColors As
Long ' Returned text color
lCustData As
Long ' Data passed to hook
function
lpfnHook As
Long ' Pointer to hook
function
lpTemplateName As
Long ' Custom template name
hInstance As
Long ' Instance handle for
template
lpszStyle As
String ' Return style field
nFontType As
Integer ' Font type bits
iAlign As
Integer ' Filler
nSizeMin As
Long ' Minimum point size
allowed
nSizeMax As
Long ' Maximum point size
allowed
End Type
Private Declare Function ChooseFont Lib "COMDLG32"
_
Alias
"ChooseFontA" (chfont As TCHOOSEFONT) As Long
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As
Long
lfOrientation As
Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As
Byte
lfCharSet As Byte
lfOutPrecision As
Byte
lfClipPrecision As
Byte
lfQuality As Byte
lfPitchAndFamily
As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Public Enum EChooseFont
CF_ScreenFonts =
&H1
CF_PrinterFonts =
&H2
CF_BOTH = &H3
CF_FontShowHelp =
&H4
CF_UseStyle =
&H80
CF_EFFECTS =
&H100
CF_AnsiOnly =
&H400
CF_NoVectorFonts =
&H800
CF_NoOemFonts =
CF_NoVectorFonts
CF_NoSimulations =
&H1000
CF_LimitSize =
&H2000
CF_FixedPitchOnly
= &H4000
CF_WYSIWYG =
&H8000& ' Must also have
ScreenFonts And PrinterFonts
CF_ForceFontExist
= &H10000
CF_ScalableOnly =
&H20000
CF_TTOnly =
&H40000
CF_NoFaceSel =
&H80000
CF_NoStyleSel =
&H100000
CF_NoSizeSel =
&H200000
' Win95 only
CF_SelectScript =
&H400000
CF_NoScriptSel =
&H800000
CF_NoVertFonts =
&H1000000
CF_InitToLogFontStruct = &H40
CF_Apply =
&H200
CF_EnableHook =
&H8
CF_EnableTemplate
= &H10
CF_EnableTemplateHandle = &H20
CF_FontNotSupported = &H238
End Enum
' These are extra nFontType bits that are added to what is
returned to the
' EnumFonts callback routine
Public Enum EFontType
Simulated_FontType
= &H8000&
Printer_FontType =
&H4000
Screen_FontType =
&H2000
Bold_FontType =
&H100
Italic_FontType =
&H200
Regular_FontType =
&H400
End Enum
Private Type TPRINTDLG
lStructSize As
Long
hWndOwner As Long
hDevMode As Long
hDevNames As Long
hdc As Long
flags As Long
nFromPage As
Integer
nToPage As Integer
nMinPage As
Integer
nMaxPage As
Integer
nCopies As Integer
hInstance As Long
lCustData As Long
lpfnPrintHook As
Long
lpfnSetupHook As
Long
lpPrintTemplateName As Long
lpSetupTemplateName As Long
hPrintTemplate As
Long
hSetupTemplate As
Long
End Type
' DEVMODE collation
selections
Private Const DMCOLLATE_FALSE = 0
Private Const DMCOLLATE_TRUE = 1
Private Declare Function PrintDlg Lib
"COMDLG32.DLL" _
Alias
"PrintDlgA" (prtdlg As TPRINTDLG) As Integer
Public Enum EPrintDialog
PD_ALLPAGES =
&H0
PD_SELECTION =
&H1
PD_PAGENUMS =
&H2
PD_NOSELECTION =
&H4
PD_NOPAGENUMS =
&H8
PD_COLLATE =
&H10
PD_PRINTTOFILE =
&H20
PD_PRINTSETUP =
&H40
PD_NOWARNING =
&H80
PD_RETURNDC =
&H100
PD_RETURNIC =
&H200
PD_RETURNDEFAULT =
&H400
PD_SHOWHELP =
&H800
PD_ENABLEPRINTHOOK
= &H1000
PD_ENABLESETUPHOOK
= &H2000
PD_ENABLEPRINTTEMPLATE = &H4000
PD_ENABLESETUPTEMPLATE = &H8000&
PD_ENABLEPRINTTEMPLATEHANDLE = &H10000
PD_ENABLESETUPTEMPLATEHANDLE = &H20000
PD_USEDEVMODECOPIES = &H40000
PD_USEDEVMODECOPIESANDCOLLATE = &H40000
PD_DISABLEPRINTTOFILE
= &H80000
PD_HIDEPRINTTOFILE
= &H100000
PD_NONETWORKBUTTON
= &H200000
End Enum
Private Type DEVNAMES
wDriverOffset As
Integer
wDeviceOffset As
Integer
wOutputOffset As
Integer
wDefault As
Integer
End Type
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Type DevMode
dmDeviceName As
String * CCHDEVICENAME
dmSpecVersion As
Integer
dmDriverVersion As
Integer
dmSize As Integer
dmDriverExtra As
Integer
dmFields As Long
dmOrientation As
Integer
dmPaperSize As
Integer
dmPaperLength As
Integer
dmPaperWidth As
Integer
dmScale As Integer
dmCopies As
Integer
dmDefaultSource As
Integer
dmPrintQuality As
Integer
dmColor As Integer
dmDuplex As
Integer
dmYResolution As
Integer
dmTTOption As
Integer
dmCollate As
Integer
dmFormName As
String * CCHFORMNAME
dmUnusedPadding As
Integer
dmBitsPerPel As
Integer
dmPelsWidth As
Long
dmPelsHeight As
Long
dmDisplayFlags As
Long
dmDisplayFrequency
As Long
End Type
' New Win95 Page Setup dialogs are up to you
Private Type POINTL
x As Long
y As Long
End Type
Private Type RECT
Left As Long
TOp As Long
Right As Long
Bottom As Long
End Type
Private Type TPAGESETUPDLG
lStructSize As Long
hWndOwner As Long
hDevMode As Long
hDevNames As Long
flags As Long
ptPaperSize As POINTL
rtMinMargin As RECT
rtMargin As RECT
hInstance As Long
lCustData As Long
lpfnPageSetupHook As
Long
lpfnPagePaintHook As
Long
lpPageSetupTemplateName As Long
hPageSetupTemplate As
Long
End Type
' EPaperSize constants same as vbPRPS constants
Public Enum EPaperSize
epsLetter = 1 ' Letter, 8 1/2 x 11 in.
epsLetterSmall ' Letter
Small, 8 1/2 x 11 in.
epsTabloid ' Tabloid, 11 x 17 in.
epsLedger ' Ledger, 17 x 11 in.
epsLegal ' Legal, 8 1/2 x 14 in.
epsStatement ' Statement, 5 1/2 x 8 1/2 in.
epsExecutive ' Executive, 7 1/2 x 10 1/2 in.
epsA3 ' A3, 297 x 420 mm
epsA4 ' A4, 210 x 297 mm
epsA4Small ' A4 Small, 210 x 297 mm
epsA5 ' A5, 148 x 210 mm
epsB4 ' B4, 250 x 354 mm
epsB5 ' B5, 182 x 257 mm
epsFolio ' Folio, 8 1/2 x 13 in.
epsQuarto ' Quarto, 215 x 275 mm
eps10x14 ' 10 x 14 in.
eps11x17 ' 11 x 17 in.
epsNote ' Note, 8 1/2 x 11 in.
epsEnv9 ' Envelope #9, 3 7/8 x 8 7/8
in.
epsEnv10 ' Envelope #10, 4 1/8 x 9 1/2
in.
epsEnv11 ' Envelope #11, 4 1/2 x 10 3/8
in.
epsEnv12 ' Envelope #12, 4 1/2 x 11 in.
epsEnv14 ' Envelope #14, 5 x 11 1/2 in.
epsCSheet ' C size sheet
epsDSheet ' D size sheet
epsESheet ' E size sheet
epsEnvDL ' Envelope DL, 110 x 220 mm
epsEnvC3 ' Envelope C3, 324 x 458 mm
epsEnvC4 ' Envelope C4, 229 x 324 mm
epsEnvC5 ' Envelope C5, 162 x 229 mm
epsEnvC6 ' Envelope C6, 114 x 162 mm
epsEnvC65 ' Envelope C65, 114 x 229 mm
epsEnvB4 ' Envelope B4, 250 x 353 mm
epsEnvB5 ' Envelope B5, 176 x 250 mm
epsEnvB6 ' Envelope B6, 176 x 125 mm
epsEnvItaly ' Envelope, 110 x 230 mm
epsenvmonarch ' Envelope Monarch, 3 7/8 x 7 1/2 in.
epsEnvPersonal ' Envelope,
3 5/8 x 6 1/2 in.
epsFanfoldUS ' U.S. Standard Fanfold, 14 7/8 x 11
in.
epsFanfoldStdGerman ' German
Standard Fanfold, 8 1/2 x 12 in.
epsFanfoldLglGerman ' German
Legal Fanfold, 8 1/2 x 13 in.
epsUser = 256 ' User-defined
End Enum
' EPrintQuality constants same as vbPRPQ constants
Public Enum EPrintQuality
epqDraft = -1
epqLow = -2
epqMedium = -3
epqHigh = -4
End Enum
Public Enum EOrientation
eoPortrait = 1
eoLandscape
End Enum
Private Declare Function PageSetupDlg Lib
"COMDLG32" _
Alias
"PageSetupDlgA" (lppage As TPAGESETUPDLG) As Boolean
Public Enum EPageSetup
PSD_Defaultminmargins = &H0 ' Default (printer's)
PSD_InWinIniIntlMeasure = &H0
PSD_MINMARGINS =
&H1
PSD_MARGINS =
&H2
PSD_INTHOUSANDTHSOFINCHES = &H4
PSD_INHUNDREDTHSOFMILLIMETERS = &H8
PSD_DISABLEMARGINS
= &H10
PSD_DISABLEPRINTER
= &H20
PSD_NoWarning =
&H80
PSD_DISABLEORIENTATION = &H100
PSD_ReturnDefault
= &H400
PSD_DISABLEPAPER =
&H200
PSD_ShowHelp =
&H800
PSD_EnablePageSetupHook = &H2000
PSD_EnablePageSetupTemplate = &H8000&
PSD_EnablePageSetupTemplateHandle = &H20000
PSD_EnablePagePaintHook = &H40000
PSD_DisablePagePainting = &H80000
End Enum
Public Enum EPageSetupUnits
epsuInches
epsuMillimeters
End Enum
' Common dialog errors
Private Declare Function CommDlgExtendedError Lib
"COMDLG32" () As Long
Public Enum EDialogError
CDERR_DIALOGFAILURE = &HFFFF
CDERR_GENERALCODES
= &H0
CDERR_STRUCTSIZE =
&H1
CDERR_INITIALIZATION = &H2
CDERR_NOTEMPLATE =
&H3
CDERR_NOHINSTANCE
= &H4
CDERR_LOADSTRFAILURE = &H5
CDERR_FINDRESFAILURE = &H6
CDERR_LOADRESFAILURE = &H7
CDERR_LOCKRESFAILURE = &H8
CDERR_MEMALLOCFAILURE = &H9
CDERR_MEMLOCKFAILURE = &HA
CDERR_NOHOOK =
&HB
CDERR_REGISTERMSGFAIL = &HC
PDERR_PRINTERCODES
= &H1000
PDERR_SETUPFAILURE
= &H1001
PDERR_PARSEFAILURE
= &H1002
PDERR_RETDEFFAILURE = &H1003
PDERR_LOADDRVFAILURE = &H1004
PDERR_GETDEVMODEFAIL = &H1005
PDERR_INITFAILURE
= &H1006
PDERR_NODEVICES =
&H1007
PDERR_NODEFAULTPRN
= &H1008
PDERR_DNDMMISMATCH
= &H1009
PDERR_CREATEICFAILURE = &H100A
PDERR_PRINTERNOTFOUND = &H100B
PDERR_DEFAULTDIFFERENT = &H100C
CFERR_CHOOSEFONTCODES = &H2000
CFERR_NOFONTS =
&H2001
CFERR_MAXLESSTHANMIN = &H2002
FNERR_FILENAMECODES = &H3000
FNERR_SUBCLASSFAILURE
= &H3001
FNERR_INVALIDFILENAME = &H3002
FNERR_BUFFERTOOSMALL = &H3003
CCERR_CHOOSECOLORCODES = &H5000
End Enum
' Array of custom colors lasts for life of app
Private alCustom(0 To 15) As Long, fNotFirst As Boolean
Public Enum EPrintRange
eprAll
eprPageNumbers
eprSelection
End Enum
Private m_lApiReturn As Long
Private m_lExtendedError As Long
Private m_dvmode As DevMode
Public Property Get APIReturn() As Long
'return object's
APIReturn property
APIReturn =
m_lApiReturn
End Property
Public Property Get ExtendedError() As Long
'return object's
ExtendedError property
ExtendedError =
m_lExtendedError
End Property
#If fComponent Then
Private Sub Class_Initialize()
InitColors
End Sub
#End If
Function VBGetOpenFileName(Filename As String, _
Optional FileTitle As String, _
Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, _
Optional Filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional flags As Long = 0) As Boolean
Dim opfile As
OPENFILENAME, s As String, afFlags As Long
m_lApiReturn = 0
m_lExtendedError =
0
With opfile
.lStructSize =
Len(opfile)
' Add in specific
flags and strip out non-VB flags
.flags =
(-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(-HideReadOnly * OFN_HIDEREADONLY) Or _
(flags
And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take
handle of owning window
If Owner <>
-1 Then .hWndOwner = Owner
' InitDir can take
initial directory string
.lpstrInitialDir =
InitDir
' DefaultExt can
take default extension
.lpstrDefExt =
DefaultExt
' DlgTitle can
take dialog box title
.lpstrTitle =
DlgTitle
' To make
Windows-style filter, replace | and : with nulls
Dim ch As String,
i As Integer
For i = 1 To
Len(Filter)
ch =
Mid$(Filter, i, 1)
If ch =
"|" Or ch = ":" Then
s = s
& vbNullChar
Else
s = s
& ch
End If
Next
' Put double null
at end
s = s &
vbNullChar & vbNullChar
.lpstrFilter = s
.nFilterIndex =
FilterIndex
' Pad file and
file title buffers to maximum path
s = Filename &
String$(MAX_PATH - Len(Filename), 0)
.lpstrFile = s
.nMaxFile =
MAX_PATH
s = FileTitle
& String$(MAX_FILE - Len(FileTitle), 0)
.lpstrFileTitle =
s
.nMaxFileTitle =
MAX_FILE
' All other fields
set to zero
m_lApiReturn =
GetOpenFileName(opfile)
Select Case
m_lApiReturn
Case 1
' Success
VBGetOpenFileName = True
Filename =
StrZToStr(.lpstrFile)
FileTitle =
StrZToStr(.lpstrFileTitle)
flags = .flags
' Return the
filter index
FilterIndex =
.nFilterIndex
' Look up the
filter the user selected and return that
Filter =
FilterLookup(.lpstrFilter, FilterIndex)
If (.flags And
OFN_READONLY) Then ReadOnly = True
Case 0
' Cancelled
VBGetOpenFileName = False
Filename =
""
FileTitle =
""
flags = 0
FilterIndex =
-1
Filter =
""
Case Else
' Extended
error
m_lExtendedError = CommDlgExtendedError()
VBGetOpenFileName = False
Filename =
""
FileTitle =
""
flags = 0
FilterIndex =
-1
Filter =
""
End Select
End With
End Function
Private Function StrZToStr(s As String) As String
StrZToStr =
Left$(s, lstrlen(s))
End Function
Function VBGetSaveFileName(Filename As String, _
Optional FileTitle As String, _
Optional OverWritePrompt As Boolean = True, _
Optional Filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional flags As Long) As Boolean
Dim opfile As
OPENFILENAME, s As String
m_lApiReturn = 0
m_lExtendedError =
0
With opfile
.lStructSize =
Len(opfile)
' Add in specific
flags and strip out non-VB flags
.flags =
(-OverWritePrompt * OFN_OVERWRITEPROMPT) Or _
OFN_HIDEREADONLY Or _
(flags
And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take
handle of owning window
If Owner <>
-1 Then .hWndOwner = Owner
' InitDir can take
initial directory string
.lpstrInitialDir =
InitDir
' DefaultExt can
take default extension
.lpstrDefExt =
DefaultExt
' DlgTitle can
take dialog box title
.lpstrTitle =
DlgTitle
' Make new filter
with bars (|) replacing nulls and double null at end
Dim ch As String,
i As Integer
For i = 1 To Len(Filter)
ch =
Mid$(Filter, i, 1)
If ch =
"|" Or ch = ":" Then
s = s
& vbNullChar
Else
s = s
& ch
End If
Next
' Put double null
at end
s = s &
vbNullChar & vbNullChar
.lpstrFilter = s
.nFilterIndex =
FilterIndex
' Pad file and
file title buffers to maximum path
s = Filename &
String$(MAX_PATH - Len(Filename), 0)
.lpstrFile = s
.nMaxFile =
MAX_PATH
s = FileTitle
& String$(MAX_FILE - Len(FileTitle), 0)
.lpstrFileTitle =
s
.nMaxFileTitle =
MAX_FILE
' All other fields
zero
m_lApiReturn =
GetSaveFileName(opfile)
Select Case
m_lApiReturn
Case 1
VBGetSaveFileName = True
Filename =
StrZToStr(.lpstrFile)
FileTitle =
StrZToStr(.lpstrFileTitle)
flags = .flags
' Return the
filter index
FilterIndex =
.nFilterIndex
' Look up the
filter the user selected and return that
Filter =
FilterLookup(.lpstrFilter, FilterIndex)
Case 0
' Cancelled:
VBGetSaveFileName = False
Filename =
""
FileTitle =
""
flags = 0
FilterIndex =
0
Filter =
""
Case Else
' Extended
error:
VBGetSaveFileName = False
m_lExtendedError = CommDlgExtendedError()
Filename =
""
FileTitle =
""
flags = 0
FilterIndex =
0
Filter =
""
End Select
End With
End Function
Private Function FilterLookup(ByVal sFilters As String,
ByVal iCur As Long) As String
Dim iStart As
Long, iEnd As Long, s As String
iStart = 1
If sFilters =
"" Then Exit Function
Do
' Cut out both
parts marked by null character
iEnd =
InStr(iStart, sFilters, vbNullChar)
If iEnd = 0
Then Exit Function
iEnd =
InStr(iEnd + 1, sFilters, vbNullChar)
If iEnd Then
s =
Mid$(sFilters, iStart, iEnd - iStart)
Else
s =
Mid$(sFilters, iStart)
End If
iStart = iEnd
+ 1
If iCur = 1
Then
FilterLookup = s
Exit
Function
End If
iCur = iCur -
1
Loop While iCur
End Function
Function VBGetFileTitle(sFile As String) As String
Dim sFileTitle As
String, cFileTitle As Integer
cFileTitle = MAX_PATH
sFileTitle =
String$(MAX_PATH, 0)
cFileTitle =
GetFileTitle(sFile, sFileTitle, MAX_PATH)
If cFileTitle Then
VBGetFileTitle
= ""
Else
VBGetFileTitle
= Left$(sFileTitle, InStr(sFileTitle, vbNullChar) - 1)
End If
End Function
' ChooseColor wrapper
Function VBChooseColor(Color As Long, _
Optional AnyColor As Boolean = True, _
Optional FullOpen As Boolean = False, _
Optional DisableFullOpen As Boolean = False, _
Optional Owner As Long = -1, _
Optional flags As Long) As Boolean
Dim chclr As
TCHOOSECOLOR
chclr.lStructSize
= Len(chclr)
' Color must get
reference variable to receive result
' Flags can get
reference variable or constant with bit flags
' Owner can take
handle of owning window
If Owner <>
-1 Then chclr.hWndOwner = Owner
' Assign color
(default uninitialized value of zero is good default)
chclr.rgbResult =
Color
' Mask out
unwanted bits
Dim afMask As Long
afMask = CLng(Not
(CC_ENABLEHOOK Or _
CC_ENABLETEMPLATE))
' Pass in flags
chclr.flags =
afMask And (CC_RGBInit Or _
IIf(AnyColor, CC_AnyColor, CC_SolidColor) Or _
(-FullOpen * CC_FullOpen) Or _
(-DisableFullOpen * CC_PreventFullOpen))
' If first time,
initialize to white
If fNotFirst =
False Then InitColors
chclr.lpCustColors
= VarPtr(alCustom(0))
' All other fields
zero
m_lApiReturn =
ChooseColor(chclr)
Select Case
m_lApiReturn
Case 1
' Success
VBChooseColor
= True
Color =
chclr.rgbResult
Case 0
' Cancelled
VBChooseColor
= False
Color = -1
Case Else
' Extended
error
m_lExtendedError = CommDlgExtendedError()
VBChooseColor
= False
Color = -1
End Select
End Function
Private Sub InitColors()
Dim i As Integer
' Initialize with
first 16 system interface colors
For i = 0 To 15
alCustom(i) =
GetSysColor(i)
Next
fNotFirst = True
End Sub
' Property to read or modify custom colors (use to save
colors in registry)
Public Property Get CustomColor(i As Integer) As Long
' If first time,
initialize to white
If fNotFirst =
False Then InitColors
If i >= 0 And i
<= 15 Then
CustomColor =
alCustom(i)
Else
CustomColor =
-1
End If
End Property
Public Property Let CustomColor(i As Integer, iValue As
Long)
' If first time,
initialize to system colors
If fNotFirst =
False Then InitColors
If i >= 0 And i
<= 15 Then
alCustom(i) =
iValue
End If
End Property
' ChooseFont wrapper
Function VBChooseFont(CurFont As Font, _
Optional PrinterDC As Long = -1, _
Optional Owner As Long = -1, _
Optional Color As Long = vbBlack, _
Optional MinSize As Long = 0, _
Optional MaxSize As Long = 0, _
Optional flags As Long = 0) As Boolean
m_lApiReturn = 0
m_lExtendedError =
0
' Unwanted Flags
bits
Const
CF_FontNotSupported = CF_Apply Or CF_EnableHook Or CF_EnableTemplate
' Flags can get
reference variable or constant with bit flags
' PrinterDC can
take printer DC
If PrinterDC = -1
Then
PrinterDC = 0
If flags And
CF_PrinterFonts Then PrinterDC = Printer.hdc
Else
flags = flags
Or CF_PrinterFonts
End If
' Must have some
fonts
If (flags And
CF_PrinterFonts) = 0 Then flags = flags Or CF_ScreenFonts
' Color can take
initial color, receive chosen color
If Color <>
vbBlack Then flags = flags Or CF_EFFECTS
' MinSize can be
minimum size accepted
If MinSize Then
flags = flags Or CF_LimitSize
' MaxSize can be
maximum size accepted
If MaxSize Then
flags = flags Or CF_LimitSize
' Put in required
internal flags and remove unsupported
flags = (flags Or
CF_InitToLogFontStruct) And Not CF_FontNotSupported
' Initialize
LOGFONT variable
Dim fnt As LOGFONT
Const
PointsPerTwip = 1440 / 72
fnt.lfHeight =
-(CurFont.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
fnt.lfWeight =
CurFont.Weight
fnt.lfItalic =
CurFont.Italic
fnt.lfUnderline =
CurFont.Underline
fnt.lfStrikeOut =
CurFont.Strikethrough
' Other fields
zero
StrToBytes
fnt.lfFaceName, CurFont.Name
' Initialize
TCHOOSEFONT variable
Dim cf As
TCHOOSEFONT
cf.lStructSize =
Len(cf)
If Owner <>
-1 Then cf.hWndOwner = Owner
cf.hdc = PrinterDC
cf.lpLogFont =
VarPtr(fnt)
cf.iPointSize =
CurFont.Size * 10
cf.flags = flags
cf.rgbColors =
Color
cf.nSizeMin =
MinSize
cf.nSizeMax = MaxSize
' All other fields
zero
m_lApiReturn =
ChooseFont(cf)
Select Case
m_lApiReturn
Case 1
' Success
VBChooseFont =
True
flags =
cf.flags
Color =
cf.rgbColors
CurFont.Bold =
cf.nFontType And Bold_FontType
'CurFont.Italic = cf.nFontType And Italic_FontType
CurFont.Italic
= fnt.lfItalic
CurFont.Strikethrough = fnt.lfStrikeOut
CurFont.Underline = fnt.lfUnderline
CurFont.Weight
= fnt.lfWeight
CurFont.Size =
cf.iPointSize / 10
CurFont.Name =
BytesToStr(fnt.lfFaceName)
Case 0
' Cancelled
VBChooseFont =
False
Case Else
' Extended
error
m_lExtendedError = CommDlgExtendedError()
VBChooseFont =
False
End Select
End Function
' PrintDlg wrapper
Function VBPrintDlg(hdc As Long, _
Optional PrintRange As EPrintRange = eprAll, _
Optional DisablePageNumbers As Boolean, _
Optional FromPage As Long = 1, _
Optional ToPage As Long = &HFFFF, _
Optional DisableSelection As Boolean, _
Optional Copies As Integer, _
Optional ShowPrintToFile As Boolean, _
Optional DisablePrintToFile As Boolean = True, _
Optional PrintToFile As Boolean, _
Optional Collate As Boolean, _
Optional
PreventWarning As Boolean, _
Optional Owner As Long, _
Optional Printer As Object, _
Optional flags As Long) As Boolean
Dim afFlags As
Long, afMask As Long
m_lApiReturn = 0
m_lExtendedError =
0
' Set PRINTDLG
flags
afFlags =
(-DisablePageNumbers * PD_NOPAGENUMS) Or _
(-DisablePrintToFile * PD_DISABLEPRINTTOFILE) Or _
(-DisableSelection * PD_NOSELECTION) Or _
(-PrintToFile * PD_PRINTTOFILE) Or _
(-(Not
ShowPrintToFile) * PD_HIDEPRINTTOFILE) Or _
(-PreventWarning * PD_NOWARNING) Or _
(-Collate * PD_COLLATE) Or _
PD_USEDEVMODECOPIESANDCOLLATE Or _
PD_RETURNDC
If PrintRange =
eprPageNumbers Then
afFlags =
afFlags Or PD_PAGENUMS
ElseIf PrintRange
= eprSelection Then
afFlags =
afFlags Or PD_SELECTION
End If
' Mask out
unwanted bits
afMask = CLng(Not
(PD_ENABLEPRINTHOOK Or _
PD_ENABLEPRINTTEMPLATE))
afMask = afMask
And _
CLng(Not
(PD_ENABLESETUPHOOK Or _
PD_ENABLESETUPTEMPLATE))
' Fill in PRINTDLG
structure
Dim pd As
TPRINTDLG
pd.lStructSize =
Len(pd)
pd.hWndOwner =
Owner
pd.flags = afFlags
And afMask
pd.nFromPage =
FromPage
pd.nToPage =
ToPage
pd.nMinPage = 1
pd.nMaxPage =
&HFFFF
' Show Print
dialog
m_lApiReturn =
PrintDlg(pd)
Select Case
m_lApiReturn
Case 1
VBPrintDlg = True
' Return
dialog values in parameters
hdc = pd.hdc
If (pd.flags
And PD_PAGENUMS) Then
PrintRange
= eprPageNumbers
ElseIf
(pd.flags And PD_SELECTION) Then
PrintRange
= eprSelection
Else
PrintRange
= eprAll
End If
FromPage =
pd.nFromPage
ToPage =
pd.nToPage
PrintToFile =
(pd.flags And PD_PRINTTOFILE)
' Get DEVMODE
structure from PRINTDLG
Dim pDevMode
As Long
pDevMode =
GlobalLock(pd.hDevMode)
CopyMemory
m_dvmode, ByVal pDevMode, Len(m_dvmode)
Call
GlobalUnlock(pd.hDevMode)
' Get Copies
and Collate settings from DEVMODE structure
Copies =
m_dvmode.dmCopies
Collate =
(m_dvmode.dmCollate = DMCOLLATE_TRUE)
' Set default
printer properties
On Error
Resume Next
If Not
(Printer Is Nothing) Then
Printer.Copies = Copies
Printer.Orientation = m_dvmode.dmOrientation
Printer.PaperSize = m_dvmode.dmPaperSize
Printer.PrintQuality = m_dvmode.dmPrintQuality
End If
On Error GoTo
0
Case 0
' Cancelled
VBPrintDlg =
False
Case Else
' Extended
error:
m_lExtendedError
= CommDlgExtendedError()
VBPrintDlg =
False
End Selec
End Function
Private Property Get DevMode() As DevMode
DevMode = m_dvmode
End Property
' PageSetupDlg wrapper
Function VBPageSetupDlg(Optional Owner As Long, _
Optional DisableMargins As Boolean, _
Optional DisableOrientation As Boolean, _
Optional DisablePaper As Boolean, _
Optional DisablePrinter As Boolean, _
Optional LeftMargin As Long,
_
Optional MinLeftMargin As Long, _
Optional RightMargin As Long, _
Optional MinRightMargin As Long, _
Optional TopMargin As Long, _
Optional MinTopMargin As Long, _
Optional BottomMargin As Long, _
Optional MinBottomMargin As Long, _
Optional PaperSize As EPaperSize = epsLetter, _
Optional Orientation As EOrientation = eoPortrait, _
Optional PrintQuality As EPrintQuality = epqDraft, _
Optional Units As EPageSetupUnits = epsuInches, _
Optional Printer As Object, _
Optional flags As Long) As Boolean
Dim afFlags As
Long, afMask As Long
m_lApiReturn = 0
m_lExtendedError =
0
' Mask out
unwanted bits
afMask = Not
(PSD_EnablePagePaintHook Or _
PSD_EnablePageSetupHook Or _
PSD_EnablePageSetupTemplate)
' Set
TPAGESETUPDLG flags
afFlags =
(-DisableMargins * PSD_DISABLEMARGINS) Or _
(-DisableOrientation * PSD_DISABLEORIENTATION) Or _
(-DisablePaper * PSD_DISABLEPAPER) Or _
(-DisablePrinter * PSD_DISABLEPRINTER) Or _
PSD_MARGINS Or PSD_MINMARGINS And afMask
Dim lUnits As Long
If Units =
epsuInches Then
afFlags =
afFlags Or PSD_INTHOUSANDTHSOFINCHES
lUnits = 1000
Else
afFlags =
afFlags Or PSD_INHUNDREDTHSOFMILLIMETERS
lUnits = 100
End If
Dim psd As
TPAGESETUPDLG
' Fill in PRINTDLG
structure
psd.lStructSize =
Len(psd)
psd.hWndOwner = Owner
psd.rtMargin.TOp =
TopMargin * lUnits
psd.rtMargin.Left
= LeftMargin * lUnits
psd.rtMargin.Bottom = BottomMargin * lUnits
psd.rtMargin.Right
= RightMargin * lUnits
psd.rtMinMargin.TOp = MinTopMargin * lUnits
psd.rtMinMargin.Left = MinLeftMargin * lUnits
psd.rtMinMargin.Bottom = MinBottomMargin * lUnits
psd.rtMinMargin.Right = MinRightMargin * lUnits
psd.flags =
afFlags
' Show Print
dialog
If
PageSetupDlg(psd) Then
VBPageSetupDlg
= True
' Return
dialog values in parameters
TopMargin =
psd.rtMargin.TOp / lUnits
LeftMargin =
psd.rtMargin.Left / lUnits
BottomMargin =
psd.rtMargin.Bottom / lUnits
RightMargin =
psd.rtMargin.Right / lUnits
MinTopMargin =
psd.rtMinMargin.TOp / lUnits
MinLeftMargin
= psd.rtMinMargin.Left / lUnits
MinBottomMargin = psd.rtMinMargin.Bottom / lUnits
MinRightMargin
= psd.rtMinMargin.Right / lUnits
' Get DEVMODE
structure from PRINTDLG
Dim dvmode As
DevMode, pDevMode As Long
pDevMode =
GlobalLock(psd.hDevMode)
CopyMemory
dvmode, ByVal pDevMode, Len(dvmode)
Call
GlobalUnlock(psd.hDevMode)
PaperSize =
dvmode.dmPaperSize
Orientation =
dvmode.dmOrientation
PrintQuality =
dvmode.dmPrintQuality
' Set default
printer properties
On Error
Resume Next
If Not
(Printer Is Nothing) Then
Printer.Copies = dvmode.dmCopies
Printer.Orientation = dvmode.dmOrientation
Printer.PaperSize = dvmode.dmPaperSize
Printer.PrintQuality = dvmode.dmPrintQuality
End If
On Error GoTo
0
End If
End Function
#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
Dim sText As
String, sSource As String
If e > 1000
Then
sSource =
App.EXEName & ".CommonDialog"
Err.Raise
COMError(e), sSource, sText
Else
' Raise
standard Visual Basic error
sSource =
App.EXEName & ".VBError"
Err.Raise e, sSource
End If
End Sub
#End If
Private Sub StrToBytes(ab() As Byte, s As String)
If
IsArrayEmpty(ab) Then
' Assign to
empty array
ab =
StrConv(s, vbFromUnicode)
Else
Dim cab As
Long
' Copy to existing
array, padding or truncating if necessary
cab =
UBound(ab) - LBound(ab) + 1
If Len(s) <
cab Then s = s & String$(cab - Len(s), 0)
'If
UnicodeTypeLib Then
' Dim st As String
' st = StrConv(s, vbFromUnicode)
' CopyMemoryStr ab(LBound(ab)), st, cab
'Else
CopyMemoryStr ab(LBound(ab)), s, cab
'End If
End If
End Sub
Private Function BytesToStr(ab() As Byte) As String
BytesToStr =
StrConv(ab, vbUnicode)
End Function
Private Function COMError(e As Long) As Long
COMError = e Or
vbObjectError
End Function
‘Private Function IsArrayEmpty(va As Variant) As Boolean
Dim v As Variant
On Error Resume
Next
v = va(LBound(va))
IsArrayEmpty =
(Err <> 0)
End Function
Class module
clsCRC(clsCRC.cls)
'CRC Checksum Class
'------------------------------------
'
'A very fast solution to calculate the
'CRC Checksum (at the moment CRC16 and
'CRC32 values) with the help of some
'pre-compiled assembler code
'
'(c) 2000, Fredrik Qvarfort
'Option Explicit
Public Enum CRCAlgorithms
CRC32
End Enum
Private m_Algorithm As Boolean
Private m_CRC16Table(0 To 255) As Long
Private m_CRC32 As Long
Private m_CRC32Asm() As Byte
Private m_CRC32Init As Boolean
Private m_CRC32Table(0 To 255) As Long
Private Declare Function CallWindowProc Lib
"user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As
Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam
As Long) As Long
Public Function AddBytes(ByteArray() As Byte) As Variant
Dim ByteSize As Long
'We need to add a
simple error trapping
'here because if the
bytearray is not
'dimensioned we want
it to just skip
'the assembler code
call below
On Local Error GoTo
NoData
'Precalculate the size
of the byte array
ByteSize =
UBound(ByteArray) - LBound(ByteArray) + 1
'No error trapping
needed, if something
'goes bad below
something is definitely
'fishy with your
computer
On Local Error GoTo
0
'Run the
pre-compiled assembler code
'for the current
selected algorithm
Call
CallWindowProc(VarPtr(m_CRC32Asm(0)), VarPtr(m_CRC32),
VarPtr(ByteArray(LBound(ByteArray))), VarPtr(m_CRC32Table(0)), ByteSize)
NoData:
'Return the current
CRC value
AddBytes = Value
End Function
Public Property Let Algorithm(New_Value As CRCAlgorithms)
'Set the new
algorithm
m_Algorithm =
New_Value
'Make sure we have
initialized the
'current selected
algorithm
If (Not
m_CRC32Init) Then Call InitializeCRC32
'Make sure we reset
the data of the
'current selected
algorithm
Call Clear
End Property
Public Property Get Algorithm() As CRCAlgorithms
Algorithm =
m_Algorithm
End Property
Public Function CalculateBytes(ByteArray() As Byte) As
Variant
'Reset the current
CRC calculation
Call Clear
'Calculate the CRC
from the bytearray
'and return the
current CRC value
CalculateBytes =
AddBytes(ByteArray)
End Function
Public Function CalculateFile(Filename As String) As Variant
On Error GoTo bawah
Dim Filenr As
Integer
Dim ByteArray() As
Byte
'Make sure the file
contains data
'to avoid errors
later below
If
(FileLen(Filename) = 0) Then Exit Function
'Open the file in
binary mode, read
'the data into a
bytearray and then
'close the file
Filenr = FreeFile
Open Filename For
Binary As #Filenr
ReDim ByteArray(0 To
LOF(Filenr) - 1)
Get #Filenr, ,
ByteArray()
Close #Filenr
'Now send the
bytearray to the function
'that can calculate
a CRC from it
CalculateFile =
CalculateBytes(ByteArray)
bawah:
Exit Function
End Function
Public Property Get Value() As Variant
Value = (Not
m_CRC32)
End Property
Public Property Let Value(New_Value As Variant)
m_CRC32 = New_Value
End Property
Public Sub Clear()
'Here can be sloppy
and reset both
'crc variables (this
procedure will
'be more advanced
when adding more
'checksums
algorithms..)
m_CRC32 =
&HFFFFFFFF
End Sub
Private Sub InitializeCRC32()
Dim i As Long
Dim sASM As String
m_CRC32Table(0) =
&H0
m_CRC32Table(1) =
&H77073096
m_CRC32Table(2) =
&HEE0E612C
m_CRC32Table(3) =
&H990951BA
m_CRC32Table(4) =
&H76DC419
m_CRC32Table(5) =
&H706AF48F
m_CRC32Table(6) =
&HE963A535
m_CRC32Table(7) =
&H9E6495A3
m_CRC32Table(8) =
&HEDB8832
m_CRC32Table(9) =
&H79DCB8A4
m_CRC32Table(10) =
&HE0D5E91E
m_CRC32Table(11) =
&H97D2D988
m_CRC32Table(12) =
&H9B64C2B
m_CRC32Table(13) =
&H7EB17CBD
m_CRC32Table(14) =
&HE7B82D07
m_CRC32Table(15) =
&H90BF1D91
m_CRC32Table(16) =
&H1DB71064
m_CRC32Table(17) =
&H6AB020F2
m_CRC32Table(18) =
&HF3B97148
m_CRC32Table(19) =
&H84BE41DE
m_CRC32Table(20) =
&H1ADAD47D
m_CRC32Table(21) =
&H6DDDE4EB
m_CRC32Table(22) =
&HF4D4B551
m_CRC32Table(23) =
&H83D385C7
m_CRC32Table(24) =
&H136C9856
m_CRC32Table(25) =
&H646BA8C0
m_CRC32Table(26) =
&HFD62F97A
m_CRC32Table(27) =
&H8A65C9EC
m_CRC32Table(28) =
&H14015C4F
m_CRC32Table(29) =
&H63066CD9
m_CRC32Table(30) =
&HFA0F3D63
m_CRC32Table(31) =
&H8D080DF5
m_CRC32Table(32) =
&H3B6E20C8
m_CRC32Table(33) =
&H4C69105E
m_CRC32Table(34) =
&HD56041E4
m_CRC32Table(35) =
&HA2677172
m_CRC32Table(36) =
&H3C03E4D1
m_CRC32Table(37) =
&H4B04D447
m_CRC32Table(38) =
&HD20D85FD
m_CRC32Table(39) =
&HA50AB56B
m_CRC32Table(40) =
&H35B5A8FA
m_CRC32Table(41) =
&H42B2986C
m_CRC32Table(42) =
&HDBBBC9D6
m_CRC32Table(43) =
&HACBCF940
m_CRC32Table(44) =
&H32D86CE3
m_CRC32Table(45) =
&H45DF5C75
m_CRC32Table(46) =
&HDCD60DCF
m_CRC32Table(47) =
&HABD13D59
m_CRC32Table(48) =
&H26D930AC
m_CRC32Table(49) =
&H51DE003A
m_CRC32Table(50) =
&HC8D75180
m_CRC32Table(51) =
&HBFD06116
m_CRC32Table(52) =
&H21B4F4B5
m_CRC32Table(53) =
&H56B3C423
m_CRC32Table(54) =
&HCFBA9599
m_CRC32Table(55) =
&HB8BDA50F
m_CRC32Table(56) =
&H2802B89E
m_CRC32Table(57) =
&H5F058808
m_CRC32Table(58) =
&HC60CD9B2
m_CRC32Table(59) =
&HB10BE924
m_CRC32Table(60) =
&H2F6F7C87
m_CRC32Table(61) =
&H58684C11
m_CRC32Table(62) =
&HC1611DAB
m_CRC32Table(63) =
&HB6662D3D
m_CRC32Table(64) =
&H76DC4190
m_CRC32Table(65) =
&H1DB7106
m_CRC32Table(66) =
&H98D220BC
m_CRC32Table(67) =
&HEFD5102A
m_CRC32Table(68) =
&H71B18589
m_CRC32Table(69) =
&H6B6B51F
m_CRC32Table(70) =
&H9FBFE4A5
m_CRC32Table(71) =
&HE8B8D433
m_CRC32Table(72) =
&H7807C9A2
m_CRC32Table(73) =
&HF00F934
m_CRC32Table(74) =
&H9609A88E
m_CRC32Table(75) =
&HE10E9818
m_CRC32Table(76) =
&H7F6A0DBB
m_CRC32Table(77) =
&H86D3D2D
m_CRC32Table(78) =
&H91646C97
m_CRC32Table(79) =
&HE6635C01
m_CRC32Table(80) =
&H6B6B51F4
m_CRC32Table(81) =
&H1C6C6162
m_CRC32Table(82) =
&H856530D8
m_CRC32Table(83) =
&HF262004E
m_CRC32Table(84) =
&H6C0695ED
m_CRC32Table(85) =
&H1B01A57B
m_CRC32Table(86) =
&H8208F4C1
m_CRC32Table(87) =
&HF50FC457
m_CRC32Table(88) =
&H65B0D9C6
m_CRC32Table(89) =
&H12B7E950
m_CRC32Table(90) =
&H8BBEB8EA
m_CRC32Table(91) =
&HFCB9887C
m_CRC32Table(92) =
&H62DD1DDF
m_CRC32Table(93) =
&H15DA2D49
m_CRC32Table(94) =
&H8CD37CF3
m_CRC32Table(95) =
&HFBD44C65
m_CRC32Table(96) =
&H4DB26158
m_CRC32Table(97) =
&H3AB551CE
m_CRC32Table(98) =
&HA3BC0074
m_CRC32Table(99) =
&HD4BB30E2
m_CRC32Table(100) =
&H4ADFA541
m_CRC32Table(101) =
&H3DD895D7
m_CRC32Table(102) =
&HA4D1C46D
m_CRC32Table(103) =
&HD3D6F4FB
m_CRC32Table(104) =
&H4369E96A
m_CRC32Table(105) =
&H346ED9FC
m_CRC32Table(106) =
&HAD678846
m_CRC32Table(107) =
&HDA60B8D0
m_CRC32Table(108) =
&H44042D73
m_CRC32Table(109) =
&H33031DE5
m_CRC32Table(110) =
&HAA0A4C5F
m_CRC32Table(111) =
&HDD0D7CC9
m_CRC32Table(112) =
&H5005713C
m_CRC32Table(113) =
&H270241AA
m_CRC32Table(114) =
&HBE0B1010
m_CRC32Table(115) =
&HC90C2086
m_CRC32Table(116) =
&H5768B525
m_CRC32Table(117) =
&H206F85B3
m_CRC32Table(118) =
&HB966D409
m_CRC32Table(119) =
&HCE61E49F
m_CRC32Table(120) =
&H5EDEF90E
m_CRC32Table(121) =
&H29D9C998
m_CRC32Table(122) =
&HB0D09822
m_CRC32Table(123) =
&HC7D7A8B4
m_CRC32Table(124) =
&H59B33D17
m_CRC32Table(125) =
&H2EB40D81
m_CRC32Table(126) =
&HB7BD5C3B
m_CRC32Table(127) =
&HC0BA6CAD
m_CRC32Table(128) =
&HEDB88320
m_CRC32Table(129) =
&H9ABFB3B6
m_CRC32Table(130) =
&H3B6E20C
m_CRC32Table(131) =
&H74B1D29A
m_CRC32Table(132) =
&HEAD54739
m_CRC32Table(133) =
&H9DD277AF
m_CRC32Table(134) =
&H4DB2615
m_CRC32Table(135) =
&H73DC1683
m_CRC32Table(136) =
&HE3630B12
m_CRC32Table(137) =
&H94643B84
m_CRC32Table(138) =
&HD6D6A3E
m_CRC32Table(139) =
&H7A6A5AA8
m_CRC32Table(140) =
&HE40ECF0B
m_CRC32Table(141) =
&H9309FF9D
m_CRC32Table(142) =
&HA00AE27
m_CRC32Table(143) =
&H7D079EB1
m_CRC32Table(144) =
&HF00F9344
m_CRC32Table(145) =
&H8708A3D2
m_CRC32Table(146) =
&H1E01F268
m_CRC32Table(147) =
&H6906C2FE
m_CRC32Table(148) =
&HF762575D
m_CRC32Table(149) =
&H806567CB
m_CRC32Table(150) =
&H196C3671
m_CRC32Table(151) =
&H6E6B06E7
m_CRC32Table(152) =
&HFED41B76
m_CRC32Table(153) =
&H89D32BE0
m_CRC32Table(154) =
&H10DA7A5A
m_CRC32Table(155) =
&H67DD4ACC
m_CRC32Table(156) =
&HF9B9DF6F
m_CRC32Table(157) =
&H8EBEEFF9
m_CRC32Table(158) =
&H17B7BE43
m_CRC32Table(159) =
&H60B08ED5
m_CRC32Table(160) =
&HD6D6A3E8
m_CRC32Table(161) =
&HA1D1937E
m_CRC32Table(162) =
&H38D8C2C4
m_CRC32Table(163) =
&H4FDFF252
m_CRC32Table(164) =
&HD1BB67F1
m_CRC32Table(165) =
&HA6BC5767
m_CRC32Table(166) =
&H3FB506DD
m_CRC32Table(167) =
&H48B2364B
m_CRC32Table(168) =
&HD80D2BDA
m_CRC32Table(169) =
&HAF0A1B4C
m_CRC32Table(170) =
&H36034AF6
m_CRC32Table(171) =
&H41047A60
m_CRC32Table(172) =
&HDF60EFC3
m_CRC32Table(173) =
&HA867DF55
m_CRC32Table(174) =
&H316E8EEF
m_CRC32Table(175) =
&H4669BE79
m_CRC32Table(176) =
&HCB61B38C
m_CRC32Table(177) =
&HBC66831A
m_CRC32Table(178) =
&H256FD2A0
m_CRC32Table(179) =
&H5268E236
m_CRC32Table(180) =
&HCC0C7795
m_CRC32Table(181) =
&HBB0B4703
m_CRC32Table(182) =
&H220216B9
m_CRC32Table(183) =
&H5505262F
m_CRC32Table(184) =
&HC5BA3BBE
m_CRC32Table(185) =
&HB2BD0B28
m_CRC32Table(186) =
&H2BB45A92
m_CRC32Table(187) =
&H5CB36A04
m_CRC32Table(188) =
&HC2D7FFA7
m_CRC32Table(189) =
&HB5D0CF31
m_CRC32Table(190) =
&H2CD99E8B
m_CRC32Table(191) =
&H5BDEAE1D
m_CRC32Table(192) =
&H9B64C2B0
m_CRC32Table(193) =
&HEC63F226
m_CRC32Table(194) =
&H756AA39C
m_CRC32Table(195) =
&H26D930A
m_CRC32Table(196) =
&H9C0906A9
m_CRC32Table(197) =
&HEB0E363F
m_CRC32Table(198) =
&H72076785
m_CRC32Table(199) =
&H5005713
m_CRC32Table(200) =
&H95BF4A82
m_CRC32Table(201) =
&HE2B87A14
m_CRC32Table(202) =
&H7BB12BAE
m_CRC32Table(203) =
&HCB61B38
m_CRC32Table(204) =
&H92D28E9B
m_CRC32Table(205) =
&HE5D5BE0D
m_CRC32Table(206) =
&H7CDCEFB7
m_CRC32Table(207) =
&HBDBDF21
m_CRC32Table(208) =
&H86D3D2D4
m_CRC32Table(209) =
&HF1D4E242
m_CRC32Table(210) =
&H68DDB3F8
m_CRC32Table(211) =
&H1FDA836E
m_CRC32Table(212) =
&H81BE16CD
m_CRC32Table(213) =
&HF6B9265B
m_CRC32Table(214) =
&H6FB077E1
m_CRC32Table(215) =
&H18B74777
m_CRC32Table(216) =
&H88085AE6
m_CRC32Table(217) =
&HFF0F6A70
m_CRC32Table(218) =
&H66063BCA
m_CRC32Table(219) =
&H11010B5C
m_CRC32Table(220) =
&H8F659EFF
m_CRC32Table(221) =
&HF862AE69
m_CRC32Table(222) =
&H616BFFD3
m_CRC32Table(223) =
&H166CCF45
m_CRC32Table(224) =
&HA00AE278
m_CRC32Table(225) =
&HD70DD2EE
m_CRC32Table(226) =
&H4E048354
m_CRC32Table(227) =
&H3903B3C2
m_CRC32Table(228) =
&HA7672661
m_CRC32Table(229) =
&HD06016F7
m_CRC32Table(230) =
&H4969474D
m_CRC32Table(231) =
&H3E6E77DB
m_CRC32Table(232) =
&HAED16A4A
m_CRC32Table(233) =
&HD9D65ADC
m_CRC32Table(234) =
&H40DF0B66
m_CRC32Table(235) =
&H37D83BF0
m_CRC32Table(236) =
&HA9BCAE53
m_CRC32Table(237) =
&HDEBB9EC5
m_CRC32Table(238) =
&H47B2CF7F
m_CRC32Table(239) =
&H30B5FFE9
m_CRC32Table(240) =
&HBDBDF21C
m_CRC32Table(241) =
&HCABAC28A
m_CRC32Table(242) =
&H53B39330
m_CRC32Table(243) =
&H24B4A3A6
m_CRC32Table(244) =
&HBAD03605
m_CRC32Table(245) =
&HCDD70693
m_CRC32Table(246) =
&H54DE5729
m_CRC32Table(247) =
&H23D967BF
m_CRC32Table(248) =
&HB3667A2E
m_CRC32Table(249) =
&HC4614AB8
m_CRC32Table(250) =
&H5D681B02
m_CRC32Table(251) =
&H2A6F2B94
m_CRC32Table(252) =
&HB40BBE37
m_CRC32Table(253) =
&HC30C8EA1
m_CRC32Table(254) =
&H5A05DF1B
m_CRC32Table(255) =
&H2D02EF8D
'Create a bytearray
to hold the
'precompiled
assembler code
sASM =
"5589E557565053518B45088B008B750C8B7D108B4D1431DB8A1E30C3C1E80833049F464975F28B4D088901595B585E5F89EC5DC21000"
ReDim m_CRC32Asm(0
To Len(sASM) \ 2 - 1)
For i = 1 To
Len(sASM) Step 2
m_CRC32Asm(i \ 2)
= Val("&H" & Mid$(sASM, i, 2))
Next
'Mark the CRC32
algorithm as initialized
m_CRC32Init = True
End Sub
Private Sub Class_Initialize()
'The default
algorithm is CRC32
Algorithm = CRC32
End Sub
Frmabout
Private Sub cmd_tutup_Click()
Unload Me
End Sub
Private Sub cmdVisitMe_Click()
ShellExecute hWnd, "open",
"http://www.narpes32.net.tc", vbNullString, vbNullString, 1
End Sub
Private Sub Form_Load()
Antivirus.Enabled = False
Me.Icon = Antivirus.Icon
Text1.Top = 2000
Timer1.Interval = 50
End Sub
Private Sub Form_Unload(Cancel As Integer)
Antivirus.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim gerak
gerak = Text1.Top - 20
Text1.Top = gerak
If gerak < -5800 Then
Text1.Top = 2090
End If
End Sub
frmExtTool
Private Sub cmdTutup_Click()
Unload Me
End Sub
Private Sub Form_Load()
Antivirus.Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
Antivirus.Enabled = True
End Sub
Private Sub Label1_Click()
If Dir(App.Path & "\FileRecover.bat") =
"" Then
MsgBox "Maaf, file " & App.Path &
"\FileRecover.bat tidak ditemukan." & vbCrLf & "NAVi
tidak dapat melakukan perintah ini." & vbCrLf & "Silahkan download
kembali dari http://www.narpes32.net.tc", 0 + vbExclamation,
"Error"
Else
ShellExecute hWnd, "open", App.Path &
"\FileRecover.bat", vbNullString, vbNullString, 1
End If
End Sub
frmSignature
Private Type Signature
sampel(2000) As
String
hash(1000) As
String
namavirus(2000) As
String
End Type
'Pengumuman variabel
Private a As Integer, b As Integer
Private sign As Signature
'akhir dari pengumuman
Private Sub cmdTutup_Click()
Unload Me 'menutup program
End Sub
Private Sub Form_Load()
Antivirus.Enabled = False
i = 1
'Mengambil signature dari file
Open App.Path & "\navi.dll" For Input As #1
Do
Input #1,
sign.sampel(i)
sign.namavirus(i)
= Mid(sign.sampel(i), InStr(1, sign.sampel(i), ":") + 1,
Len(Mid(sign.sampel(i), InStr(1, sign.sampel(i), ":") + 1)))
If
sign.namavirus(i) = "Selesai" Then Exit Do
List1.AddItem (i
& ". " & sign.namavirus(i))
i = i + 1
Loop Until i = i +
1
Close #1
'selesai mengambil signature
'mulai mengambil sampel string dari signature
a = 1
Do
sign.sampel(a) =
ambilsampel(a)
'mengambil
signature dari sampel
sign.hash(a) =
Mid(sign.sampel(a), 1, InStr(1, sign.sampel(a), ":") - 1)
'mengambil
namavirus dari sampel
sign.namavirus(a)
= Mid(sign.sampel(a), Len(sign.hash(a)) + 2, (InStr(Len(sign.hash(a)) + 2,
sign.sampel(a), ":") - (Len(sign.hash(a)) + 2)))
'mengambil
namavirus yg dihasilkan
'ukuran_asli(a) =
Mid(sampel(a), Len(sign(a)) + 1 + Len(virname(a)) + 2, Len(sampel(a)))
If sign.sampel(a)
= "Selesai:Selesai:Selesai" Then Exit Do
List1.AddItem (i
& ". " & sign.namavirus(a))
a = a + 1
i = i + 1
Loop Until a = a + 1
'selesai mengambil string
'berikan jumlah virus pada sebuah label
lblJumlahVirus.Caption = "Jumlah Signature : "
& List1.ListCount
End Sub
Private Sub Form_Unload(Cancel As Integer)
Antivirus.Enabled = True
End Sub
frmTempDb
Private Sub cmdBrowse_Click()
On Error GoTo batal
Dim c As New cCommonDialog
Dim sFileName As
String
Dim ceksum As
String
Dim m_CRC As clsCRC
Dim namavirus As
String
Set m_CRC = New
clsCRC
If
(c.VBGetOpenFileName( _
FileName:=sFileName, _
Owner:=Me.hWnd))
Then
txtFileName.Text
= sFileName
lblChecksum.Caption
= Hex(m_CRC.CalculateFile(sFileName)) 'mendapatkan crc32
lblPacker.Caption =
get_Packer(sFileName) 'memanggil fungsi untuk mendapatkan packer
lblCompiler.Caption
= get_Compiler(sFileName) ' memanggil fungsi untuk mendapatkan compiler
lblUkuran.Caption =
Round(FileLen(sFileName) / 1024, 2) & " Kb."
lblType.Caption =
typefile(sFileName) 'memanggil fungsi untuk mendapatkan typefile
If
FileLen(sFileName) / 1024 <= 750 Then
If
lblChecksum.Caption = "0" Or lblChecksum.Caption = "" Then
Check1.Enabled
= False
Else
Check1.Enabled
= True
End If
Else
Check1.Enabled =
False
End If
End If
batal:
End Sub
Private Sub cmdTutup_Click()
Unload Me
End Sub
Private Sub Form_Load()
Antivirus.Enabled
= False
Me.Icon =
Antivirus.Icon
End Sub
Private Sub Form_Unload(Cancel As Integer)
Antivirus.Enabled
= True
If Check1 =
Checked Then
TempDb =
frmTempDb.lblChecksum.Caption
End If
End Sub
DMSXpButton
Option Explicit
'mouse over effects
Private Declare Function WindowFromPoint Lib
"USER32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "USER32"
(lpPoint As POINTAPI) As Long
'draw and set rectangular area of the control
Private Declare Function GetClientRect Lib
"USER32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "USER32"
(lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2
As Long) As Long
Private Declare Function FillRect Lib "USER32"
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "USER32"
(ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SetCapture Lib "USER32"
(ByVal hwnd As Long) As Long
'draw by pixel or by line
Private Declare Function CreateSolidBrush Lib
"gdi32" (ByVal crColor As Long) As Long
Private Declare Function SetPixel Lib "gdi32"
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As
Long
Private Declare Function MoveToEx Lib "gdi32"
(ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As POINTAPI) As
Long
Private Declare Function LineTo Lib "gdi32" (ByVal
hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function CreatePen Lib "gdi32"
(ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const PS_SOLID = 0
'select and delete created objects
Private Declare Function DeleteObject Lib "gdi32"
(ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32"
(ByVal hdc As Long, ByVal hObject As Long) As Long
'create regions of pixels and remove them to make the
control transparent
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 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 Const RGN_DIFF = 4
'set text color and draw it to the control
Private Declare Function GetTextColor Lib "gdi32"
(ByVal hdc As Long) As Long
Private Declare Function SetTextColor Lib "gdi32"
(ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function DrawText Lib "USER32"
Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal
nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const DT_CENTER = &H1
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Public Event Click()
Public Event MouseDown(Button As Integer, Shift As Integer,
X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer,
X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, X
As Single, Y As Single)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseOver()
Public Event MouseOut()
Private rc As RECT
Private w As Long, H As Long
Private rgMain As Long, rgn1 As Long
Private isOver As Boolean
Private flgHover As Integer
Private flgFocus As Boolean
Private LastButton As Integer
Private LastKey As Integer
Private r As Long, l As Long, t As Long, b As Long
Private mEnabled As Boolean
Private mCaption As String
Private mForeHover As OLE_COLOR
Private Sub DrawButton()
Dim pt As POINTAPI, pen As Long, hpen As Long
With UserControl
'left top corner
hpen =
CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
t + 1, pt
LineTo .hdc, l +
2, t
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
2, t, pt
LineTo .hdc, l, t
+ 2
SelectObject .hdc,
pen
DeleteObject hpen
SetPixel .hdc, l,
t + 2, RGB(37, 87, 131)
SetPixel .hdc, l +
1, t + 2, RGB(191, 206, 220)
SetPixel .hdc, l +
2, t + 1, RGB(192, 207, 221)
'top line
hpen =
CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
3, t, pt
LineTo .hdc, r -
2, t
SelectObject .hdc,
pen
DeleteObject hpen
'right top corner
hpen =
CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, r -
2, t, pt
LineTo .hdc, r +
1, t + 3
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, r -
1, t, pt
LineTo .hdc, r, t
+ 2
SetPixel .hdc, r,
t + 1, RGB(122, 149, 168)
SetPixel .hdc, r -
2, t + 1, RGB(213, 223, 232)
SetPixel .hdc, r -
1, t + 2, RGB(191, 206, 219)
SelectObject .hdc,
pen
DeleteObject hpen
'right line
hpen =
CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, r,
t + 3, pt
LineTo .hdc, r, b
- 3
SelectObject .hdc,
pen
DeleteObject hpen
'right bottom
corner
hpen =
CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, r,
b - 3, pt
LineTo .hdc, r -
3, b
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, r,
b - 2, pt
LineTo .hdc, r -
2, b
SetPixel .hdc, r -
2, b - 2, RGB(177, 183, 182)
SetPixel .hdc, r -
1, b - 3, RGB(182, 189, 189)
SelectObject .hdc,
pen
DeleteObject hpen
'bottom line
hpen = CreatePen(PS_SOLID, 1, RGB(0, 60,
116))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
3, b - 1, pt
LineTo .hdc, r -
2, b - 1
SelectObject .hdc,
pen
DeleteObject hpen
'left bottom
corner
hpen =
CreatePen(PS_SOLID, 1, RGB(37, 87, 131))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 3, pt
LineTo .hdc, l +
3, b
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(122, 149, 168))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 2, pt
LineTo .hdc, l +
2, b
SetPixel .hdc, l +
1, b - 3, RGB(191, 199, 202)
SetPixel .hdc, l +
2, b - 2, RGB(163, 174, 180)
SelectObject .hdc,
pen
DeleteObject hpen
'left line
hpen =
CreatePen(PS_SOLID, 1, RGB(0, 60, 116))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
t + 3, pt
LineTo .hdc, l, b
- 3
SelectObject .hdc,
pen
DeleteObject hpen
End With
End Sub
Private Sub DrawFocus()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
With UserControl
'top line
hpen =
CreatePen(PS_SOLID, 1, RGB(206, 231, 251))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
2, t + 1, pt
LineTo .hdc, r -
1, t + 1
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(188, 212, 246))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
1, t + 2, pt
LineTo .hdc, r, t
+ 2
SelectObject .hdc,
pen
DeleteObject hpen
'draw gradient
ColorR = 186
ColorG = 211
ColorB = 246
For i = t + 3 To b
- 4 Step 1
hpen =
CreatePen(PS_SOLID, 2, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l
+ 2, i, pt
LineTo .hdc, l +
2, i + 1
MoveToEx .hdc, r
- 1, i, pt
LineTo .hdc, r -
1, i + 1
SelectObject
.hdc, pen
DeleteObject
hpen
If ColorB >=
228 Then
ColorR =
ColorR - 4
ColorG =
ColorG - 3
ColorB =
ColorB - 1
End If
Next i
hpen =
CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
1, b - 3, pt
LineTo .hdc, r -
1, b - 3
SelectObject .hdc,
pen
DeleteObject hpen
SetPixel .hdc, l +
2, b - 2, RGB(77, 125, 193)
hpen =
CreatePen(PS_SOLID, 1, RGB(97, 125, 229))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
3, b - 2, pt
LineTo .hdc, r -
2, b - 2
SetPixel .hdc, r -
2, b - 2, RGB(77, 125, 193)
SelectObject .hdc,
pen
DeleteObject hpen
End With
End Sub
Private Sub DrawHighlight()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
With UserControl
'top line
hpen = CreatePen(PS_SOLID,
1, RGB(255, 240, 207))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
2, t + 1, pt
LineTo .hdc, r -
1, t + 1
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(253, 216, 137))
pen = SelectObject(.hdc,
hpen)
MoveToEx .hdc, l +
1, t + 2, pt
LineTo .hdc, r, t
+ 2
SelectObject .hdc,
pen
DeleteObject hpen
'draw gradient
ColorR = 254
ColorG = 223
ColorB = 154
For i = t + 2 To b
- 3 Step 1
hpen =
CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l
+ 1, i, pt
LineTo .hdc, l +
1, i + 1
MoveToEx .hdc, r
- 1, i, pt
LineTo .hdc, r -
1, i + 1
SelectObject .hdc,
pen
DeleteObject
hpen
If ColorB >=
49 Then
ColorR =
ColorR - 1
ColorG =
ColorG - 3
ColorB =
ColorB - 7
End If
Next i
ColorR = 252
ColorG = 210
ColorB = 121
For i = t + 3 To b
- 3 Step 1
hpen = CreatePen(PS_SOLID, 1, RGB(ColorR,
ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l
+ 2, i, pt
LineTo .hdc, l +
2, i + 1
MoveToEx .hdc, r
- 2, i, pt
LineTo .hdc, r -
2, i + 1
SelectObject
.hdc, pen
DeleteObject
hpen
If ColorB >=
57 Then
ColorR =
ColorR - 1
ColorG =
ColorG - 4
ColorB =
ColorB - 8
End If
Next i
hpen =
CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
3, b - 3, pt
LineTo .hdc, r, b
- 3
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(229, 151, 0))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l +
2, b - 2, pt
LineTo .hdc, r -
1, b - 2
SelectObject .hdc,
pen
DeleteObject hpen
End With
End Sub
Private Sub DrawButtonFace()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
'draw gradient
ColorR = 255
ColorG = 255
ColorB = 253
For i = t + 3 To b
- 3 Step 1
hpen =
CreatePen(PS_SOLID, 1, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc,
l, i, pt
LineTo .hdc, r,
i
SelectObject
.hdc, pen
DeleteObject
hpen
If ColorB >=
230 Then
ColorR =
ColorR - 1
ColorG =
ColorG - 1
ColorB =
ColorB - 1
End If
Next i
'bottom shadow
hpen =
CreatePen(PS_SOLID, 1, RGB(214, 208, 197))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 2, pt
LineTo .hdc, r, b
- 2
SelectObject .hdc,
pen
DeleteObject hpen
hpen = CreatePen(PS_SOLID,
1, RGB(226, 223, 214))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 3, pt
LineTo .hdc, r, b
- 3
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(236, 235, 230))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 4, pt
LineTo .hdc, r, b
- 4
SelectObject .hdc,
pen
DeleteObject hpen
End With
End Sub
Private Sub DrawButtonDown()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
'draw gradient
ColorR = 239
ColorG = 238
ColorB = 231
For i = t + 3 To b
- 2 Step 4
hpen =
CreatePen(PS_SOLID, 4, RGB(ColorR, ColorG, ColorB))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc,
l, i, pt
LineTo .hdc, r,
i
SelectObject
.hdc, pen
DeleteObject
hpen
If ColorB >=
218 Then
ColorR =
ColorR - 1
ColorG =
ColorG - 1
ColorB =
ColorB - 1
End If
Next i
'top shadow
hpen =
CreatePen(PS_SOLID, 1, RGB(209, 204, 192))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
t + 1, pt
LineTo .hdc, r, t
+ 1
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(220, 216, 207))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
t + 2, pt
LineTo .hdc, r, t
+ 2
SelectObject .hdc,
pen
DeleteObject hpen
'bottom shadow
hpen =
CreatePen(PS_SOLID, 1, RGB(234, 233, 227))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 3, pt
LineTo .hdc, r, b
- 3
SelectObject .hdc,
pen
DeleteObject hpen
hpen =
CreatePen(PS_SOLID, 1, RGB(242, 241, 238))
pen =
SelectObject(.hdc, hpen)
MoveToEx .hdc, l,
b - 2, pt
LineTo .hdc, r, b
- 2
SelectObject .hdc,
pen
DeleteObject hpen
End With
End Sub
Private Sub DrawButtonDisabled()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
Dim hBrush As Long
With UserControl
.AutoRedraw = True
.Cls
.ScaleMode = 3
hBrush =
CreateSolidBrush(RGB(245, 244, 234))
FillRect
UserControl.hdc, rc, hBrush
DeleteObject
hBrush
hBrush =
CreateSolidBrush(RGB(201, 199, 186))
FrameRect
UserControl.hdc, rc, hBrush
DeleteObject
hBrush
'Left top corner
SetPixel .hdc, l,
t + 1, RGB(216, 213, 199)
SetPixel .hdc, l +
1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, l +
1, t, RGB(216, 213, 199)
SetPixel .hdc, l +
1, t + 2, RGB(234, 233, 222)
SetPixel .hdc, l +
2, t + 1, RGB(234, 233, 222)
'right top corner
SetPixel .hdc, r -
1, t, RGB(216, 213, 199)
SetPixel .hdc, r -
1, t + 1, RGB(216, 213, 199)
SetPixel .hdc, r,
t + 1, RGB(216, 213, 199)
SetPixel .hdc, r -
2, t + 1, RGB(234, 233, 222)
SetPixel .hdc, r -
1, t + 2, RGB(234, 233, 222)
'left bottom
corner
SetPixel .hdc, l,
b - 2, RGB(216, 213, 199)
SetPixel .hdc, l +
1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, l +
1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, l +
1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, l +
2, b - 2, RGB(234, 233, 222)
'right bottom
corner
SetPixel .hdc, r,
b - 2, RGB(216, 213, 199)
SetPixel .hdc, r -
1, b - 2, RGB(216, 213, 199)
SetPixel .hdc, r -
1, b - 1, RGB(216, 213, 199)
SetPixel .hdc, r -
1, b - 3, RGB(234, 233, 222)
SetPixel .hdc, r -
2, b - 2, RGB(234, 233, 222)
End With
End Sub
Private Sub DrawButton2()
Dim pt As POINTAPI, pen As Long, hpen As Long
Dim i As Long, ColorR As Long, ColorG As Long, ColorB As
Long
Dim hBrush As Long
With UserControl
hBrush =
CreateSolidBrush(RGB(0, 60, 116))
FrameRect
UserControl.hdc, rc, hBrush
DeleteObject
hBrush
'Left top corner
SetPixel .hdc, l,
t + 1, RGB(122, 149, 168)
SetPixel .hdc, l +
1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, l +
1, t, RGB(122, 149, 168)
'SetPixel .hdc, l
+ 1, t + 2, RGB(191, 206, 220)
'SetPixel .hdc, l
+ 2, t + 1, RGB(192, 207, 221)
'right top corner
SetPixel .hdc, r -
1, t, RGB(122, 149, 168)
SetPixel .hdc, r -
1, t + 1, RGB(37, 87, 131)
SetPixel .hdc, r,
t + 1, RGB(122, 149, 168)
'SetPixel .hdc, r
- 2, t + 1, RGB(234, 233, 222)
'SetPixel .hdc, r
- 1, t + 2, RGB(234, 233, 222)
'left bottom
corner
SetPixel .hdc, l,
b - 2, RGB(122, 149, 168)
SetPixel .hdc, l +
1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, l +
1, b - 1, RGB(122, 149, 168)
'SetPixel .hdc, l
+ 1, b - 3, RGB(234, 233, 222)
'SetPixel .hdc, l
+ 2, b - 2, RGB(234, 233, 222)
'right bottom
corner
SetPixel .hdc, r,
b - 2, RGB(122, 149, 168)
SetPixel .hdc, r -
1, b - 2, RGB(37, 87, 131)
SetPixel .hdc, r -
1, b - 1, RGB(122, 149, 168)
'SetPixel .hdc, r
- 1, b - 3, RGB(234, 233, 222)
'SetPixel .hdc, r
- 2, b - 2, RGB(234, 233, 222)
End With
End Sub
Private Sub RedrawButton(Optional ByVal Stat As Integer =
-1)
If mEnabled Then
If Stat = 1 And
LastButton = 1 Then
DrawButtonDown
Else
DrawButtonFace
If isOver = True
Then
DrawHighlight
Else
If flgFocus =
True Then
DrawFocus
End If
End If
End If
DrawButton2
Else
DrawButtonDisabled
End If
DrawCaption
MakeRegion
End Sub
Private Sub DrawCaption()
Dim vh As Long, rcTxt As RECT
With UserControl
GetClientRect
.hwnd, rcTxt
If mEnabled Then
If isOver Then
SetTextColor
.hdc, mForeHover
Else
SetTextColor
.hdc, .ForeColor
End If
Else
SetTextColor
.hdc, RGB(161, 161, 146)
End If
vh =
DrawText(.hdc, mCaption, Len(mCaption), rcTxt, DT_CALCRECT Or DT_CENTER Or
DT_WORDBREAK)
'If Button = 1
Then
' SetRect rcTxt, 0, (.ScaleHeight * 0.5) - (vh
* 0.5) + 1, .ScaleWidth, (.ScaleHeight * 0.5) + (vh * 0.5) + 1
' DrawText .hdc, mCaption, Len(mCaption),
rcTxt, DT_CENTER Or DT_WORDBREAK
'Else
SetRect rcTxt,
0, (.ScaleHeight * 0.5) - (vh * 0.5), .ScaleWidth, (.ScaleHeight * 0.5) + (vh *
0.5)
DrawText .hdc,
mCaption, Len(mCaption), rcTxt, DT_CENTER Or DT_WORDBREAK
'End If
End With
End Sub
Private Sub HoverTimer_Timer()
If Not isMouseOver
Then
HoverTimer.Enabled
= False
isOver = False
flgHover = 0
RedrawButton 0
RaiseEvent MouseOut
End If
End Sub
Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
LastButton = 1
Call
UserControl_Click
End Sub
Private Sub UserControl_Click()
If LastButton = 1
Then
RedrawButton 0
UserControl.Refresh
RaiseEvent Click
End If
End Sub
Private Sub UserControl_DblClick()
If LastButton = 1
Then
Call
UserControl_MouseDown(1, 0, 0, 0)
SetCapture hwnd
End If
End Sub
Private Sub UserControl_GotFocus()
flgFocus = True
RedrawButton 1
End Sub
Private Sub UserControl_InitProperties()
Set UserControl.Font
= Ambient.Font
mCaption =
Ambient.DisplayName
mEnabled = True
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As
Integer)
LastKey = KeyCode
Select Case KeyCode
Case vbKeySpace,
vbKeyReturn
RedrawButton 1
Case vbKeyLeft,
vbKeyRight 'right and down arrows
SendKeys
"{Tab}"
Case vbKeyDown,
vbKeyUp 'left and up arrows
SendKeys
"+{Tab}"
End Select
RaiseEvent
KeyDown(KeyCode, Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent
KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As
Integer)
If ((KeyCode =
vbKeySpace) And (LastKey = vbKeySpace)) Or ((KeyCode = vbKeyReturn) And
(LastKey = vbKeyReturn)) Then
RedrawButton 0
LastButton = 1
UserControl.Refresh
RaiseEvent Click
End If
RaiseEvent
KeyUp(KeyCode, Shift)
End Sub
Private Sub UserControl_LostFocus()
flgFocus = False
RedrawButton 0
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift
As Integer, X As Single, Y As Single)
If mEnabled = True
Then
LastButton =
Button
UserControl.Refresh
If Button <>
2 Then RedrawButton 1
RaiseEvent
MouseDown(Button, Shift, X, Y)
End If
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift
As Integer, X As Single, Y As Single)
If Button < 2
Then
If Not isMouseOver
Then
If flgHover = 0
Then Exit Sub
RedrawButton 0
Else
If flgHover = 1
Then Exit Sub
flgHover = 1
If Button = 0
And Not isOver Then
HoverTimer.Enabled = True
isOver = True
flgHover = 0
RedrawButton 0
RaiseEvent
MouseOver
ElseIf Button =
1 Then
isOver = True
RedrawButton 1
isOver = False
End If
End If
End If
RaiseEvent
MouseMove(Button, Shift, X, Y)
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As
Integer, X As Single, Y As Single)
RedrawButton 0
UserControl.Refresh
RaiseEvent
MouseUp(Button, Shift, X, Y)
End Sub
Private Sub UserControl_Resize()
GetClientRect
UserControl.hwnd, rc
With rc
r = .Right - 1: l
= .Left: t = .Top: b = .Bottom
w = .Right: H =
.Bottom
End With
RedrawButton 0
End Sub
Private Function isMouseOver() As Boolean
Dim pt As POINTAPI
GetCursorPos pt
isMouseOver = (WindowFromPoint(pt.X, pt.Y) = hwnd)
End Function
Private Sub MakeRegion()
DeleteObject rgMain
rgMain =
CreateRectRgn(0, 0, w, H)
rgn1 =
CreateRectRgn(0, 0, 1, 1)
'Left top coner
CombineRgn rgMain,
rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 =
CreateRectRgn(0, H - 1, 1, H) 'Left
bottom corner
CombineRgn rgMain,
rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 =
CreateRectRgn(w - 1, 0, w, 1) 'Right
top corner
CombineRgn rgMain,
rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
rgn1 =
CreateRectRgn(w - 1, H - 1, w, H) 'Right bottom corner
CombineRgn rgMain,
rgMain, rgn1, RGN_DIFF
DeleteObject rgn1
SetWindowRgn
UserControl.hwnd, rgMain, True
End Sub
Public Property Get Enabled() As Boolean
Enabled = mEnabled
End Property
Public Property Let Enabled(ByVal NewValue As Boolean)
mEnabled = NewValue
PropertyChanged
"Enabled"
UserControl.Enabled
= NewValue
RedrawButton 0
End Property
Public Property Get Font() As Font
Set Font =
UserControl.Font
End Property
Public Property Set Font(ByVal NewValue As Font)
Set UserControl.Font
= NewValue
RedrawButton 0
PropertyChanged
"Font"
End Property
Public Property Get Caption() As String
Caption = mCaption
End Property
Public Property Let Caption(ByVal NewValue As String)
mCaption = NewValue
RedrawButton 0
SetAccessKeys
PropertyChanged
"Caption"
End Property
Public Property Get ForeColor() As OLE_COLOR
ForeColor =
UserControl.ForeColor
End Property
Public Property Let ForeColor(ByVal NewValue As OLE_COLOR)
UserControl.ForeColor = NewValue
RedrawButton 0
PropertyChanged
"ForeColor"
End Property
Public Property Get ForeHover() As OLE_COLOR
ForeHover =
mForeHover
End Property
Public Property Let ForeHover(ByVal NewValue As OLE_COLOR)
mForeHover =
NewValue
PropertyChanged
"ForeHover"
End Property
Private Sub UserControl_Show()
RedrawButton 0
End Sub
Private Sub UserControl_ReadProperties(PropBag As
PropertyBag)
With PropBag
mEnabled =
.ReadProperty("Enabled", True)
Set
UserControl.Font = .ReadProperty("Font", Ambient.Font)
mCaption =
.ReadProperty("Caption", Ambient.DisplayName)
UserControl.ForeColor = .ReadProperty("ForeColor",
Ambient.ForeColor)
mForeHover =
.ReadProperty("ForeHover", UserControl.ForeColor)
End With
UserControl.Enabled
= mEnabled
SetAccessKeys
End Sub
Private Sub UserControl_WriteProperties(PropBag As
PropertyBag)
With PropBag
.WriteProperty
"Enabled", mEnabled, True
.WriteProperty
"Font", UserControl.Font, Ambient.Font
.WriteProperty
"Caption", mCaption, Ambient.DisplayName
.WriteProperty
"ForeColor", UserControl.ForeColor
.WriteProperty
"ForeHover", mForeHover, Ambient.ForeColor
End With
End Sub
Private Sub SetAccessKeys()
Dim i As Long
UserControl.AccessKeys = ""
If Len(mCaption)
> 1 Then
i = InStr(1,
mCaption, "&", vbTextCompare)
If (i <
Len(mCaption)) And (i > 0) Then
If
Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
Else
i = InStr(i +
2, mCaption, "&", vbTextCompare)
If
Mid$(mCaption, i + 1, 1) <> "&" Then
UserControl.AccessKeys = LCase$(Mid$(mCaption, i + 1, 1))
End If
End If
End If
End If
End Sub
Share : VB.06 (membuat Anti Virus)
VB.06 (membuat Anti Virus)
4/
5
Oleh
Unknown
