Form Dialog Cetak Buatan Sendiri ini Lebih Canggih Daripada Buatan Access

Judul posting kali ini cukup menantang dan provokatif. Apa iya ada form dialog cetak yang lebih canggih dari buatan Microsoft Access? Jawabannya, iya bisa. Kita bisa membuat sendiri form dialog untuk mencetak report yang ada di Access.

Form View dari form cetak yang diaplikasikan untuk mencetak Voucher.

Keunggulan form dialog cetak yang dibuat sendiri ini antara lain:

Bisa mencetak report sesuai dengan record yang diinginkan. Bila selama ini kita, misalnya menggunakan perintah dari record 1-7 (nomor 1 sampai nomor 7), maka dengan form ini kita bisa mencetak record sembarang, misalnya 1-7 (nomor 1 sampai nomor 7), 9 (nomor 9), 13 (nomor 13), dst.
Bisa mencetak report sesuai dengan halaman yang diinginkan. Sama seperti di atas, bila selama ini kita, misalnya menggunakan perintah dari halaman 1-7 (halaman 1 sampai halaman 7), maka dengan form ini kita bisa mencetak halaman sembarang, misalnya 1-7 (halaman 1 sampai halaman 7), 9 (halaman 9), 13 (halaman 13), dst. Mirip seperti menuliskan halaman di Word.
Ada keunggulan lain yang bisa ditambahkan sesuai dengan keinginan kita, misalnya dengan menambahkan properti margin.

Lalu bagaimana cara membuatnya? Well, jawabannya, ikuti petunjuk berikut ini.

Terlebih dahulu, ikuti petunjuk yang ada di posting berikut ini:

Setelah itu, untuk memulai, kita menggunakan form Form1 yang ada di posting Membuat Fungsi Untuk Daftar Paper Tray/Bin (Tempat Kertas Printer). Untuk memudahkan pemahaman, kita rename dulu nama form Form1 menjadi frmCetak. Setelah itu, sisipkan sejumlah kontrol berikut ini ke dalam form frmCetak.

Design View form frmCetak secara keseluruhan

Option group, lihat gambar bawah, dengan properti Name= fraPilihRecord (1), dengan dua option button dan satu text box sebagai berikut:
1. Properti option button 1: Name= optRecordYgAktif (2), Option Value= 0. Properti untuk label yang melekat pada option optRecordYgAktif: Name= lblRecordYgAktif (3), Caption= Record Yang Aktif.
2. Properti option button 2: Name= optRecordDlmRange (4), Option Value= 1. Properti untuk label yang melekat pada option optRecordDlmRange: Caption= Record Sebagai Berikut.
3. Di dalam Option Group frmPilihRecord, sisipkan sebuah text box di samping label yang mempunyai Caption= Record Sebagai Berikut. Properti text box adalah sebagai berikut: Name= txtRange (5).
  
  Bagian-bagian dari option group fraPilihRecord
Pada bagian kanan form frmCetak, kita sisipkan option group lainnya dengan properti Name= fraOrientasi, dengan dua option button sebagai berikut:
1. Properti option button 1: Name= optPotrait, Option Value= 1. Properti untuk label yang melekat pada option optPotrait: Name= lblPotrait, Caption= Potrait.
2. Properti option button 2: Name= optLandscape, Option Value= 2. Properti untuk label yang melekat pada option optLandscape: Name= lblLandscape, Caption= Landscape.
Di bawah option group fraOrientasi, sisipkan sebuah check box dengan properti Name= cbxCetakDatanyaSaja. Properti label yang melekat check box ini, Caption= Cetak Datanya Saja (abaikan format, label, dan sejenisnya).
Di bawah combo box cbbPaperBin, sisipkan sebuah text box dengan properti: Name= txtSalinan. Properti label yang melekat text box ini, Caption= Jumlah Salinan.
Di bawah text box txtSalinan, sisipkan sebuah text box dengan properti: Name= txtHalamanDlmRange. Properti label yang melekat text box ini, Caption= Halaman Sebagai Berikut.
Sisipkan empat buah tombol perintah atau command button dengan rincian properti sebagai berikut:
1. Tombol perintah 1: Name= cmdPrintPreview, Caption= Print Preview
2. Tombol perintah 2: Name= cmdReportView, Caption= Report View
3. Tombol perintah 3: Name= cmdCetak, Caption= Cetak
4. Tombol perintah 4: Name= cmdBatal, Caption= Batal/Tutup

Berikut ini adalah kode yang harus ditambahkan di modul mdlPrinter:

view plain print ?

