Skip to content

Commit 1c75193

Browse files
josef-poetzljosef-poetzl
committed
Copy CodeModules from GitHub repository
1 parent 2c91337 commit 1c75193

7 files changed

+262
-18
lines changed

‎.Copy2AddInFolder.cmd

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
copy DbmsConnectionWizard.accdb .\access-add-in\DbmsConnectionWizard.accda

‎.CreateWorkingFileFormAddInFolder.cmd

Lines changed: 19 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
@echo off
2+
3+
if exist .\DbmsConnectionWizard.accdb (
4+
set /p CopyFile=DbmsConnectionWizard.accdb exists .. overwrite with access-add-in\DbmsConnectionWizard.accda? [Y/N]:
5+
) else (
6+
set CopyFile=Y
7+
)
8+
9+
if /I %CopyFile% == Y (
10+
echo File is copied ...
11+
) else (
12+
echo Batch is cancelled
13+
pause
14+
exit
15+
)
16+
17+
copy .\access-add-in\DbmsConnectionWizard.accda DbmsConnectionWizard.accdb
18+
19+
timeout 2

‎access-add-in/DbmsConnectionWizard.accda

-1.55 MB
Binary file not shown.

‎access-add-in/Install.vbs

Lines changed: 2 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -9,8 +9,10 @@ Select Case MsgBox("Should the add-in be used as ACCDE?" + chr(13) & _
99
"(The compiled Add-In is copied into the Add-In directory.)", 3, MsgBoxTitle)
1010
case 6 ' vbYes
1111
CreateMde GetSourceFileFullName, GetDestFileFullName
12+
MsgBox "Compiled add-in created"
1213
case 7 ' vbNo
1314
FileCopy GetSourceFileFullName, GetDestFileFullName
15+
MsgBox "Add-In file was copied"
1416
case else
1517

1618
End Select
@@ -52,8 +54,6 @@ Function FileCopy(SourceFilePath, DestFilePath)
5254

5355
set fso = CreateObject("Scripting.FileSystemObject")
5456
fso.CopyFile SourceFilePath, DestFilePath
55-
56-
MsgBox "Add-In file was copied"
5757

5858
End Function
5959

@@ -62,6 +62,4 @@ Function CreateMde(SourceFilePath, DestFilePath)
6262
Set AccessApp = CreateObject("Access.Application")
6363
AccessApp.SysCmd 603, (SourceFilePath), (DestFilePath)
6464

65-
MsgBox "Compiled add-in created"
66-
6765
End Function

‎source/codelib/_codelib/addins/shared/ACLibGitHubImporter.cls

