www.softwaredevelopmentdeveloper.com
옥션 아이폰/아이팟 집에서 즐기기 롯데마트 11번가 주민등록번호 도용사실이 있는지 확인해 보세요! CJmall 회원가입 도메인 NO.1-호스팅 NO.1 든든한 웹파트너 가비아 ! 건담 전문몰 건담샵 No.1 중고차 쇼핑몰! SK엔카
아래출처는 http://ad.web2r.net/r.php?c=shop 입니다.Option Compare Database Option Explicit ' Name if this modulePrivate Const constrName = "basCustomProperty"Public Function GetCustomProperty(strName As String, intType As Integer) As Variant ' Returns user-defined property value. If property not exist, it is created and default value returned.On Error GoTo GetCustomPropertyErr Const conerrPropertyNotFound = 3270 Dim dbs As Database Dim doc As Document Dim prp As Property Dim lngErr As Long Set dbs = CurrentDb Set doc = dbs.Containers( "Databases")!UserDefined GetCustomProperty = doc.Properties(strName) GetCustomPropertyExit: Exit Function GetCustomPropertyErr: lngErr = Err.Number clsSystemDebug.Output conintError, constrName, "ERROR in 'GetCustomProperty' - " & lngErr & " " & Err.Description If lngErr = conerrPropertyNotFound And CurrentDb.Updatable Then clsSystemDebug.Output conintEvent, constrName, "Creating the unknown property" Set prp = doc.CreateProperty(strName, intType, vbNull) doc.Properties.Append prp Resume End If Resume GetCustomPropertyExit End Function Public Function SetCustomProperty(strName As String, var As Variant) As Boolean ' Returns True if OK. Note error occurs if property doesn't exist. (ie Assumes GetCP has been called first.)On Error GoTo SetCustomPropertyErr Dim dbs As Database Dim doc As Document Dim prp As Property Set dbs = CurrentDb Set doc = dbs.Containers( "Databases")!UserDefined doc.Properties(strName) = var SetCustomProperty = True SetCustomPropertyExit: Exit Function SetCustomPropertyErr: clsSystemDebug.Output conintError, constrName, "ERROR in 'SetCustomProperty' - " & Err.Number & " " & Err.Description SetCustomProperty = False Resume SetCustomPropertyExit End Function Public Function DeleteCustomProperty(strName As String) As Boolean ' Returns True if deleted OKOn Error Resume Next Dim dbs As Database Dim doc As Document Dim prp As Property Set dbs = CurrentDb Set doc = dbs.Containers( "Databases")!UserDefined doc.Properties.Delete strName DeleteCustomProperty = Err.Number = 0 End Function Public Sub PrintCustomProperties() ' Test word to display all custom database properties Dim dbs As Database Dim doc As Document Dim intCount As Integer Set dbs = CurrentDb Set doc = dbs.Containers( "Databases")!UserDefined For intCount = 0 To doc.Properties.Count - 1 Debug.Print intCount, doc.Properties(intCount).Name & Space(40 - Len(doc.Properties(intCount).Name)), _ GetTypeDescription(doc.Properties(intCount).Type), _ Format$(doc.Properties(intCount).Value) Next intCount End Sub Public Function GetTypeDescription(intType As Integer) As String Select Case intType Case dbBigInt: GetTypeDescription = "Big Integer" Case dbBinary: GetTypeDescription = "Binary" Case dbBoolean: GetTypeDescription = "Boolean" Case dbByte: GetTypeDescription = "Byte" Case dbChar: GetTypeDescription = "Char" Case dbCurrency: GetTypeDescription = "Currency" Case dbDate: GetTypeDescription = "Date/Time" Case dbDecimal: GetTypeDescription = "Decimal" Case dbDouble: GetTypeDescription = "Double" Case dbFloat: GetTypeDescription = "Float" Case dbGUID: GetTypeDescription = "Guid" Case dbInteger: GetTypeDescription = "Integer" Case dbLong: GetTypeDescription = "Long" Case dbLongBinary: GetTypeDescription = "Long Binary (OLE Object)" Case dbMemo: GetTypeDescription = "Memo" Case dbNumeric: GetTypeDescription = "Numeric" Case dbSingle: GetTypeDescription = "Single" Case dbText: GetTypeDescription = "Text" Case dbTime: GetTypeDescription = "Time" Case dbTimeStamp: GetTypeDescription = "Time Stamp" Case dbVarBinary: GetTypeDescription = "VarBinary" Case Else: GetTypeDescription = "(Unknown Type)" End Select End Function