Function aturPrintPreview(strRptName As String, Optional intModeWindow As AcWindowMode = acWindowNormal, _
Optional boolCetakLaporan As Boolean = False)
Dim lngHalaman As Variant
Dim strSelectedPage As String
Dim strNamaPrinter As String
Dim n As Integer
Dim prtApp As Printer
Dim strPrinter As String, strPaperSize As String, strPaperBin As String, _
intCopies As Integer, intOrientation As Integer, boolDataOnly As Boolean
Dim intNomorUkuranKertas, intNomorPaperBin As Integer
On Error GoTo Err_Msg
DoCmd.OpenReport strRptName, acPreview, , , intModeWindow
With Form_frmCetak
strNamaPrinter = .cbbPrinter
strPrinter = IIf(IsNull(.cbbPrinter), .cbbPrinter.ItemData(1), .cbbPrinter)
strPaperSize = IIf(IsNull(.cbbUkuranKertas), .cbbUkuranKertas.ItemData(1), .cbbUkuranKertas)
If IsNull(.cbbUkuranKertas) Then
.cbbUkuranKertas = .cbbUkuranKertas.ItemData(1)
End If
intNomorUkuranKertas = .cbbUkuranKertas.Column(0)
If Not IsNull(.cbbPaperBin.Column(0)) Then
intNomorPaperBin = .cbbPaperBin.Column(0)
strPaperBin = .cbbPaperBin.ItemData(1)
End If
intCopies = IIf(IsNull(.txtSalinan), 1, .txtSalinan)
intOrientation = .fraOrientasi
boolDataOnly = .cbxCetakDatanyaSaja
End With
' Get selected printer and set user-specified settings
Set prtApp = Application.Printers(menghitungUrutanPrinter(strPrinter))
With prtApp
.PaperSize = intNomorUkuranKertas
.PaperBin = intNomorPaperBin
.Copies = intCopies
.Orientation = intOrientation
.DataOnly = boolDataOnly
End With
' Set report's printer to selected printer.
Reports(strRptName).Printer = prtApp
'Exit Function
If boolCetakLaporan Then
cetakLaporan strRptName
DoCmd.Close acReport, strRptName
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox Err.description, vbCritical & vbOKOnly, _
"Error Number " & Err.Number & " Occurred"
Resume Exit_Function
End Function
Function cetakLaporan(strRptName As String)
Dim lngHalaman As Variant
Dim i, n As Integer
Dim strItem As Variant
Dim strPrinterPengecualian() As Variant
On Error GoTo Err_Msg
With Form_frmCetak
'dua pernyataan di bawah ini saling berkaitan,
ReDim Preserve strPrinterPengecualian(2) 'Bila nilai strPrinterPengecualian ada sejumlah X item, maka item Array() di bawah ini juga harus ada sejumlah X.
strPrinterPengecualian = Array("PDF", "XPS") 'Isikan nilai item Array() sejumlah nilai strPrinterPengecualian di atas.
For i = LBound(strPrinterPengecualian) To UBound(strPrinterPengecualian)
If InStr(1, .cbbPrinter, CStr(strPrinterPengecualian(i))) <> 0 Then
If Not IsNull(.txtHalamanDlmRange) Then
strMsg = "Format " & strPrinterPengecualian(i) & " hanya bisa digunakan untuk menyimpan semua halaman dalam satu file"
strMsg = strMsg & vbCrLf & "Simpan semua halaman dalam satu file?"
If MsgBox(strMsg, vbYesNo) = vbNo Then Exit Function
End If
DoCmd.PrintOut
Exit Function
End If
Next i
If IsNull(.txtHalamanDlmRange) Then
lngHalaman = Array(1)
DoCmd.PrintOut
Exit Function
Else
lngHalaman = Split(mengaturKriteriaHalaman, ",")
End If
For n = LBound(lngHalaman) To UBound(lngHalaman)
If InStr(1, lngHalaman(n), "-") <> 0 Then
strItem = Split(lngHalaman(n), "-")
Debug.Print CLng(strItem(0))
If Not IsNumeric(Trim(strItem(0))) And Not IsNumeric(Trim(strItem(1))) Then
MsgBox "Nilai yang dimasukkan bukan angka", vbExclamation
Cancel = True
Exit Function
End If
If CInt(Trim(strItem(0))) > CInt(Trim(strItem(1))) Then
MsgBox Trim(strItem(0)) & " harus lebih kecil dari " & (Trim(strItem(1))), vbExclamation
Cancel = True
Exit Function
End If
For i = CInt(Trim(strItem(0))) To CInt(Trim(strItem(1)))
'Debug.Print CLng(strItem(n))
DoCmd.PrintOut acPages, i, i, acDraft
Next i
Else
Debug.Print CLng(lngHalaman(n))
DoCmd.PrintOut acPages, CLng(lngHalaman(n)), CLng(lngHalaman(n)), acDraft
End If
Next n
End With
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Function cetakLaporan, Error # " & str(Err.Number) & ", source: " & Err.Source & _
Chr(13) & Err.description
Resume Exit_Function
End Function
Function membukaFormCetak(strsql As String, strNamaReport As String, _
Optional strNamaTabel As String = vbNullString, _
Optional strNamaField As String = vbNullString, _
Optional varNilaiField As Variant = vbNullString, _
Optional boolRecordYgAktif As Boolean = True, _
Optional boolSelectedRecord As Boolean = True, _
Optional intOrientasi As AcPrintOrientation = acPRORPortrait, _
Optional boolCetakDatanyaSaja As Boolean = False)
Dim varNilaiField2 As Variant
Dim strCaption As String
On Error GoTo Err_Msg
varNilaiField2 = konversiNilaiField(strNamaField, strNamaTabel, varNilaiField)
If varNilaiField <> vbNullString Then
strCaption = arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpCaption)
End If
TempVars.Add "rptRecordSource", strsql
TempVars.Add "rptNamaReport", strNamaReport
TempVars.Add "tmpNamaTabel", strNamaTabel
TempVars.Add "tmpNamaField", strNamaField
TempVars.Add "tmpNilaiField2", CStr(varNilaiField)
DoCmd.OpenForm "frmCetak"
With Form_frmCetak
If strNamaField <> vbNullString Then
.fraPilihRecord = 0
If boolRecordYgAktif Then
.lblRecordYgAktif.Caption = .lblRecordYgAktif.Caption & " (" & strCaption & "=" & varNilaiField2 & ")"
End If
End If
.fraOrientasi = intOrientasi
.cbxCetakDatanyaSaja = boolCetakDatanyaSaja
.cbbPrinter.SeparatorCharacters = 2
.cbbPrinter.RowSource = Join(membuatDaftarPrinter, ";")
.cbbPrinter = Application.Printer.DeviceName
membuatDaftarUkuranKertas Forms(.Name), .cbbUkuranKertas, menghitungUrutanPrinter(.cbbPrinter)
.cbbUkuranKertas = .cbbUkuranKertas.ItemData(1)
membuatDaftarPaperBin Forms(.Name), .cbbPaperBin, .cbbPrinter
End With
strNamaReport1 = strNamaReport
strSQLStatement1 = strsql
If strNamaField <> vbNullString Then
strSQLStatement1 = strSQLStatement1 & " WHERE " & strNamaField & "=" & varNilaiField2
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Function membukaFormCetak, Error # " & str(Err.Number) & ", source: " & Err.Source & _
Chr(13) & Err.description
Resume Exit_Function
End Function
Function mengaturKriteriaHalaman() As Variant
Dim strWhere As String, strItem As Variant
Dim strItem2 As Variant
Dim i, j, m, n As Integer
Dim strOItem() As Variant
Dim globalCriteria As String
On Error GoTo Err_Msg
strResult = vbNullString
With Form_frmCetak
strItem = Split(.txtHalamanDlmRange, ",")
i = 0
For n = LBound(strItem) To UBound(strItem)
If CStr(strItem(n)) = vbNullString Then
strResult = "Ada nilai yang tidak sesuai di " & .txtHalamanDlmRange
MsgBox strResult
Exit Function
End If
If InStr(1, strItem(n), "-") <> 0 Then
strItem2 = Split(strItem(n), "-")
If Not IsNumeric(strItem2(0)) Then
MsgBox strItem2(0) & " bukan angka!", vbCritical
Exit Function
End If
If Not IsNumeric(strItem2(1)) Then
MsgBox strItem2(1) & " bukan angka!", vbCritical
Exit Function
End If
If CLng(strItem2(0)) > CLng(strItem2(1)) Then
MsgBox strItem2(1) & " harus lebih besar atau sama dengan " & CLng(strItem2(0)) & "!", vbCritical
Exit Function
End If
For m = CLng(strItem2(0)) To CLng(strItem2(1))
ReDim Preserve strOItem(i + 1)
strOItem(i) = m
i = i + 1
Next m
Else
If Not IsNumeric(strItem(n)) Then
MsgBox strItem(n) & " bukan angka!", vbCritical
Exit Function
End If
ReDim Preserve strOItem(i + 1)
strOItem(i) = Trim(strItem(n))
i = i + 1
End If
Next n
ReDim Preserve strOItem(i - 1)
globalCriteria = Join(strOItem, ",")
End With
mengaturKriteriaHalaman = globalCriteria
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Function mengaturKriteriaHalaman, Error # " & str(Err.Number) & ", source: " & Err.Source & _
Chr(13) & Err.description
Resume Exit_Function
End Function
Function mengaturKriteriaRange(strNamaField As String, strNamaTabel As String) As String
Dim strWhere As String, strItem As Variant
Dim strItem2 As Variant
Dim i, n As Integer
Dim strOItem() As String
Dim strOItem2() As String
Dim globalCriteria As String
On Error GoTo Err_Msg
strResult = vbNullString
With Form_frmCetak
If .fraPilihRecord = 0 Then
strItem = Split([TempVars]![tmpNilaiField2], ",")
Else
strItem = Split(.txtRange, ",")
End If
i = 0
ReDim Preserve strOItem2(UBound(strItem))
For n = LBound(strItem) To UBound(strItem)
strOItem2(n) = Trim(strItem(n))
Next n
strItem = strOItem2
For n = LBound(strItem) To UBound(strItem)
If strItem(n) = "" Then
strResult = "Ada nilai yang kosong di: " & .txtRange
MsgBox strResult
mengaturKriteriaRange = vbNullString
Exit Function
End If
If InStr(1, strItem(n), "-") <> 0 Then
strItem2 = Split(strItem(n), "-")
If arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Text" Then
If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = "in " & strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & " BETWEEN '" & Trim(strItem2(0)) & "'" & " AND '" & Trim(strItem2(1)) & "'"
ElseIf arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Date" Then
If Not IsDate(strItem2(0)) Or Not IsDate(strItem2(1)) Then
strResult = "Tipe data tidak tepat di " & strItem(n)
globalCriteria = vbNullString
Exit Function
End If
If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = "in " & strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & " BETWEEN #" & Trim(strItem2(0)) & "#" & " AND #" & Trim(strItem2(1)) & "#"
Else
If Not IsNumeric(strItem2(0)) Or Not IsNumeric(strItem2(1)) Then
strResult = "Tipe data tidak tepat di " & strItem(n)
globalCriteria = vbNullString
Exit Function
End If
If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = "in " & strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & " BETWEEN " & Trim(strItem2(0)) & " AND " & Trim(strItem2(1))
End If
Else
If arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Text" Then
If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & "='" & strItem(n) & "'"
ElseIf arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Date" Then
If Not IsDate(strItem(n)) Then
strResult = "Tipe data tidak tepat di " & strItem(n)
globalCriteria = vbNullString
Exit Function
End If
If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & "=#" & strItem(n) & "#"
Else
If Not IsNumeric(strItem(n)) Then
strResult = "Tipe data tidak tepat di " & strItem(n)
globalCriteria = vbNullString
Exit Function
End If
If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
ReDim Preserve strOItem(i + 1)
strOItem(i) = strItem(n)
i = i + 1
End If
strItem(n) = strNamaField & "=" & strItem(n)
End If
End If
Next n
If i > 0 Then
strResult = "Nilai data tak dikenal:" & vbCrLf & vbCrLf & Join(strOItem, vbCrLf)
MsgBox strResult
globalCriteria = vbNullString
Else
globalCriteria = Join(strItem, " Or ")
End If
mengaturKriteriaRange = globalCriteria
End With
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Function mengaturKriteriaRange, Error # " & str(Err.Number) & ", source: " & Err.Source & _
Chr(13) & Err.description
Resume Exit_Function
End Function

