Modul global berisi fungsi yang tidak mengacu pada satu aktivitas obyek tertentu. Modul global digunakan untuk memudahkan identifikasi bahwa fungsi-fungsi yang ada di dalamnya bersifat global. Contohnya adalah fungsi tombol untuk kembali ke awal record (first), record sebelum (previous), record berikut (next), akhir record (last), dan sebagainya. Oleh karena itu modul seperti ini disimpan dengan nama mdlGlobal.
Berikut ini adalah fungsi yang ada di modul mdlGlobal. Sebelum menambahkan fungsi-fungsi di bawah ini ke mdlGlobal, tambahkan terlebih dahulu kode VBA yang ada di modul sederhana, di postingan sebelumnya.
Function Sebelumnya()
'------------------------------------------
' Sebelumnya, arahkan ke record sebelumnya
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdRecordsGoToPrevious
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function BuatRecordBaru()
'------------------------------------------
' BuatRecord, membuat record baru
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdRefresh
DoCmd.RunCommand acCmdRecordsGoToNew
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Berikutnya()
'------------------------------------------
' Berikutnya, arahkan ke record berikutnya
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdRecordsGoToNext
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Akhir()
'------------------------------------------
' Akhir, arahkan ke akhir record
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdRefresh
DoCmd.RunCommand acCmdRecordsGoToLast
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Tutup()
'------------------------------------------
' Tutup, menutup form yang aktif
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdClose
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Hapus(Optional strSumberRecord As String)
'------------------------------------------
' Hapus, menghapus record yang aktif
'------------------------------------------
Dim strMsg As String
On Error GoTo Err_Msg
DoCmd.SetWarnings False
If strSumberRecord <> "" Then
If AdaRelasiTabel(strSumberRecord) Then
strMsg = "Pengguna tidak diperkenankan untuk menghapus data ini karena " & vbCrLf
strMsg = strMsg & "data yang ada dalam form ini ada kaitannya (relasi) dengan data di tabel lain" & vbCrLf
strMsg = strMsg & "Menghapus data ini berarti menghapus data di tabel lain."
MsgBox strMsg
Exit Function
End If
End If
strMsg = "Data yang sudah dihapus tidak dapat ditampilkan kembali. " & vbCrLf
strMsg = strMsg & "Anda yakin ingin menghapus data ini?"
If MsgBox(strMsg, vbYesNo) = vbYes Then
DoCmd.RunCommand acCmdDeleteRecord
End If
DoCmd.SetWarnings True
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Batalkan()
'------------------------------------------
' Batalkan, membatalkan aksi terakhir
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.DoMenuItem acFormBar, acEditMenu, acUndo, , acMenuVer70
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Cari()
'------------------------------------------
' Cari, mencari nilai suatu field
'------------------------------------------
On Error GoTo Err_Msg
Screen.PreviousControl.SetFocus
DoCmd.DoMenuItem acFormBar, acEditMenu, 10, , acMenuVer70
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function TutupAplikasiIni()
'------------------------------------------
' Tutup database ini
'------------------------------------------
On Error GoTo Err_Msg
CloseCurrentDatabase
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Sourcbe & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function KeluarDariAccss()
'------------------------------------------
' Keluar dari Access
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdExit
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function Preview(stDocName As String)
'------------------------------------------
' Preview report, memerlukan refresh terlebih dahulu
' supaya report menampilkan data terbaru
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.RunCommand acCmdRefresh 'form direfresh lebih dulu
DoCmd.OpenReport stDocName, acPreview 'tampilkan report dengan data terbaru
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function PreviewUnRefresh(stDocName As String, Optional blViewReport As Boolean)
'------------------------------------------
' Preview_Unrefreshed report, tak memerluka refresh
' dengan menampilkan data terbaru. Cocok untuk
' kotak dialog
'------------------------------------------
On Error GoTo Err_Msg
If blViewReport Then
DoCmd.OpenReport stDocName, acViewReport
Else
DoCmd.OpenReport stDocName, acPreview
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function BukaForm(stDocName As String)
'------------------------------------------
' BukaForm, membuka form baru
'------------------------------------------
On Error GoTo Err_Msg
DoCmd.OpenForm stDocName
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function EksporKeExcel(strNamaObyek, strSumber As String, Optional strSubSumber As String)
'------------------------------------------
' Fungsi untuk mengekspor tabel atau query ke Excel.
' strNamaObyek : nama file target di Excel
' strSumber: nama form yang aktif terbuka
' strSubSumber: nama subform yang aktif terbuka
'------------------------------------------
Dim ctl As Control
Dim adaControl As Boolean
On Error GoTo Err_Msg
globSumberRecord = ""
globNamaObyek = ""
If Not AdaForm(strSumber) Then
MsgBox "Tidak ada nama " & strSumber
Exit Function
End If
adaControl = False
If strSubSumber <> "" Then
If Forms(strSumber).Controls(strSubSumber).[SourceObject] = "" Then
MsgBox "Tidak ada data yang diekspor"
Exit Function
End If
For Each ctl In Forms(strSumber).Controls
If ctl.Name = strSubSumber Then
adaControl = True
Exit For
End If
Next ctl
If Not adaControl Then
MsgBox "Tidak ada nama " & strSubSumber
Exit Function
End If
Else
strSubSumber = strSumber
End If
If strSubSumber = strSumber Then
strSubSumberSourceObject = Forms(strSumber).RecordSource
Else
strSubSumberSourceObject = Forms(strSumber).Controls(str SubSumber).[Form].[RecordSource]
End If
globSumberRecord = strSubSumberSourceObject
If globSumberRecord = "" Then
MsgBox "Tidak ada data yang akan diekspor"
Exit Function
End If
globNamaObyek = strNamaObyek
BukaForm "frmEksporDialog"
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function NamaFolder(ByRef strFullPath As String) As String
'------------------------------------------
' Fungsi untuk mengecek nama folder
' dengan nama strFullPath.
' Digunakan untuk ekspor tabel ke Excel
'------------------------------------------
Dim tSlash As String
On Error GoTo Err_Msg
If Left(Environ$("OS"), 3) = "mac" Then tSlash = "/" Else tSlash = "\"
NamaFolder = Left(strFullPath, InStrRev(strFullPath, tSlash))
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AdaFolder(DriveSpec As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah ada sebuah folder
' dengan nama DriveSpec.
' Digunakan untuk ekspor tabel ke Excel
'------------------------------------------
Dim strNamaFolder As String
Dim fso As Object
On Error GoTo Err_Msg
strNamaFolder = NamaFolder(DriveSpec)
Set fso = CreateObject("Scripting.FileSystemObject")
Select Case fso.FolderExists(strNamaFolder)
Case True
AdaFolder = True
Case False
AdaFolder = False
End Select
Set fso = Nothing
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AdaRelasiTabel(strNamaTabel As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah ada tabel
' dengan nama strNamaTabel yang mempunyai
' relasi dengan tabel lain.
'------------------------------------------
Dim obj As AccessObject, dbsObject As Object
Dim rel As DAO.Relation
Dim qdf As DAO.QueryDef
Dim dbs As DAO.Database
Dim i As Integer
Dim AdaTabel As Boolean
On Error GoTo Err_Msg
Set dbs = CurrentDb
Set dbsObject = Application.CurrentData
AdaTabel = False
For Each obj In dbsObject.AllTables
If obj.Name = strNamaTabel Then
AdaTabel = True
Exit For
End If
Next obj
If AdaTabel Then
For Each rel In dbs.Relations
If rel.Table = strNamaTabel Then
AdaRelasiTabel = True
Exit Function
End If
Next rel
Else
If AdaTabelQuery(strNamaTabel) Then
Set qdf = dbs.QueryDefs(strNamaTabel)
Else
Set qdf = dbs.CreateQueryDef("", strNamaTabel)
End If
With qdf
For i = 0 To .Fields.Count - 1
If AdaTabelQuery(.Fields(i).SourceTable) Then
For Each rel In dbs.Relations
If rel.Table = .Fields(i).SourceTable Then
AdaRelasiTabel = True
Exit Function
End If
Next rel
End If
Next i
End With
qdf.Close
Set qdf = Nothing
End If
AdaRelasiTabel = False
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function BacaLokasiFolder() As String
'------------------------------------------
' Fungsi untuk membaca folder dari
' software ini.
' Digunakan untuk import/ekspor data
'------------------------------------------
On Error GoTo Err_Msg
BacaLokasiFolder = CurrentProject.path & "\"
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AdaFile(namaFile As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah ada sebuah file
' dengan nama namaFile.
' Digunakan untuk import tabel dari Excel
'------------------------------------------
Dim objFSO As Object
On Error GoTo Err_Msg
Set objFSO = CreateObject("Scripting.FileSystemObject")
Select Case objFSO.FileExists(namaFile)
Case True
AdaFile = True
Case False
AdaFile = False
End Select
Set objFSO = Nothing
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AdaForm(NamaForm As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah ada sebuah form
' dengan nama namaForm
'------------------------------------------
Dim obj As AccessObject, dbsObject As Object
On Error GoTo Err_Msg
Set dbsObject = Application.CurrentProject
For Each obj In dbsObject.AllForms
If obj.Name = NamaForm Then
AdaForm = True
Exit Function
End If
Next obj
AdaForm = False
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AdaTabelQuery(namaTabelQuery As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah ada sebuah tabel
' atau query dengan nama namaTabelQuery
'------------------------------------------
Dim obj As AccessObject, dbsObject As Object
On Error GoTo Err_Msg
Set dbsObject = Application.CurrentData
For Each obj In dbsObject.AllTables
If obj.Name = namaTabelQuery Then
AdaTabelQuery = True
Exit Function
End If
Next obj
For Each obj In dbsObject.AllQueries
If obj.Name = namaTabelQuery Then
AdaTabelQuery = True
Exit Function
End If
Next obj
AdaTabelQuery = False
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function formdiLoad(strFormName As String) As Boolean
'------------------------------------------
' Fungsi untuk mengecek apakah sebuah
' form sedang di-load
'------------------------------------------
Const conObjStateClosed = 0
Const conDesignView = 0
On Error GoTo Err_Msg
If SysCmd(acSysCmdGetObjectState, acForm, strFormName) <> conObjStateClosed Then
If Forms(strFormName).CurrentView <> conDesignView Then
formdiLoad = True
End If
End If
Exit_Function:
Exit Function
Err_Msg:
If Err.Number = 2450 Then Exit Function
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function PreferensSistem(strNamaField As String) As Variant
'------------------------------------------
' Fungsi untuk mengambil nilai dari
' preferensi sistem
'------------------------------------------
Dim vrtDefault As Variant
On Error GoTo Err_Msg
PreferensSistem = Nz(DLookup("[" & strNamaField & "]", "tblSistemPref"), "")
If strNamaField = "FolderPenyimpanan" Then
If Right(PreferensSistem, 1) <> "\" Then _
PreferensSistem = PreferensSistem & "\"
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function IdPerusahaan(strNamaField As String) As Variant
'------------------------------------------
' Fungsi untuk mengambil nilai dari
' identitas perusahaan seperti
' nama perusahaan, alamat, NPWP, dsb
'------------------------------------------
On Error GoTo Err_Msg
IdPerusahaan = Nz(DLookup("[" & strNamaField & "]", "tblIdentitasPerusahaan"), "")
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function CekPeriodeThn(dtPeriodeSekarang As Date, strTahun As PeriodeTahun) As Boolean
'------------------------------------------
' Fungsi untuk mengambil tanggal
' yang dimasukkan sesuai dengan
' periode akuntansi.
' strTahun dapat diisi TahunBerjalan, TahunSebelum, dan TahunBerikut
'------------------------------------------
Dim dtTglAwalThn, dtTglAkhirThn, dtTglAwalThnSebelum, dtTglAkhirThnSebelum, dtTglAwalThnBerikut, dtTglAkhirThnBerikut As Date
On Error GoTo Err_Msg
dtTglAwalThn = CekPeriode("TglAwalThn")
dtTglAkhirThn = CekPeriode("TglAkhirThn")
dtTglAwalThnSebelum = CekPeriode("TglAwalThnSebelum")
dtTglAkhirThnSebelum = CekPeriode("TglAkhirThnSebelum")
dtTglAwalThnBerikut = CekPeriode("TglAwalThnBerikut")
dtTglAkhirThnBerikut = CekPeriode("TglAkhirThnBerikut")
CekPeriodeThn = False
If strTahun = TahunBerjalan Then
If (dtPeriodeSekarang > CekPeriode("TglAwalThn")) And (dtPeriodeSekarang < CekPeriode("TglAkhirThn")) Then CekPeriodeThn = True
ElseIf strTahun = TahunSebelum Then
If (dtPeriodeSekarang > CekPeriode("TglAwalThnSebelum")) And (dtPeriodeSekarang < CekPeriode("TglAkhirThnSebelum")) Then CekPeriodeThn = True
ElseIf strTahun = TahunBerikut Then
If (dtPeriodeSekarang > CekPeriode("TglAwalThnBerikut")) And (dtPeriodeSekarang < CekPeriode("TglAkhirThnBerikut")) Then CekPeriodeThn = True
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function CekPeriodeTanggal(ByVal strNamaField As PeriodeTanggal) As Variant
'------------------------------------------
' Fungsi untuk mengambil tanggal
' yang dimasukkan sesuai dengan
' periode akuntansi, menggunakan konstanta
'------------------------------------------
Dim strNamaFields As String
Dim tanggal As Variant
On Error GoTo Err_Msg
tanggal = Array("TglAwalThn", "TglAkhirThn", "TglAwalBulan", "TglAkhirBulan", "TglAwalBulanSebelum", _
"TglAkhirBulanSebelum", "TglAwalBulanBerikut", "TglAkhirBulanBerikut", "TglAwalThnSebelum", _
"TglAkhirThnSebelum", "TglAwalBulanThnSebelum", "TglAkhirBulanThnSebelum", "TglAwalThnBerikut", _
"TglAkhirThnBerikut", "TglAwalBulanThnBerikut", "TglAkhirBulanThnBerikut")
CekPeriodeTanggal = Nz(DLookup("[" & tanggal(strNamaField) & "]", "tblPeriode", "[StatusThnBerjalan]=0"), "")
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function CekPeriode(strNamaField As String) As Variant
'------------------------------------------
' Fungsi untuk mengambil tanggal
' yang dimasukkan sesuai dengan
' periode akuntansi, menggunakan strNamaField
'------------------------------------------
On Error GoTo Err_Msg
CekPeriode = Nz(DLookup("[" & strNamaField & "]", "tblPeriode", "[StatusThnBerjalan]=0"), "")
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function ValidPeriode(dtPeriodeSekarang As Date) As Boolean
'------------------------------------------
' Fungsi untuk memvalidasi apakah tanggal
' yang dimasukkan sesuai dengan
' periode akuntansi.
'------------------------------------------
Dim dtWkt_TglAwalThn, dtWkt_TglAkhirThn, dtWkt_TglAwalBulan, dtWkt_TglAkhirBulan As Date
On Error GoTo Err_Msg
dtWkt_TglAwalThn = CekPeriode("TglAwalThn")
dtWkt_TglAkhirThn = CekPeriode("TglAkhirThn")
dtWkt_TglAwalBulan = CekPeriode("TglAwalBulan")
dtWkt_TglAkhirBulan = CekPeriode("TglAkhirBulan")
If (dtPeriodeSekarang > dtWkt_TglAkhirBulan) Or (dtPeriodeSekarang < dtWkt_TglAwalBulan) Then
ValidPeriode = False
Else
ValidPeriode = True
End If
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function BuatQuery(qryNama, qrySQLStatemen)
'------------------------------------------
' Fungsi untuk membuat tabel/query
'------------------------------------------
Dim obj As AccessObject, dbsObject As Object
Dim dbs As DAO.Database
Dim qdf As DAO.QueryDef
Dim fld As DAO.Field2
On Error GoTo Err_Msg
Set dbsObject = Application.CurrentData
For Each obj In dbsObject.AllQueries
If obj.Name = qryNama Then
DoCmd.DeleteObject acQuery, obj.Name
End If
Next obj
Set dbs = CurrentDb()
Set qdf = dbs.CreateQueryDef(qryNama, qrySQLStatemen)
dbs.Close
Set qdf = Nothing
Set dbs = Nothing
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function HapusObjekYgTidakPerlu(strObjekYgAkanDihapus As String)
'------------------------------------------
' Fungsi untuk menghapus tabel/query yang dihasilkan
' setelah selesainya sebuah proses yang memerlukan pembuatan
' tabel/query sementar. Untuk keamanan data,
' maka tabel/query itu harus dihapus.
'------------------------------------------
Dim obj As AccessObject, dbsObject As Object
Dim dbs As DAO.Database
Dim tdf As DAO.TableDef
Dim qdf As DAO.QueryDef
On Error GoTo Err_Msg
DoCmd.SetWarnings False
Set dbsObject = Application.CurrentData
For Each obj In dbsObject.AllTables
If obj.Name = strObjekYgAkanDihapus Then
DoCmd.DeleteObject acTable, obj.Name
End If
Next obj
For Each obj In dbsObject.AllQueries
If obj.Name = strObjekYgAkanDihapus Then
DoCmd.DeleteObject acQuery, obj.Name
End If
Next obj
DoCmd.SetWarnings True
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function CekAccdeMde() As Boolean
'------------------------------------------
' Digunakan untuk mengecek apakah file yang
' terbuka ini bisa diedit atau tidak.
'------------------------------------------
Dim strMDE As String
Dim dbs As Object, prp As Variant
On Error Resume Next
Set dbs = CurrentDb
strMDE = dbs.Properties("MDE")
If Err = 0 And strMDE = "T" Then
' Bila MDE/ACCDE database.
CekAccdeMde = True
Else
CekAccdeMde = False
End If
End Function
Function CekPropertiStartUp() As Boolean
'------------------------------------------
' Digunakan untuk mengecek apakah properti
' dari file yang terbuka ini sudah "true"
'------------------------------------------
Const DB_Text As Long = 10
Const DB_Boolean As Long = 1
Dim dbCurrent As DAO.Database
On Error GoTo Err_Msg
CekPropertiStartUp = False
Set dbCurrent = CurrentDb
If dbCurrent.Properties("AllowFullMenus") = True Then CekPropertiStartUp = True
Set dbCurrent = Nothing
Exit_Function:
Exit Function
Err_Msg:
MsgBox "Error # " & str(Err.Number) & ", source: " & Err.Source & Chr(13) & Err.Description
Resume Exit_Function
End Function
Function AturPropertiStartUp(ptyValue As Boolean)
'------------------------------------------
' Digunakan untuk mengatur properti dari
' file database yang terbuka ini
'------------------------------------------
Const DB_Boolean As Long = 1
Const DB_Byte As Byte = 1
Dim dbCurrent As DAO.Database
On Error GoTo Err_Msg
Set dbCurrent = CurrentDb
UbahProperti "StartupShowDBWindow", DB_Boolean, ptyValue
UbahProperti "StartupShowStatusBar", DB_Boolean, ptyValue
UbahProperti "AllowFullMenus", DB_Boolean, ptyValue
UbahProperti "AllowBreakIntoCode", DB_Boolean, ptyValue
UbahProperti "AllowSpecialKeys", DB_Boolean, ptyValue
UbahProperti "AllowBypassKey", DB_Boolean, ptyValue
UbahProperti "AllowToolbarChanges", DB_Boolean, ptyValue
UbahProperti "AllowDefaultShortCutMenus", DB_Boolean, ptyValue
UbahProperti "UseMDIMode", DB_Byte, 1
Set dbCurrent = Nothing
Exit_Function:
On Error Resume Next
Set dbCurrent = Nothing
Exit Function
Err_Msg:
Select Case Err.Number
Case 3270 'properti tidak ada
Exit Function
Resume Next
Case Else
End Select
Resume Exit_Function
End Function
Function UbahProperti(strPropName As String, varPropType As Variant, varPropValue As Variant) As Integer
'------------------------------------------
' Digunakan untuk mengubah properti
' dari file yang terbuka ini.
'------------------------------------------
Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270
Set dbs = CurrentDb
On Error GoTo Err_Msg
dbs.Properties(strPropName) = varPropValue
UbahProperti = True
Exit_Function:
Exit Function
Err_Msg:
If Err = conPropNotFoundError Then 'properti tidak ada
Set prp = dbs.CreateProperty(strPropName, _
varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
UbahProperti = False
Resume Exit_Function
End If
End Function
Comments
Post a Comment