Pada pertemuan kali ini tipandtrickunikvb akan membahas tentang sebuah aplikasi untuk mengkompress suatu file gambar dengan menggunakan VB6.
Pada saat kita menggambil sebuah foto atau gambar hasil jepretan kamera ataupun hp biasanya file gambar mempunyai ukurannya lumayan besar kisaran satuan MB. Lalu pada saat kita membutuhkan file gambar tersebut untuk di Upload pada sebuah aplikasi tertentu timbul pesan “File Gambar terlalu besar”. Misalnya pada saat kita mendaftarkan sebuah aplikasi yang memerlukan verifikasi foto atau gambar, terkadang file yang dibutuhkan sudah di tentukan oleh programmer yang tidak boleh melebihi dari kapasitas yang telah ditentukan.
Dari kasus diatas maka untuk mengatasi masalah tersebut satu-satunya jalan adalah mengkompress image atau gambar yang lebih kecil lagi dari ukuran semula agar bisa di upload sesuai kapasitas file yang ditentukan.
Memang banyak berteberan aplikasi pengkompress file image baik offline maupun online yang bisa kita gunakan namun apa salahnya kalau kita membuatnya sendiri dengan program visual basic 6.0 dengan begitu dapat mempunyai kebanggaan tersendiri.
Sekarang saya tidak panjang lebar lagi langsung saja kita bahas bagaimana Cara Membuat Aplikasi Kompres File Image dengan VB6.Simak langkah-langkah dibawah ini:
Cara Membuat Aplikasi Kompres File Image dengan VB6
Buka Form VB6 Anda dengan Standar EXE
Pada Form1 desainlah Form seperti gambar dibawah ini :
 |