Function aturPrintPreview(strRptName As String, Optional intModeWindow As AcWindowMode = acWindowNormal, _
                          Optional boolCetakLaporan As Boolean = False)
  Dim lngHalaman As Variant
  Dim strSelectedPage As String
  Dim strNamaPrinter As String
  Dim n As Integer
  Dim prtApp As Printer
  Dim strPrinter As String, strPaperSize As String, strPaperBin As String, _
              intCopies As Integer, intOrientation As Integer, boolDataOnly As Boolean
  Dim intNomorUkuranKertas, intNomorPaperBin As Integer

On Error GoTo Err_Msg
  DoCmd.OpenReport strRptName, acPreview, , , intModeWindow
  With Form_frmCetak
    strNamaPrinter = .cbbPrinter
    strPrinter = IIf(IsNull(.cbbPrinter), .cbbPrinter.ItemData(1), .cbbPrinter)
    strPaperSize = IIf(IsNull(.cbbUkuranKertas), .cbbUkuranKertas.ItemData(1), .cbbUkuranKertas)
    If IsNull(.cbbUkuranKertas) Then
      .cbbUkuranKertas = .cbbUkuranKertas.ItemData(1)
    End If
    intNomorUkuranKertas = .cbbUkuranKertas.Column(0)
    If Not IsNull(.cbbPaperBin.Column(0)) Then
      intNomorPaperBin = .cbbPaperBin.Column(0)
      strPaperBin = .cbbPaperBin.ItemData(1)
    End If
    intCopies = IIf(IsNull(.txtSalinan), 1, .txtSalinan)
    intOrientation = .fraOrientasi
    boolDataOnly = .cbxCetakDatanyaSaja
  End With
    ' Get selected printer and set user-specified settings
  Set prtApp = Application.Printers(menghitungUrutanPrinter(strPrinter))
  With prtApp
    .PaperSize = intNomorUkuranKertas
    .PaperBin = intNomorPaperBin
    .Copies = intCopies
    .Orientation = intOrientation
    .DataOnly = boolDataOnly
  End With
  ' Set report's printer to selected printer.
  Reports(strRptName).Printer = prtApp
  'Exit Function
  If boolCetakLaporan Then
    cetakLaporan strRptName
    DoCmd.Close acReport, strRptName
  End If
    
