diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index b665203..c022f6b 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -58,6 +58,13 @@ jobs: } else { Write-Host "ℹ️ No Access databases found in source directory." } + Write-Host "Access ACCDE folders found: ${{ steps.build_vba.outputs.access-de-folders }}" + Write-Host "Has Access ACCDE: ${{ steps.build_vba.outputs.has-access-de }}" + if ("${{ steps.build_vba.outputs.has-access-de }}" -eq "True") { + Write-Host "✅ Access ACCDE target(s) detected and will be compiled!" + } else { + Write-Host "ℹ️ No Access ACCDE targets found in source directory." + } - name: "Upload Build Artifact" uses: actions/upload-artifact@v7 id: "upload" diff --git a/CHANGELOG.md b/CHANGELOG.md index d47dd5f..0c1a44d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,16 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +### Added + +- Build support for Microsoft Access `.accde` (compiled) databases. Source folders whose name ends in `.accde` are detected, built from source, and compiled to an ACCDE. +- New `app-config` input to pass an application config file (database properties, procedures to run, modules/references to remove) through to `msaccess-vcs-build` for Access builds. +- New `vcs-url` and `vcs-sha` inputs to select the `msaccess-vcs-addin` release used for Access builds and optionally verify its asset digest. + +### Changed + +- Access builds now delegate compile and prepare steps to `msaccess-vcs-build@v1.1.0` (previously `v1.0.1`). + ## [2.0.0] - 2026-02-18 ## Breaking changes diff --git a/Main.ps1 b/Main.ps1 index 6af52f1..459c66d 100644 --- a/Main.ps1 +++ b/Main.ps1 @@ -24,6 +24,8 @@ $processedFolders = 0 $successfulBuilds = 0 $accessFolders = @() $hasAccessDatabase = $false +$accessDeFolders = @() +$hasAccessDe = $false function Get-OfficeApp { param ( @@ -118,9 +120,15 @@ foreach ($folder in $folders) { Write-Host "Office application: $app" if ($app -eq "Access") { - Write-Host "Access database detected. Adding to Access folders list..." - $accessFolders += "${SourceDir}/${folder}" - $hasAccessDatabase = $true + if ($fileExtension -eq "accde") { + Write-Host "Access ACCDE target detected. Adding to Access ACCDE folders list..." + $accessDeFolders += "${SourceDir}/${folder}" + $hasAccessDe = $true + } else { + Write-Host "Access database detected. Adding to Access folders list..." + $accessFolders += "${SourceDir}/${folder}" + $hasAccessDatabase = $true + } Write-Host "Access is not supported in the main build process. Skipping build but tracking for separate processing..." continue } @@ -170,10 +178,14 @@ Write-Host "Setting GitHub Actions outputs..." "office-apps=$($officeApps -join '|||')" | Out-File -FilePath $env:GITHUB_OUTPUT -Append -Encoding utf8 "access-folders=$($accessFolders -join '|||')" | Out-File -FilePath $env:GITHUB_OUTPUT -Append -Encoding utf8 "has-access-database=$hasAccessDatabase" | Out-File -FilePath $env:GITHUB_OUTPUT -Append -Encoding utf8 +"access-de-folders=$($accessDeFolders -join '|||')" | Out-File -FilePath $env:GITHUB_OUTPUT -Append -Encoding utf8 +"has-access-de=$hasAccessDe" | Out-File -FilePath $env:GITHUB_OUTPUT -Append -Encoding utf8 Write-Host "Build process completed successfully!" Write-Host "Processed folders: $processedFolders" Write-Host "Successful builds: $successfulBuilds" Write-Host "Office apps used: $($officeApps -join ' ||| ')" Write-Host "Access folders found: $($accessFolders -join ' ||| ')" -Write-Host "Has Access database: $hasAccessDatabase" \ No newline at end of file +Write-Host "Has Access database: $hasAccessDatabase" +Write-Host "Access ACCDE folders found: $($accessDeFolders -join ' ||| ')" +Write-Host "Has Access ACCDE: $hasAccessDe" \ No newline at end of file diff --git a/README.md b/README.md index 6b71ccc..899507b 100644 --- a/README.md +++ b/README.md @@ -32,7 +32,7 @@ The main script is contained in `Main.ps1` and will perform the following action * Excel (.xlsm, .xlam, .xlsb and .xltm) * Word (.docm and .dotm) * PowerPoint (.pptm, .ppam and .potm) -* Access[^2] (.accdb) +* Access[^2] (.accdb and .accde) ## Why? @@ -50,7 +50,6 @@ Depending on the reaction of the community, I might add support for: - Allow unit tests to run on Microsoft Access files - More complex file structure using [vbaproject.toml](https://github.com/vbapm/core/blob/main/README.md#manifest-vbaprojecttoml) configuration file (manifest file) - Signature of the VBA Project (to facilitate distribution) -- Microsoft Access .accde file format [^1]: All modern Office file formats for Word, PowerPoint and Excel are actually .zip files in disguse. Access is an exception in this case since the content of an Access Database (.accdb) is different and in order to do version control you'd have to use a tool like [msaccess-vcs-addin](https://github.com/joyfullservice/msaccess-vcs-addin). [^2]: For Access, this GitHub Action makes use of msaccess-vcs-addin via [msaccess-vcs-build](https://github.com/AccessCodeLib/msaccess-vcs-build) meaning that you need to use the addin in Access to create the source material for the build. diff --git a/action.yml b/action.yml index 4fafe7a..216cf5d 100644 --- a/action.yml +++ b/action.yml @@ -21,6 +21,21 @@ inputs: To force a specific app instead, use the options: Excel, Word, PowerPoint or Access. required: false default: 'automatic' + app-config: + description: | + Application config file passed to msaccess-vcs-build for Access builds + (set database properties, run procedures, remove modules/references, etc.). + Empty = no prepare step. + required: false + default: '' + vcs-url: + description: 'msaccess-vcs-addin release URL used to build/compile Access databases' + required: false + default: 'https://api.github.com/repos/joyfullservice/msaccess-vcs-addin/releases/tags/v5.0.1' + vcs-sha: + description: 'Expected SHA256 digest of the vcs-addin asset (optional; empty = skip verification)' + required: false + default: '' runs: using: "composite" @@ -44,8 +59,20 @@ runs: source-dir-values: "${{ steps.run_vba_build.outputs.access-folders }}" target-dir: "${{ inputs['source-dir'] }}/out" compile: "false" - vcs-url: "https://api.github.com/repos/josef-poetzl/msaccess-vcs-addin/releases/tags/v4.1.2-build" - expected-sha256: "03e61d7c569cee55a960b23695d9128c79f2b21bff658ea52bc3849a9e351de8" + app-config: "${{ inputs['app-config'] }}" + vcs-url: "${{ inputs['vcs-url'] }}" + vcs-sha: "${{ inputs['vcs-sha'] }}" + - name: "Build Access ACCDE (if detected)" + if: steps.run_vba_build.outputs.has-access-de == 'True' + id: "build_access_de" + uses: ./subactions/msaccess-vcs-build-all + with: + source-dir-values: "${{ steps.run_vba_build.outputs.access-de-folders }}" + target-dir: "${{ inputs['source-dir'] }}/out" + compile: "true" + app-config: "${{ inputs['app-config'] }}" + vcs-url: "${{ inputs['vcs-url'] }}" + vcs-sha: "${{ inputs['vcs-sha'] }}" outputs: processed-folders: description: "Number of folders processed during the build" @@ -62,6 +89,12 @@ outputs: has-access-database: description: "Boolean indicating if any Access database folders were found" value: ${{ steps.run_vba_build.outputs.has-access-database }} + access-de-folders: + description: "Comma-separated list of Access ACCDE source folders" + value: ${{ steps.run_vba_build.outputs.access-de-folders }} + has-access-de: + description: "Boolean indicating if any Access ACCDE folders were found" + value: ${{ steps.run_vba_build.outputs.has-access-de }} first-access-folder: description: "The first Access database folder that was processed (if any)" value: ${{ steps.extract_access_folder.outputs.first-access-folder }} diff --git a/subactions/msaccess-vcs-build-all/action.yml b/subactions/msaccess-vcs-build-all/action.yml index 00d3898..eb91e2b 100644 --- a/subactions/msaccess-vcs-build-all/action.yml +++ b/subactions/msaccess-vcs-build-all/action.yml @@ -13,12 +13,16 @@ inputs: description: 'Whether to compile the Access database' required: false default: "false" + app-config: + description: 'Application config file (set database properties, run procedures, remove modules/references, etc.)' + required: false + default: "" vcs-url: description: 'VCS URL for the Access database add-in' required: false - default: "https://api.github.com/repos/josef-poetzl/msaccess-vcs-addin/releases/tags/v4.1.2-build" - expected-sha256: - description: 'Expected SHA256 digest of the VCS asset (optional - if not provided, will be fetched from release)' + default: "https://api.github.com/repos/joyfullservice/msaccess-vcs-addin/releases/tags/v5.0.1" + vcs-sha: + description: 'Expected SHA256 digest of the vcs-addin asset (optional - if not provided, verification is skipped)' required: false runs: @@ -46,13 +50,13 @@ runs: exit 1 fi - if [[ -n "${{ inputs.expected-sha256 }}" ]]; then - echo "Expected SHA256: ${{ inputs.expected-sha256 }}" + if [[ -n "${{ inputs.vcs-sha }}" ]]; then + echo "Expected SHA256: ${{ inputs.vcs-sha }}" echo "Actual SHA256: $ACTUAL_SHA" - if [[ "${{ inputs.expected-sha256 }}" != "$ACTUAL_SHA" ]]; then + if [[ "${{ inputs.vcs-sha }}" != "$ACTUAL_SHA" ]]; then echo "Error: SHA256 digest mismatch!" - echo "Expected: ${{ inputs.expected-sha256 }}" + echo "Expected: ${{ inputs.vcs-sha }}" echo "Actual: $ACTUAL_SHA" exit 1 fi @@ -65,45 +69,50 @@ runs: - name: Call action 0 if: ${{ fromJSON(steps.parse.outputs.count) > 0 }} - uses: AccessCodeLib/msaccess-vcs-build@c4bfcb0958016f6523a2c7119ac434116a76e84a # v1.0.1 + uses: AccessCodeLib/msaccess-vcs-build@da38fda0d878d93cf8be66846da0084d27ea97f1 # v1.1.0 with: source-dir: ${{ steps.parse.outputs.value0 }} target-dir: ${{ inputs.target-dir }} compile: ${{ inputs.compile }} + app-config: ${{ inputs.app-config }} vcs-url: ${{ inputs.vcs-url }} - name: Call action 1 if: ${{ fromJSON(steps.parse.outputs.count) > 1 }} - uses: AccessCodeLib/msaccess-vcs-build@c4bfcb0958016f6523a2c7119ac434116a76e84a # v1.0.1 + uses: AccessCodeLib/msaccess-vcs-build@da38fda0d878d93cf8be66846da0084d27ea97f1 # v1.1.0 with: source-dir: ${{ steps.parse.outputs.value1 }} target-dir: ${{ inputs.target-dir }} compile: ${{ inputs.compile }} + app-config: ${{ inputs.app-config }} vcs-url: ${{ inputs.vcs-url }} - name: Call action 2 if: ${{ fromJSON(steps.parse.outputs.count) > 2 }} - uses: AccessCodeLib/msaccess-vcs-build@c4bfcb0958016f6523a2c7119ac434116a76e84a # v1.0.1 + uses: AccessCodeLib/msaccess-vcs-build@da38fda0d878d93cf8be66846da0084d27ea97f1 # v1.1.0 with: source-dir: ${{ steps.parse.outputs.value2 }} target-dir: ${{ inputs.target-dir }} compile: ${{ inputs.compile }} + app-config: ${{ inputs.app-config }} vcs-url: ${{ inputs.vcs-url }} - name: Call action 3 if: ${{ fromJSON(steps.parse.outputs.count) > 3 }} - uses: AccessCodeLib/msaccess-vcs-build@c4bfcb0958016f6523a2c7119ac434116a76e84a # v1.0.1 + uses: AccessCodeLib/msaccess-vcs-build@da38fda0d878d93cf8be66846da0084d27ea97f1 # v1.1.0 with: source-dir: ${{ steps.parse.outputs.value3 }} target-dir: ${{ inputs.target-dir }} compile: ${{ inputs.compile }} + app-config: ${{ inputs.app-config }} vcs-url: ${{ inputs.vcs-url }} - name: Call action 4 if: ${{ fromJSON(steps.parse.outputs.count) > 4 }} - uses: AccessCodeLib/msaccess-vcs-build@c4bfcb0958016f6523a2c7119ac434116a76e84a # v1.0.1 + uses: AccessCodeLib/msaccess-vcs-build@da38fda0d878d93cf8be66846da0084d27ea97f1 # v1.1.0 with: source-dir: ${{ steps.parse.outputs.value4 }} target-dir: ${{ inputs.target-dir }} compile: ${{ inputs.compile }} + app-config: ${{ inputs.app-config }} vcs-url: ${{ inputs.vcs-url }} \ No newline at end of file diff --git a/tests/AccessDatabase.accde/dbs-properties.json b/tests/AccessDatabase.accde/dbs-properties.json new file mode 100644 index 0000000..2080234 --- /dev/null +++ b/tests/AccessDatabase.accde/dbs-properties.json @@ -0,0 +1,212 @@ +{ + "Info": { + "Class": "clsDbProperty", + "Description": "Database Properties (DAO)" + }, + "Items": { + "AccessVersion": { + "Value": "09.50", + "Type": 10 + }, + "AllowBuiltInToolbars": { + "Value": true, + "Type": 1 + }, + "AllowDatasheetSchema": { + "Value": true, + "Type": 1 + }, + "AllowFullMenus": { + "Value": true, + "Type": 1 + }, + "AllowShortcutMenus": { + "Value": true, + "Type": 1 + }, + "AllowSpecialKeys": { + "Value": true, + "Type": 1 + }, + "AllowToolbarChanges": { + "Value": true, + "Type": 1 + }, + "ANSI Query Mode": { + "Value": 0, + "Type": 4 + }, + "Auto Compact": { + "Value": 0, + "Type": 4 + }, + "Build": { + "Value": 720, + "Type": 4 + }, + "CheckTruncatedNumFields": { + "Value": 1, + "Type": 4 + }, + "Clear Cache on Close": { + "Value": 0, + "Type": 4 + }, + "CollatingOrder": { + "Value": 1033, + "Type": 3 + }, + "Connect": { + "Value": "", + "Type": 12 + }, + "Continuous Form Record Navigation Keys": { + "Value": 0, + "Type": 4 + }, + "DesignMasterID": { + "Value": "", + "Type": 15 + }, + "DesignWithData": { + "Value": true, + "Type": 1 + }, + "HasOfflineLists": { + "Value": 70, + "Type": 3 + }, + "Name": { + "Value": "rel:AccessDatabase.accde", + "Type": 12 + }, + "NavPane Category": { + "Value": 0, + "Type": 4 + }, + "NavPane Closed": { + "Value": 0, + "Type": 4 + }, + "NavPane Sort By": { + "Value": 1, + "Type": 4 + }, + "NavPane View By": { + "Value": 0, + "Type": 4 + }, + "NavPane Width": { + "Value": 215, + "Type": 4 + }, + "Never Cache": { + "Value": 0, + "Type": 4 + }, + "Option to enable Monaco SQL Editor": { + "Value": 1, + "Type": 4 + }, + "Picture Property Storage Format": { + "Value": 0, + "Type": 4 + }, + "ProjVer": { + "Value": 142, + "Type": 3 + }, + "QueryTimeout": { + "Value": 60, + "Type": 3 + }, + "RecordsAffected": { + "Value": 0, + "Type": 4 + }, + "ReplicaID": { + "Value": "", + "Type": 15 + }, + "Show Navigation Pane Search Bar": { + "Value": 1, + "Type": 4 + }, + "Show Values in Indexed": { + "Value": 1, + "Type": 4 + }, + "Show Values in Non-Indexed": { + "Value": 1, + "Type": 4 + }, + "Show Values in Remote": { + "Value": 0, + "Type": 4 + }, + "Show Values Limit": { + "Value": 1000, + "Type": 4 + }, + "ShowDocumentTabs": { + "Value": true, + "Type": 1 + }, + "StartUpShowDBWindow": { + "Value": true, + "Type": 1 + }, + "StartUpShowStatusBar": { + "Value": true, + "Type": 1 + }, + "Theme Resource Name": { + "Value": "Office Theme", + "Type": 10 + }, + "Themed Form Controls": { + "Value": 1, + "Type": 4 + }, + "Track Name AutoCorrect Info": { + "Value": 0, + "Type": 4 + }, + "Transactions": { + "Value": true, + "Type": 1 + }, + "Updatable": { + "Value": true, + "Type": 1 + }, + "Use BigInt for linking and importing data": { + "Value": 0, + "Type": 4 + }, + "Use DateTime2 for linking and importing data": { + "Value": 0, + "Type": 4 + }, + "Use Microsoft Access 2007 compatible cache": { + "Value": 0, + "Type": 4 + }, + "UseAppIconForFrmRpt": { + "Value": false, + "Type": 1 + }, + "UseMDIMode": { + "Value": 0, + "Type": 2 + }, + "Version": { + "Value": "12.0", + "Type": 12 + }, + "WebDesignMode": { + "Value": 0, + "Type": 2 + } + } +} diff --git a/tests/AccessDatabase.accde/documents.json b/tests/AccessDatabase.accde/documents.json new file mode 100644 index 0000000..8072147 --- /dev/null +++ b/tests/AccessDatabase.accde/documents.json @@ -0,0 +1,13 @@ +{ + "Info": { + "Class": "clsDbDocument", + "Description": "Database Documents Properties (DAO)" + }, + "Items": { + "Databases": { + "SummaryInfo": { + "Title": "Database" + } + } + } +} diff --git a/tests/AccessDatabase.accde/forms/frmStart.bas b/tests/AccessDatabase.accde/forms/frmStart.bas new file mode 100644 index 0000000..386236f --- /dev/null +++ b/tests/AccessDatabase.accde/forms/frmStart.bas @@ -0,0 +1,134 @@ +Version =20 +VersionRequired =20 +Begin Form + RecordSelectors = NotDefault + NavigationButtons = NotDefault + DividingLines = NotDefault + AllowDesignChanges = NotDefault + DefaultView =0 + ScrollBars =0 + PictureAlignment =2 + DatasheetGridlinesBehavior =3 + GridY =10 + Width =6803 + DatasheetFontHeight =11 + ItemSuffix =3 + Right =24915 + Bottom =11730 + RecSrcDt = Begin + 0xfd5e93f4705de640 + End + DatasheetFontName ="Calibri" + FilterOnLoad =0 + ShowPageMargins =0 + DisplayOnSharePointSite =1 + DatasheetAlternateBackColor =15921906 + DatasheetGridlinesColor12 =0 + FitToScreen =1 + DatasheetBackThemeColorIndex =1 + BorderThemeColorIndex =3 + ThemeFontIndex =1 + ForeThemeColorIndex =0 + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + Begin + Begin Label + BackStyle =0 + FontSize =11 + FontName ="Calibri" + ThemeFontIndex =1 + BackThemeColorIndex =1 + BorderThemeColorIndex =0 + BorderTint =50.0 + ForeThemeColorIndex =0 + ForeTint =60.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + End + Begin CommandButton + Width =1701 + Height =283 + FontSize =11 + FontWeight =400 + FontName ="Calibri" + ForeThemeColorIndex =0 + ForeTint =75.0 + GridlineThemeColorIndex =1 + GridlineShade =65.0 + UseTheme =1 + Shape =1 + Gradient =12 + BackThemeColorIndex =4 + BackTint =60.0 + BorderLineStyle =0 + BorderThemeColorIndex =4 + BorderTint =60.0 + ThemeFontIndex =1 + HoverThemeColorIndex =4 + HoverTint =40.0 + PressedThemeColorIndex =4 + PressedShade =75.0 + HoverForeThemeColorIndex =0 + HoverForeTint =75.0 + PressedForeThemeColorIndex =0 + PressedForeTint =75.0 + End + Begin Section + Height =5669 + Name ="Detail" + AlternateBackThemeColorIndex =1 + AlternateBackShade =95.0 + BackThemeColorIndex =1 + Begin + Begin Label + OverlapFlags =85 + Left =566 + Top =566 + Width =2205 + Height =675 + FontSize =26 + Name ="Label0" + Caption ="Test Form" + LayoutCachedLeft =566 + LayoutCachedTop =566 + LayoutCachedWidth =2771 + LayoutCachedHeight =1241 + End + Begin CommandButton + OverlapFlags =85 + Left =566 + Top =1700 + Width =2247 + Height =561 + Name ="cmdDevMode" + Caption ="Activate Dev Mode" + OnClick ="[Event Procedure]" + + LayoutCachedLeft =566 + LayoutCachedTop =1700 + LayoutCachedWidth =2813 + LayoutCachedHeight =2261 + End + Begin Label + Visible = NotDefault + OverlapFlags =85 + Left =2948 + Top =1700 + Width =3105 + Height =525 + FontSize =10 + ForeColor =0 + Name ="labDevMode" + Caption ="You must close and reopen \015\012the current database to take effect" + LayoutCachedLeft =2948 + LayoutCachedTop =1700 + LayoutCachedWidth =6053 + LayoutCachedHeight =2225 + ForeTint =100.0 + End + End + End + End +End +CodeBehindForm +' See "frmStart.cls" diff --git a/tests/AccessDatabase.accde/forms/frmStart.cls b/tests/AccessDatabase.accde/forms/frmStart.cls new file mode 100644 index 0000000..7eb4437 --- /dev/null +++ b/tests/AccessDatabase.accde/forms/frmStart.cls @@ -0,0 +1,46 @@ +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Compare Database +Option Explicit + +'"DatabaseProperties": [ +' { +' "Name": "AllowBypassKey", +' "Type": 1, +' "Value": false +' }, +' { +' "Name": "AllowSpecialKeys", +' "Type": 1, +' "Value": false +' }, +' { +' "Name": "StartUpShowDBWindow", +' "Type": 1, +' "Value": false +' }, +' { +' "Name": "StartUpForm", +' "Type": 10, +' "Value": "frmStart" +' } +' ... +Private Sub cmdDevMode_Click() + + Dim db As DAO.Database + Set db = CurrentDb + +On Error Resume Next + db.Properties.Delete "AllowBypassKey" + db.Properties("AllowSpecialKeys").Value = True + db.Properties("StartUpShowDBWindow").Value = True + db.Properties("ShowDocumentTabs").Value = True + db.Properties.Delete "StartUpForm" + db.Properties.Delete "CustomRibbonId" + + Me.labDevMode.Visible = True + Me.cmdDevMode.Enabled = False + +End Sub diff --git a/tests/AccessDatabase.accde/modules/FilterStringBuilder.cls b/tests/AccessDatabase.accde/modules/FilterStringBuilder.cls new file mode 100644 index 0000000..3ea73a7 --- /dev/null +++ b/tests/AccessDatabase.accde/modules/FilterStringBuilder.cls @@ -0,0 +1,484 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "FilterStringBuilder" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: data.sql.FilterStringBuilder +'--------------------------------------------------------------------------------------- +' +' Create SQL criteria (filter) expression +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' data/FilterStringBuilder.cls +' _codelib/license.bas +' text/StringCollection.cls +' data/SqlTools.cls +' _test/data/FilterStringBuilderTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private m_Items As StringCollection +Private m_SqlTool As SqlTools +Private m_DefaultConcatOperator As SqlLogicalOperator + +Private m_ConditionGroups As Collection + +Private m_SqlPrefix As String +Private m_SqlSuffix As String +Private m_ConditionPrefix As String +Private m_IgnoreSqlPreSuffixIfEmptyFilter As Boolean + +Private Const WhereReplacementText As String = "[WhereStatement]" + +Private Sub Class_Initialize() + Set m_Items = New StringCollection + m_DefaultConcatOperator = SqlLogicalOperator.SQL_And +End Sub + +Private Sub Class_Terminate() + Set m_Items = Nothing +End Sub + +'################################## +' Group: Class support + +'--------------------------------------------------------------------------------------- +' Property: Self +'--------------------------------------------------------------------------------------- +' +' Reference to Me (current instance of FilterStringBuilder class) +' +'--------------------------------------------------------------------------------------- +Public Property Get Self() As FilterStringBuilder + Set Self = Me +End Property + +'################################## +' Group: Config + +'--------------------------------------------------------------------------------------- +' Property: DefaultConcatOperator +'--------------------------------------------------------------------------------------- +' +' The default concat operator for the instance +' +'--------------------------------------------------------------------------------------- +Public Property Get DefaultConcatOperator() As SqlLogicalOperator + DefaultConcatOperator = m_DefaultConcatOperator +End Property + +Public Property Let DefaultConcatOperator(ByVal NewValue As SqlLogicalOperator) + m_DefaultConcatOperator = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlTool +'--------------------------------------------------------------------------------------- +' +' SqlTools instance to be used (if not set, clone of global SqlTools instance is used) +' +'--------------------------------------------------------------------------------------- +Friend Property Get SqlTool() As SqlTools + If m_SqlTool Is Nothing Then + Set m_SqlTool = SqlTools.Clone + End If + Set SqlTool = m_SqlTool +End Property + +Friend Property Set SqlTool(ByVal NewRef As SqlTools) + Set m_SqlTool = NewRef +End Property + +'--------------------------------------------------------------------------------------- +' Function: SelectSqlDialect +'--------------------------------------------------------------------------------------- +' +' Config sql text output format for specific sql dialect +' +' Parameters: +' +' UseDialect - sql dialect .. use setting of dialect (as base) +' SqlDateFormat - output string format for date values +' SqlBooleanTrueString - output string format for boolean values +' SqlWildCardString - wildcard string (e.g. * .. dao, % .. T-SQL) +' +'--------------------------------------------------------------------------------------- +Friend Sub SelectSqlDialect(ByVal UseDialect As SqlDialect, _ + Optional ByVal SqlDateFormat As String, _ + Optional ByVal SqlBooleanTrueString As String, _ + Optional ByVal SqlWildCardString As String) + + Set m_SqlTool = SqlTools.FromDialect(UseDialect, SqlDateFormat, SqlBooleanTrueString, SqlWildCardString) + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: ConfigSqlFormat +'--------------------------------------------------------------------------------------- +' +' Config sql text output format for specific sql dialect +' +' Parameters: +' +' SqlDateFormat - output string format for date values +' SqlBooleanTrueString - output string format for boolean values +' SqlWildCardString - wildcard string (e.g. * .. dao, % .. T-SQL) +' +'--------------------------------------------------------------------------------------- +Friend Sub ConfigSqlFormat(ByVal SqlDateFormat As String, _ + ByVal SqlBooleanTrueString As String, _ + ByVal SqlWildCardString As String) + + If m_SqlTool Is Nothing Then + Set m_SqlTool = SqlTools.NewInstance(SqlDateFormat, SqlBooleanTrueString, SqlWildCardString) + Exit Sub + End If + + With m_SqlTool + .SqlDateFormat = SqlDateFormat + .SqlBooleanTrueString = SqlBooleanTrueString + .SqlWildCardString = SqlWildCardString + End With + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: ConfigSqlStatement +'--------------------------------------------------------------------------------------- +' +' Auxiliary function for setting SQL texts if this class is used in other filter builder classes. +' (e.g. in form.filter.FilterControlCollection) +' +' Parameters: +' +' SqlPrefix - Is placed before the FilterString for ToString output (ToString = m_SqlPrefix & FilterString & m_SqlSuffix) +' SqlSuffix - Is placed after the FilterString for ToString output (ToString = m_SqlPrefix & FilterString & m_SqlSuffix) +' ConditionPrefix - Is placed before the filter condition (but only if the filter condition is > ""). +' IgnoreSqlPreSuffixIfEmptyFilter - True: SqlPrefix + SqlSuffix are not set for empty FilterString +' +'--------------------------------------------------------------------------------------- +Friend Sub ConfigSqlStatement(ByVal SqlPrefix As String, ByVal SqlSuffix As String, _ + ByVal ConditionPrefix As String, _ + Optional ByVal IgnoreSqlPreSuffixIfEmptyFilter As Boolean = False) + m_SqlPrefix = SqlPrefix + m_SqlSuffix = SqlSuffix + m_ConditionPrefix = ConditionPrefix + m_IgnoreSqlPreSuffixIfEmptyFilter = IgnoreSqlPreSuffixIfEmptyFilter + +End Sub + +'################################## +' Group: Build Criteria + +'--------------------------------------------------------------------------------------- +' Function: Add +'--------------------------------------------------------------------------------------- +' +' Add filter criteria definition +' (uses: data.SqlTools.BuildCriteria) +' +' Parameters: +' +' FieldName - Field name in the data source to be filtered +' RelationalOperator - Relational operator (=, <=, etc.) +' Value - Filter value (can be a single value or an array of values) +' Value2 - Optional 2nd filter value (for Between) +' IgnoreValue - The value for which no filter condition is to be created. (Array transfer of values possible), Default: Null +' +'--------------------------------------------------------------------------------------- +Public Sub Add(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal Value As Variant, _ + Optional ByVal Value2 As Variant = Null, _ + Optional ByVal IgnoreValue As Variant = Null) + + AddCriteria SqlTool.BuildCriteria(FieldName, FieldDataType, RelationalOperator, Value, Value2, IgnoreValue) + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: AddCriteria +'--------------------------------------------------------------------------------------- +' +' Add filter criteria (String) +' +' Parameters: +' +' Criteria - Criteria string to append +' +'--------------------------------------------------------------------------------------- +Public Sub AddCriteria(ByVal Criteria As String) + If Len(Criteria) = 0 Then Exit Sub + m_Items.Add Criteria +End Sub + +'--------------------------------------------------------------------------------------- +' Function: NewConditionGroup +'--------------------------------------------------------------------------------------- +' +' New filter condition group - e.g. for Or group: ( a = 1 and (x = 2 or x >= 10) ) +' +' Parameters: +' +' ConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' +' Returns: +' +' FilterStringBuilder instance for new group +' +'--------------------------------------------------------------------------------------- +Public Function NewConditionGroup(ByVal ConcatOperator As SqlLogicalOperator) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + + Set NewBuilder = New FilterStringBuilder + Set NewBuilder.SqlTool = m_SqlTool + NewBuilder.DefaultConcatOperator = ConcatOperator + + ConditionGroups.Add NewBuilder + + Set NewConditionGroup = NewBuilder + +End Function + +Private Function AppendFilterGroupsString(ByVal BaseFilterString As String, ByVal ConcatOperator As SqlLogicalOperator, _ + Optional ByVal IgnoreDuplicateFilters As Boolean = False) As String + + Dim CondPrefix As String + Dim CondSuffix As String + + If m_ConditionGroups Is Nothing Then + AppendFilterGroupsString = BaseFilterString + Exit Function + End If + + If m_ConditionGroups.Count = 0 Then + AppendFilterGroupsString = BaseFilterString + Exit Function + End If + + If ConcatOperator <> SQL_CommaSeparator Then + CondPrefix = "(" + CondSuffix = ")" + End If + + Dim FSB As FilterStringBuilder + + With New StringCollection + + .Add BaseFilterString + + For Each FSB In m_ConditionGroups + .Add FSB.ToString() + Next + + AppendFilterGroupsString = .ToString(GetConcatOperatorString(ConcatOperator), CondPrefix, CondSuffix, True, IgnoreDuplicateFilters) + + End With + +End Function + +'--------------------------------------------------------------------------------------- +' Function: AddSubSelectCriteria +'--------------------------------------------------------------------------------------- +' +' New filter condition group for a sub select - e.g. ( a = 1 and x In (select n from tab123) ) +' +' Parameters: +' +' FieldName - Data field name to compare +' RelationalOperator - Relational operator for sub select: usually In(...) +' SelectFromText - Sql text for sub select (without where, except UseWhereReplacementTextInFromText is used) +' IgnoreIfSubSelectHasNoCriteria - True = Ignore subselect criterion if no filter values were transferred +' UseWhereReplacementTextInFromText - Replace [Where] with Where condition string ... is required for Group By-SQL, for example. +' SubSelectConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' +' Returns: +' +' FilterStringBuilder instance for new sub select group +' +'--------------------------------------------------------------------------------------- +Public Function AddSubSelectCriteria( _ + ByVal FieldName As String, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal SelectFromText As String, _ + Optional ByVal IgnoreIfSubSelectHasNoCriteria As Boolean = False, _ + Optional ByVal UseWhereReplacementTextInFromText As Boolean = False, _ + Optional ByVal SubSelectConcatOperator As SqlLogicalOperator = SqlLogicalOperator.SQL_And _ + ) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + Dim SqlPrefix As String + Dim SqlSuffix As String + Dim WhereReplacementPos As Long + + SqlPrefix = FieldName & " " & SqlTools.GetRelationalOperatorString(RelationalOperator) & " (" + SqlSuffix = ")" + If UseWhereReplacementTextInFromText Then + WhereReplacementPos = InStr(1, SelectFromText, WhereReplacementText, vbTextCompare) + End If + + If WhereReplacementPos > 0 Then + SqlPrefix = SqlPrefix & Trim$(Left(SelectFromText, WhereReplacementPos - 1)) + SqlSuffix = " " & Trim$(Mid$(SelectFromText, WhereReplacementPos + Len(WhereReplacementText))) & SqlSuffix + Else + SqlPrefix = SqlPrefix & SelectFromText + End If + + Set NewBuilder = New FilterStringBuilder + NewBuilder.DefaultConcatOperator = SubSelectConcatOperator + Set NewBuilder.SqlTool = m_SqlTool + + NewBuilder.ConfigSqlStatement SqlPrefix:=SqlPrefix, SqlSuffix:=SqlSuffix, _ + ConditionPrefix:=" Where ", IgnoreSqlPreSuffixIfEmptyFilter:=IgnoreIfSubSelectHasNoCriteria + ConditionGroups.Add NewBuilder + + Set AddSubSelectCriteria = NewBuilder + +End Function + +'--------------------------------------------------------------------------------------- +' Function: AddExistsCriteria +'--------------------------------------------------------------------------------------- +' +' 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: +' +' SelectFromText - Sql text for sub select (without where, except UseWhereReplacementTextInFromText is used) +' IgnoreIfExistsStatementHasNoCriteria - True = Ignore subselect criterion if no filter values were transferred +' SubSelectConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] .. valid within the new group +' UseNotExists - use not exists (..): default: false = exists (...) +' +' Returns: +' +' FilterStringBuilder instance for new exists group +' +'--------------------------------------------------------------------------------------- +Public Function AddExistsCriteria( _ + ByVal SelectFromText As String, _ + Optional ByVal IgnoreIfExistsStatementHasNoCriteria As Boolean = False, _ + Optional ByVal SubSelectConcatOperator As SqlLogicalOperator = SqlLogicalOperator.SQL_And, _ + Optional ByVal UseNotExists As Boolean = False, _ + Optional ByVal UseWhereReplacementTextInFromText As Boolean = False _ + ) As FilterStringBuilder + + Dim NewBuilder As FilterStringBuilder + Dim ExistsSqlPrefix As String + Dim WhereReplacementPos As Long + Dim ExistsSqlSuffix As String + + ExistsSqlPrefix = "Exists (" + If UseNotExists Then ExistsSqlPrefix = "Not " & ExistsSqlPrefix + + If UseWhereReplacementTextInFromText Then + WhereReplacementPos = InStr(1, SelectFromText, WhereReplacementText, vbTextCompare) + End If + + If WhereReplacementPos > 0 Then + ExistsSqlSuffix = " " & Trim$(Mid$(SelectFromText, WhereReplacementPos + Len(WhereReplacementText))) & ")" + SelectFromText = Trim$(Left(SelectFromText, WhereReplacementPos - 1)) + Else + ExistsSqlSuffix = ")" + End If + + Set NewBuilder = New FilterStringBuilder + NewBuilder.DefaultConcatOperator = SubSelectConcatOperator + Set NewBuilder.SqlTool = m_SqlTool + + NewBuilder.ConfigSqlStatement SqlPrefix:=ExistsSqlPrefix & SelectFromText, _ + SqlSuffix:=ExistsSqlSuffix, ConditionPrefix:=" Where ", IgnoreSqlPreSuffixIfEmptyFilter:=IgnoreIfExistsStatementHasNoCriteria + + ConditionGroups.Add NewBuilder + + Set AddExistsCriteria = NewBuilder + +End Function + +'################################## +' Group: Output + +'--------------------------------------------------------------------------------------- +' Function: ToString +'--------------------------------------------------------------------------------------- +' +' Output criteria to String +' +' Parameters: +' +' ConcatOperator - [SQL_And (default), SQL_Or, SQL_CommaSeparator] +' IgnoreDuplicateFilters - Do not output duplicate filter criteria +' +' Returns: +' +' Criteria/filter string +' +'--------------------------------------------------------------------------------------- +Public Function ToString(Optional ByVal ConcatOperator As SqlLogicalOperator = SqlLogicalOperator.[_SQL_Default], _ + Optional ByVal IgnoreDuplicateFilters As Boolean = False) As String + + Dim FilterString As String + Dim ItemPrefix As String + Dim ItemSuffix As String + + If ConcatOperator = SqlLogicalOperator.[_SQL_Default] Then + ConcatOperator = DefaultConcatOperator + End If + + If ConcatOperator <> SQL_CommaSeparator Then + ItemPrefix = "(" + ItemSuffix = ")" + End If + + FilterString = m_Items.ToString(GetConcatOperatorString(ConcatOperator), ItemPrefix, ItemSuffix, , IgnoreDuplicateFilters) + FilterString = AppendFilterGroupsString(FilterString, ConcatOperator, IgnoreDuplicateFilters) + If Len(FilterString) > 0 Then + FilterString = m_ConditionPrefix & FilterString + End If + + If m_IgnoreSqlPreSuffixIfEmptyFilter Then + If Len(FilterString) = 0 Then + ToString = vbNullString + Exit Function + End If + End If + + ToString = m_SqlPrefix & FilterString & m_SqlSuffix + +End Function + +Private Function GetConcatOperatorString(ByVal ConcatOperator As SqlLogicalOperator) As String + + Select Case ConcatOperator + Case SqlLogicalOperator.SQL_And + GetConcatOperatorString = " And " + Case SqlLogicalOperator.SQL_Or + GetConcatOperatorString = " Or " + Case SqlLogicalOperator.SQL_CommaSeparator + GetConcatOperatorString = ", " + Case Else + + End Select + +End Function + +Private Property Get ConditionGroups() As Collection + If m_ConditionGroups Is Nothing Then + Set m_ConditionGroups = New Collection + End If + Set ConditionGroups = m_ConditionGroups +End Property diff --git a/tests/AccessDatabase.accde/modules/SqlTools.cls b/tests/AccessDatabase.accde/modules/SqlTools.cls new file mode 100644 index 0000000..997606c --- /dev/null +++ b/tests/AccessDatabase.accde/modules/SqlTools.cls @@ -0,0 +1,1410 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "SqlTools" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: data.sql.SqlTools +'--------------------------------------------------------------------------------------- +' +' Functions to build sql strings +' +' Author: +' Josef Poetzl +' +' Remarks: +' "Attribute VB_PredeclaredId = True" to enable using SqlTools without explicit instantiation. +' +' Warning: +' +'| Don't forget to set parameters for date format, boolean and wildcard for the DBMS. +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' data/SqlTools.cls +' _codelib/license.bas +' data/SqlTools.bas +' _test/data/SqlToolsTests.cls +' _test/data/SqlToolsBuildCriteriaTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private Enum SqlToolsErrorNumbers + ERRNR_NOCONFIG = vbObjectError + 1 +End Enum + +' Default values for method parameters +Private Const SQL_DEFAULT_TEXTDELIMITER As String = "'" +Private Const SQL_DEFAULT_DATEFORMAT As String = "" ' "" => SqlDateFormat property will use. + ' To disable, enter value (e.g. "\#yyyy-mm\-dd\#"), + ' then this value will be used as the default entry. +Private Const SQL_DEFAULT_BOOLTRUESTRING As String = "" ' "" => SqlBooleanTrueString is used. + ' Enter value to disable (e.g. "True or 1") +Private Const SQL_DEFAULT_WILDCARD As String = "%" ' % = default value, + ' set required variations via SqlWildCardString + +Private Const SqlAndConcatString As String = " And " +Private Const SqlOrConcatString As String = " Or " + +Private Type SqlFormatSettings + SqlDateFormat As String + SqlBooleanTrueString As String + SqlWildCardString As String +End Type + +Private m_SqlFormat As SqlFormatSettings + +Private Const ResultTextIfNull As String = "Null" + +Public Enum SqlRelationalOperators + [_IgnoreAll] = &H80000000 + SQL_Not = 1 + SQL_Equal = 2 + SQL_LessThan = 4 + SQL_GreaterThan = 8 + SQL_Like = 256 + SQL_Between = 512 + SQL_In = 1024 + SQL_Add_WildCardSuffix = 2048 + SQL_Add_WildCardPrefix = 4096 + SQL_SplitValueToArray = 8192 + SQL_AllowSqlDirect = 16384 + SQL_UseLikeBehavior = 65536 +End Enum + +Public Enum SqlFieldDataType + SQL_Boolean = 1 + SQL_Numeric = 2 + SQL_Text = 3 + SQL_Date = 4 +End Enum + +Public Enum SqlLogicalOperator + [_SQL_Default] = 0 + SQL_And = 1 + SQL_Or = 2 + SQL_CommaSeparator = 3 +End Enum + +Public Enum SqlDialect + SQL_Custom = 0 + SQL_DAO = 1 + SQL_TSQL = 2 +End Enum + +'################################## +' Group: Class support + +'--------------------------------------------------------------------------------------- +' Function: SelectDialect +'--------------------------------------------------------------------------------------- +' +' Create a new instance with basic settings of the selected dialect +' +' Parameters: +' +' UseDialect - use setting of dialect (as base) +' NewSqlDateFormat - use this date format instead of base dialect +' NewSqlBooleanTrueString - use this text for true instead of base dialect +' NewSqlWildCardString - use this wildcard string instead of base dialect +' +' Returns: +' +' SqlTools instance with config form base +' +' See Also: +' NewInstance +' +'--------------------------------------------------------------------------------------- +Public Function FromDialect(ByVal UseDialect As SqlDialect, _ + Optional ByVal NewSqlDateFormat As String = SQL_DEFAULT_DATEFORMAT, _ + Optional ByVal NewSqlBooleanTrueString As String = SQL_DEFAULT_BOOLTRUESTRING, _ + Optional ByVal NewSqlWildCardString As String = SQL_DEFAULT_WILDCARD) As SqlTools + + Dim NewSlqToolsInstance As SqlTools + + Select Case UseDialect + Case SqlDialect.SQL_DAO + Set NewSlqToolsInstance = Me.DAO + Case SqlDialect.SQL_TSQL + Set NewSlqToolsInstance = Me.TSql + Case Else + Set NewSlqToolsInstance = Me.Clone + End Select + + If Len(NewSqlDateFormat) > 0 Then NewSlqToolsInstance.SqlDateFormat = NewSqlDateFormat + If Len(NewSqlBooleanTrueString) > 0 Then NewSlqToolsInstance.SqlBooleanTrueString = NewSqlBooleanTrueString + If Len(NewSqlWildCardString) > 0 Then NewSlqToolsInstance.SqlWildCardString = NewSqlWildCardString + + Set FromDialect = NewSlqToolsInstance + +End Function + + +'--------------------------------------------------------------------------------------- +' Function: Clone +'--------------------------------------------------------------------------------------- +' +' Create a new instance with basic settings of the current instance. +' +' Parameters: +' +' NewSqlDateFormat - use this date format instead of base instance +' NewSqlBooleanTrueString - use this text for true instead of base instance +' NewSqlWildCardString - use this wildcard string instead of base instance +' +' Returns: +' +' SqlTools instance with config form base +' +' See Also: +' NewInstance +' +'--------------------------------------------------------------------------------------- +Public Function Clone(Optional ByVal NewSqlDateFormat As String = SQL_DEFAULT_DATEFORMAT, _ + Optional ByVal NewSqlBooleanTrueString As String = SQL_DEFAULT_BOOLTRUESTRING, _ + Optional ByVal NewSqlWildCardString As String = SQL_DEFAULT_WILDCARD) As SqlTools + + If Len(NewSqlDateFormat) = 0 Then NewSqlDateFormat = Me.SqlDateFormat + If Len(NewSqlBooleanTrueString) = 0 Then NewSqlBooleanTrueString = Me.SqlBooleanTrueString + If Len(NewSqlWildCardString) = 0 Then NewSqlWildCardString = Me.SqlWildCardString + + Set Clone = NewInstance(NewSqlDateFormat, NewSqlBooleanTrueString, NewSqlWildCardString) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: NewInstance +'--------------------------------------------------------------------------------------- +' +' Create a new instance +' +'--------------------------------------------------------------------------------------- +Public Function NewInstance(ByVal NewSqlDateFormat As String, _ + ByVal NewSqlBooleanTrueString As String, _ + ByVal NewSqlWildCardString As String) As SqlTools + + Dim NewInst As SqlTools + + Set NewInst = New SqlTools + With NewInst + .SqlDateFormat = NewSqlDateFormat + .SqlBooleanTrueString = NewSqlBooleanTrueString + .SqlWildCardString = NewSqlWildCardString + End With + + Set NewInstance = NewInst + +End Function + +'--------------------------------------------------------------------------------------- +' Function: InitSqlDialect +'--------------------------------------------------------------------------------------- +' +' Config sql text output format for specific sql dialect +' +' Parameters: +' +' SqlDateFormat - output string format for date values +' SqlBooleanTrueString - output string format for boolean values +' SqlWildCardString - wildcard string (e.g. * .. dao, % .. T-SQL) +' +'--------------------------------------------------------------------------------------- +Friend Sub InitSqlDialect(ByVal UseDialect As SqlDialect, _ + Optional ByVal NewSqlDateFormat As String = SQL_DEFAULT_DATEFORMAT, _ + Optional ByVal NewSqlBooleanTrueString As String = SQL_DEFAULT_BOOLTRUESTRING, _ + Optional ByVal NewSqlWildCardString As String = SQL_DEFAULT_WILDCARD) + + Dim SqlFormat As SqlFormatSettings + + Select Case UseDialect + Case SqlDialect.SQL_DAO + SqlFormat = DaoSqlFormat + Case SqlDialect.SQL_TSQL + SqlFormat = TSqlSqlFormat + Case Else + ' set nothing => use NewSql* parameter + End Select + + If Len(NewSqlDateFormat) > 0 Then SqlFormat.SqlDateFormat = NewSqlDateFormat + If Len(NewSqlBooleanTrueString) > 0 Then SqlFormat.SqlBooleanTrueString = NewSqlBooleanTrueString + If Len(NewSqlWildCardString) > 0 Then SqlFormat.SqlWildCardString = NewSqlWildCardString + + InitSqlFormat SqlFormat.SqlDateFormat, SqlFormat.SqlBooleanTrueString, SqlFormat.SqlWildCardString + + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: InitSqlFormat +'--------------------------------------------------------------------------------------- +' +' Config sql text output format for specific sql dialect +' +' Parameters: +' +' SqlDateFormat - output string format for date values +' SqlBooleanTrueString - output string format for boolean values +' SqlWildCardString - wildcard string (e.g. * .. dao, % .. T-SQL) +' +'--------------------------------------------------------------------------------------- +Friend Sub InitSqlFormat(ByVal SqlDateFormat As String, _ + ByVal SqlBooleanTrueString As String, _ + ByVal SqlWildCardString As String) + + Me.SqlDateFormat = SqlDateFormat + Me.SqlBooleanTrueString = SqlBooleanTrueString + Me.SqlWildCardString = SqlWildCardString + +End Sub + +'################################## +' Group: SQL dialect preferences + +'--------------------------------------------------------------------------------------- +' Property: DAO +'--------------------------------------------------------------------------------------- +' +' SqlTools instance configured for DAO-SQL (Jet/ACE) +' +'--------------------------------------------------------------------------------------- +Public Property Get DAO() As SqlTools + With DaoSqlFormat + Set DAO = Me.NewInstance(.SqlDateFormat, .SqlBooleanTrueString, .SqlWildCardString) + End With +End Property + +Private Property Get DaoSqlFormat() As SqlFormatSettings + + Dim SqlFormat As SqlFormatSettings + + SqlFormat.SqlDateFormat = "\#yyyy-mm-dd hh:nn:ss\#" + SqlFormat.SqlBooleanTrueString = "True" + SqlFormat.SqlWildCardString = "*" + + DaoSqlFormat = SqlFormat + +End Property + +'--------------------------------------------------------------------------------------- +' Property: TSql +'--------------------------------------------------------------------------------------- +' +' SqlTools instance configured for T-SQL +' +'--------------------------------------------------------------------------------------- +Public Property Get TSql() As SqlTools + With TSqlSqlFormat + Set TSql = Me.NewInstance(.SqlDateFormat, .SqlBooleanTrueString, .SqlWildCardString) + End With +End Property + +Private Property Get TSqlSqlFormat() As SqlFormatSettings + + Dim SqlFormat As SqlFormatSettings + + SqlFormat.SqlDateFormat = "'yyyymmdd hh:nn:ss'" + SqlFormat.SqlBooleanTrueString = "1" + SqlFormat.SqlWildCardString = "%" + + TSqlSqlFormat = SqlFormat + +End Property + +' Configuration for SQL dialect + +'--------------------------------------------------------------------------------------- +' Property: SqlWildCardString +'--------------------------------------------------------------------------------------- +' +' Wildcard character for like +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlWildCardString() As String + If Len(m_SqlFormat.SqlWildCardString) > 0 Then + SqlWildCardString = m_SqlFormat.SqlWildCardString + Else + SqlWildCardString = SQL_DEFAULT_WILDCARD + End If +End Property + +Public Property Let SqlWildCardString(ByVal NewValue As String) + m_SqlFormat.SqlWildCardString = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlDateFormat +'--------------------------------------------------------------------------------------- +' +' Format for date values +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlDateFormat() As String + If Len(m_SqlFormat.SqlDateFormat) > 0 Then + SqlDateFormat = m_SqlFormat.SqlDateFormat + Else + SqlDateFormat = SQL_DEFAULT_DATEFORMAT + End If +End Property + +Public Property Let SqlDateFormat(ByVal NewValue As String) + m_SqlFormat.SqlDateFormat = NewValue +End Property + +'--------------------------------------------------------------------------------------- +' Property: SqlBooleanTrueString +'--------------------------------------------------------------------------------------- +' +' Boolean string in SQL statement +' +'--------------------------------------------------------------------------------------- +Public Property Get SqlBooleanTrueString() As String + If Len(m_SqlFormat.SqlBooleanTrueString) > 0 Then + SqlBooleanTrueString = m_SqlFormat.SqlBooleanTrueString + Else + SqlBooleanTrueString = SQL_DEFAULT_BOOLTRUESTRING + End If +End Property + +Public Property Let SqlBooleanTrueString(ByVal NewValue As String) + m_SqlFormat.SqlBooleanTrueString = NewValue +End Property + +'################################## +' Group: BuildCriteria + +'--------------------------------------------------------------------------------------- +' Function: BuildCriteria +'--------------------------------------------------------------------------------------- +' +' Create SQL criteria string +' +' Parameters: +' FieldName - Field name in the data source to be filtered +' RelationalOperator - Relational operator (=, <=, etc.) +' FilterValue - Filter value (can be a single value or an array of values) +' FilterValue2 - Optional 2nd filter value (for Between) +' IgnoreValue - The value for which no filter condition is to be created. (Array transfer of values possible) +' +' Returns: +' SQL criteria string +' +'--------------------------------------------------------------------------------------- +Public Function BuildCriteria(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal FilterValue As Variant, _ + Optional ByVal FilterValue2 As Variant = Null, _ + Optional ByVal IgnoreValue As Variant, _ + Optional ByVal DisableIgnoreNullValue As Boolean = False) As String + + Dim FilterValueString As String + Dim OperatorString As String + Dim Criteria As String + + If (RelationalOperator And [_IgnoreAll]) = [_IgnoreAll] Then + Exit Function + End If + + If IsMissing(IgnoreValue) Then + If Not DisableIgnoreNullValue Then + DisableIgnoreNullValue = True + End If + IgnoreValue = Null + End If + + ' Special cases (part 1): + If Not IsArray(FilterValue) Then + + If FilterValue = "{NULL}" Or FilterValue = "{LEER}" Or FilterValue = "{EMPTY}" Then + FilterValue = Null + DisableIgnoreNullValue = True + End If + + If FilterValue2 = "{NULL}" Or FilterValue2 = "{LEER}" Or FilterValue2 = "{EMPTY}" Then + FilterValue2 = Null + DisableIgnoreNullValue = True + End If + + If (RelationalOperator And SQL_AllowSqlDirect) = SQL_AllowSqlDirect Then + If FilterValue Like "{*@*}" Then ' Idee von Ulrich: Anwender schreibt SQL-Ausdruck + Criteria = Replace(Mid(FilterValue, 2, Len(FilterValue) - 2), "@", FieldName) + If (RelationalOperator And SQL_Not) = SQL_Not Then + Criteria = "Not " & Criteria + End If + BuildCriteria = Criteria + Exit Function + End If + End If + + End If + + If NullFilterOrEmptyFilter(FieldName, FieldDataType, RelationalOperator, Nz(FilterValue, FilterValue2), IgnoreValue, Criteria, DisableIgnoreNullValue) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildSplitToArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + 'Special cases (part 2): + If Not IsArray(FilterValue) Then + + If FieldDataType = SQL_Numeric Or FieldDataType = SQL_Date Then + + If FilterValue = "*" And RelationalOperator = SQL_Equal Then + BuildCriteria = BuildCriteria(FieldName, FieldDataType, SQL_Not, Null, Null, 0, True) + Exit Function + End If + + If IsNull(FilterValue2) Then + If TryBuildNumericSpecialCasesCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, DisableIgnoreNullValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + End If + + ConfigNumericSpecials RelationalOperator, FilterValue, FilterValue2 + + End If + + End If + + If TryBuildInCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + + If TryBuildBetweenCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, FilterValue2, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + 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|||@@@") + FilterValue = Replace(FilterValue, "*", SqlWildCardString) + FilterValue = Replace(FilterValue, "@@@|||STAR|||@@@", "*") + End If + End If + End If + + If (RelationalOperator And SQL_Add_WildCardSuffix) = SQL_Add_WildCardSuffix Then + If TryBuildWildCardSuffixOrPreBuildParams(FieldName, FieldDataType, RelationalOperator, FilterValue, FilterValue2, IgnoreValue, Criteria) Then + BuildCriteria = Criteria + Exit Function + End If + End If + + If (RelationalOperator And SQL_Add_WildCardPrefix) = SQL_Add_WildCardPrefix Then + If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + FilterValue = SqlWildCardString & FilterValue + End If + End If + + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + + If (RelationalOperator And SQL_Like) = SQL_Like Then + OperatorString = " Like " + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = " Not" & OperatorString + End If + BuildCriteria = FieldName & OperatorString & FilterValueString + Exit Function + End If + + OperatorString = GetRelationalOperatorString(RelationalOperator) + + Criteria = FieldName & " " & OperatorString & " " & FilterValueString + + If (RelationalOperator And SQL_Not) = SQL_Not Then + '?: will this line be reached? + Criteria = "Not " & Criteria + End If + + BuildCriteria = Criteria + +End Function + +'################################## +' Group: Convert to SQL + +'--------------------------------------------------------------------------------------- +' Function: ConvertToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert values to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FieldDataType - Data type of the value to be converted +' +' Returns: +' String - SQL conform string +' +'--------------------------------------------------------------------------------------- +Public Function ConvertToSqlText(ByVal Value As Variant, _ + ByVal FieldDataType As SqlFieldDataType) As String + + Select Case FieldDataType + Case SqlFieldDataType.SQL_Text + ConvertToSqlText = TextToSqlText(Value) + Case SqlFieldDataType.SQL_Numeric + ConvertToSqlText = NumberToSqlText(Value) + Case SqlFieldDataType.SQL_Date + ConvertToSqlText = DateToSqlText(Value) + Case SqlFieldDataType.SQL_Boolean + ConvertToSqlText = BooleanToSqlText(Value) + Case Else + Err.Raise vbObjectError, "SqlTools.ConvertToSqlText", "FieldDataType '" & FieldDataType & "' not supported" + End Select + +End Function + +'--------------------------------------------------------------------------------------- +' Function: TextToSqlText +'--------------------------------------------------------------------------------------- +' +' Prepare text for SQL statement +' +' Parameters: +' Value - Value to convert +' Delimiter - Delimiter for text values. (In most DBMS ' is used as a delimiter). +' WithoutLeftRightDelim - Only double the boundary drawing within the values, but do not set the boundary. +' +' Returns: +' String +' +' Example: +' strSQL = "select ... from tabelle where Feld = " & TextToSqlText("ab'cd") +' => strSQL = "select ... from tabelle where Feld = 'ab''cd'" +' +'--------------------------------------------------------------------------------------- +Public Function TextToSqlText(ByVal Value As Variant, _ + Optional ByVal Delimiter As String = SQL_DEFAULT_TEXTDELIMITER, _ + Optional ByVal WithoutLeftRightDelim As Boolean = False) As String + + Dim Result As String + + If IsNull(Value) Then + TextToSqlText = ResultTextIfNull + Exit Function + End If + + Result = Replace$(Value, Delimiter, Delimiter & Delimiter) + If Not WithoutLeftRightDelim Then + Result = Delimiter & Result & Delimiter + End If + + TextToSqlText = Result + +End Function + +'--------------------------------------------------------------------------------------- +' Function: DateToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert date value to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FormatString - Date format (depends on DBMS!) +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function DateToSqlText(ByVal Value As Variant, _ + Optional ByVal FormatString As String = SQL_DEFAULT_DATEFORMAT) As String + + If IsNull(Value) Then + DateToSqlText = ResultTextIfNull + Exit Function + End If + + If Not IsDate(Value) Then + Err.Raise vbObjectError, "SqlTools.DateToSqlText", "Der Wert '" & Value & "' vom Parameter Value ist kein Datumswert!" + End If + + If Len(FormatString) = 0 Then + FormatString = SqlDateFormat + If Len(FormatString) = 0 Then + Err.Raise SqlToolsErrorNumbers.ERRNR_NOCONFIG, "DateToSqlText", "date format is not defined" + End If + End If + + DateToSqlText = VBA.Format$(Value, FormatString) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: NumberToSqlText +'--------------------------------------------------------------------------------------- +' +' Convert numeric value to string for SQL statement assembled by VBA. +' +' Parameters: +' Value - Value to convert +' FormatString - Date format (depends on DBMS!) +' +' Returns: +' String +' +' Remarks: +' Str function ensures ".". +' +'--------------------------------------------------------------------------------------- +Public Function NumberToSqlText(ByVal Value As Variant) As String + + Dim Result As String + + If IsNull(Value) Then + NumberToSqlText = ResultTextIfNull + Exit Function + End If + + Value = ConvertToNumeric(Value) + + Result = Trim$(Str$(Value)) + If Left(Result, 1) = "." Then + Result = "0" & Result + End If + + NumberToSqlText = Result + +End Function + +Friend Function ConvertToNumeric(ByVal Value As Variant) As Variant + + Const CheckNumber As Double = 1.23 + + Dim CheckText As String + Dim DecimalSeparatorToReplace As String + Dim NewDecimalSeparator As String + + If IsNull(Value) Then + ConvertToNumeric = Null + Exit Function + ElseIf CStr(Value) = vbNullString Then + ConvertToNumeric = Null + Exit Function + End If + + CheckText = CStr(CheckNumber) + If InStr(1, CheckText, ",") > 0 Then + DecimalSeparatorToReplace = "." + NewDecimalSeparator = "," + Else + DecimalSeparatorToReplace = "," + NewDecimalSeparator = "." + End If + + If InStr(1, Value, DecimalSeparatorToReplace) > 0 Then + Value = Replace(Value, DecimalSeparatorToReplace, NewDecimalSeparator) + Do While Value Like "*" & NewDecimalSeparator & "*" & NewDecimalSeparator & "*" + Value = Replace(Value, NewDecimalSeparator, vbNullString, 1, 1) + Loop + End If + + ConvertToNumeric = CDbl(Value) + +End Function + +'--------------------------------------------------------------------------------------- +' Function: BooleanToSqlText +'--------------------------------------------------------------------------------------- +' +' Prepare Boolean for SQL text +' +' Parameters: +' Value - Value to convert +' TrueString - String for true value (optional) +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function BooleanToSqlText(ByVal Value As Variant, _ + Optional ByVal TrueString As String = SQL_DEFAULT_BOOLTRUESTRING) As String + + If IsNull(Value) Then + BooleanToSqlText = ResultTextIfNull + Exit Function + End If + + If CBool(Value) = True Then ' CBool(Value) to raise error 13 (type mismatch) if Value is not a boolean + If Len(TrueString) = 0 Then + TrueString = SqlBooleanTrueString + If Len(TrueString) = 0 Then + Err.Raise SqlToolsErrorNumbers.ERRNR_NOCONFIG, "BooleanToSqlText", "boolean string for true is not defined" + End If + End If + BooleanToSqlText = TrueString + Else + BooleanToSqlText = "0" + End If + +End Function + +Private Function ConfigNumericSpecials( _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant) + + If Left(FilterValue, 1) = "<" Then + If ((RelationalOperator And SQL_Equal) = SQL_Equal) Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + RelationalOperator = RelationalOperator Or SQL_LessThan + FilterValue = Mid(FilterValue, 2) + End If + + If Left(FilterValue, 1) = ">" Then + If ((RelationalOperator And SQL_Equal) = SQL_Equal) Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + RelationalOperator = RelationalOperator Or SQL_GreaterThan + FilterValue = Mid(FilterValue, 2) + End If + + If Left(FilterValue, 1) = "=" Then + RelationalOperator = RelationalOperator Or SQL_Equal + FilterValue = Mid(FilterValue, 2) + End If + + If Right(FilterValue, 1) = "*" Then + RelationalOperator = RelationalOperator Or SQL_Add_WildCardSuffix + ElseIf Right(FilterValue2, 1) = "*" Then + RelationalOperator = RelationalOperator Or SQL_Add_WildCardSuffix + End If + +End Function + +Private Function GetNextDigitNumber(ByVal NumValue As Variant, Optional AddToAbsoluteValue As Boolean = False) As Double + + Dim TestString As String + Dim DecSignPos As Long + Dim Digits As Long + Dim IsNegativ As Boolean + + Const AdditionalDecDigit As String = "1" + Const AdditionalDecDigitKorr As Double = 0.1 + + TestString = Trim(CStr(ConvertToNumeric(Replace(CStr(NumValue), "*", AdditionalDecDigit)))) + + If Left(TestString, 1) = "-" And (Not AddToAbsoluteValue) Then + GetNextDigitNumber = CDbl(Replace(CStr(NumValue), "*", vbNullString)) + Exit Function + End If + + If Left(TestString, 1) = "-" Then + IsNegativ = True + End If + + DecSignPos = InStrRev(TestString, DecimalMarker) + If DecSignPos = 0 Then ' next integer + If AddToAbsoluteValue And IsNegativ Then + GetNextDigitNumber = CDbl(Replace(CStr(NumValue), "*", vbNullString)) - 1 + Else + GetNextDigitNumber = CDbl(Replace(CStr(NumValue), "*", vbNullString)) + 1 + End If + Exit Function + End If + + Digits = Len(TestString) - DecSignPos - 1 + + If Left(TestString, 1) = "-" Then + IsNegativ = True + End If + + If AddToAbsoluteValue And IsNegativ Then + GetNextDigitNumber = CDbl(TestString) + AdditionalDecDigitKorr / 10 ^ Digits - AdditionalDecDigitKorr / 10 ^ (Digits - 1) + Else + GetNextDigitNumber = CDbl(TestString) + (1 - AdditionalDecDigitKorr) / 10 ^ Digits + End If + +End Function + +Private Property Get DecimalMarker() As String + + Static DecChar As String + Dim CheckString As String + + If Len(DecChar) = 0 Then + CheckString = Trim(CStr(1.2)) + DecChar = Mid(CheckString, 2, 1) + End If + + DecimalMarker = DecChar + +End Property + +Private Function CharTrim(ByVal ValueToTrim As String, ByVal TrimChar As String) As String + + Dim TrimString As String + + TrimString = " " & TrimChar + Do While InStr(1, ValueToTrim, TrimString) + ValueToTrim = Replace(ValueToTrim, TrimString, TrimChar) + Loop + + TrimString = TrimChar & " " + Do While InStr(1, ValueToTrim, TrimString) + ValueToTrim = Replace(ValueToTrim, TrimString, TrimChar) + Loop + + CharTrim = ValueToTrim + +End Function + +Friend Function GetRelationalOperatorString(ByRef RelationalOperator As SqlRelationalOperators) As String + + Dim OperatorString As String + Dim op As SqlRelationalOperators + + If (RelationalOperator And SQL_In) = SQL_In Then + OperatorString = OperatorString & "In" + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = "Not " & OperatorString + End If + GetRelationalOperatorString = OperatorString + Exit Function + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then + + op = RelationalOperator Xor SQL_Not + + If op = SqlRelationalOperators.SQL_Equal Then ' => "=" zu "<>" .. null berücksichtigen? + RelationalOperator = SQL_LessThan + SQL_GreaterThan + ElseIf op = SQL_GreaterThan + SQL_LessThan Then ' => "<>" zu "=" .. null berücksichtigen? + RelationalOperator = SQL_Equal + Else + RelationalOperator = RelationalOperator Xor SQL_Not + If (op And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator Xor SQL_Equal + Else + RelationalOperator = RelationalOperator Or SQL_Equal + End If + If (op And SQL_LessThan) = SQL_LessThan Then + RelationalOperator = RelationalOperator Xor SQL_LessThan + RelationalOperator = RelationalOperator Or SQL_GreaterThan + End If + If (op And SQL_GreaterThan) = SQL_GreaterThan Then + RelationalOperator = RelationalOperator Xor SQL_GreaterThan + RelationalOperator = RelationalOperator Or SQL_LessThan + End If + End If + End If + + If (RelationalOperator And SQL_LessThan) = SQL_LessThan Then + OperatorString = OperatorString & "<" + End If + + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + OperatorString = OperatorString & ">" + End If + + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + OperatorString = OperatorString & "=" + End If + + GetRelationalOperatorString = OperatorString + +End Function + +Private Function TryBuildWildCardSuffixOrPreBuildParams(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim Criteria1 As String + Dim Criteria2 As String + + If (RelationalOperator And SQL_Like) = SQL_Like Or (RelationalOperator And SQL_UseLikeBehavior) = SQL_UseLikeBehavior Then + FilterValue = FilterValue & SqlWildCardString + ElseIf FieldDataType = SQL_Date Then + If (RelationalOperator And SQL_LessThan) = 0 Then ' no < therefore: >, >= or only = + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + ' change nothing ... >= DataValue / SQL_Add_WildCardSuffix is not logical + Else ' Consider the whole day ... FieldName >= DateValue and FieldName < DateAdd("d", 1, FilterValue)) + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , , False) & _ + SqlAndConcatString & _ + BuildCriteria(FieldName, FieldDataType, SQL_LessThan, DateAdd("d", 1, CDate(CLng(CDate(FilterValue)))), , , False) + TryBuildWildCardSuffixOrPreBuildParams = True + Exit Function + End If + Else + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + FilterValue = DateAdd("d", 1, CDate(CLng(CDate(FilterValue)))) + End If + ElseIf FieldDataType = SQL_Numeric Then + If (RelationalOperator And SQL_LessThan) = 0 Then ' no < daher: >, >= or only = + If (RelationalOperator And SQL_GreaterThan) = SQL_GreaterThan Then + If FilterValue Like "*[,.]*[*]" Then + FilterValue = Replace(FilterValue, "*", 0) + ElseIf FilterValue Like "*[*]" Then + FilterValue = Replace(FilterValue, "*", vbNullString) + End If + ' change nothing => >= Number / SQL_Add_WildCardSuffix is not logical + Else ' Consider following decimal values ... FieldName >= Number and FieldName < (Number + x) + If FilterValue Like "-*[*]" Then + If FilterValue Like "*[,.]*[*]" Then + FilterValue2 = Replace(FilterValue, "*", 0) + Else + FilterValue2 = Replace(FilterValue, "*", vbNullString) + End If + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan, GetNextDigitNumber(FilterValue, True), , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal, FilterValue2, , Null, False) + Else + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, GetNextDigitNumber(FilterValue), , Null, False) + End If + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildWildCardSuffixOrPreBuildParams = True + Exit Function + End If + Else + If (RelationalOperator And SQL_Equal) = SQL_Equal Then + RelationalOperator = RelationalOperator - SQL_Equal + End If + FilterValue = GetNextDigitNumber(FilterValue) + End If + End If + +End Function + +Private Function TryBuildNumericSpecialCasesCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef DisableIgnoreNullValue As Boolean, _ + ByRef Criteria As String) As Boolean + + Dim CriteriaBuild As Boolean + Dim TempArr() As String + + Const FilterValue2 As Variant = Null + + If VarType(FilterValue) = vbString Then + FilterValue = Trim(FilterValue) + End If + + If FilterValue Like "[0-9]*..*[0-9]*" Or FilterValue Like "[+-][0-9]*..*[0-9]*" Then + TempArr = Split(FilterValue, "..") + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + ElseIf FilterValue Like "[0-9]*-*[0-9]*" Or FilterValue Like "[+-][0-9]*-*[0-9]*" Then ' convert to a..b + If Left(FilterValue, 1) = "-" Then + FilterValue = "{M}" & Mid(FilterValue, 2) + End If + FilterValue = Replace(FilterValue, " ", " ") + FilterValue = Replace(FilterValue, "- -", "--") + FilterValue = Replace(FilterValue, "--", "-{M}") + FilterValue = Replace(FilterValue, "-", "..") + FilterValue = Replace(FilterValue, "{M}", "-") + + TempArr = Split(FilterValue, "..") + Criteria = BuildCriteria(FieldName, FieldDataType, SQL_Between, Trim(TempArr(0)), Trim(TempArr(1)), IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + ElseIf FilterValue Like "*[0-9]" & DecimalMarker & "*[*]" Then + If (RelationalOperator And SQL_Add_WildCardSuffix) = 0 Then + Criteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator + SQL_Add_WildCardSuffix, FilterValue, FilterValue2, IgnoreValue, DisableIgnoreNullValue) + CriteriaBuild = True + End If + End If + + TryBuildNumericSpecialCasesCriteria = CriteriaBuild + +End Function + + +Private Function TryBuildSplitToArrayCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim ValueSplitted As Boolean + Dim CriteriaConcatString As String + + If (RelationalOperator And SQL_SplitValueToArray) = SQL_SplitValueToArray Then + + RelationalOperator = RelationalOperator Xor SQL_SplitValueToArray + + If InStr(1, FilterValue, SqlOrConcatString, vbTextCompare) > 0 Then + FilterValue = Replace(FilterValue, SqlOrConcatString, ";") + End If + + If InStr(1, FilterValue, SqlAndConcatString, vbTextCompare) > 0 Then + FilterValue = Replace(FilterValue, SqlAndConcatString, "+") + End If + + If InStr(1, FilterValue, ";") > 0 Then + If InStr(1, FilterValue, "+") > 0 Then + RelationalOperator = RelationalOperator Or SQL_SplitValueToArray + End If + CriteriaConcatString = SqlOrConcatString + FilterValue = Split(CharTrim(FilterValue, ";"), ";") + ValueSplitted = True + ElseIf InStr(1, FilterValue, "+") > 0 Then + CriteriaConcatString = SqlAndConcatString + FilterValue = Split(CharTrim(FilterValue, "+"), "+") + ValueSplitted = True + End If + End If + + If ValueSplitted Then + + If CriteriaConcatString = SqlOrConcatString Then + If TryBuildInCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria) Then + Exit Function + End If + End If + + TryBuildSplitToArrayCriteria = TryBuildArrayCriteria(FieldName, FieldDataType, RelationalOperator, FilterValue, IgnoreValue, Criteria, CriteriaConcatString) + + End If + +End Function + + +Private Function TryBuildArrayCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String, _ + Optional ByVal CriteriaConcatString As String = SqlOrConcatString) As Boolean + Dim itm As Variant + Dim ItmCriteria As String + + Dim arrFilterValue() As Variant + + If Not IsArray(FilterValue) Then + Exit Function + End If + + 'Connect criteria via Or + For Each itm In FilterValue + ItmCriteria = BuildCriteria(FieldName, FieldDataType, RelationalOperator, itm, , IgnoreValue, False) + If Len(ItmCriteria) > 0 Then + Criteria = Criteria & CriteriaConcatString & ItmCriteria + End If + Next + If Len(Criteria) > 0 Then + Criteria = Mid(Criteria, Len(CriteriaConcatString) + 1) ' 1. Or wegschneiden + End If + + TryBuildArrayCriteria = True + +End Function + +Private Function TryBuildInCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim OperatorString As String + Dim FilterValueString As String + + If (RelationalOperator And SQL_In) = 0 Then + Exit Function + End If + + If IsArray(FilterValue) Then + FilterValueString = GetValueArrayString(FilterValue, FieldDataType, ",", IgnoreValue) + ElseIf VarType(FilterValue) = vbString Then + If FieldDataType = SQL_Text Then + If Left(FilterValue, 1) = "'" Then ' Is already as SQL text in the FilterString + FilterValueString = FilterValue + Else + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + End If + Else + FilterValueString = FilterValue ' Value is already in the listing as a string + End If + Else + FilterValueString = ConvertToSqlText(FilterValue, FieldDataType) + End If + + OperatorString = " In " + If (RelationalOperator And SQL_Not) = SQL_Not Then + OperatorString = " Not" & OperatorString + End If + + If Len(FilterValueString) > 0 Then + + If RemoveNullFromInValueString(FilterValueString) Then + Criteria = FieldName & " Is Null" + If Len(FilterValueString) > 0 Then + Criteria = Criteria & " Or " & FieldName & OperatorString & "(" & FilterValueString & ")" + End If + Else + Criteria = FieldName & OperatorString & "(" & FilterValueString & ")" + End If + + End If + + TryBuildInCriteria = True + +End Function + +Private Function TryBuildBetweenCriteria(ByRef FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByRef RelationalOperator As SqlRelationalOperators, _ + ByRef FilterValue As Variant, _ + ByRef FilterValue2 As Variant, _ + ByRef IgnoreValue As Variant, _ + ByRef Criteria As String) As Boolean + + Dim Criteria1 As String + Dim Criteria2 As String + + If (RelationalOperator And SQL_Between) = False Then + TryBuildBetweenCriteria = False + Exit Function + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then 'Reverse condition + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue, , IgnoreValue, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan, FilterValue2, , IgnoreValue, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + End If + + If FieldDataType = SQL_Numeric Then + If FilterValue2 Like "<=*" Then 'cut away + FilterValue2 = Mid(FilterValue2, 3) + ElseIf FilterValue2 Like "<*" Then + FilterValue2 = Mid(FilterValue2, 2) + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + End If + End If + + If IsNull(FilterValue2) Or IsMissing(FilterValue2) Or ValuesAreEqual(FieldDataType, FilterValue2, IgnoreValue) Then + RelationalOperator = SQL_GreaterThan + SQL_Equal + ElseIf IsNull(FilterValue) Or ValuesAreEqual(FieldDataType, FilterValue, IgnoreValue) Then + RelationalOperator = SQL_LessThan + SQL_Equal + FilterValue = FilterValue2 + FilterValue2 = GetCheckedIgnoreValue(IgnoreValue) + ElseIf (FieldDataType And SQL_Date) = SQL_Date And (RelationalOperator And SQL_Add_WildCardSuffix) Then + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + ElseIf (FieldDataType And SQL_Numeric) = SQL_Numeric And (RelationalOperator And SQL_Add_WildCardSuffix) Then + Criteria1 = BuildCriteria(FieldName, FieldDataType, SQL_GreaterThan + SQL_Equal, FilterValue, , Null, False) + Criteria2 = BuildCriteria(FieldName, FieldDataType, SQL_LessThan + SQL_Equal + SQL_Add_WildCardSuffix, FilterValue2, , Null, False) + Criteria = Criteria1 & SqlAndConcatString & Criteria2 + TryBuildBetweenCriteria = True + Exit Function + Else + Criteria = FieldName & " Between " & ConvertToSqlText(FilterValue, FieldDataType) & SqlAndConcatString & ConvertToSqlText(FilterValue2, FieldDataType) + TryBuildBetweenCriteria = True + Exit Function + End If + +End Function + +Private Function GetCheckedIgnoreValue(ByVal IgnoreValue As Variant) As Variant + If IsArray(IgnoreValue) Then + GetCheckedIgnoreValue = IgnoreValue(LBound(IgnoreValue)) + Else + GetCheckedIgnoreValue = IgnoreValue + End If +End Function + +Private Function NullFilterOrEmptyFilter(ByVal FieldName As String, ByVal FieldDataType As SqlFieldDataType, _ + ByVal RelationalOperator As SqlRelationalOperators, _ + ByVal Value As Variant, ByVal IgnoreValue As Variant, _ + ByRef NullFilterString As String, _ + Optional ByVal DisableIgnoreNullValue As Boolean = False) As Boolean + + If IsObject(IgnoreValue) Then + If IgnoreValue Is Nothing Then + If IsNull(Value) Then + If (RelationalOperator And SQL_Not) = SQL_Not Then + NullFilterString = FieldName & " Is Not Null" + Else + NullFilterString = FieldName & " Is Null" + End If + NullFilterOrEmptyFilter = True + Else + NullFilterOrEmptyFilter = False + End If + Exit Function + End If + End If + + If IsNull(Value) Then + If DisableIgnoreNullValue Then + NullFilterString = FieldName & " Is Null" + ElseIf Not ValuesAreEqual(FieldDataType, Value, IgnoreValue) Then + NullFilterString = FieldName & " Is Null" + End If + NullFilterOrEmptyFilter = True + ElseIf IsArray(Value) Then + Dim CheckArray() As Variant +On Error Resume Next + CheckArray = Value + If Err.Number = 0 Then + If (0 / 1) + (Not Not CheckArray) = 0 Then + NullFilterOrEmptyFilter = True + Exit Function + End If + Else + Err.Clear + Dim ArraySize As Long + ArraySize = UBound(Value) + If Err.Number <> 0 Then + Err.Clear + NullFilterOrEmptyFilter = True + Exit Function + End If + End If + Else + NullFilterOrEmptyFilter = ValuesAreEqual(FieldDataType, Value, IgnoreValue) + End If + + If (RelationalOperator And SQL_Not) = SQL_Not Then + NullFilterString = Replace(NullFilterString, "Is Null", "Is Not Null") + End If + +End Function + +Private Function ValuesAreEqual(ByVal FieldDataType As SqlFieldDataType, ByVal Value As Variant, ByVal Value2 As Variant) As Boolean + + If IsArray(Value2) Then + ValuesAreEqual = ArrayContains(FieldDataType, Value2, Value) + ElseIf IsNull(Value) Then + ValuesAreEqual = IsNull(Value2) + ElseIf IsNull(Value2) Then + ValuesAreEqual = False + Else + Select Case FieldDataType + Case SqlFieldDataType.SQL_Text + ValuesAreEqual = (VBA.StrComp(Value, Value2, vbTextCompare) = 0) + Case SqlFieldDataType.SQL_Numeric + ValuesAreEqual = (CDbl(Value) = CDbl(Value2)) + Case SqlFieldDataType.SQL_Date + ValuesAreEqual = (CDate(Value) = CDate(Value2)) + Case SqlFieldDataType.SQL_Boolean + ValuesAreEqual = (CBool(Value) = CBool(Value2)) + Case Else + ValuesAreEqual = (Value = Value2) + End Select + End If + +End Function + +Private Function ArrayContains(ByVal FieldDataType As SqlFieldDataType, ByVal ArrayToCheck As Variant, ByVal SearchValue As Variant) As Boolean + + Dim i As Long + + If IsNull(SearchValue) Then + ArrayContains = ArrayContainsNull(ArrayToCheck) + Exit Function + End If + + For i = LBound(ArrayToCheck) To UBound(ArrayToCheck) + If ValuesAreEqual(FieldDataType, ArrayToCheck(i), SearchValue) Then + ArrayContains = True + Exit Function + End If + Next + + ArrayContains = False + +End Function + +Private Function ArrayContainsNull(ByVal ArrayToCheck As Variant) As Boolean + + Dim i As Long + + For i = LBound(ArrayToCheck) To UBound(ArrayToCheck) + If IsNull(ArrayToCheck(i)) Then + ArrayContainsNull = True + Exit Function + End If + Next + + ArrayContainsNull = False + +End Function + +Private Function GetValueArrayString(ByVal Value As Variant, ByVal FieldDataType As SqlFieldDataType, _ + ByVal Delimiter As String, ByVal IgnoreValue As Variant) As String + + Dim i As Long + Dim s As String + + For i = LBound(Value) To UBound(Value) + If IsArray(IgnoreValue) Then + If ArrayContains(FieldDataType, IgnoreValue, Value(i)) Then + Else + s = s & Delimiter & ConvertToSqlText(Value(i), FieldDataType) + End If + Else + If Value(i) = IgnoreValue Then + ElseIf IsNull(Value(i)) And IsNull(IgnoreValue) Then + Else + s = s & Delimiter & ConvertToSqlText(Value(i), FieldDataType) + End If + End If + Next + If Len(s) > 0 And Len(Delimiter) > 0 Then + s = Mid(s, Len(Delimiter) + 1) + End If + GetValueArrayString = s + +End Function + +Private Function RemoveNullFromInValueString(ByRef ValueString As String) As Boolean + + Const NullCheckString As String = ",Null," + Dim TestString As String + + TestString = "," & ValueString & "," + + If Not (InStr(1, TestString, NullCheckString) > 0) Then + RemoveNullFromInValueString = False + Exit Function + End If + + TestString = Replace(TestString, NullCheckString, ",") + + If Len(TestString) > 1 Then + ValueString = Mid(TestString, 2, Len(TestString) - 2) + Else + ValueString = vbNullString + End If + + RemoveNullFromInValueString = True + +End Function diff --git a/tests/AccessDatabase.accde/modules/StringCollection.cls b/tests/AccessDatabase.accde/modules/StringCollection.cls new file mode 100644 index 0000000..34133ec --- /dev/null +++ b/tests/AccessDatabase.accde/modules/StringCollection.cls @@ -0,0 +1,318 @@ +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True +END +Attribute VB_Name = "StringCollection" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'--------------------------------------------------------------------------------------- +' Class: text.StringCollection +'--------------------------------------------------------------------------------------- +' +' Collection for strings +' +' Author: +' Josef Poetzl +' +'--------------------------------------------------------------------------------------- + +'--------------------------------------------------------------------------------------- +' +' text/StringCollection.cls +' _codelib/license.bas +' _test/text/StringCollectionTests.cls +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Private m_Items As Collection + +Private Sub Class_Initialize() + Set m_Items = New Collection +End Sub + +Private Sub Class_Terminate() + Set m_Items = Nothing +End Sub + +'--------------------------------------------------------------------------------------- +' Property: Self +'--------------------------------------------------------------------------------------- +' +' Reference to self (Me) +' +' Remarks: +' Useful for with-block +' +' Returns: +' Database.StringCollection +' +'--------------------------------------------------------------------------------------- +Public Property Get Self() As StringCollection + Set Self = Me +End Property + +'--------------------------------------------------------------------------------------- +' Property: Items +'--------------------------------------------------------------------------------------- +' +' Collection with items +' +' Returns: +' VBA.Collection +' +'--------------------------------------------------------------------------------------- +Public Property Get Items() As Collection + Set Items = m_Items +End Property + +'--------------------------------------------------------------------------------------- +' Property: Item +'--------------------------------------------------------------------------------------- +' +' Item of Collection +' +' Parameters: +' Index - (Variant) +' +' Returns: +' Item string - (String) +' +'--------------------------------------------------------------------------------------- +Public Property Get Item(ByVal Index As Variant) As String + Item = m_Items.Item(Index) +End Property + +Public Property Let Item(ByVal Index As Variant, ByVal NewValue As String) +Attribute Item.VB_UserMemId = 0 + m_Items.Add NewValue, , , Index + m_Items.Remove Index +End Property + +'--------------------------------------------------------------------------------------- +' Sub: Add +'--------------------------------------------------------------------------------------- +' +' Add string to collection +' +' Parameters: +' Item to add - (String) +' +'--------------------------------------------------------------------------------------- +Public Sub Add(ByVal Item As String) + m_Items.Add Item +End Sub + +'--------------------------------------------------------------------------------------- +' Sub: AddFromArray +'--------------------------------------------------------------------------------------- +' +' Add items form an array to collection +' +' Parameters: +' ArrayToAdd - (Variant) +' ItemStringFormat - (String) Format each item of Array with ItemStringFormat before add to collection +' +'--------------------------------------------------------------------------------------- +Public Sub AddFromArray(ByRef ArrayToAdd As Variant, Optional ByVal ItemStringFormat As String = vbNullString) + + Dim i As Long + + For i = LBound(ArrayToAdd) To UBound(ArrayToAdd) + m_Items.Add Format(ArrayToAdd(i), ItemStringFormat) + Next + +End Sub + +'--------------------------------------------------------------------------------------- +' Sub: AddFromCollection +'--------------------------------------------------------------------------------------- +' +' Add items form a collection to string collection +' +' Parameters: +' CollectionToAppend - (Object) .. so that all collections with Enumarable and Item(index) interface can be run through +' ItemStringFormat - (String) Format each item of collection with ItemStringFormat before add to collection +' +'--------------------------------------------------------------------------------------- +Public Sub AddFromCollection(ByVal CollectionToAppend As Object, Optional ByVal ItemStringFormat As String = vbNullString) + + Dim itm As Variant + + For Each itm In CollectionToAppend + m_Items.Add Format(itm, ItemStringFormat) + Next + +End Sub + +'--------------------------------------------------------------------------------------- +' Function: ToString +'--------------------------------------------------------------------------------------- +' +' Return Collection items as joined String +' +' Parameters: +' Delimiter - (String) Example: ", " => "Item1, Item2, Item3" +' ItemPrefix - (String) Prefix for each item +' ItemSuffix - (String) Suffix for each item +' IgnoreEmptyValue - (Boolean) don't output an empty item +' IgnoreDuplicateValues - (Boolean) True = don't output duplicate items +' +' Returns: +' String +' +'--------------------------------------------------------------------------------------- +Public Function ToString(Optional ByVal Delimiter As String = ", ", _ + Optional ByVal ItemPrefix As String = vbNullString, _ + Optional ByVal ItemSuffix As String = vbNullString, _ + Optional ByVal IgnoreEmptyValue As Boolean = False, _ + Optional ByVal IgnoreDuplicateValues As Boolean = False) As String + + Dim s As String + + s = VBA.Join(ToStringArray(IgnoreEmptyValue, IgnoreDuplicateValues), ItemSuffix & Delimiter & ItemPrefix) + If Len(s) > 0 Then s = ItemPrefix & s & ItemSuffix + + ToString = s + +End Function + +'--------------------------------------------------------------------------------------- +' Function: ToStringArray +'--------------------------------------------------------------------------------------- +' +' Return Collection items as String array +' +' Parameters: +' IgnoreEmptyValue - (Boolean) don't output an empty item +' IgnoreDuplicateValues - (Boolean) True = don't output duplicate items +' +' Returns: +' String array +' +'--------------------------------------------------------------------------------------- +Public Function ToStringArray(Optional ByVal IgnoreEmptyValue As Boolean = False, _ + Optional ByVal IgnoreDuplicateValues As Boolean = False) As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim i As Long + + MaxArrayIndex = m_Items.Count - 1 + + If MaxArrayIndex < 0 Then + ToStringArray = ItemArray + Exit Function + End If + + If IgnoreEmptyValue Then + If IgnoreDuplicateValues Then + ToStringArray = RemoveDuplicateValues(GetArrayWithoutEmptyValues()) + Else + ToStringArray = GetArrayWithoutEmptyValues() + End If + Exit Function + End If + + ReDim ItemArray(0 To MaxArrayIndex) + For i = 0 To MaxArrayIndex + ItemArray(i) = m_Items.Item(i + 1) + Next + + If IgnoreDuplicateValues Then + ToStringArray = RemoveDuplicateValues(ItemArray) + Else + ToStringArray = ItemArray + End If + +End Function + +Private Function GetArrayWithoutEmptyValues() As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim ItemIndex As Long + Dim itm As Variant + + MaxArrayIndex = m_Items.Count - 1 + + If MaxArrayIndex < 0 Then + GetArrayWithoutEmptyValues = ItemArray + Exit Function + End If + + ReDim ItemArray(0 To MaxArrayIndex) + ItemIndex = -1 + For Each itm In m_Items + If Len(itm) > 0 Then + ItemIndex = ItemIndex + 1 + ItemArray(ItemIndex) = itm + End If + Next + + If ItemIndex = -1 Then + Erase ItemArray + GetArrayWithoutEmptyValues = ItemArray + Exit Function + End If + + If ItemIndex < (m_Items.Count - 1) Then + ReDim Preserve ItemArray(0 To ItemIndex) + End If + + GetArrayWithoutEmptyValues = ItemArray + +End Function + +Private Function RemoveDuplicateValues(ByRef ArrayToCheck() As String) As String() + + Dim ItemArray() As String + Dim MaxArrayIndex As Long + Dim ItemIndex As Long + Dim ArrayItem As Variant + + MaxArrayIndex = UBound(ArrayToCheck) + + If MaxArrayIndex = 0 Then + RemoveDuplicateValues = ArrayToCheck + Exit Function + End If + + ReDim ItemArray(MaxArrayIndex) + + ItemIndex = -1 + For Each ArrayItem In ArrayToCheck + If Not ValueExistsInArray(ItemArray, ArrayItem, ItemIndex) Then + ItemIndex = ItemIndex + 1 + ItemArray(ItemIndex) = ArrayItem + End If + Next + + If ItemIndex < (m_Items.Count - 1) Then + ReDim Preserve ItemArray(0 To ItemIndex) + End If + + RemoveDuplicateValues = ItemArray + +End Function + +Private Function ValueExistsInArray(ByRef ArrayToCheck() As String, ByVal ValueToCheck As String, ByVal CheckUntilArrayIndex As Long) As Boolean + + Dim i As Long + + If CheckUntilArrayIndex < 0 Then + Exit Function + End If + + For i = LBound(ArrayToCheck) To CheckUntilArrayIndex + If StrComp(ArrayToCheck(i), ValueToCheck, vbBinaryCompare) = 0 Then + ValueExistsInArray = True + Exit Function + End If + Next + +End Function diff --git a/tests/AccessDatabase.accde/modules/_AccessCodeLib_license.bas b/tests/AccessDatabase.accde/modules/_AccessCodeLib_license.bas new file mode 100644 index 0000000..a5dab1a --- /dev/null +++ b/tests/AccessDatabase.accde/modules/_AccessCodeLib_license.bas @@ -0,0 +1,81 @@ +Attribute VB_Name = "_AccessCodeLib_license" +'--------------------------------------------------------------------------------------- +' access-codelib.net Lizenz +'--------------------------------------------------------------------------------------- +'/** +' +' access-codelib.net Lizenz +' +' +'---------------------------------------------------------------------------------------\n +' access-codelib.net Lizenz \n +'---------------------------------------------------------------------------------------\n +' +' Copyright (c) access-codelib.net +' All rights reserved. +' +' Redistribution and use in source and binary forms, with or without modification, +' are permitted provided that the following conditions are met: +' +' * Redistributions of source code must retain the above copyright notice, +' this list of conditions and the following disclaimer. +' * Redistributions in binary form must reproduce the above copyright notice, +' this list of conditions and the following disclaimer in the documentation +' and/or other materials provided with the distribution. +' * Neither the name of access-codelib.net nor the names of its contributors may +' be used to endorse or promote products derived from this software without specific +' prior written permission. +' +' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +' INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +' DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +' SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +' LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +' CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +' SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +' +'---------------------------------------------------------------------------------------\n +' BSD-Lizenz im Originial: http://opensource.org/licenses/bsd-license.php \n +'---------------------------------------------------------------------------------------\n +' +' Beachten Sie auch die Nutzungsbedingungen von access-codelib.net: +' http://access-codelib.net/nutzungsbedingungen.html +' +' +'**/ +'--------------------------------------------------------------------------------------- +' +' _codelib/license.bas +' +'--------------------------------------------------------------------------------------- +' +Option Compare Text +Option Explicit + +Public Function GetAccessCodeLibLicense() As String + +On Error Resume Next + + GetAccessCodeLibLicense = _ + "Copyright (c) access-codelib.net" & vbNewLine & _ + "All rights reserved." & vbNewLine & vbNewLine & _ + "Redistribution and use in source and binary forms, with or without modification," & vbNewLine & _ + "are permitted provided that the following conditions are met:" & vbNewLine & _ + vbNewLine & _ + "* Redistributions of source code must retain the above copyright notice," & vbNewLine & _ + " this list of conditions and the following disclaimer." & vbNewLine & _ + "* Redistributions in binary form must reproduce the above copyright notice," & vbNewLine & _ + " this list of conditions and the following disclaimer in the documentation" & vbNewLine & _ + " and/or other materials provided with the distribution." & vbNewLine & _ + "* Neither the name of access-codelib.net nor the names of its contributors may" & vbNewLine & _ + " be used to endorse or promote products derived from this software without" & vbNewLine & _ + " specific prior written permission." & vbNewLine & vbNewLine & _ + "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ""AS IS"" AND ANY EXPRESS OR IMPLIED WARRANTIES," & vbNewLine & _ + "INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE" & vbNewLine & _ + "DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL," & vbNewLine & _ + "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;" & vbNewLine & _ + "LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN" & vbNewLine & _ + "CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS" & vbNewLine & _ + "SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE." + +End Function diff --git a/tests/AccessDatabase.accde/modules/modRibbonProcedures.bas b/tests/AccessDatabase.accde/modules/modRibbonProcedures.bas new file mode 100644 index 0000000..eef5359 --- /dev/null +++ b/tests/AccessDatabase.accde/modules/modRibbonProcedures.bas @@ -0,0 +1,7 @@ +Attribute VB_Name = "modRibbonProcedures" +Option Compare Database +Option Explicit + +Public Function RibbonProcTest1() + MsgBox "You clicked!", vbCritical, "" +End Function diff --git a/tests/AccessDatabase.accde/modules/modTestProcedures.bas b/tests/AccessDatabase.accde/modules/modTestProcedures.bas new file mode 100644 index 0000000..a8c1c1c --- /dev/null +++ b/tests/AccessDatabase.accde/modules/modTestProcedures.bas @@ -0,0 +1,28 @@ +Attribute VB_Name = "modTestProcedures" +Option Compare Database +Option Explicit + +Public Sub TestProcedure() + SaveTestInfo "TestProcedure" +End Sub + +Public Sub TestProcedure2(ByVal T As String, ByVal N As Long) + SaveTestInfo "TestProcedure2", T, N +End Sub + +Private Sub SaveTestInfo(ByVal ProcName As String, Optional ByVal T As Variant, Optional ByVal N As Variant) + + With CurrentDb.OpenRecordset("tabTest", dbOpenTable, dbAppendOnly) + .AddNew + .Fields("ProcName").Value = ProcName + If Not IsMissing(T) Then + .Fields("T").Value = T + End If + If Not IsMissing(N) Then + .Fields("N").Value = N + End If + .Update + .Close + End With + +End Sub diff --git a/tests/AccessDatabase.accde/nav-pane-groups.json b/tests/AccessDatabase.accde/nav-pane-groups.json new file mode 100644 index 0000000..5dfe254 --- /dev/null +++ b/tests/AccessDatabase.accde/nav-pane-groups.json @@ -0,0 +1,24 @@ +{ + "Info": { + "Class": "clsDbNavPaneGroup", + "Description": "Navigation Pane Custom Groups" + }, + "Items": { + "Categories": [ + { + "Name": "Custom", + "Flags": 0, + "Position": 2, + "Groups": [ + { + "Name": "Custom Group 1", + "Flags": 0, + "Position": 2, + "Objects": [ + ] + } + ] + } + ] + } +} diff --git a/tests/AccessDatabase.accde/proj-properties.json b/tests/AccessDatabase.accde/proj-properties.json new file mode 100644 index 0000000..9d09328 --- /dev/null +++ b/tests/AccessDatabase.accde/proj-properties.json @@ -0,0 +1,9 @@ +{ + "Info": { + "Class": "clsDbProjProperty", + "Description": "Project Properties (Access)" + }, + "Items": { + "VCS Source Path": "\\AccessDatabase.accdb" + } +} diff --git a/tests/AccessDatabase.accde/project.json b/tests/AccessDatabase.accde/project.json new file mode 100644 index 0000000..f8bcac2 --- /dev/null +++ b/tests/AccessDatabase.accde/project.json @@ -0,0 +1,10 @@ +{ + "Info": { + "Class": "clsDbProject", + "Description": "Project" + }, + "Items": { + "FileFormat": 12, + "RemovePersonalInformation": false + } +} diff --git a/tests/AccessDatabase.accde/tables/USysRibbons.xml b/tests/AccessDatabase.accde/tables/USysRibbons.xml new file mode 100644 index 0000000..46bd7b7 --- /dev/null +++ b/tests/AccessDatabase.accde/tables/USysRibbons.xml @@ -0,0 +1,15 @@ + + + + 1 + MainRibbon + <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" ><commands><command idMso="Help" enabled="false"/></commands><ribbon startFromScratch="true"> +<tabs><tab id="T1" label="Home"> +<group id="G1" label="Test"> + <button id="TestBtn1" label="Don't click here" size="large" imageMso="CreateTable" onAction="=RibbonProcTest1()" /> + <button idMso="PrintDialogAccess" size="large" label="Print Dialog" /> + <control idMso="WindowsSwitch" size="large" label="Switch Windows" /> +</group> +</tab></tabs></ribbon></customUI> + + diff --git a/tests/AccessDatabase.accde/tbldefs/USysRibbons.sql b/tests/AccessDatabase.accde/tbldefs/USysRibbons.sql new file mode 100644 index 0000000..b28beb4 --- /dev/null +++ b/tests/AccessDatabase.accde/tbldefs/USysRibbons.sql @@ -0,0 +1,5 @@ +CREATE TABLE [USysRibbons] ( + [lngID] AUTOINCREMENT CONSTRAINT [lngID] PRIMARY KEY UNIQUE NOT NULL, + [RibbonName] VARCHAR (255), + [RibbonXml] LONGTEXT +) diff --git a/tests/AccessDatabase.accde/tbldefs/USysRibbons.xml b/tests/AccessDatabase.accde/tbldefs/USysRibbons.xml new file mode 100644 index 0000000..27ee871 --- /dev/null +++ b/tests/AccessDatabase.accde/tbldefs/USysRibbons.xml @@ -0,0 +1,103 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/AccessDatabase.accde/tbldefs/tabTest.sql b/tests/AccessDatabase.accde/tbldefs/tabTest.sql new file mode 100644 index 0000000..297c15e --- /dev/null +++ b/tests/AccessDatabase.accde/tbldefs/tabTest.sql @@ -0,0 +1,7 @@ +CREATE TABLE [tabTest] ( + [id] AUTOINCREMENT CONSTRAINT [PrimaryKey] PRIMARY KEY UNIQUE NOT NULL, + [RecDate] DATETIME, + [ProcName] VARCHAR (255), + [T] VARCHAR (255), + [N] LONG +) diff --git a/tests/AccessDatabase.accde/tbldefs/tabTest.xml b/tests/AccessDatabase.accde/tbldefs/tabTest.xml new file mode 100644 index 0000000..abd595a --- /dev/null +++ b/tests/AccessDatabase.accde/tbldefs/tabTest.xml @@ -0,0 +1,135 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/AccessDatabase.accde/vbe-project.json b/tests/AccessDatabase.accde/vbe-project.json new file mode 100644 index 0000000..370e859 --- /dev/null +++ b/tests/AccessDatabase.accde/vbe-project.json @@ -0,0 +1,17 @@ +{ + "Info": { + "Class": "clsDbVbeProject", + "Description": "VBE Project" + }, + "Items": { + "Name": "TestApp", + "Description": "", + "FileName": "AccessDatabase.accdb", + "HelpFile": "", + "HelpContextId": 0, + "ConditionalCompilationArguments": "", + "Mode": 0, + "Protection": 0, + "Type": 100 + } +} diff --git a/tests/AccessDatabase.accde/vbe-references.json b/tests/AccessDatabase.accde/vbe-references.json new file mode 100644 index 0000000..b3ce747 --- /dev/null +++ b/tests/AccessDatabase.accde/vbe-references.json @@ -0,0 +1,16 @@ +{ + "Info": { + "Class": "clsDbVbeReference", + "Description": "VBE References" + }, + "Items": { + "stdole": { + "GUID": "{00020430-0000-0000-C000-000000000046}", + "Version": "2.0" + }, + "DAO": { + "GUID": "{4AC9E1DA-5BAD-4AC7-86E3-24F4CDCECA28}", + "Version": "12.0" + } + } +} diff --git a/tests/AccessDatabase.accde/vcs-options.json b/tests/AccessDatabase.accde/vcs-options.json new file mode 100644 index 0000000..98a104c --- /dev/null +++ b/tests/AccessDatabase.accde/vcs-options.json @@ -0,0 +1,66 @@ +{ + "Info": { + "AddinVersion": "4.1.2", + "AccessVersion": "16.0 64-bit" + }, + "Options": { + "ExportFolder": "\\tests\\AccessDatabase.accde", + "ShowDebug": false, + "UseFastSave": true, + "UseMergeBuild": false, + "UseGitIntegration": false, + "SavePrintVars": true, + "ExportPrintSettings": { + "Orientation": true, + "PaperSize": true, + "Duplex": false, + "PrintQuality": false, + "DisplayFrequency": false, + "Collate": false, + "Resolution": false, + "DisplayFlags": false, + "Color": false, + "Copies": false, + "ICMMethod": false, + "DefaultSource": false, + "Scale": false, + "ICMIntent": false, + "FormName": false, + "PaperLength": false, + "DitherType": false, + "MediaType": false, + "PaperWidth": false, + "TTOption": false + }, + "SaveQuerySQL": true, + "FormatSQL": true, + "ForceImportOriginalQuerySQL": false, + "SaveTableSQL": true, + "SplitLayoutFromVBA": true, + "StripPublishOption": true, + "SanitizeColors": 1, + "SanitizeLevel": 2, + "ExtractThemeFiles": false, + "TablesToExportData": { + "USysRegInfo": { + "Format": "Tab Delimited" + }, + "USysRibbons": { + "Format": "XML Format" + } + }, + "SchemaExports": { + }, + "RunBeforeExport": "", + "RunAfterExport": "", + "RunBeforeBuild": "", + "RunAfterBuild": "", + "RunBeforeMerge": "", + "RunAfterMerge": "", + "ShowVCSLegacy": true, + "HashAlgorithm": "SHA256", + "UseShortHash": true, + "BreakOnError": false, + "PreserveRubberDuckID": false + } +} diff --git a/tests/Application-Config.json b/tests/Application-Config.json new file mode 100644 index 0000000..d890441 --- /dev/null +++ b/tests/Application-Config.json @@ -0,0 +1,32 @@ +{ + "RemoveModules": ["Tests_*"], + "RemoveReferences": ["Rubberduck"], + "Procedures": [ + { + "Name": "ChangeEnvironment", + "Parameters": [3] + } + ], + "DatabaseProperties": [ + { + "Name": "AllowBypassKey", + "Type": 1, + "Value": false + }, + { + "Name": "AllowSpecialKeys", + "Type": 1, + "Value": false + }, + { + "Name": "StartUpShowDBWindow", + "Type": 1, + "Value": false + }, + { + "Name": "StartUpForm", + "Type": 10, + "Value": "frmMainMenu" + } + ] +}