| Desain Form |
Untuk lebih jelasnya ikuti tabel dbawah ini untuk mendesain seperti form diatas
| No | Toll Box | Properties | Keterangan |
|---|---|---|---|
| 1 | Label1 | Caption : Cari Lokasi Image | Form1 |
| 2 | Label2 | Name : lblPathLoad Caption :Label2 |
Form1 |
| 3 | Label3 | Caption : Lokasi Penyimpanan Gambar | Form1 |
| 4 | Label4 | Caption :Label4 Name:lblPathTujuan |
Form1 |
| 5 | CommonDialog1 | Name : CommonDialog1 | Form1 |
| 6 | Command1 | Caption : Cari Image Name:cmdLoad |
Form1 |
| 7 | Command2 | Caption : Cek Properties Name:cmdCekProperties |
Form1 |
| 8 | Command3 | Caption : Lokasi Simpan Name :cmdTujuan |
Form1 |
| 9 | Command4 | Caption : Kompress Name:cmdCompres |
Form1 |
| 10 | Command5 | Caption : Cek Properties Name:cmdPropertiesSetelahCompress |
Form1 |
| 11 | Frame1 | Caption: Cari Gambar | Form 1 |
| 12 | Frame2 | Caption : Kompres Gambar | Form 1 |
| 13 | PictureBox | Name:Picture1 | Form 1 |
| 14 | Module1 | Name:- | Moduke1 |
| 15 | Module2 | Name:- | Module2 |
Setelah mendesain form seperti diatas, kita lanjutkan untuk mengisi kode :
Pada Module1 ketik kode dibawah ini :
Type SHELLEXECUTEINFO
cbSize As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon As Long
hProcess As Long
End Type
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Const SEE_MASK_NOCLOSEPROCESS = &H40
Public Const SEE_MASK_FLAG_NO_UI = &H400
Declare Function ShellExecuteEX Lib "shell32.dll" Alias _
"ShellExecuteEx" (SEI As SHELLEXECUTEINFO) As Long
Masukan kode dibawah ini pada Module2 :
Private 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
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_EDITBOX = &H10
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_USENEWUI = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
Private Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
(ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" _
Alias "lstrcatA" (ByVal lpString1 As String, _
ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpBI As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Const CSIDL_DESKTOP = &H0
Const CSIDL_PROGRAMS = &H2
Const CSIDL_CONTROLS = &H3
Const CSIDL_PRINTERS = &H4
Const CSIDL_PERSONAL = &H5
Const CSIDL_FAVORITES = &H6
Const CSIDL_STARTUP = &H7
Const CSIDL_RECENT = &H8
Const CSIDL_SENDTO = &H9
Const CSIDL_BITBUCKET = &HA
Const CSIDL_STARTMENU = &HB
Const CSIDL_DESKTOPDIRECTORY = &H10
Const CSIDL_DRIVES = &H11
Const CSIDL_NETWORK = &H12
Const CSIDL_NETHOOD = &H13
Const CSIDL_FONTS = &H14
Const CSIDL_TEMPLATES = &H15
Const CSIDL_COMMON_STARTMENU = &H16
Const CSIDL_COMMON_PROGRAMS = &H17
Const CSIDL_COMMON_STARTUP = &H18
Const CSIDL_COMMON_DESKTOPDIRECTORY = &H19
Const CSIDL_APPDATA = &H1A
Const CSIDL_PRINTHOOD = &H1B
Private Type SHITEMID
Cb As Long
AbID As Byte
End Type
Private Type ITEMIDLIST
Mkid As SHITEMID
End Type
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function OleInitialize Lib "ole32.dll" (lp As Any) As Long
Private Declare Sub OleUninitialize Lib "ole32" ()
Private Function fGetSpecialFolder(CSIDL As Long, IDL As ITEMIDLIST) As String
Dim sPath As String
If SHGetSpecialFolderLocation(hwnd, CSIDL, IDL) = 0 Then
sPath = Space$(MAX_PATH)
If SHGetPathFromIDList(ByVal IDL.Mkid.Cb, ByVal sPath) Then
fGetSpecialFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1) & "\"
End If
End If
End Function
Public Function fBrowseForFolder(hwndOwner As Long, sPrompt As String) As String
Dim iNull As Long
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim sPath1 As String
Dim udtBI As BrowseInfo
Dim IDL As ITEMIDLIST
'
sPath1 = fGetSpecialFolder(CSIDL_DESKTOP, IDL)
Call OleInitialize(ByVal 0&)
With udtBI
.pIDLRoot = IDL.Mkid.Cb
.hwndOwner = hwndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS + BIF_USENEWUI
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
Call OleUninitialize
fBrowseForFolder = sPath
End Function
Kembali ke Form kemudian ketik kode dibawah ini pada masing-masing komponen Form :
Private Sub cmdCekProperties_Click()
If lblPathLoad.Caption <> vbNullString Then
Call ShowProps(lblPathLoad.Caption, Me.hwnd)
End If
End Sub
Private Sub cmdCompres_Click()
If lblPathTujuan.Caption = vbNullString Then: Exit Sub
Set Picture1 = LoadPicture(lblPathLoad.Caption)
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
Picture1.PaintPicture Picture1.Picture, _
0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
0, 0, Picture1.Picture.Width / 26.46, _
Picture1.Picture.Height / 26.46
Picture1.Picture = Picture1.Image
SavePicture Picture1.Picture, lblPathTujuan.Caption
cmdPropertiesSetelahCompress.Enabled = True
End Sub
Private Sub cmdLoad_Click()
Dim nPath
CommonDialog1.CancelError = True
CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNPathMustExist + cdlOFNFileMustExist
CommonDialog1.Filter = "JPG (*.jpg)|*.jpg|JPEG (*.jpeg)|*.jpeg|BMP (*.bmp)|*.bmp"
CommonDialog1.ShowOpen
nPath = CommonDialog1.FileName
If nPath <> vbNullString Then
lblPathLoad.Caption = nPath
Set Picture1 = LoadPicture(nPath)
Picture1.ScaleMode = 3
Picture1.AutoRedraw = True
Picture1.PaintPicture Picture1.Picture, _
0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, _
0, 0, Picture1.Picture.Width / 26.46, _
Picture1.Picture.Height / 26.46
Picture1.Picture = Picture1.Image
Else
nPath = ""
End If
cmdTujuan.Enabled = True
End Sub
Private Sub cmdPropertiesSetelahCompress_Click()
If lblPathTujuan.Caption <> vbNullString Then
Call ShowProps(lblPathTujuan.Caption, Me.hwnd)
End If
End Sub
Private Sub cmdTujuan_Click()
Dim sStrMySql As String
sStrMySql = fBrowseForFolder(hwnd, "Pilih Direktori Tujuan Simpan")
If sStrMySql <> vbNullString Then
lblPathTujuan.Caption = sStrMySql & "\" & StripPath(lblPathLoad.Caption)
End If
cmdCompres.Enabled = True
End Sub
Private Sub Form_Load()
Set Picture1.Picture = Nothing
lblPathLoad.Caption = ""
lblPathTujuan.Caption = ""
cmdCompres.Enabled = False
cmdTujuan.Enabled = False
cmdPropertiesSetelahCompress.Enabled = False
End Sub
Function StripPath(T$) As String
Dim x%, ct%
StripPath$ = T$
x% = InStr(T$, "\")
Do While x%
ct% = x%
x% = InStr(ct% + 1, T$, "\")
Loop
If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
Public Sub ShowProps(FileName As String, OwnerhWnd _
As Long)
Dim SEI As SHELLEXECUTEINFO
Dim r As Long
With SEI
.cbSize = Len(SEI)
.fMask = SEE_MASK_NOCLOSEPROCESS Or _
SEE_MASK_INVOKEIDLIST Or SEE_MASK_FLAG_NO_UI
.hwnd = OwnerhWnd
.lpVerb = "properties"
.lpFile = FileName
.lpParameters = vbNullChar
.lpDirectory = vbNullChar
.nShow = 0
.hInstApp = 0
.lpIDList = 0
End With
r = ShellExecuteEX(SEI)
End Sub
Simpan kode Anda dan jalankan program, dan anda siap mengkompress file Image Anda sekarang.
 |
| Output Program |
Demikianlah artikel dari saya tentang Cara Membuat Aplikasi Kompres File Image dengan VB6,semoga artikel ini bermanfaat buat kita semua.
apibila ada kesalahan atau error pada program yang Anda buat silahkan tulis dalam komentar.
Jangan lupa tekan tombol share dan bagikan pada tombol dibawah ini
No comments:
Post a Comment