Exit_Function:
    Exit Function
    
Err_Msg:
    MsgBox Err.description, vbCritical & vbOKOnly, _
        "Error Number " & Err.Number & " Occurred"
    Resume Exit_Function
End Function

Function cetakLaporan(strRptName As String)
  Dim lngHalaman As Variant
  Dim i, n As Integer
  Dim strItem As Variant
  Dim strPrinterPengecualian() As Variant
On Error GoTo Err_Msg
  With Form_frmCetak
'dua pernyataan di bawah ini saling berkaitan,
    ReDim Preserve strPrinterPengecualian(2) 'Bila nilai strPrinterPengecualian ada sejumlah X item, maka item Array() di bawah ini juga harus ada sejumlah X.
    strPrinterPengecualian = Array("PDF", "XPS") 'Isikan nilai item Array() sejumlah nilai strPrinterPengecualian di atas.
    
    For i = LBound(strPrinterPengecualian) To UBound(strPrinterPengecualian)
      If InStr(1, .cbbPrinter, CStr(strPrinterPengecualian(i))) <> 0 Then
        If Not IsNull(.txtHalamanDlmRange) Then
          strMsg = "Format " & strPrinterPengecualian(i) & " hanya bisa digunakan untuk menyimpan semua halaman dalam satu file"
          strMsg = strMsg & vbCrLf & "Simpan semua halaman dalam satu file?"
          If MsgBox(strMsg, vbYesNo) = vbNo Then Exit Function
        End If
        DoCmd.PrintOut
        Exit Function
      End If
    Next i
    If IsNull(.txtHalamanDlmRange) Then
      lngHalaman = Array(1)
      DoCmd.PrintOut
      Exit Function
    Else
      lngHalaman = Split(mengaturKriteriaHalaman, ",")
    End If
  
    For n = LBound(lngHalaman) To UBound(lngHalaman)
      If InStr(1, lngHalaman(n), "-") <> 0 Then
        strItem = Split(lngHalaman(n), "-")
Debug.Print CLng(strItem(0))
        If Not IsNumeric(Trim(strItem(0))) And Not IsNumeric(Trim(strItem(1))) Then
          MsgBox "Nilai yang dimasukkan bukan angka", vbExclamation
          Cancel = True
          Exit Function
        End If
        If CInt(Trim(strItem(0))) > CInt(Trim(strItem(1))) Then
          MsgBox Trim(strItem(0)) & " harus lebih kecil dari " & (Trim(strItem(1))), vbExclamation
          Cancel = True
          Exit Function
        End If
        For i = CInt(Trim(strItem(0))) To CInt(Trim(strItem(1)))
'Debug.Print CLng(strItem(n))
          DoCmd.PrintOut acPages, i, i, acDraft
        Next i
      Else
Debug.Print CLng(lngHalaman(n))
        DoCmd.PrintOut acPages, CLng(lngHalaman(n)), CLng(lngHalaman(n)), acDraft
      End If
    Next n
  End With
Exit_Function:
  Exit Function
Err_Msg:
  MsgBox "Function cetakLaporan, Error # " & str(Err.Number) & ", source: " & Err.Source & _
  Chr(13) & Err.description
  Resume Exit_Function
End Function

Function membukaFormCetak(strsql As String, strNamaReport As String, _
                          Optional strNamaTabel As String = vbNullString, _
                          Optional strNamaField As String = vbNullString, _
                          Optional varNilaiField As Variant = vbNullString, _
                          Optional boolRecordYgAktif As Boolean = True, _
                          Optional boolSelectedRecord As Boolean = True, _
                          Optional intOrientasi As AcPrintOrientation = acPRORPortrait, _
                          Optional boolCetakDatanyaSaja As Boolean = False)
  Dim varNilaiField2 As Variant
  Dim strCaption As String
