' ====================================================================
' PROSEDUR INISIALISASI MANUAL - JALANKAN INI UNTUK SETUP APLIKASI
' ====================================================================
Sub InisialisasiAplikasi()
On Error Resume Next
' Hapus sheet yang sudah ada jika diperlukan (opsional)
Application.DisplayAlerts = False
If SheetExists("Dashboard") Then Sheets("Dashboard").Delete
If SheetExists("Data") Then Sheets("Data").Delete
If SheetExists("Settings") Then Sheets("Settings").Delete
Application.DisplayAlerts = True
' Buat sheet baru
Sheets.Add.Name = "Dashboard"
Sheets.Add.Name = "Data"
Sheets.Add.Name = "Settings"
' Setup masing-masing sheet
Call SetupDashboard
Call SetupDataSheet
Call SetupSettingsSheet
' Tampilkan dashboard
Sheets("Dashboard").Select
MsgBox "Aplikasi Buffer Stock IT berhasil diinisialisasi!", vbInformation
End Sub
' ====================================================================
' FUNGSI PEMBANTU
' ====================================================================
Function SheetExists(sheetName As String) As Boolean
' Fungsi untuk mengecek apakah sheet sudah ada
On Error Resume Next
SheetExists = (Sheets(sheetName).Name <> "")
On Error GoTo 0
End Function
' ====================================================================
' SETUP SHEET DASHBOARD
' ====================================================================
Sub SetupDashboard()
' Setup dashboard layout
With Sheets("Dashboard")
' Judul
.Range("A1").Value = "DASHBOARD BUFFER STOCK BARANG IT"
.Range("A1:H1").Merge
.Range("A1").Font.Size = 16
.Range("A1").Font.Bold = True
.Range("A1").HorizontalAlignment = xlCenter
' Tombol
.Shapes.AddShape(msoShapeRoundedRectangle, 50, 50, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 112, 192)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Tambah Item"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "TambahItem"
Selection.ShapeRange.Name = "btnTambah"
.Shapes.AddShape(msoShapeRoundedRectangle, 180, 50, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Refresh Data"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "RefreshData"
Selection.ShapeRange.Name = "btnRefresh"
.Shapes.AddShape(msoShapeRoundedRectangle, 310, 50, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 0, 0)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Hapus Item"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "HapusItem"
Selection.ShapeRange.Name = "btnHapus"
.Shapes.AddShape(msoShapeRoundedRectangle, 440, 50, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(112, 48, 160)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Email
Settings"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "ShowEmailSettings"
Selection.ShapeRange.Name = "btnEmailSettings"
' Filter
.Range("A4").Value = "Filter Indent:"
.Range("A4").Font.Bold = True
.Range("B4").Value = "Semua"
.Range("C4").Value = "1 Bulan"
.Range("D4").Value = "2 Bulan"
.Range("E4").Value = "3 Bulan"
.Range("F4").Value = "> 3 Bulan"
.Range("B4:F4").Select
Selection.Borders.LineStyle = xlContinuous
Selection.Font.Bold = True
Selection.HorizontalAlignment = xlCenter
Selection.Interior.Color = RGB(217, 217, 217)
' Keterangan warna
.Range("A3").Value = "Keterangan Warna:"
.Range("A3").Font.Bold = True
.Range("B3").Interior.Color = RGB(255, 199, 206)
.Range("B3").Borders.LineStyle = xlContinuous
.Range("C3:D3").Merge
.Range("C3").Value = "Stok Tersisa 1 (Kritis)"
.Range("E3").Interior.Color = RGB(255, 235, 156)
.Range("E3").Borders.LineStyle = xlContinuous
.Range("F3:G3").Merge
.Range("F3").Value = "Stok Di Bawah Buffer"
' Header tabel
.Range("A6").Value = "No."
.Range("B6").Value = "Kode Barang"
.Range("C6").Value = "Nama Barang"
.Range("D6").Value = "Kategori"
.Range("E6").Value = "Stok Buffer"
.Range("F6").Value = "Stok Tersedia"
.Range("G6").Value = "Indent Period"
.Range("H6").Value = "Tanggal Update"
.Range("A6:H6").Select
Selection.Font.Bold = True
Selection.Interior.Color = RGB(0, 112, 192)
Selection.Font.Color = RGB(255, 255, 255)
Selection.Borders.LineStyle = xlContinuous
Selection.HorizontalAlignment = xlCenter
' Atur lebar kolom
.Columns("A").ColumnWidth = 5
.Columns("B").ColumnWidth = 15
.Columns("C").ColumnWidth = 25
.Columns("D").ColumnWidth = 15
.Columns("E").ColumnWidth = 12
.Columns("F").ColumnWidth = 12
.Columns("G").ColumnWidth = 15
.Columns("H").ColumnWidth = 18
' Setup event click pada filter
' CATATAN: Tidak bisa dibuat otomatis, harus ditempatkan di kode Sheet
"Dashboard"
.Hyperlinks.Add Anchor:=.Range("B4"), Address:="", SubAddress:="B4",
TextToDisplay:="Semua"
.Hyperlinks.Add Anchor:=.Range("C4"), Address:="", SubAddress:="C4",
TextToDisplay:="1 Bulan"
.Hyperlinks.Add Anchor:=.Range("D4"), Address:="", SubAddress:="D4",
TextToDisplay:="2 Bulan"
.Hyperlinks.Add Anchor:=.Range("E4"), Address:="", SubAddress:="E4",
TextToDisplay:="3 Bulan"
.Hyperlinks.Add Anchor:=.Range("F4"), Address:="", SubAddress:="F4",
TextToDisplay:="> 3 Bulan"
End With
' Panggil refresh data untuk pertama kali
Call RefreshData
End Sub
' ====================================================================
' SETUP SHEET DATA
' ====================================================================
Sub SetupDataSheet()
With Sheets("Data")
' Header
.Range("A1").Value = "ID"
.Range("B1").Value = "Kode Barang"
.Range("C1").Value = "Nama Barang"
.Range("D1").Value = "Kategori"
.Range("E1").Value = "Stok Buffer"
.Range("F1").Value = "Stok Tersedia"
.Range("G1").Value = "Indent Period"
.Range("H1").Value = "Tanggal Update"
.Range("A1:H1").Select
Selection.Font.Bold = True
Selection.Interior.Color = RGB(0, 112, 192)
Selection.Font.Color = RGB(255, 255, 255)
Selection.Borders.LineStyle = xlContinuous
' Atur lebar kolom
.Columns("A").ColumnWidth = 5
.Columns("B").ColumnWidth = 15
.Columns("C").ColumnWidth = 25
.Columns("D").ColumnWidth = 15
.Columns("E").ColumnWidth = 12
.Columns("F").ColumnWidth = 12
.Columns("G").ColumnWidth = 15
.Columns("H").ColumnWidth = 18
' Sembunyikan sheet data
.Visible = xlSheetHidden
End With
End Sub
' ====================================================================
' SETUP SHEET SETTINGS
' ====================================================================
Sub SetupSettingsSheet()
' Setup sheet settings
With Sheets("Settings")
' Judul
.Range("A1").Value = "PENGATURAN EMAIL NOTIFIKASI"
.Range("A1:D1").Merge
.Range("A1").Font.Size = 14
.Range("A1").Font.Bold = True
.Range("A1").HorizontalAlignment = xlCenter
' Email settings
.Range("A3").Value = "Email Tujuan:"
.Range("A3").Font.Bold = True
.Range("B3").Value = ""
.Range("B3").Interior.Color = RGB(255, 255, 200)
.Range("B3:D3").Merge
.Range("A4").Value = "Aktifkan Email Notifikasi:"
.Range("A4").Font.Bold = True
.Range("B4").Value = "TIDAK"
.Range("B4").Font.Bold = True
.Range("A6").Value = "Subjek Email:"
.Range("A6").Font.Bold = True
.Range("B6").Value = "[NOTIFIKASI] Stok Barang IT Kritis"
.Range("B6:D6").Merge
.Range("A7").Value = "Interval Cek (jam):"
.Range("A7").Font.Bold = True
.Range("B7").Value = 24
.Range("B7").NumberFormat = "0"
.Range("A9").Value = "Terakhir Dikirim:"
.Range("A9").Font.Bold = True
.Range("B9").Value = ""
.Range("B9:C9").Merge
' Tombol simpan
.Shapes.AddShape(msoShapeRoundedRectangle, 100, 200, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 176, 80)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Simpan
Setting"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "SaveEmailSettings"
Selection.ShapeRange.Name = "btnSaveSettings"
' Tombol test email
.Shapes.AddShape(msoShapeRoundedRectangle, 240, 200, 120, 30).Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(0, 112, 192)
Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "Test Email"
Selection.ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB =
RGB(255, 255, 255)
Selection.ShapeRange.TextFrame2.TextRange.Font.Bold = msoTrue
Selection.ShapeRange.OnAction = "TestEmail"
Selection.ShapeRange.Name = "btnTestEmail"
' Instruksi
.Range("A12").Value = "Catatan:"
.Range("A12").Font.Bold = True
.Range("A13").Value = "1. Pastikan Outlook sudah terinstal untuk
menggunakan fitur email notifikasi."
.Range("A14").Value = "2. Email notifikasi akan dikirim saat aplikasi
dibuka dan saat data diperbarui."
.Range("A15").Value = "3. Notifikasi hanya akan dikirim jika ada barang
dengan stok tersisa 1 unit."
.Range("A16").Value = "4. Interval cek digunakan untuk menghindari
pengiriman email yang terlalu sering."
' Sembunyikan sheet Settings
.Visible = xlSheetHidden
End With
End Sub
' ====================================================================
' FUNGSI MENAMBAH ITEM BARU
' ====================================================================
Sub TambahItem()
' Menampilkan form untuk menambah item baru
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Data")
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim newID As Long
If lastRow = 1 Then
newID = 1
Else
newID = ws.Cells(lastRow, 1).Value + 1
End If
' Input data
Dim kodeBarang As String
Dim namaBarang As String
Dim kategori As String
Dim stokBuffer As Long
Dim stokTersedia As Long
Dim indentPeriod As String
kodeBarang = InputBox("Masukkan Kode Barang:", "Tambah Item Baru")
If kodeBarang = "" Then Exit Sub
namaBarang = InputBox("Masukkan Nama Barang:", "Tambah Item Baru")
If namaBarang = "" Then Exit Sub
kategori = InputBox("Masukkan Kategori Barang:", "Tambah Item Baru")
If kategori = "" Then Exit Sub
On Error Resume Next
stokBuffer = CLng(InputBox("Masukkan Jumlah Stok Buffer:", "Tambah Item Baru"))
If Err.Number <> 0 Then
MsgBox "Masukkan angka yang valid untuk Stok Buffer!", vbExclamation
Exit Sub
End If
stokTersedia = CLng(InputBox("Masukkan Jumlah Stok Tersedia:", "Tambah Item
Baru"))
If Err.Number <> 0 Then
MsgBox "Masukkan angka yang valid untuk Stok Tersedia!", vbExclamation
Exit Sub
End If
On Error GoTo 0
' Pilih indent period dari dropdown
Dim indentOptions As String
indentOptions = "1 Bulan,2 Bulan,3 Bulan,> 3 Bulan"
Dim selectedIndent As String
selectedIndent = InputBox("Pilih Indent Period:" & vbCrLf & _
"1. 1 Bulan" & vbCrLf & _
"2. 2 Bulan" & vbCrLf & _
"3. 3 Bulan" & vbCrLf & _
"4. > 3 Bulan" & vbCrLf & vbCrLf & _
"Masukkan nomor pilihan (1-4):", "Tambah Item Baru")
If selectedIndent = "" Then Exit Sub
Dim choice As Integer
On Error Resume Next
choice = CInt(selectedIndent)
On Error GoTo 0
If choice < 1 Or choice > 4 Then
MsgBox "Pilihan tidak valid!", vbExclamation
Exit Sub
End If
Select Case choice
Case 1: selectedIndent = "1 Bulan"
Case 2: selectedIndent = "2 Bulan"
Case 3: selectedIndent = "3 Bulan"
Case 4: selectedIndent = "> 3 Bulan"
End Select
' Simpan data ke sheet Data
ws.Cells(lastRow + 1, 1).Value = newID
ws.Cells(lastRow + 1, 2).Value = kodeBarang
ws.Cells(lastRow + 1, 3).Value = namaBarang
ws.Cells(lastRow + 1, 4).Value = kategori
ws.Cells(lastRow + 1, 5).Value = stokBuffer
ws.Cells(lastRow + 1, 6).Value = stokTersedia
ws.Cells(lastRow + 1, 7).Value = selectedIndent
ws.Cells(lastRow + 1, 8).Value = Now()
MsgBox "Data berhasil ditambahkan!", vbInformation
' Refresh tampilan dashboard
Call RefreshData
End Sub
' ====================================================================
' FUNGSI REFRESH DATA
' ====================================================================
Sub RefreshData()
' Refresh data di dashboard berdasarkan filter yang dipilih
Dim wsData As Worksheet
Dim wsDashboard As Worksheet
Set wsData = ThisWorkbook.Sheets("Data")
Set wsDashboard = ThisWorkbook.Sheets("Dashboard")
' Bersihkan data sebelumnya
If wsDashboard.Range("A7").Value <> "" Then
Dim lastRow As Long
lastRow = wsDashboard.Cells(wsDashboard.Rows.Count, "A").End(xlUp).Row
If lastRow > 6 Then
wsDashboard.Range("A7:H" & lastRow).ClearContents
wsDashboard.Range("A7:H" & lastRow).Interior.ColorIndex = xlNone
wsDashboard.Range("A7:H" & lastRow).Font.Bold = False
wsDashboard.Range("A7:H" & lastRow).Font.Color = RGB(0, 0, 0)
End If
End If
' Dapatkan filter yang aktif
Dim activeFilter As String
activeFilter = "Semua" ' Default
If wsDashboard.Range("B4").Font.Underline = xlUnderlineStyleSingle Then
activeFilter = "Semua"
ElseIf wsDashboard.Range("C4").Font.Underline = xlUnderlineStyleSingle Then
activeFilter = "1 Bulan"
ElseIf wsDashboard.Range("D4").Font.Underline = xlUnderlineStyleSingle Then
activeFilter = "2 Bulan"
ElseIf wsDashboard.Range("E4").Font.Underline = xlUnderlineStyleSingle Then
activeFilter = "3 Bulan"
ElseIf wsDashboard.Range("F4").Font.Underline = xlUnderlineStyleSingle Then
activeFilter = "> 3 Bulan"
End If
' Jika tidak ada yang terpilih, pilih "Semua"
If activeFilter = "Semua" Then
wsDashboard.Range("B4").Font.Underline = xlUnderlineStyleSingle
wsDashboard.Range("C4:F4").Font.Underline = xlNone
End If
' Salin data dari sheet Data ke Dashboard sesuai filter
Dim dataLastRow As Long
dataLastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
If dataLastRow <= 1 Then
' Tidak ada data
Exit Sub
End If
Dim targetRow As Long
targetRow = 7 ' Baris awal di dashboard
Dim i As Long
For i = 2 To dataLastRow ' Mulai dari 2 karena baris 1 adalah header
Dim includeRow As Boolean
includeRow = False
If activeFilter = "Semua" Then
includeRow = True
ElseIf wsData.Cells(i, 7).Value = activeFilter Then
includeRow = True
End If
If includeRow Then
' Salin data ke dashboard
wsDashboard.Cells(targetRow, 1).Value = targetRow - 6 ' Nomor urut
wsDashboard.Cells(targetRow, 2).Value = wsData.Cells(i, 2).Value ' Kode
Barang
wsDashboard.Cells(targetRow, 3).Value = wsData.Cells(i, 3).Value ' Nama
Barang
wsDashboard.Cells(targetRow, 4).Value = wsData.Cells(i, 4).Value '
Kategori
wsDashboard.Cells(targetRow, 5).Value = wsData.Cells(i, 5).Value ' Stok
Buffer
wsDashboard.Cells(targetRow, 6).Value = wsData.Cells(i, 6).Value ' Stok
Tersedia
wsDashboard.Cells(targetRow, 7).Value = wsData.Cells(i, 7).Value '
Indent Period
wsDashboard.Cells(targetRow, 8).Value = wsData.Cells(i, 8).Value '
Tanggal Update
' Format tanggal
wsDashboard.Cells(targetRow, 8).NumberFormat = "dd-mmm-yyyy hh:mm"
' Format angka
wsDashboard.Cells(targetRow, 5).NumberFormat = "#,##0"
wsDashboard.Cells(targetRow, 6).NumberFormat = "#,##0"
' Atur warna baris berselang-seling dan warna khusus untuk stok kritis
If wsData.Cells(i, 6).Value = 1 Then
' Warna merah untuk stok tersisa 1
wsDashboard.Range("A" & targetRow & ":H" &
targetRow).Interior.Color = RGB(255, 199, 206)
' Warna teks bold untuk peringatan
wsDashboard.Range("F" & targetRow).Font.Bold = True
wsDashboard.Range("F" & targetRow).Font.Color = RGB(192, 0, 0)
ElseIf wsData.Cells(i, 6).Value < wsData.Cells(i, 5).Value Then
' Warna kuning untuk stok di bawah buffer namun > 1
wsDashboard.Range("A" & targetRow & ":H" &
targetRow).Interior.Color = RGB(255, 235, 156)
wsDashboard.Range("F" & targetRow).Font.Bold = True
ElseIf (targetRow - 6) Mod 2 = 0 Then
wsDashboard.Range("A" & targetRow & ":H" &
targetRow).Interior.Color = RGB(240, 240, 240)
wsDashboard.Range("F" & targetRow).Font.Bold = False
wsDashboard.Range("F" & targetRow).Font.Color = RGB(0, 0, 0)
Else
wsDashboard.Range("A" & targetRow & ":H" &
targetRow).Interior.Color = RGB(255, 255, 255)
wsDashboard.Range("F" & targetRow).Font.Bold = False
wsDashboard.Range("F" & targetRow).Font.Color = RGB(0, 0, 0)
End If
' Format teks di tengah untuk kolom tertentu
wsDashboard.Range("A" & targetRow & ":A" &
targetRow).HorizontalAlignment = xlCenter
wsDashboard.Range("G" & targetRow & ":H" &
targetRow).HorizontalAlignment = xlCenter
' Tambahkan border
wsDashboard.Range("A" & targetRow & ":H" & targetRow).Borders.LineStyle
= xlContinuous
targetRow = targetRow + 1
End If
Next i
' Tampilkan pesan jika tidak ada data yang sesuai filter
If targetRow = 7 Then
wsDashboard.Range("A7").Value = "Tidak ada data yang sesuai dengan filter."
wsDashboard.Range("A7:H7").Merge
wsDashboard.Range("A7").HorizontalAlignment = xlCenter
wsDashboard.Range("A7").Font.Italic = True
End If
' Cek stok rendah dan kirim email jika diperlukan
Call CheckLowStockAndSendEmail
End Sub
' ====================================================================
' FUNGSI FILTER
' ====================================================================
Sub ApplyFilter(filterRange As String)
' Fungsi untuk mengaplikasikan filter
Dim wsDashboard As Worksheet
Set wsDashboard = ThisWorkbook.Sheets("Dashboard")
' Reset semua filter
wsDashboard.Range("B4:F4").Font.Underline = xlNone
' Aktifkan filter yang dipilih
wsDashboard.Range(filterRange).Font.Underline = xlUnderlineStyleSingle
' Refresh data
Call RefreshData
End Sub
' CATATAN: Fungsi ini harus ditempatkan di kode Sheet "Dashboard"
' untuk mendukung hyperlink filter
'Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
' ' Fungsi untuk menangani klik pada filter
' If Target.Range.Address = "$B$4" Then ' Semua
' Call ApplyFilter("B4")
' ElseIf Target.Range.Address = "$C$4" Then ' 1 Bulan
' Call ApplyFilter("C4")
' ElseIf Target.Range.Address = "$D$4" Then ' 2 Bulan
' Call ApplyFilter("D4")
' ElseIf Target.Range.Address = "$E$4" Then ' 3 Bulan
' Call ApplyFilter("E4")
' ElseIf Target.Range.Address = "$F$4" Then ' > 3 Bulan
' Call ApplyFilter("F4")
' End If
'End Sub
' ====================================================================
' FUNGSI HAPUS ITEM
' ====================================================================
Sub HapusItem()
' Fungsi untuk menghapus item berdasarkan ID
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Data")
Dim idToDelete As String
idToDelete = InputBox("Masukkan ID item yang akan dihapus:", "Hapus Item")
If idToDelete = "" Then Exit Sub
On Error Resume Next
Dim idNum As Long
idNum = CLng(idToDelete)
If Err.Number <> 0 Then
MsgBox "ID harus berupa angka!", vbExclamation
Exit Sub
End If
On Error GoTo 0
' Cari item dengan ID yang sesuai
Dim foundRow As Long
foundRow = 0
Dim lastRow As Long
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim i As Long
For i = 2 To lastRow
If ws.Cells(i, 1).Value = idNum Then
foundRow = i
Exit For
End If
Next i
If foundRow = 0 Then
MsgBox "Item dengan ID " & idToDelete & " tidak ditemukan.", vbExclamation
Exit Sub
End If
' Konfirmasi penghapusan
Dim namaBarang As String
namaBarang = ws.Cells(foundRow, 3).Value
Dim response As VbMsgBoxResult
response = MsgBox("Anda yakin ingin menghapus item '" & namaBarang & "' (ID: "
& idNum & ")?", vbYesNo + vbQuestion, "Konfirmasi Hapus")
If response = vbYes Then
' Hapus baris
ws.Rows(foundRow).Delete
MsgBox "Item berhasil dihapus.", vbInformation
' Refresh data
Call RefreshData
End If
End Sub
' ====================================================================
' FUNGSI EMAIL SETTINGS
' ====================================================================
Sub ShowEmailSettings()
' Tampilkan sheet settings
Sheets("Settings").Visible = xlSheetVisible
Sheets("Settings").Select
End Sub
Sub SaveEmailSettings()
' Simpan pengaturan email
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Settings")
' Validasi email
Dim emailAddr As String
emailAddr = ws.Range("B3").Value
If emailAddr = "" Then
MsgBox "Masukkan alamat email tujuan!", vbExclamation
ws.Range("B3").Select
Exit Sub
End If
' Validasi sederhana format email
If InStr(1, emailAddr, "@") = 0 Or InStr(1, emailAddr, ".") = 0 Then
MsgBox "Format email tidak valid!", vbExclamation
ws.Range("B3").Select
Exit Sub
End If
' Toggle status email
If ws.Range("B4").Value = "TIDAK" Then
ws.Range("B4").Value = "YA"
ws.Range("B4").Font.Color = RGB(0, 128, 0)
Else
ws.Range("B4").Value = "TIDAK"
ws.Range("B4").Font.Color = RGB(192, 0, 0)
End If
MsgBox "Pengaturan email berhasil disimpan!", vbInformation
End Sub
Sub TestEmail()
' Kirim email test
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Settings")
' Validasi email
Dim emailAddr As String
emailAddr = ws.Range("B3").Value
If emailAddr = "" Then
MsgBox "Masukkan alamat email tujuan terlebih dahulu!", vbExclamation
ws.Range("B3").Select
Exit Sub
End If
' Validasi sederhana format email
If InStr(1, emailAddr, "@") = 0 Or InStr(1, emailAddr, ".") = 0 Then
MsgBox "Format email tidak valid!", vbExclamation
ws.Range("B3").Select
Exit Sub
End If
' Kirim email test
On Error Resume Next
Dim outlookApp As Object
Dim outlookMail As Object
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.To = emailAddr
.Subject = "Test Email dari Aplikasi Buffer Stock IT"
.Body = "Ini adalah email test dari aplikasi Buffer Stock IT." & vbCrLf &
vbCrLf & _
"Jika Anda menerima email ini, berarti pengaturan email sudah
benar." & vbCrLf & vbCrLf & _
"Tanggal & Waktu: " & Now
.Send
End With
If Err.Number <> 0 Then
MsgBox "Gagal mengirim email. Pastikan Outlook telah dikonfigurasi dengan
benar." & vbCrLf & _
"Error: " & Err.Description, vbCritical
Else
MsgBox "Email test berhasil dikirim ke " & emailAddr & "!", vbInformation
ws.Range("B9").Value = Now
ws.Range("B9").NumberFormat = "dd-mmm-yyyy hh:mm"
End If
On Error GoTo 0
Set outlookMail = Nothing
Set outlookApp = Nothing
End Sub
' ====================================================================
' FUNGSI CEK STOK DAN KIRIM EMAIL
' ====================================================================
Sub CheckLowStockAndSendEmail()
' Cek apakah ada barang dengan stok = 1 dan kirim email jika perlu
Dim wsData As Worksheet
Dim wsSettings As Worksheet
Set wsData = ThisWorkbook.Sheets("Data")
Set wsSettings = ThisWorkbook.Sheets("Settings")
' Cek apakah notifikasi email diaktifkan
If wsSettings.Range("B4").Value <> "YA" Then
Exit Sub
End If
' Cek interval
Dim lastSent As Date
If IsDate(wsSettings.Range("B9").Value) Then
lastSent = wsSettings.Range("B9").Value
Dim intervalHours As Double
intervalHours = wsSettings.Range("B7").Value
' Jika belum waktunya untuk mengirim email lagi, keluar
If Now < DateAdd("h", intervalHours, lastSent) Then
Exit Sub
End If
End If
' Cek apakah ada barang dengan stok = 1
Dim lastRow As Long
lastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row
If lastRow <= 1 Then
Exit Sub ' Tidak ada data
End If
Dim lowStockItems As String
lowStockItems = ""
Dim i As Long
For i = 2 To lastRow
If wsData.Cells(i, 6).Value = 1 Then ' Stok tersedia = 1
lowStockItems = lowStockItems & "- " & wsData.Cells(i, 3).Value & "
(Kode: " & _
wsData.Cells(i, 2).Value & "), Stok Tersisa: 1" & vbCrLf
End If
Next i
' Jika ada barang dengan stok = 1, kirim email
If lowStockItems <> "" Then
' Kirim email
On Error Resume Next
Dim outlookApp As Object
Dim outlookMail As Object
Set outlookApp = CreateObject("Outlook.Application")
Set outlookMail = outlookApp.CreateItem(0)
With outlookMail
.To = wsSettings.Range("B3").Value
.Subject = wsSettings.Range("B6").Value
.Body = "Notifikasi Stok Barang IT Kritis" & vbCrLf & vbCrLf & _
"Berikut daftar barang IT dengan stok tersisa 1 unit:" & vbCrLf
& vbCrLf & _
lowStockItems & vbCrLf & vbCrLf & _
"Mohon segera tindak lanjuti untuk menghindari kehabisan stok."
& vbCrLf & vbCrLf & _
"Email ini dikirim otomatis dari Aplikasi Buffer Stock Barang
IT pada " & Now
.Send
End With
If Err.Number = 0 Then
' Update waktu terakhir kirim email
wsSettings.Range("B9").Value = Now
wsSettings.Range("B9").NumberFormat = "dd-mmm-yyyy hh:mm"
End If
On Error GoTo 0
Set outlookMail = Nothing
Set outlookApp = Nothing
End If
End Sub