Lines changed: 226 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,226 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "ACLibGitHubImporter"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
'---------------------------------------------------------------------------------------
11+
' Klassenmodul: ACLibGitHubImporter
12+
'---------------------------------------------------------------------------------------
13+
'/**
14+
' <summary>
15+
' Import GitHub files
16+
' </summary>
17+
' <remarks>
18+
' </remarks>
19+
'\ingroup addins_shared
20+
'**/
21+
'---------------------------------------------------------------------------------------
22+
'<codelib>
23+
' <file>_codelib/addins/shared/ACLibGitHubImporter.cls</file>
24+
' <license>_codelib/license.bas</license>
25+
'</codelib>
26+
'---------------------------------------------------------------------------------------
27+
'
28+
Option Compare Database
29+
Option Explicit
30+
31+
Const GitHubContentBaseUrl As String = "https://raw.githubusercontent.com/AccessCodeLib/AccessCodeLib/{branch}/{path}"
32+
Const GitHubApiBaseUrl As String = "https://api.github.com/repos/AccessCodeLib/AccessCodeLib/"
33+
34+
Private m_LastCommit As Date
35+
Private m_UseDraftBranch As Boolean
36+
37+
#If VBA7 Then
38+
Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
39+
Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
40+
#Else
41+
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
42+
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
43+
#End If
44+
45+
Public Property Get UseDraftBranch() As Boolean
46+
UseDraftBranch = m_UseDraftBranch
47+
End Property
48+
49+
Public Property Let UseDraftBranch(ByVal NewValue As Boolean)
50+
m_UseDraftBranch = NewValue
51+
End Property
52+
53+
Public Property Get RevisionString(Optional ByVal Requery As Boolean = False) As String
54+
RevisionString = Format(LastCommit, "yyyymmddhhnnss")
55+
If UseDraftBranch Then
56+
RevisionString = RevisionString & "-draft"
57+
End If
58+
End Property
59+
60+
Public Property Get LastCommit(Optional ByVal Requery As Boolean = False) As String
61+
If m_LastCommit = 0 Or Requery Then
62+
m_LastCommit = GetLastCommitFromWeb()
63+
End If
64+
LastCommit = m_LastCommit
65+
End Property
66+
67+
Public Sub UpdateCodeModules()
68+
69+
Dim SelectSql As String
70+
Dim IsFirstRecord As Boolean
71+
72+
SelectSql = "select id, url from usys_Appfiles where url > ''"
73+
74+
With CreateObject("ADODB.Recordset")
75+
.CursorLocation = 3 'adUseClient
76+
.Open SelectSql, CodeProject.Connection, 1, 1 ' 1 = adOpenKeyset, 1 = adLockReadOnly
77+
Set .ActiveConnection = Nothing
78+
79+
IsFirstRecord = True
80+
Do While Not .EOF
81+
UpdateCodeModuleInTable .Fields(0).Value, .Fields(1).Value, IsFirstRecord
82+
If IsFirstRecord Then IsFirstRecord = False
83+
.MoveNext
84+
Loop
85+
86+
.Close
87+
88+
End With
89+
90+
End Sub
91+
92+
Private Sub UpdateCodeModuleInTable(ByVal ModuleName As String, ByVal ACLibPath As String, Optional ByVal Requery As Boolean = False)
93+
94+
Dim TempFile As String
95+
Dim DownLoadUrl As String
96+
Dim BranchName As String
97+
98+
TempFile = FileTools.TempPath & ModuleName & ".cls"
99+
100+
If UseDraftBranch Then
101+
BranchName = "draft"
102+
Else
103+
BranchName = "master"
104+
End If
105+
DownLoadUrl = Replace(GitHubContentBaseUrl, "{branch}", BranchName)
106+
DownLoadUrl = Replace(DownLoadUrl, "{path}", ACLibPath)
107+
108+
DownloadFileFromWeb DownLoadUrl, TempFile
109+
CurrentApplication.SaveAppFile ModuleName, TempFile, False, "SccRev", Me.RevisionString(Requery)
110+
Kill TempFile
111+
112+
End Sub
113+
114+
Private Function GetLastCommitFromWeb() As Date
115+
116+
'alternative: git rev-list HEAD --count
117+
118+
' https://api.github.com/repos/AccessCodeLib/AccessCodeLib/commits/master
119+
120+
Dim CommitUrl As String
121+
Dim LastCommitInfo As String
122+
CommitUrl = GitHubApiBaseUrl & "commits/"
123+
124+
If UseDraftBranch Then
125+
CommitUrl = CommitUrl & "draft"
126+
Else
127+
CommitUrl = CommitUrl & "master"
128+
End If
129+
130+
Const RevisionTag As String = "Revision "
131+
132+
Dim JsonString As String
133+
JsonString = GetJsonString(CommitUrl)
134+
135+
Dim LastCommitPos As Long
136+
LastCommitPos = InStr(1, JsonString, """committer"":")
137+
LastCommitPos = InStr(LastCommitPos, JsonString, """date"":") + Len("date"": """)
138+
'"date": "2023-05-14T09:34:04Z"
139+
LastCommitInfo = Mid(JsonString, LastCommitPos, Len("2023-05-14T09:34:04"))
140+
141+
GetLastCommitFromWeb = CDate(Replace(LastCommitInfo, "T", " "))
142+
143+
End Function
144+
145+
Private Function GetJsonString(ByVal ApiUrl As String) As String
146+
147+
Dim ApiResponse As String
148+
Dim json As Object
149+
150+
Dim xml As Object ' MSXML2.XMLHTTP60
151+
Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
152+
153+
xml.Open "GET", ApiUrl, False
154+
xml.setRequestHeader "Content-type", "application/json"
155+
xml.send
156+
While xml.ReadyState <> 4
157+
DoEvents
158+
Wend
159+
ApiResponse = xml.responseText
160+
161+
GetJsonString = ApiResponse
162+
163+
End Function
164+
165+
Private Sub OpenIEandLoadHtmlDoc(ByVal Url As String, ByRef IE As Object, ByRef HtmlDoc As Object)
166+
167+
Dim TimeOut As Long
168+
Dim RunInTimeOut As Boolean
169+
Dim ErrHdlCnt As Long
170+
171+
Dim ErrNumber As Long
172+
Dim ErrDescription As String
173+
174+
On Error Resume Next
175+
Set IE = CreateObject("InternetExplorer.Application")
176+
Do While Err.Number = -2147023706 And ErrHdlCnt < 10
177+
Err.Clear
178+
ErrHdlCnt = ErrHdlCnt + 1
179+
Set IE = CreateObject("InternetExplorer.Application")
180+
Loop
181+
182+
If Err.Number <> 0 Then
183+
ErrNumber = Err.Number
184+
ErrDescription = Err.Description
185+
On Error GoTo 0
186+
Err.Raise ErrNumber, "ACLibWebImporter.OpenIEandLoadHtmlDoc", ErrDescription
187+
End If
188+
189+
On Error GoTo 0
190+
191+
With IE
192+
TimeOut = Timer + 10
193+
Do While .Busy And (Not RunInTimeOut)
194+
DoEvents
195+
If Timer > TimeOut Then RunInTimeOut = True
196+
Loop
197+
198+
If Not RunInTimeOut Then
199+
.Visible = 0
200+
.navigate Url
201+
TimeOut = Timer + 10
202+
Do Until .ReadyState = 4 Or RunInTimeOut
203+
DoEvents
204+
If Timer > TimeOut Then RunInTimeOut = True
205+
Loop
206+
End If
207+
208+
If RunInTimeOut Then
209+
On Error Resume Next
210+
IE.Quit
211+
Set IE = Nothing
212+
On Error GoTo 0
213+
Err.Raise vbObjectError, "OpenIEandLoadHtmlDoc", "Time-Out beim Laden von '" & Url & "'"
214+
End If
215+
216+
Set HtmlDoc = IE.Document
217+
218+
End With
219+
220+
End Sub
221+
222+
Private Sub DownloadFileFromWeb(ByVal Url As String, ByVal TargetPath As String)
223+
If FileExists(TargetPath) Then Kill TargetPath
224+
DeleteUrlCacheEntry Url
225+
URLDownloadToFile 0, Url, TargetPath, 0, 0
226+
End Sub

‎source/codelib/_codelib/addins/FilterFormWizard/modWizardCodeModulesData.bas renamed to ‎source/codelib/_codelib/addins/shared/modWizardCodeModulesData.bas

Lines changed: 10 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1,18 +1,18 @@
11
Attribute VB_Name = "modWizardCodeModulesData"
22
'---------------------------------------------------------------------------------------
3-
' Modul: defGlobal_FilterFormWizard
3+
' Modul: modWizardCodeModulesData
44
'---------------------------------------------------------------------------------------
55
'/**
66
' <summary>
7-
' Hilfsfunktionen für FilterFormWizard
7+
' SCC file data in usys_AppFiles
88
' </summary>
99
' <remarks>
1010
' </remarks>
11-
' \ingroup ACLibAddInFilterFormWizard
11+
' \ingroup addins_shared
1212
'**/
1313
'---------------------------------------------------------------------------------------
1414
'<codelib>
15-
' <file>_codelib/addins/FilterFormWizard/modWizardCodeModulesData.bas</file>
15+
' <file>_codelib/addins/shared/modWizardCodeModulesData.bas</file>
1616
' <license>_codelib/license.bas</license>
1717
'</codelib>
1818
'---------------------------------------------------------------------------------------
@@ -21,22 +21,22 @@ Option Compare Database
2121
Option Explicit
2222
Option Private Module
2323

24-
Public Property Get SvnRev() As String
24+
Public Property Get SccRev() As String
2525

26-
With CodeDb.OpenRecordset("select max(SvnRev) from usys_AppFiles")
26+
With CodeDb.OpenRecordset("select max(SccRev) from usys_AppFiles")
2727
If Not .EOF Then
28-
SvnRev = Nz(.Fields(0).Value, 0)
28+
SccRev = Nz(.Fields(0).Value, 0)
2929
End If
3030
.Close
3131
End With
3232

3333
End Property
3434

35-
Public Property Get SvnRevMin() As String
35+
Public Property Get SccRevMin() As String
3636

37-
With CodeDb.OpenRecordset("select Min(SvnRev) from usys_AppFiles")
37+
With CodeDb.OpenRecordset("select Min(SccRev) from usys_AppFiles")
3838
If Not .EOF Then
39-
SvnRevMin = Nz(.Fields(0).Value, "0")
39+
SccRevMin = Nz(.Fields(0).Value, "0")
4040
End If
4141
.Close
4242
End With

‎source/defGlobal_DBMS.bas

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
Attribute VB_Name = "defGlobal_DBMS"
22
'---------------------------------------------------------------------------------------
3-
' Modul: defGlobal_DBMS (2009-08-16)
3+
' Modul: defGlobal_DBMS
44
'---------------------------------------------------------------------------------------
55
'/**
66
' <summary>
@@ -39,7 +39,7 @@ Private m_DbmsConfigFormName As String
3939

4040

4141
'---------------------------------------------------------------------------------------
42-
' Property: DbmsConfigFormName (2009-07-08)
42+
' Property: DbmsConfigFormName
4343
'---------------------------------------------------------------------------------------
4444
'/**
4545
' <summary>
@@ -57,9 +57,9 @@ On Error Resume Next
5757
If Len(m_DbmsConfigFormName) = 0 Then 'Wert von Konstante
5858
m_DbmsConfigFormName = m_conDbmsConfigFormName
5959
End If
60-
60+
6161
DbmsConfigFormName = m_DbmsConfigFormName
62-
62+
6363
End Property
6464

6565
Public Property Let DbmsConfigFormName(ByVal AppName As String)

0 commit comments

Comments
 (0)