diff --git a/access-add-in/ACLibImportWizard.accda b/access-add-in/ACLibImportWizard.accda index c4e1edb..b77bb06 100644 Binary files a/access-add-in/ACLibImportWizard.accda and b/access-add-in/ACLibImportWizard.accda differ diff --git a/source/ACLibFileManager.cls b/source/ACLibFileManager.cls index 2a07cfa..afc2f32 100644 --- a/source/ACLibFileManager.cls +++ b/source/ACLibFileManager.cls @@ -30,7 +30,7 @@ Attribute VB_Description = "Import/Export der Access-Objekte in/aus lokaler Code '--------------------------------------------------------------------------------------- ' ' %AppFolder%/source/ACLibFileManager.cls -' Kuemmert sich um den Import und Export der Codemodule aus dem und in das Repository +' Import/export of Access objects to/from local code library ' _codelib/license.bas ' base/ApplicationHandler.cls ' file/modFiles.bas @@ -117,6 +117,7 @@ Private m_ExportAllToApplicationSourceFolder As Boolean ' Events Public Event PropertyMissingLocalRepositoryRootDirectory(ByRef NewValue As String) +Public Event MissingLocalRepositoryFile(ByVal ACLibPath As String, ByVal FullFilePath As String) Public Event ImportRepositoryFile(ByVal ObjectName As String, ByVal RepositoryFile As String, _ ByVal ElementType As CodeLibElementType, ByRef Dependency As Variant, _ ByRef ImportFile As Object, ByRef Cancel As Integer) @@ -323,6 +324,8 @@ Public Sub ImportRepositoryFile(ByVal RepositoryPath As String, _ PathString = GetRepositoryFullPath(RepositoryPath) + + Dim TempFile As Object Set TempFile = fso.GetFile(PathString) AddMissingFile TempFile, ImportMode @@ -638,6 +641,7 @@ End Property Public Function GetRepositoryFullPath(ByVal ReleativPath As String) As String Dim RepPath As String + Dim FullPath As String ReleativPath = Replace(ReleativPath, "/", "\") @@ -671,8 +675,14 @@ Public Function GetRepositoryFullPath(ByVal ReleativPath As String) As String Do While Left$(ReleativPath, 1) = "\" ReleativPath = Mid$(ReleativPath, 2) Loop + + FullPath = RepPath & ReleativPath + + If Len(VBA.Dir(FullPath)) = 0 Then + RaiseEvent MissingLocalRepositoryFile(ReleativPath, FullPath) + End If - GetRepositoryFullPath = RepPath & ReleativPath + GetRepositoryFullPath = FullPath End Function @@ -1248,7 +1258,6 @@ Public Function GetCodeLibInfoFromFilePath(ByVal FilePath As String, Optional By GetCodeLibInfoFromFilePath = cli End Function - Private Sub GetCodeLibInfoFromFile(ByRef CodeLibInf As CodeLibInfo, ByVal InputFile As Object, _ Optional ByVal FindDependency As Boolean = True, _ Optional ByVal FindTests As Boolean = True) @@ -1258,8 +1267,10 @@ Private Sub GetCodeLibInfoFromFile(ByRef CodeLibInf As CodeLibInfo, ByVal InputF Dim TempString As String Dim i As Long Dim FileNumber As Long + Dim StringCutPos As Long FileNumber = FreeFile + Open InputFile.Path For Binary Access Read As FileNumber CheckString = String$(LOF(FileNumber), 0) Get FileNumber, , CheckString @@ -1269,7 +1280,12 @@ Private Sub GetCodeLibInfoFromFile(ByRef CodeLibInf As CodeLibInfo, ByVal InputF CodeLibInf.Name = FindSubString(CheckString, SEARCHSTRING_ATTRIBUTNAME_BEGIN, SEARCHSTRING_ATTRIBUTNAME_END, Pos) If Len(CodeLibInf.Name) = 0 Then ' from filenames - CodeLibInf.Name = Left$(InputFile.Name, InStrRev(InputFile.Name, ".") - 1) + StringCutPos = InStrRev(InputFile.Name, ".") + If StringCutPos > 1 Then + CodeLibInf.Name = Left$(InputFile.Name, InStrRev(InputFile.Name, ".") - 1) + Else + CodeLibInf.Name = InputFile.Name + End If End If 'Determine type diff --git a/source/ACLibImportWizardForm.frm b/source/ACLibImportWizardForm.frm index b21b090..2d1b2f1 100644 Binary files a/source/ACLibImportWizardForm.frm and b/source/ACLibImportWizardForm.frm differ diff --git a/source/ACLibRepositoryTreeForm.frm b/source/ACLibRepositoryTreeForm.frm new file mode 100644 index 0000000..f59cf7a Binary files /dev/null and b/source/ACLibRepositoryTreeForm.frm differ diff --git a/source/GitHubTreeJsonConverter.cls b/source/GitHubTreeJsonConverter.cls new file mode 100644 index 0000000..bf15bc3 --- /dev/null +++ b/source/GitHubTreeJsonConverter.cls @@ -0,0 +1,223 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "GitHubTreeJsonConverter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Const SubPropIndentLen As Long = 2 + +Public Function Json2TreeNode(ByVal JsonString As String) As JsonProperties + + JsonString = OptimizeJsonString(JsonString) + + If Left(JsonString, 1) <> "{" Then + Err.Raise vbObjectError, "JsonConverter.Parse", "Missing JSON structure" + End If + + If Right(JsonString, 1) <> "}" Then + Err.Raise vbObjectError, "JsonConverter.Parse", "Missing JSON structure" + End If + + Set Json2TreeNode = ParseProperties(JsonString) + +End Function + +'############################################# +' Parse JSON + +Private Function OptimizeJsonString(ByVal JsonString As String) As String + + JsonString = Replace(JsonString, vbNewLine, vbNullString) + JsonString = Replace(JsonString, vbTab, vbNullString) + JsonString = Replace(JsonString, vbCr, vbNullString) + JsonString = Replace(JsonString, vbLf, vbNullString) + + JsonString = Trim(JsonString) + + OptimizeJsonString = JsonString + +End Function + +Private Function ParseProperties(ByVal JsonString As String) As JsonProperties + + Dim Props As JsonProperties + Set Props = New JsonProperties + + Dim PropStringArray() As String + Dim i As Long + Dim PropString As String + + JsonString = Trim(JsonString) + If Left(JsonString, 1) = "{" And Right(JsonString, 1) = "}" Then ' if + JsonString = Mid(JsonString, 2, Len(JsonString) - 2) + Else + Err.Raise vbObjectError, "JsonConverter.ParseProperties", "Missing JSON structure" + End If + + + PropStringArray = Split(SetSplitMarker(JsonString), ",|") + + For i = LBound(PropStringArray) To UBound(PropStringArray) + PropString = Trim(PropStringArray(i)) + If Len(PropString) > 0 Then + Props.Append ConvertString2Property(PropString) + End If + Next + + Set ParseProperties = Props + +End Function + +Private Function ConvertString2Property(ByVal JsonString As String) As JsonProperty +' "Name" : "abc" => Value +' "Name" : 123 => Value +' "Name" : { ... => Properties + + Dim Prop As JsonProperty + + Dim PropName As String + Dim PropValueString As Variant + + Dim CutPos As Long + + Set Prop = New JsonProperty + + CutPos = InStr(1, JsonString, ":") + + PropName = Trim(Left(JsonString, CutPos - 1)) + If Left(PropName, 1) = """" And Right(PropName, 1) = """" Then + PropName = Mid(PropName, 2, Len(PropName) - 2) + End If + Prop.Name = PropName + + PropValueString = Trim(Mid(JsonString, CutPos + 1)) + + If Left(PropValueString, 1) = "{" Then ' new properties + Set Prop.Properties = ParseProperties(PropValueString) + ElseIf Left(PropValueString, 1) = "[" Then ' new properties + Set Prop.ObjectValue = ConvertString2JsonItem(PropValueString) + Else + Prop.Value = ConvertString2JsonItem(PropValueString) + End If + + Set ConvertString2Property = Prop + +End Function + +Private Function ConvertString2JsonItem(ByVal PropValueString As String) As Variant + + If Left(PropValueString, 1) = "{" Then ' new properties + Set ConvertString2JsonItem = ParseProperties(PropValueString) + ElseIf Left(PropValueString, 1) = "[" Then ' new nodes + Set ConvertString2JsonItem = ParseJsonArray(PropValueString) + ElseIf PropValueString = "null" Then + ConvertString2JsonItem = Null + ElseIf PropValueString = "true" Then + ConvertString2JsonItem = True + ElseIf PropValueString = "false" Then + ConvertString2JsonItem = False + ElseIf Left(PropValueString, 1) = """" Then 'string + ConvertString2JsonItem = Mid(PropValueString, 2, Len(PropValueString) - 2) + Else ' Variant + ConvertString2JsonItem = CVar(PropValueString) + End If + +End Function + +Private Function ParseJsonArray(ByVal JsonString As String) As Collection + + Dim Items As Collection + Dim PropStringArray() As String + Dim i As Long + Dim Props As Variant + + If Left(JsonString, 1) = "[" And Right(JsonString, 1) = "]" Then + JsonString = Trim(Mid(JsonString, 2, Len(JsonString) - 2)) + End If + + PropStringArray = Split(SetSplitMarker(JsonString), ",|") + + Set Items = New Collection + For i = LBound(PropStringArray) To UBound(PropStringArray) + Items.Add ConvertString2JsonItem(Trim(PropStringArray(i))) + Next + + Set ParseJsonArray = Items + +End Function + +Private Function ParseValueFromString(ByVal JsonString As String) As Variant + + JsonString = Trim(JsonString) + + If JsonString = "null" Then + ParseValueFromString = Null + ElseIf JsonString = "true" Then + ParseValueFromString = True + ElseIf JsonString = "false" Then + ParseValueFromString = False + ElseIf Left(JsonString, 1) = """" And Right(JsonString, 1) = """" Then 'string + ParseValueFromString = Mid(JsonString, 2, Len(JsonString) - 2) + Else + ParseValueFromString = Val(JsonString) + End If + +End Function + +Private Function SetSplitMarker(ByVal JsonString As String) As String + + Dim Pos As Long + Dim LeftPart As String + Dim CheckString As String + + JsonString = Replace(JsonString, ",", ", ") ' place to insert marker + + Pos = InStr(1, JsonString, ",") + + Do While Pos > 0 + CheckString = Left(JsonString, Pos - 1) + If Not PosIsInSubObject(CheckString) Then + If Not PosIsInArray(CheckString) Then + Mid(JsonString, Pos + 1, 1) = "|" + End If + End If + Pos = InStr(Pos + 1, JsonString, ",") + Loop + + SetSplitMarker = Replace(JsonString, ", ", ",") + +End Function + +Private Function PosIsInSubObject(ByVal StringToCheck As String) As Boolean + + PosIsInSubObject = PosIsInOpenStruct(StringToCheck, "{", "}") + +End Function + +Private Function PosIsInArray(ByVal StringToCheck As String) As Boolean + + PosIsInArray = PosIsInOpenStruct(StringToCheck, "[", "]") + +End Function + +Private Function PosIsInOpenStruct(ByVal StringToCheck As String, ByVal OpeningChar As String, ByVal ClosingChar As String) As Boolean + + Dim CntOpeningBrackets As Long + Dim CntClosingBrackets As Long + + CntOpeningBrackets = Len(StringToCheck) - Len(Replace(StringToCheck, OpeningChar, vbNullString)) + CntClosingBrackets = Len(StringToCheck) - Len(Replace(StringToCheck, ClosingChar, vbNullString)) + + If CntOpeningBrackets > CntClosingBrackets Then + PosIsInOpenStruct = True + Else + PosIsInOpenStruct = False + End If + +End Function diff --git a/source/GitHubTreeNode.cls b/source/GitHubTreeNode.cls new file mode 100644 index 0000000..a9f834e --- /dev/null +++ b/source/GitHubTreeNode.cls @@ -0,0 +1,182 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "GitHubTreeNode" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private Const GitHubApiTreesUrl As String = "https://api.github.com/repos/AccessCodeLib/AccessCodeLib/git/trees/{SHA}" + +Private m_Properties As Dictionary +Private m_Nodes As Dictionary +Private m_GitHubApiAuthToken As String + +Private Sub Class_Initialize() + Set m_Properties = New Dictionary + Set m_Nodes = New Dictionary +End Sub + +Public Property Get Properties() As Dictionary + Set Properties = m_Properties +End Property + +Public Property Get Nodes() As Dictionary + Set Nodes = m_Nodes +End Property + +Public Property Get IsFolder() As Boolean + If NodeType = "tree" Then + IsFolder = True + ElseIf Len(NodeType) = 0 Then + IsFolder = True + End If +End Property + +Public Property Get NodeType() As String + If m_Properties.Exists("type") Then + NodeType = m_Properties.Item("type") + End If +End Property + +Public Property Get Path() As String + If m_Properties.Exists("path") Then + Path = m_Properties.Item("path") + End If +End Property + +Public Property Get Sha() As String + If m_Properties.Exists("sha") Then + Sha = m_Properties.Item("sha") + End If +End Property + +Public Sub BuildFromSHA(ByVal Sha As String, _ + Optional ByVal ReadSubTreeLevel As Long = 0, _ + Optional ByVal GitHubApiAuthToken As String = vbNullString) + + Dim JsonString As String + + With New ACLibGitHubImporter + If Len(GitHubApiAuthToken) > 0 Then + m_GitHubApiAuthToken = GitHubApiAuthToken + End If + If Len(m_GitHubApiAuthToken) > 0 Then + .GitHubApiAuthorizationToken = m_GitHubApiAuthToken + End If + JsonString = .GetJsonString(Replace(GitHubApiTreesUrl, "{SHA}", Sha)) + + If JsonString Like "{""message"":*" Then + Err.Raise vbObjectError, "GitHubTreeNode.BuildFromSHA", BuildErrMsgFromGitHubApiMessage(JsonString) + End If + + BuildFromJson JsonString, ReadSubTreeLevel + End With + +End Sub + +Private Function BuildErrMsgFromGitHubApiMessage(ByVal MsgJson As String) As String +' {"message":"API rate limit exceeded for 84.112.118.32. (But here's the good news: Authenticated requests get a higher rate limit. Check out the documentation for more details.)","documentation_url":"https://docs.github.com/rest/overview/resources-in-the-rest-api#rate-limiting"} + + Dim Msg As String + Msg = Replace(MsgJson, "{""message"":""", vbNullString) + Msg = Replace(Msg, """,""documentation_url"":""", vbNewLine & "URL: ") + Msg = Replace(Msg, """}", vbNullString) + + BuildErrMsgFromGitHubApiMessage = Msg + +End Function + +Friend Sub BuildFromJson(ByVal JsonString As String, Optional ByVal ReadSubTreeLevel As Long = 0) + + Dim Props As JsonProperties + + With New GitHubTreeJsonConverter + Set Props = .Json2TreeNode(JsonString) + End With + + InitFromJsonProperties Props, ReadSubTreeLevel + +End Sub + +Friend Sub InitFromJsonProperties(ByVal Props As JsonProperties, Optional ByVal ReadSubTreeLevel As Long = 0, _ + Optional ByVal GitHubApiAuthToken As String = vbNullString) + + Dim Prop As JsonProperty + Dim i As Long + + If Len(GitHubApiAuthToken) > 0 Then + m_GitHubApiAuthToken = GitHubApiAuthToken + End If + + For i = 1 To Props.Count + Set Prop = Props.Item(i) + If Prop.Name = "Tree" Then + AddNodesfromJsonCollection Prop.Value, ReadSubTreeLevel + Else + m_Properties(Prop.Name) = Prop.Value + End If + Next + +End Sub + +Private Sub AddNodesfromJsonCollection(ByVal JsonNodeCollection As Collection, Optional ByVal ReadSubTreeLevel As Long = 0) + + Dim NodeProps As JsonProperties + Dim Node As GitHubTreeNode + + For Each NodeProps In JsonNodeCollection + Set Node = GetNodeFromNodeProps(NodeProps) + Set m_Nodes(Node.Path) = Node + Next + + If ReadSubTreeLevel > 0 Then + FillNextTreeLevel ReadSubTreeLevel + End If + +End Sub + +Private Function GetNodeFromNodeProps(ByVal NodeProps As JsonProperties) As GitHubTreeNode + + Dim Node As GitHubTreeNode + + Set Node = New GitHubTreeNode + Node.InitFromJsonProperties NodeProps, , m_GitHubApiAuthToken + + Set GetNodeFromNodeProps = Node + +End Function + +Friend Sub FillNextTreeLevel(Optional ByVal ReadSubTreeLevel As Long = 0, _ + Optional ByVal GitHubApiAuthToken As String = vbNullString) + + Dim Node As GitHubTreeNode + Dim NodeKey As Variant + + If Not IsFolder Then + Exit Sub + End If + + If Len(GitHubApiAuthToken) > 0 Then + m_GitHubApiAuthToken = GitHubApiAuthToken + End If + + If m_Nodes.Count = 0 Then + Me.BuildFromSHA Me.Sha, ReadSubTreeLevel, m_GitHubApiAuthToken + Exit Sub + End If + + If ReadSubTreeLevel > 0 Then + For Each NodeKey In m_Nodes.Keys + Set Node = m_Nodes(NodeKey) + If Node.IsFolder Then + Node.FillNextTreeLevel ReadSubTreeLevel - 1 + End If + Next + End If + +End Sub diff --git a/source/GitHubTreeNodeTests.cls b/source/GitHubTreeNodeTests.cls new file mode 100644 index 0000000..dcd8d3d --- /dev/null +++ b/source/GitHubTreeNodeTests.cls @@ -0,0 +1,126 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "GitHubTreeNodeTests" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +'AccUnit:TestClass + +'TestSuite.AddByClassName("GitHubTreeNodeTests").Run + +Private m_TreeNode As GitHubTreeNode + +Public Sub Setup() + Set m_TreeNode = New GitHubTreeNode +End Sub + +Public Sub Teardown() + Set m_TreeNode = Nothing +End Sub + +Public Sub JsonString_Without_Nodes() + +Const TestJson As String = _ +"{" & vbNewLine & _ +" ""sha"": ""f369b695f119081de974a5c9a0357bf563e7ec94""," & vbNewLine & _ +" ""url"": ""https://api.github.com/repos/AccessCodeLib/AccessCodeLib/git/trees/f369b695f119081de974a5c9a0357bf563e7ec94"" " & vbNewLine & _ +"}" + + m_TreeNode.BuildFromJson TestJson + + Assert.That m_TreeNode.Nodes.Count, Iz.EqualTo(0) + Assert.That m_TreeNode.Properties.Count, Iz.EqualTo(2) + +End Sub + +Public Sub JsonString_With_Nodes() + +Const TestJson As String = _ +"{" & vbNewLine & _ +" ""sha"": ""f369b695f119081de974a5c9a0357bf563e7ec94""," & vbNewLine & _ +" ""url"": ""https://api.github.com/repos/AccessCodeLib/AccessCodeLib/git/trees/f369b695f119081de974a5c9a0357bf563e7ec94""," & vbNewLine & _ +" ""tree"": [" & vbNewLine & _ +" {" & vbNewLine & _ +" ""path"": ""LICENSE""," & vbNewLine & _ +" ""mode"": ""100644""," & vbNewLine & _ +" ""type"": ""blob""," & vbNewLine & _ +" ""sha"": ""4bd7d68f9f4597e859a7667b0a1fe1576cff05d3""," & vbNewLine & _ +" ""size"": 1505," & vbNewLine & _ +" ""url"": ""https://api.github.com/repos/AccessCodeLib/AccessCodeLib/git/blobs/4bd7d68f9f4597e859a7667b0a1fe1576cff05d3""" & vbNewLine & _ +" }," & vbNewLine & _ +" {" & vbNewLine & _ +" ""path"": ""README.md""," & vbNewLine & _ +" ""mode"": ""100644""," & vbNewLine & _ +" ""type"": ""blob""," & vbNewLine & _ +" ""sha"": ""ad54412d9b3f1efc4cb5c008d699fddde24bfc16""," & vbNewLine & _ +" ""size"": 225," & vbNewLine & _ +" ""url"": ""https://api.github.com/repos/AccessCodeLib/AccessCodeLib/git/blobs/ad54412d9b3f1efc4cb5c008d699fddde24bfc16""" & vbNewLine & _ +" }" & vbNewLine & _ +" ]," & vbNewLine & _ +"}" + + m_TreeNode.BuildFromJson TestJson + + Assert.That m_TreeNode.Properties.Count, Iz.EqualTo(2) + Assert.That m_TreeNode.Nodes.Count, Iz.EqualTo(2) + + Dim NodeKey As Variant + Dim Node As GitHubTreeNode + For Each NodeKey In m_TreeNode.Nodes.Keys + Set Node = m_TreeNode.Nodes(NodeKey) + Assert.That Node.Nodes.Count, Iz.EqualTo(0) + Next + +End Sub + +Public Sub BuildFromSHA_master_CheckCount() + + m_TreeNode.BuildFromSHA "master", 0 + + Assert.That m_TreeNode.Properties.Count, Iz.EqualTo(3) + Assert.That m_TreeNode.Nodes.Count, Iz.EqualTo(28) + + Dim NodeKey As Variant + Dim Node As GitHubTreeNode + For Each NodeKey In m_TreeNode.Nodes.Keys + Set Node = m_TreeNode.Nodes(NodeKey) + Assert.That Node.Nodes.Count, Iz.EqualTo(0) + Next + +End Sub + +Public Sub BuildFromSHA_masterWithSubTrees_CheckCount() + + m_TreeNode.BuildFromSHA "master", 1 + + Assert.That m_TreeNode.Properties.Count, Iz.EqualTo(3) + Assert.That m_TreeNode.Nodes.Count, Iz.EqualTo(28) + + Dim Node As GitHubTreeNode + Set Node = m_TreeNode.Nodes.Item("data") + Assert.That Node.Nodes.Count, Iz.GreaterThan(0) + +End Sub + +Public Sub BuildFromSHA_master_CheckSubTreeDaoFromData() + + m_TreeNode.BuildFromSHA "master", 1 + + Assert.That m_TreeNode.Properties.Count, Iz.EqualTo(3) + Assert.That m_TreeNode.Nodes.Count, Iz.EqualTo(28) + + Dim DataNode As GitHubTreeNode + Dim DaoNode As GitHubTreeNode + + Set DataNode = m_TreeNode.Nodes.Item("data") + Assert.That DataNode.Nodes.Count, Iz.GreaterThan(0) + Set DaoNode = DataNode.Nodes("dao") + Assert.That DataNode.NodeType, Iz.EqualTo("tree") + +End Sub diff --git a/source/JsonProperties.cls b/source/JsonProperties.cls new file mode 100644 index 0000000..585312a --- /dev/null +++ b/source/JsonProperties.cls @@ -0,0 +1,55 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "JsonProperties" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private m_Properties As Collection + +Private Sub Class_Initialize() + Set m_Properties = New Collection +End Sub + +Public Function NewProperty(ByVal Name As String) As JsonProperty + With New JsonProperty + .Name = Name + Append .Self + Set NewProperty = .Self + End With +End Function + +Public Sub Append(ByVal Property As JsonProperty) + m_Properties.Add Property, Property.Name +End Sub + +Public Property Get Item(ByVal Index As Variant) As JsonProperty +Attribute Item.VB_UserMemId = 0 + Set Item = m_Properties.Item(Index) +End Property + +Public Property Get Count() As Long + Count = m_Properties.Count +End Property + +Public Sub SetProperties(ByVal NewProperties As JsonProperties) + + Dim CurrentProp As JsonProperty + Dim NewProp As JsonProperty + Dim i As Long + + For i = 1 To NewProperties.Count + Set NewProp = NewProperties.Item(i) + Set CurrentProp = m_Properties.Item(NewProp.Name) + CurrentProp.Value = NewProp.Value + If NewProp.Properties.Count > 0 Then + CurrentProp.Properties.SetProperties NewProp.Properties + End If + Next + +End Sub diff --git a/source/JsonProperty.cls b/source/JsonProperty.cls new file mode 100644 index 0000000..f526ebd --- /dev/null +++ b/source/JsonProperty.cls @@ -0,0 +1,55 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "JsonProperty" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +Private m_Name As String +Private m_Value As Variant +Private m_Properties As JsonProperties + +Public Property Get Self() As JsonProperty + Set Self = Me +End Property + +Public Property Get Name() As String + Name = m_Name +End Property + +Friend Property Let Name(ByVal NewValue As String) + m_Name = NewValue +End Property + +Public Property Get Value() As Variant +''Attribute Value.VB_UserMemId = 0 + If IsObject(m_Value) Then + Set Value = m_Value + Else + Value = m_Value + End If +End Property + +Public Property Let Value(ByVal NewValue As Variant) + m_Value = NewValue +End Property + +Public Property Set ObjectValue(ByVal NewValue As Object) + Set m_Value = NewValue +End Property + +Public Property Get Properties() As JsonProperties + If m_Properties Is Nothing Then + Set m_Properties = New JsonProperties + End If + Set Properties = m_Properties +End Property + +Public Property Set Properties(ByVal NewRef As JsonProperties) + Set m_Properties = NewRef +End Property diff --git a/source/_config_Application.bas b/source/_config_Application.bas index 6fb3028..4a17cf8 100644 --- a/source/_config_Application.bas +++ b/source/_config_Application.bas @@ -31,7 +31,7 @@ Option Compare Database Option Explicit 'Versionsnummer -Private Const APPLICATION_VERSION As String = "1.2.0" +Private Const APPLICATION_VERSION As String = "1.3.0" #Const USE_CLASS_ApplicationHandler_AppFile = 1 #Const USE_CLASS_ApplicationHandler_DirTextbox = 1 diff --git a/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls b/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls index 87d6835..b547286 100644 --- a/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls +++ b/source/codelib/_codelib/addins/shared/ACLibConfiguration.cls @@ -64,11 +64,13 @@ Private Const SQL_CREATETABLE_CONFIGTABLE As String = _ Private Const PROPNAME_LOCALREPOSITORYROOT As String = "LocalRepositoryRoot" Private Const PROPNAME_PRIVATEREPOSITORYROOT As String = "PrivateRepositoryRoot" Private Const PROPNAME_IMPORTTESTDEFAULTVALUE As String = "ImportTestDefaultValue" +Private Const PROPNAME_GITHUBAUTHPERSONALACCESSTOKEN As String = "GitHubAuthPersonalAccessToken" ' Hilfsvariablen Private m_LocalRepositoryPath As String ' allg. Repository-Verzeichnis Private m_PrivateRepositoryPath As String ' privates Verzeichnis (nicht in CodeLib enthalten) Private m_ImportTestDefaultValue As Long +Private m_GitHubAuthPersonalAccessToken As String Private m_ACLibPropertyDb As DAO.Database '--------------------------------------------------------------------------------------- @@ -172,7 +174,6 @@ Public Property Let LocalRepositoryPath(ByVal NewPath As String) End Property - Public Property Get PrivateRepositoryPath() As String If Len(m_PrivateRepositoryPath) = 0 Then @@ -224,7 +225,24 @@ Public Property Let ImportTestsDefaultValue(ByVal NewValue As Boolean) End Property -Private Function GetACLibGlobalProperty(ByRef PropertyName As String) As String +Public Property Get GitHubAuthPersonalAccessToken() As String +'m_GitHubAuthPersonalAccessToken: vbnullstring = noch nicht abgefragt + + If StrPtr(m_GitHubAuthPersonalAccessToken) = 0 Then + m_GitHubAuthPersonalAccessToken = GetACLibGlobalProperty(PROPNAME_GITHUBAUTHPERSONALACCESSTOKEN) & "" + End If + GitHubAuthPersonalAccessToken = m_GitHubAuthPersonalAccessToken + +End Property + +Public Property Let GitHubAuthPersonalAccessToken(ByVal NewValue As String) + + m_GitHubAuthPersonalAccessToken = NewValue + SetACLibGlobalProperty PROPNAME_GITHUBAUTHPERSONALACCESSTOKEN, m_GitHubAuthPersonalAccessToken + +End Property + +Private Function GetACLibGlobalProperty(ByVal PropertyName As String) As String Dim rst As DAO.Recordset Dim SelectSql As String @@ -240,7 +258,7 @@ Private Function GetACLibGlobalProperty(ByRef PropertyName As String) As String End Function -Private Function SetACLibGlobalProperty(ByRef PropertyName As String, ByRef NewValue As String) As String +Private Function SetACLibGlobalProperty(ByVal PropertyName As String, ByVal NewValue As String) As String Dim rst As DAO.Recordset Dim SelectSql As String diff --git a/source/codelib/_codelib/addins/shared/ACLibGitHubImporter.cls b/source/codelib/_codelib/addins/shared/ACLibGitHubImporter.cls new file mode 100644 index 0000000..23984ec --- /dev/null +++ b/source/codelib/_codelib/addins/shared/ACLibGitHubImporter.cls @@ -0,0 +1,264 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "ACLibGitHubImporter" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: _codelib.addins.shared.ACLibGitHubImporter +'--------------------------------------------------------------------------------------- +' +' Import GitHub files +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' _codelib/addins/shared/ACLibGitHubImporter.cls +' _codelib/license.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Database +Option Explicit + +Private Const GitHubContentBaseUrl As String = "https://raw.githubusercontent.com/AccessCodeLib/AccessCodeLib/{branch}/{path}" +Private Const GitHubApiBaseUrl As String = "https://api.github.com/repos/AccessCodeLib/AccessCodeLib/" + +Private m_GitHubApiAuthorizationToken As String +Private m_LastCommit As Date +Private m_UseDraftBranch As Boolean + +#If VBA7 Then +Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long +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 +#Else +Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long +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 +#End If + +'--------------------------------------------------------------------------------------- +' Property: GitHubAuthorizationubAuthToken +'--------------------------------------------------------------------------------------- +Public Property Get GitHubApiAuthorizationToken() As String + GitHubApiAuthorizationToken = m_GitHubApiAuthorizationToken +End Property + +Public Property Let GitHubApiAuthorizationToken(ByVal NewValue As String) + m_GitHubApiAuthorizationToken = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: UseDraftBranch +'--------------------------------------------------------------------------------------- +Public Property Get UseDraftBranch() As Boolean + UseDraftBranch = m_UseDraftBranch +End Property + +Public Property Let UseDraftBranch(ByVal NewValue As Boolean) + m_UseDraftBranch = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: RevisionString +'--------------------------------------------------------------------------------------- +Public Property Get RevisionString(Optional ByVal Requery As Boolean = False) As String + RevisionString = Format(LastCommit, "yyyymmddhhnnss") + If UseDraftBranch Then + RevisionString = RevisionString & "-draft" + End If +End Property + +'--------------------------------------------------------------------------------------- +' Property: LastCommit +'--------------------------------------------------------------------------------------- +Public Property Get LastCommit(Optional ByVal Requery As Boolean = False) As String + If m_LastCommit = 0 Or Requery Then + m_LastCommit = GetLastCommitFromWeb() + End If + LastCommit = m_LastCommit +End Property + +'--------------------------------------------------------------------------------------- +' Sub: UpdateCodeModules +'--------------------------------------------------------------------------------------- +Public Sub UpdateCodeModules() + + Dim SelectSql As String + Dim IsFirstRecord As Boolean + + SelectSql = "select id, url from usys_Appfiles where url > ''" + + With CreateObject("ADODB.Recordset") + .CursorLocation = 3 'adUseClient + .Open SelectSql, CodeProject.Connection, 1, 1 ' 1 = adOpenKeyset, 1 = adLockReadOnly + Set .ActiveConnection = Nothing + + IsFirstRecord = True + Do While Not .EOF + UpdateCodeModuleInTable .Fields(0).Value, .Fields(1).Value, IsFirstRecord + If IsFirstRecord Then IsFirstRecord = False + .MoveNext + Loop + + .Close + + End With + +End Sub + +Private Sub UpdateCodeModuleInTable(ByVal ModuleName As String, ByVal ACLibPath As String, Optional ByVal Requery As Boolean = False) + + Dim TempFile As String + + + TempFile = FileTools.TempPath & ModuleName & FileTools.GetFileExtension(ACLibPath, True) + DownloadACLibFileFromWeb ACLibPath, TempFile + + CurrentApplication.SaveAppFile ModuleName, TempFile, False, "SccRev", Me.RevisionString(Requery) + Kill TempFile + +End Sub + +Friend Sub DownloadACLibFileFromWeb(ByVal ACLibPath As String, ByVal TargetFilePath As String) + + Dim DownLoadUrl As String + Dim BranchName As String + + If UseDraftBranch Then + BranchName = "draft" + Else + BranchName = "master" + End If + DownLoadUrl = Replace(GitHubContentBaseUrl, "{branch}", BranchName) + DownLoadUrl = Replace(DownLoadUrl, "{path}", ACLibPath) + + DownloadFileFromWeb DownLoadUrl, TargetFilePath + +End Sub + +Private Function GetLastCommitFromWeb() As Date + +'alternative: git rev-list HEAD --count + +' https://api.github.com/repos/AccessCodeLib/AccessCodeLib/commits/master + + Dim CommitUrl As String + Dim LastCommitInfo As String + CommitUrl = GitHubApiBaseUrl & "commits/" + + If UseDraftBranch Then + CommitUrl = CommitUrl & "draft" + Else + CommitUrl = CommitUrl & "master" + End If + + Const RevisionTag As String = "Revision " + + Dim JsonString As String + JsonString = GetJsonString(CommitUrl) + + Dim LastCommitPos As Long + LastCommitPos = InStr(1, JsonString, """committer"":") + LastCommitPos = InStr(LastCommitPos, JsonString, """date"":") + Len("date"": """) + '"date": "2023-05-14T09:34:04Z" + LastCommitInfo = Mid(JsonString, LastCommitPos, Len("2023-05-14T09:34:04")) + + GetLastCommitFromWeb = CDate(Replace(LastCommitInfo, "T", " ")) + +End Function + +Friend Function GetJsonString(ByVal ApiUrl As String) As String + + Dim ApiResponse As String + Dim ApiAuthToken As String + Dim json As Object + Dim xml As MSXML2.XMLHTTP60 + + ApiAuthToken = GitHubApiAuthorizationToken + + Set xml = CreateObject("MSXML2.XMLHTTP.6.0") + + xml.Open "GET", ApiUrl, False + If Len(ApiAuthToken) > 0 Then + xml.setRequestHeader "Authorization", ApiAuthToken + End If + xml.setRequestHeader "Content-type", "application/json" + xml.send + While xml.ReadyState <> 4 + DoEvents + Wend + ApiResponse = xml.responseText + + GetJsonString = ApiResponse + +End Function + +Private Sub OpenIEandLoadHtmlDoc(ByVal Url As String, ByRef IE As Object, ByRef HtmlDoc As Object) + + Dim TimeOut As Long + Dim RunInTimeOut As Boolean + Dim ErrHdlCnt As Long + + Dim ErrNumber As Long + Dim ErrDescription As String + +On Error Resume Next + Set IE = CreateObject("InternetExplorer.Application") + Do While Err.Number = -2147023706 And ErrHdlCnt < 10 + Err.Clear + ErrHdlCnt = ErrHdlCnt + 1 + Set IE = CreateObject("InternetExplorer.Application") + Loop + + If Err.Number <> 0 Then + ErrNumber = Err.Number + ErrDescription = Err.Description + On Error GoTo 0 + Err.Raise ErrNumber, "ACLibWebImporter.OpenIEandLoadHtmlDoc", ErrDescription + End If + +On Error GoTo 0 + + With IE + TimeOut = Timer + 10 + Do While .Busy And (Not RunInTimeOut) + DoEvents + If Timer > TimeOut Then RunInTimeOut = True + Loop + + If Not RunInTimeOut Then + .Visible = 0 + .navigate Url + TimeOut = Timer + 10 + Do Until .ReadyState = 4 Or RunInTimeOut + DoEvents + If Timer > TimeOut Then RunInTimeOut = True + Loop + End If + + If RunInTimeOut Then + On Error Resume Next + IE.Quit + Set IE = Nothing + On Error GoTo 0 + Err.Raise vbObjectError, "OpenIEandLoadHtmlDoc", "Time-Out beim Laden von '" & Url & "'" + End If + + Set HtmlDoc = IE.Document + + End With + +End Sub + +Private Sub DownloadFileFromWeb(ByVal Url As String, ByVal TargetPath As String) + If FileExists(TargetPath) Then Kill TargetPath + DeleteUrlCacheEntry Url + URLDownloadToFile 0, Url, TargetPath, 0, 0 +End Sub diff --git a/source/codelib/_codelib/addins/shared/CodeModuleReader.cls b/source/codelib/_codelib/addins/shared/CodeModuleReader.cls index 92299b2..3b3d7cb 100644 --- a/source/codelib/_codelib/addins/shared/CodeModuleReader.cls +++ b/source/codelib/_codelib/addins/shared/CodeModuleReader.cls @@ -347,7 +347,7 @@ Public Function ProcedureUsed(ByRef CodeModuleProc As CodeModuleProcedure) As Bo With RegEx .Pattern = SearchStringArray(i) .Global = False - IsUsed = .test(m_CodeModuleText) + IsUsed = .Test(m_CodeModuleText) If IsUsed Then Exit For End If @@ -398,7 +398,7 @@ Public Function HeaderItemUsed(ByRef HdrItm As CodeModuleHeaderItem) As Boolean With RegEx .Pattern = SearchStringArray(i) .Global = False - IsUsed = .test(m_CodeModuleText) + IsUsed = .Test(m_CodeModuleText) If IsUsed Then Exit For End With #Else diff --git a/source/codelib/data/dao/DaoHandler.cls b/source/codelib/data/dao/DaoHandler.cls index f81e42c..af67e2c 100644 --- a/source/codelib/data/dao/DaoHandler.cls +++ b/source/codelib/data/dao/DaoHandler.cls @@ -21,6 +21,7 @@ Attribute VB_Exposed = False '--------------------------------------------------------------------------------------- ' ' data/dao/DaoHandler.cls +' DAO data connection methods ' _codelib/license.bas ' DAO50{00025E01-0000-0000-C000-000000000046} ' _test/data/dao/DaoHandlerTests.cls