On Error GoTo Err_Msg
  varNilaiField2 = konversiNilaiField(strNamaField, strNamaTabel, varNilaiField)
  If varNilaiField <> vbNullString Then
    strCaption = arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpCaption)
  End If
  TempVars.Add "rptRecordSource", strsql
  TempVars.Add "rptNamaReport", strNamaReport
  TempVars.Add "tmpNamaTabel", strNamaTabel
  TempVars.Add "tmpNamaField", strNamaField
  TempVars.Add "tmpNilaiField2", CStr(varNilaiField)
  
  DoCmd.OpenForm "frmCetak"
  With Form_frmCetak
    If strNamaField <> vbNullString Then
    .fraPilihRecord = 0
    If boolRecordYgAktif Then
      .lblRecordYgAktif.Caption = .lblRecordYgAktif.Caption & " (" & strCaption & "=" & varNilaiField2 & ")"
    End If
    End If
    .fraOrientasi = intOrientasi
    .cbxCetakDatanyaSaja = boolCetakDatanyaSaja
    .cbbPrinter.SeparatorCharacters = 2
    .cbbPrinter.RowSource = Join(membuatDaftarPrinter, ";")
    .cbbPrinter = Application.Printer.DeviceName
    membuatDaftarUkuranKertas Forms(.Name), .cbbUkuranKertas, menghitungUrutanPrinter(.cbbPrinter)
    .cbbUkuranKertas = .cbbUkuranKertas.ItemData(1)
    membuatDaftarPaperBin Forms(.Name), .cbbPaperBin, .cbbPrinter
  End With
  strNamaReport1 = strNamaReport
  strSQLStatement1 = strsql
  If strNamaField <> vbNullString Then
    strSQLStatement1 = strSQLStatement1 & " WHERE " & strNamaField & "=" & varNilaiField2
  End If
Exit_Function:
  Exit Function
Err_Msg:
  MsgBox "Function membukaFormCetak, Error # " & str(Err.Number) & ", source: " & Err.Source & _
  Chr(13) & Err.description
  Resume Exit_Function
End Function

Function mengaturKriteriaHalaman() As Variant
  Dim strWhere As String, strItem As Variant
  Dim strItem2 As Variant
  Dim i, j, m, n As Integer
  Dim strOItem() As Variant
  Dim globalCriteria As String
On Error GoTo Err_Msg
  strResult = vbNullString

  With Form_frmCetak
    strItem = Split(.txtHalamanDlmRange, ",")
    i = 0
    For n = LBound(strItem) To UBound(strItem)
    
      If CStr(strItem(n)) = vbNullString Then
        strResult = "Ada nilai yang tidak sesuai di " & .txtHalamanDlmRange
        MsgBox strResult
        Exit Function
      End If
      If InStr(1, strItem(n), "-") <> 0 Then
        strItem2 = Split(strItem(n), "-")
        If Not IsNumeric(strItem2(0)) Then
          MsgBox strItem2(0) & " bukan angka!", vbCritical
          Exit Function
        End If
        If Not IsNumeric(strItem2(1)) Then
          MsgBox strItem2(1) & " bukan angka!", vbCritical
          Exit Function
        End If
        If CLng(strItem2(0)) > CLng(strItem2(1)) Then
          MsgBox strItem2(1) & " harus lebih besar atau sama dengan " & CLng(strItem2(0)) & "!", vbCritical
          Exit Function
        End If
        For m = CLng(strItem2(0)) To CLng(strItem2(1))
          ReDim Preserve strOItem(i + 1)
          strOItem(i) = m
          i = i + 1
        Next m
      Else
        If Not IsNumeric(strItem(n)) Then
          MsgBox strItem(n) & " bukan angka!", vbCritical
          Exit Function
        End If
        ReDim Preserve strOItem(i + 1)
        strOItem(i) = Trim(strItem(n))
        i = i + 1
      End If
    Next n
  ReDim Preserve strOItem(i - 1)
  globalCriteria = Join(strOItem, ",")
  End With
  mengaturKriteriaHalaman = globalCriteria
Exit_Function:
  Exit Function
Err_Msg:
  MsgBox "Function mengaturKriteriaHalaman, Error # " & str(Err.Number) & ", source: " & Err.Source & _
  Chr(13) & Err.description
  Resume Exit_Function
End Function

Function mengaturKriteriaRange(strNamaField As String, strNamaTabel As String) As String
  Dim strWhere As String, strItem As Variant
  Dim strItem2 As Variant
  Dim i, n As Integer
  Dim strOItem() As String
  Dim strOItem2() As String
  Dim globalCriteria As String
