From 204b141fc08a18c2754358804f0c0e9ea823f560 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 14:07:33 +0200 Subject: [PATCH 01/17] + Install form for add-ins + AddInConfiguration + AddInInstaller --- _codelib/addins/shared/AddInConfiguration.cls | 360 ++++++++++++++++++ _codelib/addins/shared/AddInInstaller.cls | 212 +++++++++++ _codelib/addins/shared/InstallAddInForm.frm | Bin 0 -> 74262 bytes 3 files changed, 572 insertions(+) create mode 100644 _codelib/addins/shared/AddInConfiguration.cls create mode 100644 _codelib/addins/shared/AddInInstaller.cls create mode 100644 _codelib/addins/shared/InstallAddInForm.frm diff --git a/_codelib/addins/shared/AddInConfiguration.cls b/_codelib/addins/shared/AddInConfiguration.cls new file mode 100644 index 0000000..27af39a --- /dev/null +++ b/_codelib/addins/shared/AddInConfiguration.cls @@ -0,0 +1,360 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "AddInConfiguration" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: _codelib.addins.shared.AddInConfiguration +'--------------------------------------------------------------------------------------- +' +' Manage Access Add-In configuration settings +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' _codelib/addins/shared/AddInConfiguration.cls +' _codelib/license.bas +' base/ApplicationHandler.cls +' DAO50{00025E01-0000-0000-C000-000000000046} +' +'--------------------------------------------------------------------------------------- +' +Option Compare Database +Option Explicit + +Private m_AppTitle As String +Private m_Title As String +Private m_Author As String +Private m_Company As String +Private m_Comments As String + +Private m_AddInRegPathName As String +Private m_AddInRegFilePath As String +Private m_AddInStartFunction As String + +Private m_InsertRecordset As DAO.Recordset + +Public Property Get FileName() As String + If Len(m_AddInRegFilePath) > 0 Then + FileName = Mid(m_AddInRegFilePath, InStrRev(m_AddInRegFilePath, "\", , vbTextCompare) + 1) + End If +End Property + +Public Property Let FileName(ByVal NewValue As String) + If Len(NewValue) > 0 Then + AddInRegFilePath = "|ACCDIR\" & NewValue + End If +End Property + +Public Property Get AppTitle() As String + AppTitle = m_AppTitle +End Property + +Public Property Let AppTitle(ByVal NewValue As String) + m_AppTitle = NewValue +End Property + +Public Property Get Title() As String + Title = m_Title +End Property + +Public Property Let Title(ByVal NewValue As String) + m_Title = NewValue +End Property + +Public Property Get Author() As String + Author = m_Author +End Property + +Public Property Let Author(ByVal NewValue As String) + m_Author = NewValue +End Property + +Public Property Get Company() As String + Company = m_Company +End Property + +Public Property Let Company(ByVal NewValue As String) + m_Company = NewValue +End Property + +Public Property Get Comments() As String + Comments = m_Comments +End Property + +Public Property Let Comments(ByVal NewValue As String) + m_Comments = NewValue +End Property + +Public Property Get AddInRegPathName() As String + AddInRegPathName = m_AddInRegPathName +End Property + +Public Property Let AddInRegPathName(ByVal NewValue As String) + m_AddInRegPathName = NewValue +End Property + +Public Property Get AddInStartFunction() As String + AddInStartFunction = m_AddInStartFunction +End Property + +Public Property Let AddInStartFunction(ByVal NewValue As String) + m_AddInStartFunction = NewValue +End Property + +Public Property Get AddInRegFilePath() As String + AddInRegFilePath = m_AddInRegFilePath +End Property + +Public Property Let AddInRegFilePath(ByVal NewValue As String) + m_AddInRegFilePath = NewValue +End Property + +Public Sub LoadFromCurrentFile() + + If CurrentDb Is Nothing Then + Exit Sub + End If + + LoadDataFromUSysRegInfo + LoadDataFromDatabase + +End Sub + +Private Sub LoadDataFromDatabase() + + Dim db As DAO.Database + Set db = CurrentDb + + m_AppTitle = GetDbProperty(db, "AppTitle", vbNullString) + + If Len(FileName) = 0 Then + FileName = Replace(CurrentProject.Name, ".accdb", ".accda", , , vbTextCompare) + End If + + m_Title = GetDocProperty(db, "Title", vbNullString) + m_Author = GetDocProperty(db, "Author", vbNullString) + m_Company = GetDocProperty(db, "Company", vbNullString) + m_Comments = GetDocProperty(db, "Comments", vbNullString) + +End Sub + +Private Function GetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, Optional ByVal ValueIfNotExists As Variant = Null) As Variant + + On Error Resume Next + + GetDbProperty = PropDb.Properties(PropertyName) + If Err.Number <> 0 Then + Err.Clear + GetDbProperty = ValueIfNotExists + End If + +End Function + +Private Function GetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, Optional ByVal ValueIfNotExists As Variant = Null) As String + +On Error Resume Next + + Dim PropValue As String + + PropValue = PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName) + If Err.Number <> 0 Then + Err.Clear + PropValue = ValueIfNotExists + End If + + GetDocProperty = PropValue + +End Function + +Private Sub LoadDataFromUSysRegInfo() +'Subkey Type ValName Value +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 0 +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Expression =LoadAddIn() +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Library |ACCDIR\ACLibAccessAddInBuilder.accda + + Dim AddInRegPathName As String + Dim AddInStartFunction As String + + Dim ValNameField As DAO.Field + Dim SubkeyField As DAO.Field + Dim ValueField As DAO.Field + + If Not Nz(DLookup("True", "MSysObjects", "[Name]='USysRegInfo'"), False) Then + Exit Sub + End If + + With CurrentDb.OpenRecordset("select * from USysRegInfo Order By Subkey, ValName") + If Not .EOF Then + + Set SubkeyField = .Fields("Subkey") + Set ValNameField = .Fields("ValName") + Set ValueField = .Fields("Value") + + Do While Not .EOF + If IsNull(ValNameField.Value) Then + With .Fields("Subkey") + m_AddInRegPathName = Mid(.Value, InStrRev(.Value, "\", , vbTextCompare) + 1) + End With + + ElseIf ValNameField.Value = "Expression" Then + m_AddInStartFunction = Nz(ValueField.Value, vbNullString) + + ElseIf ValNameField.Value = "Library" Then + m_AddInRegFilePath = Nz(ValueField.Value, vbNullString) + + End If + .MoveNext + Loop + End If + .Close + End With + +End Sub + +Public Sub SaveToCurrentFile() + + If CurrentDb Is Nothing Then + Exit Sub + End If + + SaveDataToUSysRegInfo + SaveDataToDatabase + +End Sub + +Private Sub SaveDataToDatabase() + + Dim db As DAO.Database + Set db = CurrentDb + + SetDbProperty db, "AppTitle", m_AppTitle + + SetDocProperty db, "Title", m_Title + SetDocProperty db, "Author", m_Author + SetDocProperty db, "Company", m_Company + SetDocProperty db, "Comments", m_Comments + +End Sub + +Private Sub SetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, ByVal NewValue As Variant) + +On Error GoTo HandleErr + + PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) + +ExitHere: + Exit Sub + +HandleErr: + If Err.Number = 3270 Then + PropDb.Properties.Append PropDb.CreateProperty(PropertyName, dbText, NewValue) + Resume ExitHere + End If + + HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + +End Sub + +Private Sub SetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, ByVal NewValue As Variant) + +On Error GoTo HandleErr + + PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) + +ExitHere: + Exit Sub + +HandleErr: + If Err.Number = 3270 Then + If Len(NewValue) > 0 Then + PropDb.Containers("Databases").Documents("SummaryInfo").Properties.Append PropDb.CreateProperty(PropertyName, dbText, NewValue) + End If + Resume ExitHere + End If + + HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + +End Sub + +Private Sub SaveDataToUSysRegInfo() +'Subkey Type ValName Value +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 0 +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Expression =LoadAddIn() +'HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\ACLib Access Add-In Builder 1 Library |ACCDIR\ACLibAccessAddInBuilder.accda +' + Dim SubKey As String + Dim Expression As String + Dim Library As String + + If Len(m_AddInRegPathName) = 0 Then + MsgBox "Enter USysRegInfo-Name first!" + Exit Sub + End If + SubKey = "HKEY_CURRENT_ACCESS_PROFILE\Menu Add-Ins\" & m_AddInRegPathName + + + If Len(m_AddInStartFunction) = 0 Then + m_AddInStartFunction = "=LoadAddIn()" + End If + Expression = m_AddInStartFunction + If Left(Expression, 1) <> "=" Then + Expression = "=" & Expression + End If + If Right(Expression, 1) <> ")" Then + Expression = Expression & "()" + End If + + Library = m_AddInRegFilePath + + If Not Nz(DLookup("True", "MSysObjects", "[Name]='USysRegInfo'"), False) Then + CreateTableUSysRegInfo + End If + + Dim db As DAO.Database + Set db = CurrentDb + + db.Execute "delete from USysRegInfo where Type = 0 or Type = 1 and ValName in ('Expression', 'Library')" + + Dim rs As DAO.Recordset + Set rs = db.OpenRecordset("select * from USysRegInfo") + + InsertUSysRegInfoRecord rs, SubKey, 0, Null, Null + InsertUSysRegInfoRecord rs, SubKey, 1, "Expression", Expression + InsertUSysRegInfoRecord rs, SubKey, 1, "Library", Library + + rs.Close + +End Sub + +Private Sub InsertUSysRegInfoRecord(ByVal RegInfoRs As DAO.Recordset, ByVal SubKey As String, ByVal TypeNo As Long, ByVal ValName As Variant, ByVal NewValue As Variant) + + With RegInfoRs + .AddNew + .Fields("Subkey").Value = SubKey + .Fields("Type").Value = TypeNo + .Fields("ValName").Value = ValName + .Fields("Value").Value = NewValue + .Update + End With + +End Sub + +Private Sub CreateTableUSysRegInfo() + + Dim CreateTableDDL As String + + CreateTableDDL = "create Table USysRegInfo (" & _ + " Subkey nvarchar(255), Type int, ValName nvarchar(255), [Value] nvarchar(255))" + + CurrentProject.Connection.Execute CreateTableDDL + +End Sub diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls new file mode 100644 index 0000000..30837d2 --- /dev/null +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -0,0 +1,212 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "AddInInstaller" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: _codelib.addins.shared.AddInInstaller +'--------------------------------------------------------------------------------------- +' +' Install Access add-in +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' _codelib/addins/shared/AddInInstaller.cls +' _codelib/license.bas +' _codelib/addins/shared/AddInConfiguration.cls +' DAO50{00025E01-0000-0000-C000-000000000046} +' +'--------------------------------------------------------------------------------------- +' +Option Compare Database +Option Explicit + +Private m_ConfigData As AddInConfiguration + +Public Function InstallAddIn(ByVal AddInConfigData As AddInConfiguration, _ + Optional ByVal CompileAddIn As Boolean = False, _ + Optional ByRef CompletedMsg As String) As Boolean + + Dim AddInFileInstalled As Boolean + + Set m_ConfigData = AddInConfigData + + If CompileAddIn Then + AddInFileInstalled = CreateAccde(GetSourceFileFullName, GetDestFileFullName) + If AddInFileInstalled Then + CompletedMsg = "Add-In was compiled and saved in '" + GetAddInLocation + "'." + Else + CompletedMsg = "Error! Compiled file was not created." + End If + Else + DeleteAddInFiles + AddInFileInstalled = TryFileCopy(GetSourceFileFullName, GetDestFileFullName) + If AddInFileInstalled Then + CompletedMsg = "Add-In was saved in '" + GetAddInLocation + "'." + Else + CompletedMsg = "Error! File was not copied." + End If + End If + + If AddInFileInstalled = True Then + RegisterAddIn GetDestFileFullName() + End If + + InstallAddIn = AddInFileInstalled + +End Function + +Public Property Get AddInName() As String + AddInName = m_ConfigData.AddInRegPathName +End Property + +Public Property Get AddInFileName() As String + AddInFileName = m_ConfigData.FileName +End Property + +Public Property Get MsgBoxTitle() As String + MsgBoxTitle = "Install " & AddInName +End Property + +Function GetSourceFileFullName() + GetSourceFileFullName = CurrentDb.Name +End Function + +Function GetDestFileFullName() + GetDestFileFullName = GetAddInLocation & AddInFileName +End Function + +Function GetAddInLocation() + GetAddInLocation = GetAppDataLocation & "Microsoft\AddIns\" +End Function + +Function GetAppDataLocation() + GetAppDataLocation = Environ("APPDATA") & "\" +End Function + +Function DeleteAddInFiles() + + Dim DestFile As String + DestFile = GetDestFileFullName() + DeleteFile DestFile + +End Function + +Function DeleteFile(File2Delete) + If FileTools.FileExists(File2Delete) Then + Kill File2Delete + End If +End Function + +Private Function TryFileCopy(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean + +On Error Resume Next + + With CreateObject("Scripting.FileSystemObject") + If .FileExists(DestFilePath) Then + .DeleteFile DestFilePath, True + End If + .CopyFile SourceFilePath, DestFilePath, True + End With + + If Err.Number <> 0 Then + Err.Clear + TryFileCopy = False + Else + TryFileCopy = True + End If + +End Function + +Function CreateAccde(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean + + Dim FileToCompile As String + Dim AccessApp As Access.Application + + DeleteAddInFiles + + FileToCompile = DestFilePath & ".accdb" + If Not TryFileCopy(SourceFilePath, FileToCompile) Then + Exit Function + End If + + Set AccessApp = CreateObject("Access.Application") + AccessApp.SysCmd 603, (FileToCompile), (DestFilePath) + + DeleteFile FileToCompile + + CreateAccde = True + +End Function + + +'################################################## +' Register Menu Add-In + +Function RegisterAddIn(AddInFile) + + Dim AddInDb As DAO.Database + Dim rst As DAO.Recordset + Dim ItemValue As Variant + Dim wsh As Object + + Set AddInDb = DBEngine.OpenDatabase(AddInFile) + + Set wsh = CreateObject("WScript.Shell") + Set rst = AddInDb.OpenRecordset("select Subkey, ValName, Type, Value from USysRegInfo where ValName > '' Order By ValName", 8) 'dbOpenForwardOnly=8 + Do While Not rst.EOF + ItemValue = rst.Fields("Value").Value + If Len(ItemValue) > 0 Then + If InStr(1, ItemValue, "|ACCDIR") > 0 Then + ItemValue = AddInDb.Name + End If + End If + RegisterMenuAddInItem wsh, rst.Fields("Subkey").Value, rst.Fields("ValName").Value, rst.Fields("Type").Value, ItemValue + rst.MoveNext + Loop + rst.Close + + AddInDb.Close + +End Function + +Function RegisterMenuAddInItem(wsh, ByVal SubKey, ByVal ItemValName, ByVal RegType, ByVal ItemValue) + Dim RegName + RegName = GetRegistryPath(SubKey) + With wsh + If Len(ItemValName) > 0 Then + RegName = RegName & "\" & ItemValName + End If + .RegWrite RegName, ItemValue, GetRegTypeString(RegType) + End With +End Function + +Function GetRegTypeString(ByVal RegType) + Select Case RegType + Case 1 + GetRegTypeString = "REG_SZ" + Case 4 + GetRegTypeString = "REG_DWORD" + Case 0 + GetRegTypeString = vbNullString + Case Else + Err.Raise vbObjectError, "GetRegTypeString", "RegType not supported" + End Select +End Function + +Function GetRegistryPath(SubKey) + GetRegistryPath = Replace(SubKey, "HKEY_CURRENT_ACCESS_PROFILE", HkeyCurrentAccessProfileRegistryPath()) +End Function + +Function HkeyCurrentAccessProfileRegistryPath() + HkeyCurrentAccessProfileRegistryPath = "HKCU\SOFTWARE\Microsoft\Office\" & Access.Application.Version & "\Access" +End Function diff --git a/_codelib/addins/shared/InstallAddInForm.frm b/_codelib/addins/shared/InstallAddInForm.frm new file mode 100644 index 0000000000000000000000000000000000000000..39e809e5b112145d985115a9a531924c3367e61a GIT binary patch literal 74262 zcmeHQZEqYmlJ3t3++&D-W#bKIN-@D$oZxifF}nt#YMADj2C z{%W({+-Yt%cco2yyC;8W`GGw7Mj!y6CxX|BJdf+M^Ur;0>rk%$Q|`W#Z)fs6`T*=_ z%@1??# z)C0#0`vT)cIOMGP?C1+<>j|g66L@DbdXPEvMtksHet|1cV=b!j$c_50&=}H&G5c2P zVhm9CNUoeZ=>i2XHsI35c3J0t-M!VMk3TthXVL;{ZVAqJMRG$4Tf_oV42-`M4A6(S z=h&~F>l)H;TdvPV+IOVS2l9E>d^*Pu`XOxNdwK5Q9LgQJ2R#zre<>}hgs;mT{DpU4 zBv{;)e%wx4z$l%`=fiK>YD1pdOdu`xmDKYTe<(1ZuawrS(hf8qbl$zB|EfE7FHKp%#EAkA(Iji5O<<+CAB_hhs;g*qGZH+R?KzCV_c*pI03P`Dx1**BVPdFoU! zfZl`VQyIJ^bUSKpM70+wz|n>-0ulx9^@x(D}@)* zWN|!|n$TIl2u)$VbPR@Y65CJ9J)t(Zi`V&kE;0cw!yoRU4}0=CaD2ES<*r=uz1fgo z`vPlEplwKbAb(r(pK$xB3J8$rP2qZu7Rq&jw=Q@9BA`Jdu-$v^$~}k6Yxg9)4#D2`}zMsd9G$yRLF04TK;ZtKvaNUM* z4zwezMh>^NbAEsQ+vq8uvF$w>TWH=@$M60r-Y+e4xb?$UdGyc4boJNyjpNYwoIYQM z8{52?a>8vKT_?ItbQ?#3akVCXo9H%<0^@2;{5H{T90kVJs>^S~{Ia2#*2QgTtNL8( zDc^B3qlZ>snXGj2YrX>w@ncnXe-{wB@iq5X`sEzpu*oeW!&srDt364W&Mh z?})Ol%imr3h7yt1d*{#L8sM&H^_ND<&<Swi12~&f5BPz;`Eh?H5!~-3D!41yYh?Cs&0~oaGN*v(;Rk_+ET3i`{+>i@!>n5h zEpGjpz|uU&1IcpKdv-@M2+03EmtMRPOrJ`5BHs|5RvwP=KrZT3V#|l}oZIi^#OiUA_nT&BbW{JsB%RiZF8F*epWL7hi2h^TH2V@m3bR-Jb>obdf1Wvl zTuYk!oe#h;rb+kM`1buMJ;5(lhTTc0l zF3NEnV)}PIogdS#TFbdU;Wm!W6Wu1djibQ0S`)ubbQ?#3akVCXo9H%<0^@4c<+ove z*-%XD;x@EZeQwHM*yuI%>B}6`J{%|9`Y6v=W0K{ zYP7vawXT*>rWOuea4fhXs{%O4te`{&LraB@Oa;CnYoVpCbN1KOG9a6R`-pJpb9xBO!ThalB7=hazAZk-zVLah3P)dvv-XAcbGQ*U;}ppF0G957 z%F#`6LnbK3QTs+Z>Mu`cUT3>G+>k}mez7g>H#17OhfiK2vGZz2xB$7NhZ42lZhmsP zg(KO^fc(p@+a<=`V`)}_d%nUpn1Av4$eHA>00(=L+Me_^G`kV+uZerWXIU~QfjrQ! z(gLzA=?)b>%QDP{_?!Z2-gP5;M|i3a2J;+oePjs1Wq0Kh=Z)AlOX5u}s9C+-ehb!Q zndY5hOn`;vupmcwvvl_v7GjmludscVV{=lh&oUepkCE?Hj8mQ~Vp#7aGp74;Aa7~T zhwZcE$d=;Z;rR9;v3>2Q{|@bYb~K z_70G%A2@x!D^dYXXNMJz6k%H80QPx?mlTz)Th8Y6#e-vj7>-L#Si|L-lH^lA-K z8ahK9F7qj*t4>**d5Gwyo+z1{lcrQf#&WACzZ7e(N75F~D8ng`$O%FdA-4K9*|A10 zW!b&2Cmko8O4+`9i?CRB!z>-KZpg7zwCzG7b}Z}Z&0M~gt+5PqJi|Q{)@F%ai}1Ob zLAHAsgv7Eeb3iC8pPkRj4}~L-#2{bH!Lu=WnbiD z$&G283IDOHb9kPDxUdY*T*TT1WDqR)gl979*{_z`v3G~F82e%z#G7TRZ*)zE1&5b1 zqOaZAh(1^Q{#D@i|`QpvT-AHC-xBQE?n#bhUI{EQNLWF zS-1nUiO-I1XW~_0{RyH3`{F74vr5OvO&8oUdFp~1%Nh2%W9D9i4vX@K*q%*(Ubr#C ztPs1mHFA|-9YYymsSwml1Si^RtABtKtdHEP1CK@CpJnSTLpUCnd=`LpS%xF%CDtyd z-anxpiDwL$6lITR`hLf@6!Qz5_<-1&x7U0oKFzofa(ch*{N=HpKnj}@O-!L3 zZaAwx&NE2i*OB!UDtUL&&V!T3=mWM;+lwGvmdM)ReCuDOM0R&qxaPj|yg_gEENohy zkXeRWzst)gm-nt#>gs{6R$~1CpULWjkXkIeT3XZ_cAtc8uq^jc2#IBx&q63HLt1$G zwfhZ($FjB`LAWeEt|fj2p{dtp(Ivxc41Y58Q|JXiN9A*h>;udCkrAaZ{A|8QVT!hp z+U@1ljkegWL9BnTPOQZ?4~cyq_1*OBvbnq^NZ(Ci^W18CQ*|`j6lYmhoW(9lp{)(Q zwOGO~GRmUwwz1f`Fg6iKT5R$c!kJnbe%T&UN^)Z0OoX=~1BhAz3`*bw|Kh5}4%~U%l@@1{8uuD{EAungnuWy#M>4CPag)P^X zW+`m7!)U=2bx37Ye|vwcBm?5T28*2_M!xnGb*M29DYM=j6_&9zzdmsXzoufmttJgv zwnZQ6L7(Cdq_dW_y@(k4Ox_*;`&n6G_c>B(4f8>k8F?7vlcc>W_fgs*`s{?wXGx)j zRQI-eijAanN`DWJcnp6s^i!tTNJ{ax-=xx)x#tACMX*E4;`7Gd)YXZN*tAqWHiCH< z_CjJ$?`Pvak=j0x*O?{rn`u47verY4k*Ux|UQTobD?F{5pw08hpM;uf*fcs~t35?W zQhF}_uA@D?-(ay6#Kza2q9b*qBV%+8M}=i<&#z;2q{Ld23M|{=BQ@dI_6~?Q%R2H- zXe^nHoA#cNBEIah-K5#FR%X=D1zmlKb;L3wBxC#%KQ{WU+)rtT=p!UHza@nhQr*k% z6d_6Jl>Qzb_Za?U=&Nwz3k@_{5bs*I z>8T+x61*cFdpf5TB&l|)o%?y^PT{~AQhOD4(0)nlQO3wRVj6Sp%niv-yob-T--hwzxHj6 zUo*5Xu?|{hL}!fOllH3I4{C?#BRV#}D1{bskoO0sh)znU^!M;M&G08fUx-!_GIP8zB`Zf^!%(T zoHm7%HW3T4#VOi66F~8hXXmhQ$-LYO{h8Ew=+3gm8Jo}!H=4i6>9lx{jlKm5@9n_( zzBn=SqkNw?e>e8PYoC(Y2)VR8|Fg_>DE9MIhp(r#$XRF&!dL^TIxa)h1+`2kbU{sZ z#l@X~x+(kh@Wy2eh1>jrzBde~T0M=7SnG$e5${LX&b14v?oSNdD!86$^w0y4>M(@QhsXtO)7nv>vr+J zt1@q|#=6}#(bKlmkJ`LFo9>8xy>w5r-y``%{3V?2&v$Ov{Jz=|qdNN7>#$f8tN$>a z9p9!0+OCCGHuT3r%VU?XE~v}%oYus1S~p5$o9ASc$kcDL)egNTFTHk;Cxmm^-dF82 zU+ZWO9|y5`)|4M#d&(%)%_xnr#3tFY~=B1D$q%xDq1{rxnA%W`07l>@|kN4!syg2%w`rnWByLPnMrn_gZ|?Q1_Ot?p>8Pd2JeF&9Szu5l5-> z&b@UL569kE8b^5{k>5A+_P1S$pS+#Ug_qo1`=_>l^Chjy9V1(ztqdbGvCLiM$?$lu ztyLqmc_21vOk*gv+F|S?oZI}x7z+yFc<;xSg$YN{dk}VSr?z+FaVha;y#HXaSJWN8 z_7p>@8$%hRYd9(_V;yr5F%-LXO_zAJF^{q<$6o2{V@y804piRH#h?4C)= z1LdAdJ4Ej-*gTgMT1a(ovF+YN3b(d5k;3=5mUtJ0Iy|0XuQ42Uxwk?M|D$B$@oxAN zx7P7UzF|abygLsoB>{C;&gy#NO4vU@ziZs1!)Q>+dXX|c=VQHyi^Es2_?WR?sW z?yYdVv0Cb##1Gy|^Z;Xl=(w#n^e|BSM$_--V0X058)@@vew4SDe-{4H=m*yM9!PA^ z2A4F5djPF~llHNa&IYfJW+7)T=3rotEqu1jH7GWoshF}?7UH|IGxLNTRW5AVBz9?tmOCVH;mB-m+v=V z#i~_{wfPM;J(&6pw%U{5&~6=PvU?G8{UNd(#usQ+r?nVebj5X2sU$|R-8_{s+7Szd z9j5q?-K9@uZi)yE=G(Ri9%q)QS-KVjTEM2eV{hi_ti`a+LgH8f*J2!tSMgGOi8G07 z&A$k5Vwtf6``XekYwd+ymM-5DSQXu4)c|dtfNf7&>Iv9thn~Q+_M+W-)rnzxe_@Ds zkz(R&Pirq~uf4GAnsjtxJANJ3UO-#E7Q1}t&Ry9u+UKPQ{As%6FadV|1_9 z%8OXWZS(&$7h$U%&$~}u?*EC*xKD&;))UR!EcmT+ufXE3=1-alb-OLbkcaDY&o!a? z`MzDJ5L_QPds?lwZ|g$h_a16C-9NfJrFJXQJ|bPujJdIeAjsD z4Oy9n-^di&a)RC_m#ixEQrPB2^VAp%FNA(W*SeT79NGo9jB~r7#vFZ-dy4SpYOB1p z`;Io5U5sqm>UYPsY*r$K<9$~fjBpgaTnyL!^vHbO5}ESRB#Yb-2VZ-NMb((2mgxtM z3d>k8V110$(h?HOa?3|ZED_CtN3W8F?~nwWbQ2cK*fv7mG`_Vi5w45aMU*>7cP6c4 z9rv#IU3<>j+bk#h#Ilam6B|kZ*(m>h;!#>m#|x!s7&Vb8-#p-!%= zw}#JuISRvT41coR`>8prZeLR~ehmyxjkcW^W1dyPGQ7N0WKL|alH?{T+4NHxrw z*n3<5nOoWs{>Oe~_#!258q~Al^c^p!0`r4N)wta_^{ri(o~AFLGZHHgbU`iSjV`Du z&%nR4jd&O2l$R|0*snplpIE%(ulR4UDTo|F1HE;+dS7BQ@Sfj0iMcPan=|?KPCVa_ z@(rB)N}m3?`BvgLALJ_HIP{ZuTwEQi=P>3tNsv(h)5m^1pT!wS1eE-OZ4nmdW4u1YsUD0)!e#PA5iTpHwrqQf0pk*3ypNd z58arq2)*zg5LoF`vCXH#1*G6g=Nm&p4!NFGA#K9-NeAbAKNCLuAhc4NfF}>-gSVPs z=7oI>Iu8Tg^c^P(jWF*!NqOs_{n_y@MuDIIlI!5H1G(~CzR#t#Uj=>$bkWX+MdJ2zXPqU{>X~piq6|N(Xf{M??I+4<|-*Pmnt7lER|7x*@+BfA4tf0md z_=EL)C+}CnIKu9}7f$aUV`xEWKR+tn&vvz-Z*bzyu+IYRTc-uJSM9uYv-zWI)zY?V z+->32{$6dnUi~1vjnn<0`QJz_UA1xK=tTXEa_1c1K3eIzf_d{#hdbZ5m8Y1tqaNB! z^vFTbI@|4rpdL>iFN_P}r(@AIW;-I$uca5X{69B1@e>*YBg0yXJA7$S5#tFB!F3k8 zdQUmfYYo&5Y5P=YyCQl7eqj52XGP%RbPF#Hp!16GBvuEe@Nt?o>^FVXS@Q>Z`o{Sm zzCRRPPnw^kCx2+Zb2~OL-vht#$rul9MkaQOu9TZ*fE@b^Z>=D5s-H-$icL{VQyboCwZ&|YU)U;NxAJ<&hkW_LZb>)WPwp=|IjuMg8Y`FB&o7g3G= zj}}YwNO<(U=xMYR&du8NjmMj{Vt?|fcmS~ZS{F2cUj#pZ{R+o6T^YA>?i0X1?g=)^ z7h#QjKUbWtX7r;y{@{B+ieuGc>RrUWf|u;;DLyH+)OyDCJO|$F@d*DUH2Xnjus3DL zBrJDs1yRU%sORG=e{AqO#z99!?Sx`Z&SL-Lk)Z{d%c$M#fHjku)J!rE-M$^7Tlb|O z+Pbc9YsU;2{~~@0ux9MQ`!%?m_ru_^ Date: Tue, 17 Jun 2025 14:12:42 +0200 Subject: [PATCH 02/17] ApplicationHandler: refresh property collection before check --- base/ApplicationHandler.cls | 1 + 1 file changed, 1 insertion(+) diff --git a/base/ApplicationHandler.cls b/base/ApplicationHandler.cls index ceb9514..a3cd35d 100644 --- a/base/ApplicationHandler.cls +++ b/base/ApplicationHandler.cls @@ -484,6 +484,7 @@ Private Sub SetAppDbProperty(ByVal PropName As String, ByVal PropType As Long, B Set db = AppDb Set PropCol = db.Properties + PropCol.Refresh If DbPropertyExists(PropCol, PropName) Then If Len(PropValue) = 0 Or IsNull(PropValue) Then db.Properties.Delete PropName From f9d22265da097893389956f2d1f43a3df53980dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 14:20:59 +0200 Subject: [PATCH 03/17] SqlTools: fix comment --- data/SqlTools.cls | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/data/SqlTools.cls b/data/SqlTools.cls index 00c7912..75d09c8 100644 --- a/data/SqlTools.cls +++ b/data/SqlTools.cls @@ -891,9 +891,9 @@ Friend Function GetRelationalOperatorString(ByRef RelationalOperator As SqlRelat op = RelationalOperator Xor SQL_Not - If op = SqlRelationalOperators.SQL_Equal Then ' => "=" zu "<>" .. null ber�cksichtigen? + If op = SqlRelationalOperators.SQL_Equal Then ' => "=" zu "<>" .. check for Null required? RelationalOperator = SQL_LessThan + SQL_GreaterThan - ElseIf op = SQL_GreaterThan + SQL_LessThan Then ' => "<>" zu "=" .. null ber�cksichtigen? + ElseIf op = SQL_GreaterThan + SQL_LessThan Then ' => "<>" zu "=" .. check for Null required? RelationalOperator = SQL_Equal Else RelationalOperator = RelationalOperator Xor SQL_Not From bd671299784ef222d24472654a6f2d52ae94042f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 15:10:17 +0200 Subject: [PATCH 04/17] AddInInstaller: check installed add-in (in add-in folder) --- _codelib/addins/shared/AddInInstaller.cls | 31 ++++++++++---------- _codelib/addins/shared/InstallAddInForm.frm | Bin 74262 -> 75408 bytes 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index 30837d2..97eabeb 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -65,43 +65,44 @@ Public Function InstallAddIn(ByVal AddInConfigData As AddInConfiguration, _ End Function -Public Property Get AddInName() As String +Private Property Get AddInName() As String AddInName = m_ConfigData.AddInRegPathName End Property -Public Property Get AddInFileName() As String +Private Property Get AddInFileName() As String AddInFileName = m_ConfigData.FileName End Property -Public Property Get MsgBoxTitle() As String +Private Property Get MsgBoxTitle() As String MsgBoxTitle = "Install " & AddInName End Property -Function GetSourceFileFullName() +Private Function GetSourceFileFullName() GetSourceFileFullName = CurrentDb.Name End Function -Function GetDestFileFullName() +Private Function GetDestFileFullName() GetDestFileFullName = GetAddInLocation & AddInFileName End Function -Function GetAddInLocation() +Friend Function GetAddInLocation() GetAddInLocation = GetAppDataLocation & "Microsoft\AddIns\" End Function -Function GetAppDataLocation() +Private Function GetAppDataLocation() GetAppDataLocation = Environ("APPDATA") & "\" End Function -Function DeleteAddInFiles() +Private Function DeleteAddInFiles() Dim DestFile As String + DestFile = GetDestFileFullName() DeleteFile DestFile End Function -Function DeleteFile(File2Delete) +Private Function DeleteFile(File2Delete) If FileTools.FileExists(File2Delete) Then Kill File2Delete End If @@ -127,7 +128,7 @@ On Error Resume Next End Function -Function CreateAccde(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean +Friend Function CreateAccde(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean Dim FileToCompile As String Dim AccessApp As Access.Application @@ -152,7 +153,7 @@ End Function '################################################## ' Register Menu Add-In -Function RegisterAddIn(AddInFile) +Private Function RegisterAddIn(AddInFile) Dim AddInDb As DAO.Database Dim rst As DAO.Recordset @@ -179,7 +180,7 @@ Function RegisterAddIn(AddInFile) End Function -Function RegisterMenuAddInItem(wsh, ByVal SubKey, ByVal ItemValName, ByVal RegType, ByVal ItemValue) +Private Function RegisterMenuAddInItem(wsh, ByVal SubKey, ByVal ItemValName, ByVal RegType, ByVal ItemValue) Dim RegName RegName = GetRegistryPath(SubKey) With wsh @@ -190,7 +191,7 @@ Function RegisterMenuAddInItem(wsh, ByVal SubKey, ByVal ItemValName, ByVal RegTy End With End Function -Function GetRegTypeString(ByVal RegType) +Private Function GetRegTypeString(ByVal RegType) Select Case RegType Case 1 GetRegTypeString = "REG_SZ" @@ -203,10 +204,10 @@ Function GetRegTypeString(ByVal RegType) End Select End Function -Function GetRegistryPath(SubKey) +Private Function GetRegistryPath(SubKey) GetRegistryPath = Replace(SubKey, "HKEY_CURRENT_ACCESS_PROFILE", HkeyCurrentAccessProfileRegistryPath()) End Function -Function HkeyCurrentAccessProfileRegistryPath() +Private Function HkeyCurrentAccessProfileRegistryPath() HkeyCurrentAccessProfileRegistryPath = "HKCU\SOFTWARE\Microsoft\Office\" & Access.Application.Version & "\Access" End Function diff --git a/_codelib/addins/shared/InstallAddInForm.frm b/_codelib/addins/shared/InstallAddInForm.frm index 39e809e5b112145d985115a9a531924c3367e61a..6f53d3bc78386792282381693478c6c314dd7ad6 100644 GIT binary patch delta 721 zcmaiyO>0v@6o%geH`f?rz<}h7nlYd>Vq!Gbgi3{ws04#8v9uc(ttQ4xK7=&giLG|! zMp8zcAK(vAS6K^g{R=K#ikt4b@V)m^T2vAaGt7O@nP<+&{qW5if49c3&gXC)w@^Tt zdl^M6&`MwSzn+TSq`FD9#E2(c)T!LqbAl5mC=bqERB)||=V;?8x~OA-EsS`nM{A>H zJ|(2IGbI4?$l@$Q-tuuZIOr3*O3V-)Vn(Q-MRV~hR7ZSJQQPAFh+jkA7%AMz zIvf*7$tAN9mvFs~XN<_7;5Etb;2sHX!pHOml`a*93|=z6N~(;}M(X`v%fBqVlp0HrWeOocv5k GA@~RCiI9o_ delta 76 zcmbPmmSx%zmI-yjh786GrVIuQ77RvUmL-Gf#>ofS#m#|Y$v~I}#3>9WKspg9V%VI` Wu|1oE(OYo(5+z2X?Fn*>1{?saT@gM2 From 7a166a7de20bd6f0d95c39072c473c6c4ec99270 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 17:06:10 +0200 Subject: [PATCH 05/17] test UTF8-BOM --- _codelib/addins/shared/AddInConfiguration.cls | 2 +- _codelib/addins/shared/InstallAddInForm.frm | Bin 75408 -> 75420 bytes 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/_codelib/addins/shared/AddInConfiguration.cls b/_codelib/addins/shared/AddInConfiguration.cls index 27af39a..d788782 100644 --- a/_codelib/addins/shared/AddInConfiguration.cls +++ b/_codelib/addins/shared/AddInConfiguration.cls @@ -1,4 +1,4 @@ -VERSION 1.0 CLASS +VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END diff --git a/_codelib/addins/shared/InstallAddInForm.frm b/_codelib/addins/shared/InstallAddInForm.frm index 6f53d3bc78386792282381693478c6c314dd7ad6..959b37a5e0e761a1cfaac983ade04b90283de68e 100644 GIT binary patch delta 237 zcmbPmmSxUamI-x&mJEgrMhs>QCP3Pf!GghJdvU zHCdt9Xwv$o&CjxD@Il3DCeLa%n*8BW%jALgw&{BTXXrkDUVO`b5- z1SG%Nq4yj@u4frYZgbYWef*OXiZmt*G>1(V$X42XX5ADHxB)W`fDOnyXtMdkjxAu# un=hOQPy{QuaH3{%&2zA`YF^*qnY^MwV{^lg3YN(aDnV{m+3fMxLlXda9&L00 delta 328 zcmbPpmSqAE)rsmd7&4eK7%*4>Nec#J22&t3-`M}tbn+}4u1UK^CJV$GO+I5|GP%Il zZ}T+sV~W$4DKZL7c6j74`ChuoF=-eiMTfywWH^oD4j z%@2CNF>TI@3*$l2w%H*&j~_(@XpqX}ef36Q!)CRB4cqKjQ-!ALz!b1`n-zM+1W@%K zn4+@z*4!ev=# Date: Tue, 17 Jun 2025 17:10:06 +0200 Subject: [PATCH 06/17] utf8 tests --- _codelib/addins/shared/AddInConfiguration.cls | 2 +- _codelib/addins/shared/AddInInstaller.cls | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/_codelib/addins/shared/AddInConfiguration.cls b/_codelib/addins/shared/AddInConfiguration.cls index d788782..27af39a 100644 --- a/_codelib/addins/shared/AddInConfiguration.cls +++ b/_codelib/addins/shared/AddInConfiguration.cls @@ -1,4 +1,4 @@ -VERSION 1.0 CLASS +VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index 97eabeb..aedd126 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -211,3 +211,4 @@ End Function Private Function HkeyCurrentAccessProfileRegistryPath() HkeyCurrentAccessProfileRegistryPath = "HKCU\SOFTWARE\Microsoft\Office\" & Access.Application.Version & "\Access" End Function + From 122a93d948360d4e545378d2758585f7dd873242 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 17:55:30 +0200 Subject: [PATCH 07/17] InstallAddInForm.frm: add use tag for modApplication --- _codelib/addins/shared/InstallAddInForm.frm | Bin 75420 -> 75498 bytes 1 file changed, 0 insertions(+), 0 deletions(-) diff --git a/_codelib/addins/shared/InstallAddInForm.frm b/_codelib/addins/shared/InstallAddInForm.frm index 959b37a5e0e761a1cfaac983ade04b90283de68e..cf32935860d0574b4d5b6bed8fbeaac5b3f7d9c0 100644 GIT binary patch delta 47 zcmbPpmgUu1mWC~i2Sld(i7@i46f>kU=riOplS delta 17 ZcmaELmSxUamWC~i2Sm2>i89_11OQ2u2KoR1 From 366a1352a49dd93230dad80c8baf601a6acc742e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 17:59:39 +0200 Subject: [PATCH 08/17] fix use tags --- _codelib/addins/shared/InstallAddInForm.frm | Bin 75498 -> 75578 bytes base/_config_Application.bas | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) diff --git a/_codelib/addins/shared/InstallAddInForm.frm b/_codelib/addins/shared/InstallAddInForm.frm index cf32935860d0574b4d5b6bed8fbeaac5b3f7d9c0..2ed222ef50c730b60be608fbc58b38a88efbb977 100644 GIT binary patch delta 46 zcmaELmSxvDmWC~ie4^72h%m~DyD}63VLlLhFeEbMF{Ci$Fr+dRZT~F7_+1bHT&@k! delta 17 ZcmdmWj^))^mWC~ie4^XqL>cc00suz92DktK diff --git a/base/_config_Application.bas b/base/_config_Application.bas index 58420a7..8fb62c7 100644 --- a/base/_config_Application.bas +++ b/base/_config_Application.bas @@ -50,7 +50,7 @@ Const m_DefaultErrorHandlerMode = ACLibErrorHandlerMode.aclibErrMsgBox Private Const m_ApplicationStartFormName As String = "" -#Const USE_EXTENSIONS = True +#Const USE_EXTENSIONS = False #If USE_EXTENSIONS = True Then Private m_Extensions As ApplicationHandler_ExtensionCollection #End If From 927688b7026544ebf7c81fb85b50c7192a220fc5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 18:02:59 +0200 Subject: [PATCH 09/17] fix use tag --- _codelib/addins/shared/AddInInstaller.cls | 1 + 1 file changed, 1 insertion(+) diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index aedd126..c591d46 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -23,6 +23,7 @@ Attribute VB_Exposed = False ' _codelib/addins/shared/AddInInstaller.cls ' _codelib/license.bas ' _codelib/addins/shared/AddInConfiguration.cls +' file/FileTools.bas ' DAO50{00025E01-0000-0000-C000-000000000046} ' '--------------------------------------------------------------------------------------- From 6c44a7c96646772a96d6034ecbdf952097063ab0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 18:35:45 +0200 Subject: [PATCH 10/17] fix download issues (charset/BOM) --- .../addins/shared/ACLibGitHubImporter.cls | 54 ++++++++++++++++++- _codelib/addins/shared/AddInInstaller.cls | 1 - 2 files changed, 53 insertions(+), 2 deletions(-) diff --git a/_codelib/addins/shared/ACLibGitHubImporter.cls b/_codelib/addins/shared/ACLibGitHubImporter.cls index 61acbc9..acd56c8 100644 --- a/_codelib/addins/shared/ACLibGitHubImporter.cls +++ b/_codelib/addins/shared/ACLibGitHubImporter.cls @@ -40,7 +40,7 @@ Private m_BranchName As String #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 +Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As LongPtr, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As LongPtr) 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 @@ -298,7 +298,59 @@ On Error GoTo 0 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 + + If IsUTF16(TargetPath) Then 'Forms/Reports + Exit Sub + End If + + NormalizeDownloadFile TargetPath ' fix issues with import as module instead of Class + +End Sub + +Function IsUTF16(ByVal InputFile As String) As Boolean + + Dim FileNumber As Integer + Dim CheckByte(1 To 2) As Byte + FileNumber = FreeFile + Open InputFile For Binary Access Read As #FileNumber + If LOF(FileNumber) >= 2 Then + Get #FileNumber, , CheckByte + If (CheckByte(1) = &HFF And CheckByte(2) = &HFE) Or (CheckByte(1) = &HFE And CheckByte(2) = &HFF) Then + IsUTF16 = True + End If + End If + Close #FileNumber + +End Function + +Sub NormalizeDownloadFile(ByVal InputFile As String) + + Dim TextStreamIn As Scripting.TextStream, TextStreamOut As Scripting.TextStream + Dim TempFile As String + Dim TextLine As String + + TempFile = InputFile & ".temp" + + With New Scripting.FileSystemObject + + Set TextStreamIn = .OpenTextFile(InputFile, ForReading, False) + Set TextStreamOut = .OpenTextFile(TempFile, ForWriting, True, TristateUseDefault) + + Do While Not TextStreamIn.AtEndOfStream + TextLine = TextStreamIn.ReadLine + TextStreamOut.Write TextLine & vbCrLf + Loop + + TextStreamIn.Close + TextStreamOut.Close + + .DeleteFile InputFile + .MoveFile TempFile, InputFile + + End With + End Sub diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index c591d46..b6549e0 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -212,4 +212,3 @@ End Function Private Function HkeyCurrentAccessProfileRegistryPath() HkeyCurrentAccessProfileRegistryPath = "HKCU\SOFTWARE\Microsoft\Office\" & Access.Application.Version & "\Access" End Function - From 6716f695fd877bfe528d8edd6582312005135f86 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Tue, 17 Jun 2025 23:00:25 +0200 Subject: [PATCH 11/17] don't set db property if value is empty --- _codelib/addins/shared/AddInConfiguration.cls | 12 ++++++++---- base/ApplicationHandler.cls | 10 +++++----- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/_codelib/addins/shared/AddInConfiguration.cls b/_codelib/addins/shared/AddInConfiguration.cls index 27af39a..3589835 100644 --- a/_codelib/addins/shared/AddInConfiguration.cls +++ b/_codelib/addins/shared/AddInConfiguration.cls @@ -249,8 +249,10 @@ Private Sub SetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, On Error GoTo HandleErr - PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) - + If Len(NewValue) > 0 Then + PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) + End If + ExitHere: Exit Sub @@ -268,8 +270,10 @@ Private Sub SetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, On Error GoTo HandleErr - PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) - + If Len(NewValue) > 0 Then + PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) + End If + ExitHere: Exit Sub diff --git a/base/ApplicationHandler.cls b/base/ApplicationHandler.cls index a3cd35d..dae3f3c 100644 --- a/base/ApplicationHandler.cls +++ b/base/ApplicationHandler.cls @@ -112,7 +112,7 @@ Private m_AppDb As DAO.Database ' Replacement for CurrentDb or Code Private m_ApplicationName As String ' Application name cache (short) Private m_ApplicationFullName As String ' Application name cache (long) -Private m_APPLICATIONVERSION As String ' Version number to be displayed +Private m_ApplicationVersion As String ' Version number to be displayed Private m_TransferValue As Variant Private m_PublicPath As String ' Default directory for file explorer @@ -351,19 +351,19 @@ End Property '--------------------------------------------------------------------------------------- Public Property Get Version() As String - If Len(m_APPLICATIONVERSION) = 0 Then ' ... aus Properties lesen? + If Len(m_ApplicationVersion) = 0 Then ' ... aus Properties lesen? '/** ' @todo Versionskennung aus DB-Eigenschaften bzw. aus den Dateieigenschaften lesen '**/ - m_APPLICATIONVERSION = "" + m_ApplicationVersion = "" End If - Version = m_APPLICATIONVERSION + Version = m_ApplicationVersion End Property Public Property Let Version(ByVal AppVersion As String) - m_APPLICATIONVERSION = AppVersion + m_ApplicationVersion = AppVersion End Property '--------------------------------------------------------------------------------------- From 79d463d1a65baca3b9bf02c5bd1e22a773db850c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Wed, 18 Jun 2025 21:17:26 +0200 Subject: [PATCH 12/17] refactoring: reduced dependency --- _codelib/addins/shared/AddInConfiguration.cls | 17 ++++++----------- _codelib/addins/shared/AddInInstaller.cls | 3 +-- 2 files changed, 7 insertions(+), 13 deletions(-) diff --git a/_codelib/addins/shared/AddInConfiguration.cls b/_codelib/addins/shared/AddInConfiguration.cls index 3589835..f7181a6 100644 --- a/_codelib/addins/shared/AddInConfiguration.cls +++ b/_codelib/addins/shared/AddInConfiguration.cls @@ -22,7 +22,6 @@ Attribute VB_Exposed = False ' ' _codelib/addins/shared/AddInConfiguration.cls ' _codelib/license.bas -' base/ApplicationHandler.cls ' DAO50{00025E01-0000-0000-C000-000000000046} ' '--------------------------------------------------------------------------------------- @@ -249,10 +248,8 @@ Private Sub SetDbProperty(ByVal PropDb As DAO.Database, PropertyName As String, On Error GoTo HandleErr - If Len(NewValue) > 0 Then - PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) - End If - + PropDb.Properties(PropertyName).Value = Nz(NewValue, vbNullString) + ExitHere: Exit Sub @@ -262,7 +259,7 @@ HandleErr: Resume ExitHere End If - HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + Err.Raise Err.Number, "AddInConfiguration.SetDbProperty->" & Err.Source, Err.Description End Sub @@ -270,10 +267,8 @@ Private Sub SetDocProperty(ByVal PropDb As DAO.Database, PropertyName As String, On Error GoTo HandleErr - If Len(NewValue) > 0 Then - PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) - End If - + PropDb.Containers("Databases").Documents("SummaryInfo").Properties(PropertyName).Value = Nz(NewValue, vbNullString) + ExitHere: Exit Sub @@ -285,7 +280,7 @@ HandleErr: Resume ExitHere End If - HandleError Err.Number, Err.Source, Err.Description, aclibErrRaise + Err.Raise Err.Number, "AddInConfiguration.SetDocProperty->" & Err.Source, Err.Description End Sub diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index b6549e0..5886edc 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -23,7 +23,6 @@ Attribute VB_Exposed = False ' _codelib/addins/shared/AddInInstaller.cls ' _codelib/license.bas ' _codelib/addins/shared/AddInConfiguration.cls -' file/FileTools.bas ' DAO50{00025E01-0000-0000-C000-000000000046} ' '--------------------------------------------------------------------------------------- @@ -104,7 +103,7 @@ Private Function DeleteAddInFiles() End Function Private Function DeleteFile(File2Delete) - If FileTools.FileExists(File2Delete) Then + If Len(Dir(File2Delete)) > 0 Then Kill File2Delete End If End Function From 4f8aaaf72f2f2f43ac4fbe05d25fd79584921291 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Wed, 18 Jun 2025 21:18:02 +0200 Subject: [PATCH 13/17] add PtrSafe --- usability/OptionManager.cls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/usability/OptionManager.cls b/usability/OptionManager.cls index 98276e9..0eb8d90 100644 --- a/usability/OptionManager.cls +++ b/usability/OptionManager.cls @@ -35,7 +35,7 @@ Private Const EnumKeyFieldName As String = "strKey" Private Const EnumValueFieldName As String = "strValue" Private Const EnumName As String = "SettingKeys" -Private Declare Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias "GetMem4" (pArray() As Any, Ptr As Long) +Private Declare PtrSafe Sub GetSafeArrayPointer Lib "msvbvm60.dll" Alias "GetMem4" (pArray() As Any, Ptr As Long) '*************************************************************************** '****** Zentrale Property Setting zum Holen und Setzen eines Wertes ******** From 2607e78eba8b058b2009b96f3f306929204fd55b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Wed, 18 Jun 2025 22:03:44 +0200 Subject: [PATCH 14/17] use replace VBA.Dir/Kill with Scripting.FileSystemObject --- _codelib/addins/shared/AddInInstaller.cls | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/_codelib/addins/shared/AddInInstaller.cls b/_codelib/addins/shared/AddInInstaller.cls index 5886edc..1f36055 100644 --- a/_codelib/addins/shared/AddInInstaller.cls +++ b/_codelib/addins/shared/AddInInstaller.cls @@ -103,9 +103,11 @@ Private Function DeleteAddInFiles() End Function Private Function DeleteFile(File2Delete) - If Len(Dir(File2Delete)) > 0 Then - Kill File2Delete - End If + With CreateObject("Scripting.FileSystemObject") + If .FileExists(File2Delete) Then + .DeleteFile File2Delete, True + End If + End With End Function Private Function TryFileCopy(ByVal SourceFilePath As String, ByVal DestFilePath As String) As Boolean From d24597894d6bd1b0509d20ae6d1a9a6af4653a3e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Wed, 18 Jun 2025 22:45:30 +0200 Subject: [PATCH 15/17] + Package: Access-Add-In-Template --- _packages/Access-Add-In-Template.package | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 _packages/Access-Add-In-Template.package diff --git a/_packages/Access-Add-In-Template.package b/_packages/Access-Add-In-Template.package new file mode 100644 index 0000000..0b0677b --- /dev/null +++ b/_packages/Access-Add-In-Template.package @@ -0,0 +1,13 @@ +'--------------------------------------------------------------------------------------- +' Package: Access Add-in Template +'--------------------------------------------------------------------------------------- +' +' Access Add-in Template +' Install form, config class, ... +' base/_initApplication.bas +' _codelib/addins/shared/InstallAddInForm.frm +' %addins%\ACLibAccessAddInBuilder.LoadAddIn +' +'--------------------------------------------------------------------------------------- +' Note: If ACLibAccessAddInBuilder add-in is installed, it will be called after import +'--------------------------------------------------------------------------------------- \ No newline at end of file From d3cd97615265dba0eedacd57588d2b125e99b307 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Mon, 30 Jun 2025 21:09:54 +0200 Subject: [PATCH 16/17] minor fixes, upd. letter case, remove VBA6 support (use VBA7 as default) --- file/FileTools.bas | 79 ++++++++++++++++------------------------------ 1 file changed, 27 insertions(+), 52 deletions(-) diff --git a/file/FileTools.bas b/file/FileTools.bas index 3b16c63..1fbd33e 100644 --- a/file/FileTools.bas +++ b/file/FileTools.bas @@ -26,12 +26,12 @@ Option Private Module #If USELOCALIZATION_DE = 1 Then Private Const SELECTBOX_FILE_DIALOG_TITLE As String = "Datei auswählen" Private Const SELECTBOX_FOLDER_DIALOG_TITLE As String = "Ordner auswählen" -Private Const SELECTBOX_OPENTITLE As String = "auswählen" +Private Const SELECTBOX_OPENTITLE As String = "Auswählen" Private Const FILTERSTRING_ALL_FILES As String = "Alle Dateien (*.*)" #Else Private Const SELECTBOX_FILE_DIALOG_TITLE As String = "Select file" Private Const SELECTBOX_FOLDER_DIALOG_TITLE As String = "Select folder" -Private Const SELECTBOX_OPENTITLE As String = "auswählen" +Private Const SELECTBOX_OPENTITLE As String = "Select" Private Const FILTERSTRING_ALL_FILES As String = "All Files (*.*)" #End If @@ -43,8 +43,6 @@ Private Const SE_ERR_NOASSOC As Long = 31 Private Const VbaErrNo_FileNotFound As Long = 53 -#If VBA7 Then - Private Declare PtrSafe Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" ( _ ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long @@ -57,7 +55,7 @@ Private Declare PtrSafe Function API_GetTempFilename Lib "kernel32" Alias "GetTe ByVal lpPrefixString As String, _ ByVal wUnique As Long, _ ByVal lpTempFileName As String) As Long - + Private Declare PtrSafe Function API_ShellExecuteA Lib "shell32.dll" Alias "ShellExecuteA" ( _ ByVal Hwnd As LongPtr, _ ByVal lOperation As String, _ @@ -66,30 +64,6 @@ Private Declare PtrSafe Function API_ShellExecuteA Lib "shell32.dll" Alias "Shel ByVal lpDirectory As String, _ ByVal nShowCmd As Long) As Long -#Else - -Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" ( _ - ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long - -Private Declare Function API_GetTempPath Lib "kernel32" Alias "GetTempPathA" ( _ - ByVal nBufferLength As Long, _ - ByVal lpBuffer As String) As Long - -Private Declare Function API_GetTempFilename Lib "kernel32" Alias "GetTempFileNameA" ( _ - ByVal lpszPath As String, _ - ByVal lpPrefixString As String, _ - ByVal wUnique As Long, _ - ByVal lpTempFileName As String) As Long - -Private Declare Function API_ShellExecuteA Lib "shell32.dll" Alias "ShellExecuteA" ( _ - ByVal Hwnd As Long, _ - ByVal lOperation As String, _ - ByVal lpFile As String, _ - ByVal lpParameters As String, _ - ByVal lpDirectory As String, _ - ByVal nShowCmd As Long) As Long - -#End If '--------------------------------------------------------------------------------------- ' Function: SelectFile @@ -156,6 +130,7 @@ Private Function WizHook_GetFileName( _ Optional ByVal SelectFolderFlag As Boolean = False, _ Optional ByVal AppName As String) As String + 'Summary of WizHook.GetFileName parameters: http://www.team-moeller.de/?Tipps_und_Tricks:Wizhook-Objekt:GetFileName 'View 0: Detailansicht ' 1: Vorschauansicht @@ -214,25 +189,25 @@ End Function ' '--------------------------------------------------------------------------------------- Public Function UncPath(ByVal Path As String, Optional ByVal IgnoreErrors As Boolean = True) As String - + Dim UNC As String * 512 - + If VBA.Len(Path) = 1 Then Path = Path & ":" - + If WNetGetConnection(VBA.Left$(Path, 2), UNC, VBA.Len(UNC)) Then - + If IgnoreErrors Then UncPath = Path Else Err.Raise 5 ' Invalid procedure call or argument End If - + Else UncPath = VBA.Left$(UNC, VBA.InStr(UNC, vbNullChar) - 1) & VBA.Mid$(Path, 3) - + End If - + End Function '--------------------------------------------------------------------------------------- @@ -282,7 +257,7 @@ Public Function GetNewTempFileName(Optional ByVal PathToUse As String = "", _ Optional ByVal FileExtension As String = "") As String Dim NewTempFileName As String - + If Len(PathToUse) = 0 Then PathToUse = TempPath End If @@ -513,7 +488,7 @@ Public Function DirExists(ByVal FullPath As String) As Boolean DirExists = (VBA.Dir$(FullPath, vbDirectory Or vbReadOnly Or vbHidden Or vbSystem) = ".") VBA.Dir$ "\" ' Avoiding error: issue #109 - + End Function '--------------------------------------------------------------------------------------- @@ -664,7 +639,7 @@ Public Function GetRelativPathFromFullPath(ByVal FullPath As String, _ Optional ByVal DisableDecreaseBaseDir As Boolean = False) As String Dim RelativPath As String - + If FullPath = BaseDir Then GetRelativPathFromFullPath = "." Exit Function @@ -675,7 +650,7 @@ Public Function GetRelativPathFromFullPath(ByVal FullPath As String, _ GetRelativPathFromFullPath = "." Exit Function End If - + If Not DisableDecreaseBaseDir Then RelativPath = TryGetRelativPathWithDecreaseBaseDir(FullPath, BaseDir, EnableRelativePrefix) Else @@ -690,7 +665,7 @@ Public Function GetRelativPathFromFullPath(ByVal FullPath As String, _ End If End If End If - + GetRelativPathFromFullPath = RelativPath End Function @@ -701,7 +676,7 @@ Private Function TryGetRelativPathWithDecreaseBaseDir(ByVal FullPath As String, Dim DecreaseCounter As Long Dim Pos As Long Dim i As Long - + RelativPath = BaseDir Do While InStr(1, FullPath, RelativPath) = 0 @@ -713,7 +688,7 @@ Private Function TryGetRelativPathWithDecreaseBaseDir(ByVal FullPath As String, Exit Do End If Loop - + If Len(RelativPath) > 0 Then RelativPath = Replace(FullPath, RelativPath, vbNullString) For i = 1 To DecreaseCounter @@ -752,7 +727,7 @@ Public Sub AddToZipFile(ByVal ZipFile As String, ByVal FullFileName As String) End If With CreateObject("Shell.Application") - .NameSpace(ZipFile & "").CopyHere FullFileName & "" + .Namespace(ZipFile & "").CopyHere FullFileName & "" End With End Sub @@ -774,8 +749,8 @@ End Sub Public Function ExtractFromZipFile(ByVal ZipFile As String, ByVal Destination As String) As String With CreateObject("Shell.Application") - .NameSpace(Destination & "").CopyHere .NameSpace(ZipFile & "").Items - ExtractFromZipFile = .NameSpace(ZipFile & "").Items.Item(0).Name + .Namespace(Destination & "").CopyHere .Namespace(ZipFile & "").Items + ExtractFromZipFile = .Namespace(ZipFile & "").Items.Item(0).Name End With End Function @@ -862,7 +837,7 @@ Public Function OpenFile(ByVal FilePath As String, Optional ByVal ReadOnlyMode A End If If Len(VBA.Dir(FilePath2Open)) = 0 Then - + #If USELOCALIZATION = 1 Then FileNotFoundErrorText = Replace(L10n.Text(FileNotFoundErrorTextTemplate), "{FilePath}", FilePath2Open) #Else @@ -873,7 +848,7 @@ Public Function OpenFile(ByVal FilePath As String, Optional ByVal ReadOnlyMode A End If OpenFile = ShellExecute(FilePath2Open, "open") - + End Function Public Function BuildFullFileName(ByVal FileName As String, ByVal DefaultFileFolderIfFileNameOnly As String) As String @@ -921,7 +896,7 @@ Public Function OpenFilePath(ByVal FolderPath As String) As Boolean Dim FolderNotFoundErrorText As String If Len(VBA.Dir(FolderPath, vbDirectory)) = 0 Then - + #If USELOCALIZATION = 1 Then FolderNotFoundErrorText = Replace(L10n.Text(FolderNotFoundErrorTextTemplate), "{FolderPath}", FolderPath) #Else @@ -932,7 +907,7 @@ Public Function OpenFilePath(ByVal FolderPath As String) As Boolean End If OpenFilePath = ShellExecute(FolderPath, "open") - + End Function Private Function ShellExecute(ByVal FilePath As String, _ @@ -951,7 +926,7 @@ Private Function ShellExecute(ByVal FilePath As String, _ DeskWin = Application.hWndAccessApp Ret = API_ShellExecuteA(DeskWin, ApiOperation, FilePath, vbNullString, vbNullString, vbNormalFocus) End If - + If Ret = SE_ERR_NOTFOUND Then #If USELOCALIZATION = 1 Then FileNotFoundErrorText = Replace(L10n.Text(FileNotFoundErrorTextTemplate), "{FilePath}", FilePath) @@ -973,7 +948,7 @@ Private Function ShellExecute(ByVal FilePath As String, _ ' Call ShellExecuteA(DeskWin, vbNullString, "RUNDLL32.EXE", "shell32.dll, OpenAs_RunDLL " & _ ' FilePath, Directory, vbNormalFocus) End If - + ShellExecute = True End Function From 3228089b26ad9620eced6b8be3f14fabb0f2f362 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Josef=20P=C3=B6tzl?= Date: Sun, 19 Oct 2025 11:22:41 +0200 Subject: [PATCH 17/17] + SqlTools.BuildCriteria: DataField Like 'x' => DataField = 'x' --- _test/data/SqlToolsBuildCriteriaTests.cls | 6 +++--- data/FilterStringBuilder.cls | 4 ++-- data/SqlTools.cls | 17 +++++++++++++++++ 3 files changed, 22 insertions(+), 5 deletions(-) diff --git a/_test/data/SqlToolsBuildCriteriaTests.cls b/_test/data/SqlToolsBuildCriteriaTests.cls index d7d8e26..117c958 100644 --- a/_test/data/SqlToolsBuildCriteriaTests.cls +++ b/_test/data/SqlToolsBuildCriteriaTests.cls @@ -64,16 +64,16 @@ End Sub 'AccUnit:Row(2, "a", Null, Null, "F = 'a'", "F = 'a'").Name("Equal") 'AccUnit:Row(2+8, "a", Null, Null, "F >= 'a'", "F >= 'a'").Name("Equal+GreaterThan") 'AccUnit:Row(2+4, "a", Null, Null, "F <= 'a'", "F <= 'a'").Name("Equal+LessThan") -'AccUnit:Row(256, "a", Null, Null, "F Like 'a'", "F Like 'a'").Name("Like") +'AccUnit:Row(256, "a", Null, Null, "F = 'a'", "F = 'a'").Name("Like without *") 'AccUnit:Row(256, "a*", Null, Null, "F Like 'a*'", "F Like 'a%'").Name("Like+*") -'AccUnit:Row(256, "a[*]", Null, Null, "F Like 'a[*]'", "F Like 'a*'").Name("Like+[*]") +'AccUnit:Row(256, "a[*]", Null, Null, "F = 'a*'", "F = 'a*'").Name("Like+[*]") 'AccUnit:Row(256+2048, "a", Null, Null, "F Like 'a*'", "F Like 'a%'").Name("Like+WildCardSuffix") 'AccUnit:Row(256+4096, "a", Null, Null, "F Like '*a'", "F Like '%a'").Name("Like+WildCardPrefix") 'AccUnit:Row(256+2048+4096, "a", Null, Null, "F Like '*a*'", "F Like '%a%'").Name("Like+WildCardSuffix+Prefix") 'AccUnit:Row(512, "a", "d", Null, "F Between 'a' And 'd'", "F Between 'a' And 'd'").Name("Between") 'AccUnit:Row(512, "a", Null, Null, "F >= 'a'", "F >= 'a'").Name("Between+V2=Null") 'AccUnit:Row(512, Null, "d", Null, "F <= 'd'", "F <= 'd'").Name("Between+V1=Null") -'AccUnit:Row(1 + 256, "d", Null, Null, "F Not Like 'd'", "F Not Like 'd'").Name("not like") +'AccUnit:Row(1 + 256, "d", Null, Null, "F <> 'd'", "F <> 'd'").Name("not like") 'AccUnit:Row(1 + 512, "a", "d", Null, "F < 'a' And F > 'd'", "F < 'a' And F > 'd'").Name("Not Between") 'AccUnit:Row(1+2, "a", Null, Null, "F <> 'a'", "F <> 'a'").Name("Not Equal") 'AccUnit:Row(1+2+4, "a", Null, Null, "F > 'a'", "F > 'a'").Name("Not <=") diff --git a/data/FilterStringBuilder.cls b/data/FilterStringBuilder.cls index c2178ae..cb407ee 100644 --- a/data/FilterStringBuilder.cls +++ b/data/FilterStringBuilder.cls @@ -297,7 +297,7 @@ End Function ' Function: AddSubSelectCriteria '--------------------------------------------------------------------------------------- ' -' New filter condition group for a sub select. +' New filter condition group for a sub select. ' e.g. ( a = 1 and x In (select n from tab123) ) ' ' Parameters: @@ -357,7 +357,7 @@ End Function ' Function: AddExistsCriteria '--------------------------------------------------------------------------------------- ' -' New filter condition group for a exits sub select +' New filter condition group for a exits sub select ' e.g. ( a = 1 and exists (select * from tab123 where t = a and y = 123) ) ' ' Parameters: diff --git a/data/SqlTools.cls b/data/SqlTools.cls index 75d09c8..f2ccc8e 100644 --- a/data/SqlTools.cls +++ b/data/SqlTools.cls @@ -496,6 +496,7 @@ Public Function BuildCriteria(ByVal FieldName As String, ByVal FieldDataType As End If If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + If SqlWildCardString <> "*" Then If InStr(1, FilterValue, "*") > 0 Then FilterValue = Replace(FilterValue, "[*]", "@@@|||STAR|||@@@") @@ -503,6 +504,22 @@ Public Function BuildCriteria(ByVal FieldName As String, ByVal FieldDataType As FilterValue = Replace(FilterValue, "@@@|||STAR|||@@@", "*") End If End If + + If ((RelationalOperator And SQL_Add_WildCardPrefix) = 0) _ + And ((RelationalOperator And SQL_Add_WildCardSuffix) = 0) Then + + FilterValue = Replace(FilterValue, "[" & SqlWildCardString & "]", "@@@|||STAR|||@@@") + If InStr(1, FilterValue, SqlWildCardString) = 0 Then + RelationalOperator = RelationalOperator - SQL_Like + RelationalOperator = RelationalOperator Or SQL_Equal + FilterValue = Replace(FilterValue, "@@@|||STAR|||@@@", SqlWildCardString) + Else + FilterValue = Replace(FilterValue, "@@@|||STAR|||@@@", "[" & SqlWildCardString & "]") + End If + + End If + + End If If (RelationalOperator And SQL_Add_WildCardSuffix) = SQL_Add_WildCardSuffix Then