-
Notifications
You must be signed in to change notification settings - Fork 2
/
mdlMain.bas
161 lines (137 loc) · 6.57 KB
/
mdlMain.bas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
Option Compare Database
Option Explicit
Global Const AppTitle = "Demo GoogleDrive VBA integration"
Global Const StrNull = "N/A"
Global Const VbAgent = "Ms Access VBA browser" '"Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; WOW64; Trident/5.0)" '"Cig_manager"
' For ini read write
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lsString As Any, ByVal lplFilename As String) As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Property Let AppProperty(KeyName As String, Optional Section As String = "", Optional ConfigFile As String = "", keyValue As String)
WritePrivateProfileString AppTitle & IIf(Section = "", "", "-" & Section), KeyName, keyValue, IIf(ConfigFile = "", AppConfigPath, ConfigFile)
End Property
Property Get AppProperty(KeyName As String, Optional Section As String = "", Optional ConfigFile As String = "") As String
Dim tmpBuffer As String * 255, tRet As Long
tRet = GetPrivateProfileString(AppTitle & IIf(Section = "", "", "-" & Section), KeyName, StrNull, tmpBuffer, Len(tmpBuffer), IIf(ConfigFile = "", AppConfigPath, ConfigFile))
AppProperty = Left(tmpBuffer, tRet)
End Property
Sub AppStatus(msgText As String)
SysCmd acSysCmdSetStatus, msgText
End Sub
Property Get AppConfigPath() As String
AppConfigPath = CurrentProject.path & "\Config.ini"
End Property
Sub OpenLocation(sPath As String)
' For browsing specified location
Dim retVal
retVal = VBA.Shell("explorer.exe " & sPath, vbNormalFocus)
End Sub
Sub WriteLog(ErrDesc As String, Optional LogFileName As String = "Error.txt", Optional KillIfExist As Boolean = False)
Dim txtString As String, FileNames As String
FileNames = LogFileName
txtString = ErrDesc
Dim UnicodeFile As Boolean
Const ForAppending = 8
UnicodeFile = True
Dim fso As Object, ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
' check if the file exist
If KillIfExist Then If FileOrDirExists(LogFileName, True) Then Kill LogFileName
Set ts = fso.OpenTextFile(FileNames, ForAppending, True, UnicodeFile)
ts.WriteLine txtString
ts.Close
Set ts = Nothing
Set fso = Nothing
End Sub
Function GetAuthCode(Optional client_id As String = "", Optional client_secret As String = "", _
Optional txtGAccount As String, Optional txtGPassword As String, _
Optional IsGetNewToken As Boolean = False) As String
' Get token for accessing drive object
Dim myClass As New gAuth2
If client_id = "" Then
client_id = AppProperty("App_client_id", "Google Drive")
client_secret = AppProperty("App_client_secret", "Google Drive")
Else
AppProperty("App_client_id", "Google Drive") = client_id
AppProperty("App_client_secret", "Google Drive") = client_secret
End If
With myClass
.InitClientCredentials client_id, client_secret
.InitEndPoints
If IsGetNewToken Then
.LogOnGoogle txtGAccount, txtGPassword
If Not .GetNewToken() Then GoTo Exit_Function
End If
GetAuthCode = .AuthHeader
End With
Exit_Function:
Set myClass = Nothing
End Function
Property Let SetObjInterface(CallObject As Object)
' This will set object face language at runtime rather than do this just one
Dim iObj As New ADODB.Recordset, iCr As Control, Obj As Object, iCaption As String
Dim i As Long, fLang As String
fLang = AppLanguage
' Initialize interface recordset
iObj.Open "Select * from tblCaption where ObjectID='" & CallObject.name & "';", CurrentProject.Connection
With iObj
' Set caption for the object
On Error GoTo ExitMe
' Now set caption for all the label in the object
While Not iObj.EOF
CallObject.Controls(.Fields("MsgID")).Caption = .Fields("MsgCap" & fLang)
If .Fields("MsgID") = "FORM_OR_REPORT_NAME" Then CallObject.Caption = .Fields("Msg" + fLang)
.MoveNext
Wend
.Close
Set Obj = Nothing
End With
ExitMe:
End Property
Sub GetObjectCaption()
' This will get caption of all object and store in tblCaption
Dim frmObj As Form, SqlStr As String, CtrObj As Control, i As Long
For i = 0 To CurrentProject.AllForms.Count - 1
DoCmd.OpenForm CurrentProject.AllForms.Item(i).name, acDesign, , , , acHidden
Set frmObj = Forms(CurrentProject.AllForms.Item(i).name)
For Each CtrObj In frmObj.Controls
If TypeOf CtrObj Is label Or TypeOf CtrObj Is CommandButton Then
SqlStr = "INSERT INTO tblCaption(ObjectID, MsgGroup, MsgID, MsgCapV) "
SqlStr = SqlStr + "VALUES('" + frmObj.name + "',1,'" + CtrObj.name + "','" + CtrObj.Caption + "');"
CurrentDb.Execute SqlStr
End If
Next
' now for form/report caption
SqlStr = "INSERT INTO tblCaption(ObjectID, MsgGroup, MsgID, MsgCapV) "
SqlStr = SqlStr + "VALUES('" + frmObj.name + "',1,'FORM_OR_REPORT_NAME', '" + frmObj.Caption + "')"
CurrentDb.Execute SqlStr
DoCmd.Close acForm, frmObj.name, acSaveNo
Next
ExitMe:
End Sub
Property Get Msg(MessageID As String) As String
' This will read the category table for returning a congigured item
Msg = nz(DLookup("MsgCapV", "tblCaption", "MsgID='" & MessageID & "'"), "Unknown ID or Data not avaiable")
End Property
Property Let DBConfig(PropertyName As String, PropertyValue As String)
' Write to property DB
Dim PrpVal As String
'1. Check for whether such property exists
PrpVal = nz(DLookup("MsgCapV", "tblCaption", "MsgID='" & PropertyName & "'"), "")
If PrpVal <> "" Then
PrpVal = "UPDATE tblCaption SET MsgCapV='" & PropertyValue & "' WHERE MsgID='" & PropertyName & "';"
Else
PrpVal = "INSERT INTO tblCaption(MsgGroup, MsgID, MsgCapV) VALUES(99,'" & PropertyName & "','" & PropertyValue & "');"
End If
CurrentDb.Execute PrpVal
End Property
Property Get DBConfig(PropertyName As String) As String
DBConfig = nz(DLookup("MsgCapV", "tblCaption", "MsgID='" & PropertyName & "'"), "")
End Property
Property Let AppLanguage(NewValue As String)
' set default language to English
If NewValue = "" Then NewValue = "E"
DBConfig("APP_LANGUAGE") = NewValue
End Property
Property Get AppLanguage() As String
AppLanguage = DBConfig("APP_LANGUAGE")
End Property