On Error GoTo Err_Msg
  strResult = vbNullString

  With Form_frmCetak
    If .fraPilihRecord = 0 Then
      strItem = Split([TempVars]![tmpNilaiField2], ",")
    Else
      strItem = Split(.txtRange, ",")
    End If
    i = 0
    
    ReDim Preserve strOItem2(UBound(strItem))
    For n = LBound(strItem) To UBound(strItem)
      strOItem2(n) = Trim(strItem(n))
    Next n
    strItem = strOItem2

    For n = LBound(strItem) To UBound(strItem)
      If strItem(n) = "" Then
        strResult = "Ada nilai yang kosong di: " & .txtRange
        MsgBox strResult
        mengaturKriteriaRange = vbNullString
        Exit Function
      End If
      
      If InStr(1, strItem(n), "-") <> 0 Then
        strItem2 = Split(strItem(n), "-")
        If arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Text" Then
          If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
          adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = "in " & strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & " BETWEEN '" & Trim(strItem2(0)) & "'" & " AND '" & Trim(strItem2(1)) & "'"
        ElseIf arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Date" Then
          If Not IsDate(strItem2(0)) Or Not IsDate(strItem2(1)) Then
            strResult = "Tipe data tidak tepat di " & strItem(n)
            globalCriteria = vbNullString
            Exit Function
          End If
          If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
          adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = "in " & strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & " BETWEEN #" & Trim(strItem2(0)) & "#" & " AND #" & Trim(strItem2(1)) & "#"
        Else
          If Not IsNumeric(strItem2(0)) Or Not IsNumeric(strItem2(1)) Then
            strResult = "Tipe data tidak tepat di " & strItem(n)
            globalCriteria = vbNullString
            Exit Function
          End If
          If Not (adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(0)))) Or _
          adaNilaiField(strNamaField, strNamaTabel, CStr(Trim(strItem2(1))))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = "in " & strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & " BETWEEN " & Trim(strItem2(0)) & " AND " & Trim(strItem2(1))
        End If
      Else
        If arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Text" Then
          If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & "='" & strItem(n) & "'"
        ElseIf arrayTampilkanPropertiField(strNamaField, strNamaTabel, prpTypeGlobal) = "Date" Then
          If Not IsDate(strItem(n)) Then
            strResult = "Tipe data tidak tepat di " & strItem(n)
            globalCriteria = vbNullString
            Exit Function
          End If
          If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & "=#" & strItem(n) & "#"
        Else
          If Not IsNumeric(strItem(n)) Then
            strResult = "Tipe data tidak tepat di " & strItem(n)
            globalCriteria = vbNullString
            Exit Function
          End If
          If Not adaNilaiField(strNamaField, strNamaTabel, CStr(strItem(n))) Then
            ReDim Preserve strOItem(i + 1)
            strOItem(i) = strItem(n)
            i = i + 1
          End If
          strItem(n) = strNamaField & "=" & strItem(n)
        End If
      End If
    Next n
    If i > 0 Then
      strResult = "Nilai data tak dikenal:" & vbCrLf & vbCrLf & Join(strOItem, vbCrLf)
      MsgBox strResult
      globalCriteria = vbNullString
    Else
      globalCriteria = Join(strItem, " Or ")
    End If
  mengaturKriteriaRange = globalCriteria
  End With
Exit_Function:
  Exit Function
Err_Msg:
  MsgBox "Function mengaturKriteriaRange, Error # " & str(Err.Number) & ", source: " & Err.Source & _
  Chr(13) & Err.description
  Resume Exit_Function
End Function

Langkah berikutnya, ganti kode VBA di modul form frmCetak dengan kode VBA di bawah ini:

view plain print ?

Option Compare Database
Private Sub cbbPrinter_Change()
membuatDaftarUkuranKertas Forms(Me.Name), Controls(Me.cbbUkuranKertas.Name), menghitungUrutanPrinter(Me.cbbPrinter)
membuatDaftarPaperBin Forms(Me.Name), Controls(Me.cbbPaperBin.Name), Me.cbbPrinter
End Sub
Private Sub cmdCetak_Click()
If Not validasi Then Exit Sub
If seleksi Then aturPrintPreview [TempVars]![rptNamaReport], , True
End Sub
Private Sub cmdPrintView_Click()
If Not validasi Then Exit Sub
If seleksi Then aturPrintPreview [TempVars]![rptNamaReport]
End Sub
Private Function validasi() As Boolean
Dim blnIsValidPrinter As Boolean
Dim ukuranKertas() As String
' Jika printer tidak ada lakukan prosedur di bawah ini
If IsNull(Me.cbbPrinter.Value) Then
MsgBox Prompt:="Pilih nama printer yang sesuai."
Me.cbbPrinter = Application.Printer.DeviceName
validasi = False
Exit Function
End If
blnIsValidPrinter = False
' Periksa apakah printer sudah valid
For Each prt In Application.Printers
If prt.DeviceName = Me.cbbPrinter.Value Then
blnIsValidPrinter = True
End If
Next
' Jika printer tidak valid lakukan prosedur di bawah ini.
If Not blnIsValidPrinter Then
MsgBox "Pilih printer yang sesuai"
Me.cbbPrinter = Application.Printer.DeviceName
validasi = False
Exit Function
End If
blnIsValidPrinter = False
ReDim Preserve ukuranKertas(Me.cbbUkuranKertas.ListCount - 1)
For n = 0 To Me.cbbUkuranKertas.ListCount - 1
ukuranKertas(n) = Me.cbbUkuranKertas.ItemData(n)
If Me.cbbUkuranKertas = ukuranKertas(n) Then
blnIsValidPrinter = True
End If
Next n
If Not blnIsValidPrinter Then
MsgBox "Pilih ukuran kertas yang sesuai"
validasi = False
Exit Function
End If
validasi = True
End Function
Private Function seleksi() As Boolean
If Me.fraPilihRecord = 0 Then
TempVars.Add "rptRecordSource1", [TempVars]![rptRecordSource] & " WHERE " & _
mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel])
Else
If IsNull(Me.txtRange) Then
TempVars.Remove "rptRecordSource2"
TempVars.Remove "rptRecordSource1"
TempVars.Add "rptRecordSource1", CStr([TempVars]![rptRecordSource])
seleksi = True
Exit Function
Else
If mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel]) = vbNullString Then
seleksi = False
Exit Function
Else
TempVars.Add "rptRecordSource1", [TempVars]![rptRecordSource] & " WHERE " & _
mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel])
End If
End If
End If
seleksi = True
End Function
Private Sub cmdReportView_Click()
If seleksi Then DoCmd.OpenReport [TempVars]![rptNamaReport], acViewReport
End Sub
Private Sub Form_Close()
TempVars.Remove "rptRecordSource"
TempVars.Remove "rptNamaReport"
TempVars.Remove "tmpNamaTabel"
TempVars.Remove "tmpNamaField"
TempVars.Remove "tmpNilaiField2"
TempVars.Remove "rptRecordSource1"
End Sub
Private Sub txtRange_GotFocus()
Me.fraPilihRecord = 1
End Sub

Option Compare Database

Private Sub cbbPrinter_Change()
  membuatDaftarUkuranKertas Forms(Me.Name), Controls(Me.cbbUkuranKertas.Name), menghitungUrutanPrinter(Me.cbbPrinter)
  membuatDaftarPaperBin Forms(Me.Name), Controls(Me.cbbPaperBin.Name), Me.cbbPrinter
End Sub
Private Sub cmdCetak_Click()
  If Not validasi Then Exit Sub
  If seleksi Then aturPrintPreview [TempVars]![rptNamaReport], , True
End Sub

Private Sub cmdPrintView_Click()
  If Not validasi Then Exit Sub
  If seleksi Then aturPrintPreview [TempVars]![rptNamaReport]

End Sub
Private Function validasi() As Boolean
  Dim blnIsValidPrinter As Boolean
  Dim ukuranKertas() As String
  ' Jika printer tidak ada lakukan prosedur di bawah ini
  If IsNull(Me.cbbPrinter.Value) Then
      MsgBox Prompt:="Pilih nama printer yang sesuai."
      Me.cbbPrinter = Application.Printer.DeviceName
      validasi = False
      Exit Function
  End If
  blnIsValidPrinter = False
  
  ' Periksa apakah printer sudah valid
  For Each prt In Application.Printers
      If prt.DeviceName = Me.cbbPrinter.Value Then
          blnIsValidPrinter = True
      End If
  Next
  
  ' Jika printer tidak valid lakukan prosedur di bawah ini.
  If Not blnIsValidPrinter Then
      MsgBox "Pilih printer yang sesuai"
      Me.cbbPrinter = Application.Printer.DeviceName
      validasi = False
      Exit Function
  End If
  
  blnIsValidPrinter = False
  ReDim Preserve ukuranKertas(Me.cbbUkuranKertas.ListCount - 1)
  For n = 0 To Me.cbbUkuranKertas.ListCount - 1
    ukuranKertas(n) = Me.cbbUkuranKertas.ItemData(n)
    If Me.cbbUkuranKertas = ukuranKertas(n) Then
      blnIsValidPrinter = True
    End If
  Next n
  If Not blnIsValidPrinter Then
    MsgBox "Pilih ukuran kertas yang sesuai"
    validasi = False
    Exit Function
  End If
  validasi = True
End Function
Private Function seleksi() As Boolean
  If Me.fraPilihRecord = 0 Then
    TempVars.Add "rptRecordSource1", [TempVars]![rptRecordSource] & " WHERE " & _
      mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel])
  Else
    If IsNull(Me.txtRange) Then
      TempVars.Remove "rptRecordSource2"
      TempVars.Remove "rptRecordSource1"
      TempVars.Add "rptRecordSource1", CStr([TempVars]![rptRecordSource])
      seleksi = True
      Exit Function
    Else
      If mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel]) = vbNullString Then
        seleksi = False
        Exit Function
      Else
        TempVars.Add "rptRecordSource1", [TempVars]![rptRecordSource] & " WHERE " & _
          mengaturKriteriaRange([TempVars]![tmpNamaField], [TempVars]![tmpNamaTabel])
      End If
    End If
  End If
  seleksi = True
End Function
Private Sub cmdReportView_Click()
  If seleksi Then DoCmd.OpenReport [TempVars]![rptNamaReport], acViewReport
End Sub

Private Sub Form_Close()
  TempVars.Remove "rptRecordSource"
  TempVars.Remove "rptNamaReport"
  TempVars.Remove "tmpNamaTabel"
  TempVars.Remove "tmpNamaField"
  TempVars.Remove "tmpNilaiField2"
  TempVars.Remove "rptRecordSource1"
End Sub

Private Sub txtRange_GotFocus()
  Me.fraPilihRecord = 1
End Sub

Untuk dapat menjalankan kode VBA di atas, ada fungsi-fungsi tertentu yang harus dibuat terlebih dahulu. Jadi, fungsi-fungsi di atas tidak berdiri sendiri, mereka tergantung pada fungsi lain yang ada di halaman Database Front-end dan Back-end terutama fungsi yang ada di modul mdlCore, nomor 1 s/d 27. Ke-27 fungsi itu harus ada.

Terakhir, pada report yang ingin di printview, report view, atau dicetak, sisipkan event procedure on Open sebagai berikut:

view plain print ?

Private Sub Report_Open(Cancel As Integer)
If Not IsNull([TempVars]![rptRecordSource1]) Then Me.RecordSource = [TempVars]![rptRecordSource1]
End Sub

Private Sub Report_Open(Cancel As Integer)
  If Not IsNull([TempVars]![rptRecordSource1]) Then Me.RecordSource = [TempVars]![rptRecordSource1]
End Sub

Untuk membuka form frmCetak, kita harus menyisipkan sebuah tombol perintah yang digunakan untuk membuka form itu, melalui event procedure On Click. Contohnya pada gambar di bawah ini.

Pada tombol, misalnya ber-caption Open Print Report (properti Name=cmdPrintReport) event On Click, sisipkan kode VBA berikut ini:

view plain print ?

Private Sub cmdPrintReport_Click()
If IsNull(Me.vouchId) Then
membukaFormCetak "SELECT tblVoucherTemp.*, tblVoucherTempEntries.*, tblPrimaryAccountsFin.primaryaccountName, " _
& "tblTipeDokumen.docDeskripsi FROM ((tblVoucherTemp INNER JOIN tblPrimaryAccountsFin ON " _
& "tblVoucherTemp.vouchPrimaryAccountCode = tblPrimaryAccountsFin.documentCoding) LEFT JOIN " _
& "tblVoucherTempEntries ON tblVoucherTemp.vouchId = tblVoucherTempEntries.vouchId) INNER JOIN " _
& "tblTipeDokumen ON tblVoucherTemp.vouchType = tblTipeDokumen.dokTipe", "rptVoucherTemp", False, , acPRORPortrait, True
Else
membukaFormCetak "SELECT tblVoucherTemp.*, tblVoucherTempEntries.*, tblPrimaryAccountsFin.primaryaccountName, tblTipeDokumen.docDeskripsi FROM ((tblVoucherTemp INNER JOIN tblPrimaryAccountsFin ON tblVoucherTemp.vouchPrimaryAccountCode = tblPrimaryAccountsFin.documentCoding) LEFT JOIN tblVoucherTempEntries ON tblVoucherTemp.vouchId = tblVoucherTempEntries.vouchId) INNER JOIN tblTipeDokumen ON tblVoucherTemp.vouchType = tblTipeDokumen.dokTipe", "rptVoucherTemp", "tblVoucherTemp", _
"tblVoucherTemp.vouchId", Me.vouchId, , , acPRORPortrait, True
End If
End Sub

Private Sub cmdPrintReport_Click()
  If IsNull(Me.vouchId) Then
    membukaFormCetak "SELECT tblVoucherTemp.*, tblVoucherTempEntries.*, tblPrimaryAccountsFin.primaryaccountName, " _
    & "tblTipeDokumen.docDeskripsi FROM ((tblVoucherTemp INNER JOIN tblPrimaryAccountsFin ON " _
    & "tblVoucherTemp.vouchPrimaryAccountCode = tblPrimaryAccountsFin.documentCoding) LEFT JOIN " _
    & "tblVoucherTempEntries ON tblVoucherTemp.vouchId = tblVoucherTempEntries.vouchId) INNER JOIN " _
    & "tblTipeDokumen ON tblVoucherTemp.vouchType = tblTipeDokumen.dokTipe", "rptVoucherTemp", False, , acPRORPortrait, True
  Else
    membukaFormCetak "SELECT tblVoucherTemp.*, tblVoucherTempEntries.*, tblPrimaryAccountsFin.primaryaccountName, tblTipeDokumen.docDeskripsi FROM ((tblVoucherTemp INNER JOIN tblPrimaryAccountsFin ON tblVoucherTemp.vouchPrimaryAccountCode = tblPrimaryAccountsFin.documentCoding) LEFT JOIN tblVoucherTempEntries ON tblVoucherTemp.vouchId = tblVoucherTempEntries.vouchId) INNER JOIN tblTipeDokumen ON tblVoucherTemp.vouchType = tblTipeDokumen.dokTipe", "rptVoucherTemp", "tblVoucherTemp", _
    "tblVoucherTemp.vouchId", Me.vouchId, , , acPRORPortrait, True
  End If
End Sub

Dengan demikian, saat tombol Open Print Report diklik, form frmCetak akan terbuka dengan isi form yang sudah diatur terlebih dahulu melalui fungsi membukaFormCetak.

Untuk memahami penerapan form cetak dan fungsi VBA yang mendukung didalamnya, kita dapat melihat video demonya di bawah ini

Pada video itu kita bisa mencetak record sesuai dengan keinginan, baik melalui primary key, maupun melalui halaman tertentu. Sangat fleksibel. Contohnya, 1,5 menit terakhir dari video demo itu berisi halaman tertentu yang dicetak sesuai dengan pengaturan nomor halaman di form cetak.

Khusus untuk primary key, ada tiga tipe data yang bisa dibaca, Number, Text, dan Date/Time. Jadi misalnya primary key untuk Number: 1,2,3,5-9, 21-34, dst., untuk Text misalnya AMB, BDG-JKT, MRK, dst., untuk Date misalnya, 1/21/2018, 1/23/2018-1/24/2018, dst. Jadi, kita tidak perlu menggunakan tanda "'" (tanda petik tunggal) untuk menyatakan tipe datanya berupa Text atau "#" (tanda pagar) untuk menyatakan tipe datanya berupa Date/Time.

SILAKAN DICOBA!!!😎. .

Comments

Novianto15 November, 2019 09:51
gan mau tanya, kalo semisal saya buat form dialog cetak tapi isinya cuman list printer yang ada di control panel dan bisa langsung nyambung dengan report dan printernya yang di pilih itu diambil kodingnya yg mana aja ya ?? terima kasih
Novianto15 November, 2019 10:30
standart yg dipakai acces tidak terdapat pilihan printernya, sempet coba DoCmd.RunCommand acCmdPrint tp ketika sudah dipilih printernya settingan printernya tidak mau mengikuti settingan printer di control panel. tujuan saya bikin form dialog cetak sendiri agar bisa mengganti pilihan printer agar tidak bingung" mengubah default printer di control panel,dan ketika printer yg dipilih di form dialog sendiri, bisa langsung otomatis conect printer sekaligus settingan seperti kertas dll di control panel
Novianto15 November, 2019 15:39
satu lagi mas, koding ini bisa dibuat di access xp kah ?? soalnya yang saya pakai office xp (access xp)

Access Terapan

Search This Blog

Form Dialog Cetak Buatan Sendiri ini Lebih Canggih Daripada Buatan Access

Labels

Comments

Post a Comment

Posting Terpopuler

Membuat Fungsi Terbilang Dalam Bahasa Inggris di MS Access VBA

Format Untuk Field Dengan Tipe Data Date/Time di MS Access

Menampilkan Menu Autoformat Di Access 2010 ke atas