├── Cairo ├── CairoQuote.ctl ├── JpegWriter.cls ├── t_JpegWriter.cls ├── wgtContainer.ctl ├── wgtTextCursor.cls └── wgtTextField.cls ├── Controls ├── FrameScroller.cls ├── RichTextBoxWrapper.cls ├── RtbSubclass.bas ├── VSplitterWnd.cls └── deprecated │ └── TextEditorController.cls ├── Data Structures ├── CollectionWrapper.cls ├── ITreeNode.cls ├── TreeBranch.cls ├── TreeLeaf.cls ├── TreeSampler.cls ├── tCollection_Wrapper.cls └── t_CollectionWrapper.cls ├── Dates └── GmtDateTime.bas ├── Excel ├── Excel12Helper.cls ├── Excel12HelperTests.cls └── ExcelCache.cls ├── FileSystem ├── FileSystemHelper.bas ├── ShellTester.frm └── t_FileSystem.cls ├── Fonts └── Fonts.bas ├── Html ├── HtmlWrapper1.cls └── t_HtmlWrapper1.cls ├── Kindle └── KindleGenWrapper.cls ├── Language ├── Pluralizer.bas ├── QuotePresenter.cls └── t_Pluralizer.cls ├── Markdown ├── MarkdownExe.cls ├── README.txt ├── multimarkdown.exe └── t_MarkdownExe.cls ├── NativeMethodReplacements.bas ├── Obfuscation └── Randomizer.bas ├── README.md ├── Shell └── CmdOutput.bas ├── SimplyVbUnit ├── FileSystemConstraints.bas ├── FileSystemConstraints.cls ├── XmlConstraints.bas └── XmlConstraints.cls ├── Strings ├── CString.cls ├── StringBuilder.cls ├── StringWrapper.cls ├── t_StringWrapper.cls └── t_Strings.cls ├── Timers ├── SelfTimer.cls ├── SelfTimerDemo.vbp ├── SelfTimerDemo.vbw ├── TickCounter.cls └── frmDemo.frm ├── VLC ├── README.txt ├── axvlc.dll ├── libvlc.dll ├── libvlccore.dll ├── npvlc.dll └── test.html ├── Web API ├── IWebApiClient.cls ├── MsXml2HttpClient.cls ├── TfiWebApiAuth1.cls └── vbRcHttpClient.cls ├── Wiki ├── WikiParser1.cls └── t_WikiParser1.cls ├── XML ├── XmlWriter.cls ├── cElementWrapper.cls ├── cElementWrappers.cls ├── t_XmlWriter.cls └── t_cElementWrapper.cls ├── t_Replacements.cls └── vbRichClient ├── 4.0.0.6 ├── DirectCOM.dll ├── _Library-Licenses.txt ├── _Version-History.txt ├── vbRichClient4.dll └── vb_cairo_sqlite.dll ├── 5.0.0.6 ├── DirectCOM.dll ├── _Library-Licenses.txt ├── _Version-History.txt ├── vbRichClient5.dll └── vb_cairo_sqlite.dll ├── 5.0.0.9 ├── DirectCOM.dll ├── RC4Factory.bas ├── _Library-Licenses.txt ├── _Version-History.txt ├── vbRichClient5.dll └── vb_cairo_sqlite.dll ├── DirectCOM.dll ├── Tests └── t_vbRichClient.cls ├── _Library-Licenses.txt ├── _Version-History.txt ├── vbRichClient5.dll └── vb_cairo_sqlite.dll /Cairo/CairoQuote.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl CairoQuote 3 | Alignable = -1 'True 4 | ClientHeight = 3600 5 | ClientLeft = 0 6 | ClientTop = 0 7 | ClientWidth = 4800 8 | ScaleHeight = 3600 9 | ScaleWidth = 4800 10 | End 11 | Attribute VB_Name = "CairoQuote" 12 | Attribute VB_GlobalNameSpace = False 13 | Attribute VB_Creatable = True 14 | Attribute VB_PredeclaredId = False 15 | Attribute VB_Exposed = False 16 | 'Option Explicit 17 | ' 18 | 'Private Enum CairoQuoteErrors ' you may make this Public for tests 19 | ' ErrorBase = vbObjectError + 513 ' you may adjust this minimum 20 | ' NotInitted 21 | ' AlreadyInitted 22 | ' ' add error numbers here 23 | 'End Enum 24 | ' 25 | 'Private Type ErrorHolder ' 26 | ' HasError As Boolean ' temp storage for errors 27 | ' Source As String ' 28 | ' Number As CairoQuoteErrors ' 29 | ' Description As String 30 | 'End Type 31 | 'Private mError As ErrorHolder 32 | ' 33 | ' 34 | ' 35 | ' 36 | 'Public Sub DrawQuote() 37 | ' Debug.Print "DrawQuote" 38 | 'End Sub 39 | ' 40 | ' 41 | ' 42 | ' 43 | ' 44 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 45 | '' 46 | '' Constructor 47 | '' 48 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 49 | ' 50 | 'Public Sub Init() 51 | ' 52 | 'End Sub 53 | ' 54 | ' 55 | ' 56 | ' 57 | ' 58 | ' 59 | ' 60 | ' 61 | ' 62 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 63 | '' 64 | '' Class Events 65 | '' 66 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 67 | ' 68 | 'Private Sub UserControl_Initialize() 69 | ' On Error GoTo Cleanup 70 | ' 71 | ' 'Set mSomeObject = New Something 72 | ' 73 | 'Cleanup: SaveError 74 | ' 'Set someObj = Nothing 75 | ' 'Erase someArray 76 | ' LoadError "UserControl_Initialize" 77 | 'End Sub 78 | ' 79 | 'Private Sub UserControl_Terminate() 80 | ' On Error GoTo Cleanup 81 | ' 82 | ' 'Set mSomeObject = Nothing 83 | ' 84 | 'Cleanup: SaveError 85 | ' 'Set someObj = Nothing 86 | ' 'Erase someArray 87 | ' LoadError "UserControl_Terminate" 88 | 'End Sub 89 | ' 90 | ' 91 | ' 92 | ' 93 | ' 94 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 95 | '' 96 | '' Error Handlers 97 | '' 98 | '' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 99 | ' 100 | 'Private Sub ErrorIf(errCondition As Boolean _ 101 | ' , errorMsg As String _ 102 | ' , Optional errorNumbr As CairoQuoteErrors = -1 _ 103 | ' ) 104 | ' If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 105 | 'End Sub 106 | ' 107 | 'Private Sub SaveError() 108 | ' With mError 109 | ' If Err Then 110 | ' .HasError = True 111 | ' .Description = Err.Description 112 | ' .Number = Err.Number 113 | ' .Source = Err.Source 114 | ' 115 | ' Else 116 | ' .HasError = False 117 | ' .Description = vbNullString 118 | ' .Number = 0 119 | ' .Source = vbNullString 120 | ' End If 121 | ' End With 122 | ' Err.Clear 123 | 'End Sub 124 | ' 125 | 'Private Sub Blame(ByVal currntProcedure As String _ 126 | ' , Optional ByVal errorDescrption As String _ 127 | ' , Optional ByVal errorNumbr As CairoQuoteErrors = -1 _ 128 | ' ) 129 | ' Call SaveError 130 | ' Call LoadError(currntProcedure, errorDescrption, errorNumbr) 131 | 'End Sub 132 | ' 133 | 'Private Sub LoadError(ByVal currntProcedure As String _ 134 | ' , Optional ByVal errorDescrption As String _ 135 | ' , Optional ByVal errorNumbr As CairoQuoteErrors = -1 _ 136 | ' ) 137 | ' With mError 138 | ' If Not .HasError Then Exit Sub 139 | ' 140 | ' If LenB(errorDescrption) = 0 Then 141 | ' errorDescrption = .Description 142 | ' Else 143 | ' errorDescrption = .Description & vbCrLf & errorDescrption 144 | ' End If 145 | ' 146 | ' currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 147 | ' 148 | ' If errorNumbr = -1 Then errorNumbr = .Number 149 | ' 150 | ' Select Case errorNumbr 151 | ' Case NotInitted 152 | ' errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 153 | ' & "Please call " & TypeName(Me) _ 154 | ' & ".Init() before " & currntProcedure & "." 155 | ' 156 | ' Case Else 157 | ' errorDescrption = currntProcedure & vbCrLf & errorDescrption 158 | ' End Select 159 | ' 160 | ' Err.Raise errorNumbr, .Source, errorDescrption 161 | ' 162 | ' End With 163 | 'End Sub 164 | -------------------------------------------------------------------------------- /Cairo/JpegWriter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "JpegWriter" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum JpegWriterErrors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ExpressionTooComplex = 16 21 | ' add error numbers here 22 | End Enum 23 | 24 | Private Type ErrorHolder ' 25 | HasError As Boolean ' temp storage for errors 26 | Source As String ' 27 | Number As JpegWriterErrors ' 28 | Description As String 29 | End Type 30 | Private mError As ErrorHolder 31 | 32 | 33 | 34 | Public Sub TemporaryCover(bookTtle As String _ 35 | , authrName As String _ 36 | , outputJpgPath As String _ 37 | , Optional subTtle$ = "(subtitle goes here)" _ 38 | , Optional jpgWidth As Long = 600 _ 39 | , Optional jpgHeight As Long = 800 _ 40 | ) 41 | Dim srf As cCairoSurface, c As cCairoContext _ 42 | , boxW#, boxH#, innrX#, innrY#, innrW#, innrH#, nextY#, div2# 43 | On Error GoTo Cleanup 44 | 45 | With New_RC4.Cairo 46 | Set srf = .CreateSurface(jpgWidth, jpgHeight) 47 | End With 48 | Set c = srf.CreateContext 49 | With c 50 | 51 | 52 | ' draw border 53 | ' 54 | .SetSourceColor vbWhite ' bg color 55 | .Paint 56 | 57 | Const boxX# = 60 58 | Const boxY# = 60 59 | boxW = jpgWidth - boxX * 2 60 | boxH = jpgHeight - boxY * 2 61 | .Rectangle boxX, boxY, boxW, boxH 62 | .SetSourceColor vbBlack 63 | .Stroke 64 | 65 | innrX = boxX + 40 66 | innrY = boxY + 70 67 | innrW = jpgWidth - innrX * 2 68 | innrH = jpgHeight - innrY * 2 69 | '.Rectangle innrX, innrY, innrW, innrH: .Stroke ' uncomment this to show inner rectangle 70 | 71 | 72 | ' draw title text 73 | ' 74 | .SelectFont "Times New Roman", 40 75 | nextY = DrawText(bookTtle, c, innrX, innrY, innrW) 76 | 77 | 78 | ' draw subtitle text 79 | ' 80 | .SelectFont "Times New Roman", 20 81 | nextY = DrawText(subTtle, c, innrX, nextY + 50, innrW) 82 | 83 | 84 | ' divide remaining space among them 85 | ' 86 | div2 = (innrH - nextY) / 2 87 | 88 | 89 | ' draw "temporary" text 90 | ' 91 | .SelectFont "verdana", 14, vbRed 92 | DrawText "(temporary book cover)", c, innrX, nextY + div2, innrW 93 | 94 | 95 | ' draw author text 96 | ' 97 | .SelectFont "Times New Roman", 20 98 | DrawText "by: " & authrName, c, innrX, nextY + div2 * 2, innrW 99 | 100 | End With 101 | 102 | Call srf.WriteContentToJpgFile(outputJpgPath) 103 | 104 | Cleanup: SaveError 105 | Set c = Nothing 106 | Set srf = Nothing 107 | 'Erase someArray 108 | LoadError "TemporaryCover" ', "details of error" 109 | End Sub 110 | 111 | 112 | 113 | Private Function DrawText(strText As String _ 114 | , cairoContxt As cCairoContext _ 115 | , xPosition As Double _ 116 | , yPosition As Double _ 117 | , maxmumWidth As Double _ 118 | , Optional textAlignmnt As AlignmentConstants = vbCenter _ 119 | ) As Double 120 | Dim numRows&, extntH#, redrawAttmpts& 121 | On Error GoTo Cleanup 122 | With cairoContxt 123 | 124 | 125 | ' calculate height of text-extent 126 | ' 127 | numRows = .DrawText(0, 0, maxmumWidth, 0, strText, , textAlignmnt) 128 | extntH = numRows * .GetFontHeight() 129 | 130 | 131 | ' render actual text 132 | ' 133 | RedrawText: 134 | .DrawText xPosition, yPosition, maxmumWidth, extntH, strText, , textAlignmnt 135 | 136 | 137 | ' return next clear yPosition 138 | ' 139 | DrawText = yPosition + extntH 140 | 141 | End With 142 | Cleanup: If Err = ExpressionTooComplex And _ 143 | redrawAttmpts < 1 Then 144 | redrawAttmpts = redrawAttmpts + 1 145 | Err.Clear 146 | GoTo RedrawText 147 | End If 148 | SaveError 149 | 'Set someObj = Nothing 150 | 'Erase someArray 151 | LoadError "DrawText" ', "details of error" 152 | End Function 153 | 154 | 155 | 156 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 157 | ' 158 | ' Constructor 159 | ' 160 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 161 | 162 | Public Sub Init() 163 | 164 | End Sub 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 175 | ' 176 | ' Class Events 177 | ' 178 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 179 | 180 | Private Sub Class_Initialize() 181 | On Error GoTo Cleanup 182 | 183 | 'Set mSomeObject = New Something 184 | 185 | Cleanup: SaveError 186 | 'Set someObj = Nothing 187 | 'Erase someArray 188 | LoadError "Class_Initialize" 189 | End Sub 190 | 191 | Private Sub Class_Terminate() 192 | On Error GoTo Cleanup 193 | 194 | 'Set mSomeObject = Nothing 195 | 196 | Cleanup: SaveError 197 | 'Set someObj = Nothing 198 | 'Erase someArray 199 | LoadError "Class_Terminate" 200 | End Sub 201 | 202 | 203 | 204 | 205 | 206 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 207 | ' 208 | ' Error Handlers 209 | ' 210 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 211 | 212 | Private Sub ErrorIf(errCondition As Boolean _ 213 | , errorMsg As String _ 214 | , Optional errorNumbr As JpegWriterErrors = -1 _ 215 | ) 216 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 217 | End Sub 218 | 219 | Private Sub SaveError() 220 | With mError 221 | If Err Then 222 | .HasError = True 223 | .Description = Err.Description 224 | .Number = Err.Number 225 | .Source = Err.Source 226 | 227 | Else 228 | .HasError = False 229 | .Description = vbNullString 230 | .Number = 0 231 | .Source = vbNullString 232 | End If 233 | End With 234 | Err.Clear 235 | End Sub 236 | 237 | Private Sub LoadError(ByVal currntProcedure As String _ 238 | , Optional ByVal errorDescrption As String _ 239 | , Optional ByVal errorNumbr As JpegWriterErrors = -1 _ 240 | ) 241 | With mError 242 | If Not .HasError Then Exit Sub 243 | 244 | If LenB(errorDescrption) = 0 Then 245 | errorDescrption = .Description 246 | Else 247 | errorDescrption = .Description & vbCrLf & errorDescrption 248 | End If 249 | 250 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 251 | 252 | If errorNumbr = -1 Then errorNumbr = .Number 253 | 254 | Select Case errorNumbr 255 | Case NotInitted 256 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 257 | & "Please call " & TypeName(Me) _ 258 | & ".Init() before " & currntProcedure & "." 259 | 260 | Case Else 261 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 262 | End Select 263 | 264 | Err.Raise errorNumbr, .Source, errorDescrption 265 | 266 | End With 267 | End Sub 268 | 269 | -------------------------------------------------------------------------------- /Cairo/t_JpegWriter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_JpegWriter" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private SUT As JpegWriter 17 | Private mMethodsRan&, mMethodCount& 18 | 19 | 20 | 21 | Public Sub TemporaryCover_CreatesJpeg() 22 | 23 | Dim jpgF$: jpgF = F_.TempFile(, , ".jpg") 24 | 25 | 26 | ' Execute method under test. 27 | Call SUT.TemporaryCover(Rand.mPhrase(4, 6) _ 28 | , Rand.mPhrase(4, 6) _ 29 | , jpgF _ 30 | , Rand.mPhrase(4)) 31 | 32 | ' Verify result. 33 | Assert.That jpgF, Path.Exists 34 | 35 | 36 | 'RunCommand "start " & jpgF 37 | 38 | ' Cleanup test context. 39 | F_.Delete jpgF 40 | End Sub 41 | 42 | 43 | 44 | 45 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 46 | ' 47 | ' Test Utility Methods 48 | ' 49 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 50 | 51 | Private Sub DoSomething() 52 | 53 | End Sub 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 62 | ' 63 | ' Fixture Framework Methods 64 | ' 65 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 66 | 67 | Public Sub FixtureSetup() 68 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 69 | 70 | End Sub 71 | 72 | 73 | Public Sub Setup() 74 | Set SUT = New JpegWriter 75 | Call SUT.Init 76 | End Sub 77 | 78 | 79 | Public Sub Teardown() 80 | Set SUT = Nothing 81 | 82 | mMethodsRan = mMethodsRan + 1 83 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 84 | End Sub 85 | 86 | 87 | Public Sub FixtureTeardown() 88 | If mMethodsRan < mMethodCount Then Exit Sub 89 | 90 | 'TestBed.QuitExcel 91 | End Sub 92 | -------------------------------------------------------------------------------- /Cairo/wgtContainer.ctl: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.UserControl wgtContainer 3 | ClientHeight = 3600 4 | ClientLeft = 0 5 | ClientTop = 0 6 | ClientWidth = 4800 7 | ControlContainer= -1 'True 8 | DefaultCancel = -1 'True 9 | BeginProperty Font 10 | Name = "Verdana" 11 | Size = 8.25 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | ScaleHeight = 3600 19 | ScaleWidth = 4800 20 | End 21 | Attribute VB_Name = "wgtContainer" 22 | Attribute VB_GlobalNameSpace = False 23 | Attribute VB_Creatable = True 24 | Attribute VB_PredeclaredId = False 25 | Attribute VB_Exposed = False 26 | Option Explicit 27 | Const MODULE_NAME$ = "wgtContainer" 28 | 29 | Private Enum wgtContainerErrors ' you may make this Public for tests 30 | ErrorBase = 3000 ' you may adjust this minimum 31 | ' add more errors here 32 | End Enum 33 | 34 | Private Type ErrorHolder ' 35 | HasError As Boolean ' temp storage for errors 36 | Source As String ' 37 | Number As wgtContainerErrors ' 38 | Description As String 39 | End Type 40 | Private mError As ErrorHolder 41 | 42 | 43 | 44 | 45 | Public Property Get WidgetRoot() As cWidgetRoot 46 | Static mWidgetRoot As cWidgetRoot 47 | On Error GoTo Cleanup 48 | 49 | If mWidgetRoot Is Nothing Then 50 | 'Set mWidgetRoot = New cWidgetRoot 51 | Set mWidgetRoot = Cairo.WidgetRoot 52 | 53 | mWidgetRoot.RenderContentIn Me 54 | End If 55 | 56 | Set WidgetRoot = mWidgetRoot 57 | 58 | Cleanup: SaveError 59 | 'Set someObj = Nothing 60 | 'Erase someArray 61 | LoadError "[Get]WidgetRoot" ', "details of error" 62 | End Property 63 | 64 | Public Property Get Widgets() As cWidgets 65 | Set Widgets = WidgetRoot.Widgets 66 | End Property 67 | 68 | 69 | 70 | 71 | 72 | 73 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 74 | ' 75 | ' Control Events 76 | ' 77 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 78 | 79 | Private Sub UserControl_Initialize() 80 | On Error GoTo Cleanup 81 | 82 | ' initialize vbRichClient4 83 | ' - needed for using Cairo 84 | ' 85 | Call RC4Factory.Init(App.Path) 86 | 87 | Cleanup: SaveError 88 | 'Set someObj = Nothing 89 | 'Erase someArray 90 | LoadError "UserControl_Initialize" ', "details of error" 91 | End Sub 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 101 | ' 102 | ' Error Handlers 103 | ' 104 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 105 | 106 | Private Sub ErrorIf(errCondition As Boolean _ 107 | , errorMsg As String _ 108 | , Optional errorNumbr As wgtContainerErrors = -1 _ 109 | ) 110 | If errCondition Then Err.Raise errorNumbr, MODULE_NAME, errorMsg 111 | End Sub 112 | 113 | Private Sub SaveError() 114 | With mError 115 | If Err Then 116 | .HasError = True 117 | .Description = Err.Description 118 | .Number = Err.Number 119 | .Source = Err.Source 120 | 121 | Else 122 | .HasError = False 123 | .Description = vbNullString 124 | .Number = 0 125 | .Source = vbNullString 126 | End If 127 | End With 128 | Err.Clear 129 | End Sub 130 | 131 | Private Sub LoadError(ByVal currntProcedure As String _ 132 | , Optional ByVal errorDescrption As String _ 133 | , Optional ByVal errorNumbr As wgtContainerErrors = -1 _ 134 | ) 135 | With mError 136 | If Not .HasError Then Exit Sub 137 | 138 | If LenB(errorDescrption) = 0 Then 139 | errorDescrption = .Description 140 | Else 141 | errorDescrption = .Description & vbCrLf & errorDescrption 142 | End If 143 | 144 | currntProcedure = MODULE_NAME & "." & currntProcedure & "()" 145 | 146 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 147 | 148 | If errorNumbr = -1 Then errorNumbr = .Number 149 | 150 | Err.Raise errorNumbr, .Source, errorDescrption 151 | 152 | End With 153 | End Sub 154 | -------------------------------------------------------------------------------- /Cairo/wgtTextCursor.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "wgtTextCursor" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Const MODULE_NAME$ = "wgtTextCursor" 16 | 17 | Private Enum wgtTextCursorErrors ' you may make this Public for tests 18 | ErrorBase = 3000 ' you may adjust this minimum 19 | ' add error numbers here 20 | End Enum 21 | 22 | Private Type ErrorHolder ' 23 | HasError As Boolean ' temp storage for errors 24 | Source As String ' 25 | Number As wgtTextCursorErrors ' 26 | Description As String 27 | End Type 28 | Private mError As ErrorHolder 29 | 30 | Private WithEvents mBase As cWidgetBase 31 | Attribute mBase.VB_VarHelpID = -1 32 | 33 | Private mSymbol As String 34 | 35 | 36 | 37 | 38 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 39 | ' 40 | ' Drawing Methods 41 | ' 42 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 43 | 44 | Private Sub mBase_Paint(CC As vbRichClient4.cCairoContext _ 45 | , ByVal xAbs As Single _ 46 | , ByVal yAbs As Single _ 47 | , ByVal dx_Aligned As Single _ 48 | , ByVal dy_Aligned As Single _ 49 | , UserObj As Object _ 50 | ) 51 | On Error GoTo Cleanup 52 | 53 | With mBase 54 | 55 | ' inherit parent's font properties 56 | ' 57 | With .Parent 58 | CC.SelectFont .FontName, .FontSize, .ForeColor _ 59 | , .FontBold, .FontItalic 60 | End With 61 | 62 | CC.DrawText 0, 0, .ScaleWidth, .ScaleHeight _ 63 | , mSymbol, False, vbCenter, 0, 1 64 | End With 65 | 66 | Cleanup: SaveError 67 | 'Set someObj = Nothing 68 | 'Erase someArray 69 | LoadError "mBase_Paint" ', "details of error" 70 | End Sub 71 | 72 | 73 | 74 | Public Property Get Symbol() As String 75 | Symbol = mSymbol 76 | End Property 77 | 78 | Public Property Let Symbol(newSymbolChar As String) 79 | If mSymbol = newSymbolChar Then Exit Property 80 | mSymbol = newSymbolChar 81 | Call mBase.Refresh 82 | End Property 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 92 | ' 93 | ' Widget Accessors 94 | ' 95 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 96 | 97 | Public Property Get Widget() As cWidgetBase 98 | Set Widget = mBase 99 | End Property 100 | 101 | Public Property Get Widgets() As cWidgets 102 | Set Widgets = mBase.Widgets 103 | End Property 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 112 | ' 113 | ' Class Events 114 | ' 115 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 116 | 117 | Private Sub Class_Initialize() 118 | On Error GoTo Cleanup 119 | 120 | mSymbol = "|" 121 | 122 | Set mBase = Cairo.WidgetBase 123 | With mBase 124 | .CanGetFocus = False 125 | 126 | End With 127 | 128 | Cleanup: SaveError 129 | 'Set someObj = Nothing 130 | 'Erase someArray 131 | LoadError "Class_Initialize" 132 | End Sub 133 | 134 | Private Sub Class_Terminate() 135 | On Error GoTo Cleanup 136 | 137 | Set mBase = Nothing 138 | mSymbol = vbNullString 139 | 140 | Cleanup: SaveError 141 | 'Set someObj = Nothing 142 | 'Erase someArray 143 | LoadError "Class_Terminate" 144 | End Sub 145 | 146 | 147 | 148 | 149 | 150 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 151 | ' 152 | ' Error Handlers 153 | ' 154 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 155 | 156 | Private Sub ErrorIf(errCondition As Boolean _ 157 | , errorMsg As String _ 158 | , Optional errorNumbr As wgtTextCursorErrors = -1 _ 159 | ) 160 | If errCondition Then Err.Raise errorNumbr, MODULE_NAME, errorMsg 161 | End Sub 162 | 163 | Private Sub SaveError() 164 | With mError 165 | If Err Then 166 | .HasError = True 167 | .Description = Err.Description 168 | .Number = Err.Number 169 | .Source = Err.Source 170 | 171 | Else 172 | .HasError = False 173 | .Description = vbNullString 174 | .Number = 0 175 | .Source = vbNullString 176 | End If 177 | End With 178 | Err.Clear 179 | End Sub 180 | 181 | Private Sub LoadError(ByVal currntProcedure As String _ 182 | , Optional ByVal errorDescrption As String _ 183 | , Optional ByVal errorNumbr As wgtTextCursorErrors = -1 _ 184 | ) 185 | With mError 186 | If Not .HasError Then Exit Sub 187 | 188 | If LenB(errorDescrption) = 0 Then 189 | errorDescrption = .Description 190 | Else 191 | errorDescrption = .Description & vbCrLf & errorDescrption 192 | End If 193 | 194 | currntProcedure = MODULE_NAME & "." & currntProcedure & "()" 195 | 196 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 197 | 198 | If errorNumbr = -1 Then errorNumbr = .Number 199 | 200 | Err.Raise errorNumbr, .Source, errorDescrption 201 | 202 | End With 203 | End Sub 204 | -------------------------------------------------------------------------------- /Controls/FrameScroller.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "FrameScroller" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum FrameScrollerErrors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As FrameScrollerErrors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | Private mResizedHere As Boolean _ 32 | , mOldBoundaryWidth& 33 | 34 | Private WithEvents mTarget As VB.PictureBox _ 35 | , WithEvents mBoundary As VB.PictureBox _ 36 | , WithEvents mScrollBar As VB.VScrollBar 37 | Attribute mTarget.VB_VarHelpID = -1 38 | Attribute mBoundary.VB_VarHelpID = -1 39 | Attribute mScrollBar.VB_VarHelpID = -1 40 | 41 | Event ScrollBarToggled() 42 | 43 | 44 | Public Sub Refresh() 45 | Dim prevVisbl As Boolean 46 | On Error GoTo ErrH 47 | 48 | If Not mTarget.Visible Then Exit Sub 49 | 50 | If mResizedHere Then Exit Sub ' ignore if resize came from within 51 | mResizedHere = True ' 52 | 53 | With mScrollBar 54 | prevVisbl = .Visible 55 | .Visible = mTarget.Height > mBoundary.Height 56 | 57 | If .Visible Then 58 | 59 | If mOldBoundaryWidth <> mBoundary.Width Then ' so we don't shrink 60 | mBoundary.Width = mBoundary.Width - .Width ' if only target resized 61 | mOldBoundaryWidth = mBoundary.Width 62 | End If 63 | 64 | .Max = mTarget.ScaleHeight - mBoundary.ScaleHeight 65 | .LargeChange = mBoundary.ScaleHeight 66 | .SmallChange = mBoundary.ScaleHeight 67 | 68 | .Left = mBoundary.Left + mBoundary.Width 69 | .Top = mBoundary.Top 70 | .Height = mBoundary.Height 71 | End If 72 | 73 | If .Visible <> prevVisbl _ 74 | Then RaiseEvent ScrollBarToggled 75 | 76 | End With 77 | 78 | mResizedHere = False 79 | 80 | ErrH: Blame "Refresh" 81 | End Sub 82 | 83 | 84 | Private Sub mTarget_Resize() 85 | On Error GoTo ErrH 86 | 87 | Call Me.Refresh 88 | 89 | ErrH: Blame "mTarget_Resize" 90 | End Sub 91 | 92 | 93 | Private Sub mBoundary_Resize() 94 | On Error GoTo ErrH 95 | 96 | Call Me.Refresh 97 | 98 | ErrH: Blame "mBoundary_Resize" 99 | End Sub 100 | 101 | Private Sub mScrollBar_Change() 102 | Call ScrollVertical(mScrollBar.Value) 103 | End Sub 104 | 105 | Private Sub mScrollBar_Scroll() 106 | Call ScrollVertical(mScrollBar.Value) 107 | End Sub 108 | 109 | Private Sub mScrollBar_GotFocus() 110 | mBoundary.SetFocus 111 | End Sub 112 | 113 | Private Sub ScrollVertical(scrolBarValue As Long) 114 | On Error GoTo ErrH 115 | 116 | mTarget.Top = -scrolBarValue - 10 117 | 118 | ErrH: Blame "ScrollVertical" 119 | End Sub 120 | 121 | 122 | 123 | 124 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 125 | ' 126 | ' Constructor 127 | ' 128 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 129 | 130 | Public Sub Init(picBoxToBeScrolled As VB.PictureBox _ 131 | , boundingPicBox As VB.PictureBox _ 132 | , vertcalScrollBar As VB.VScrollBar _ 133 | ) 134 | On Error GoTo ErrH 135 | 136 | Set mTarget = picBoxToBeScrolled 137 | Set mBoundary = boundingPicBox 138 | Set mScrollBar = vertcalScrollBar 139 | 140 | mTarget.Top = -23 141 | 142 | Call mBoundary_Resize 143 | 144 | ErrH: Blame "Init" 145 | End Sub 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 156 | ' 157 | ' Class Events 158 | ' 159 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 160 | 161 | Private Sub Class_Initialize() 162 | On Error GoTo ErrH 163 | 164 | 'Set mSomeObject = New Something 165 | 166 | ErrH: Blame "Class_Initialize" 167 | End Sub 168 | 169 | Private Sub Class_Terminate() 170 | On Error GoTo ErrH 171 | 172 | Set mTarget = Nothing 173 | Set mBoundary = Nothing 174 | Set mScrollBar = Nothing 175 | 176 | ErrH: Blame "Class_Terminate" 177 | End Sub 178 | 179 | 180 | 181 | 182 | 183 | 184 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 185 | ' 186 | ' Error Handlers 187 | ' 188 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 189 | 190 | Private Sub ErrorIf(errCondition As Boolean _ 191 | , errorMsg As String _ 192 | , Optional errorNumbr As FrameScrollerErrors = -1 _ 193 | ) 194 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 195 | End Sub 196 | 197 | Private Sub SaveError() 198 | With mError 199 | If Err Then 200 | .HasError = True 201 | .Description = Err.Description 202 | .Number = Err.Number 203 | .Source = Err.Source 204 | 205 | Else 206 | .HasError = False 207 | .Description = vbNullString 208 | .Number = 0 209 | .Source = vbNullString 210 | End If 211 | End With 212 | Err.Clear 213 | End Sub 214 | 215 | Private Sub Blame(ByVal currntProcedure As String _ 216 | , Optional ByVal errorDescrption As String _ 217 | , Optional ByVal errorNumbr As FrameScrollerErrors = -1 _ 218 | ) 219 | Call SaveError 220 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 221 | End Sub 222 | 223 | Private Sub LoadError(ByVal currntProcedure As String _ 224 | , Optional ByVal errorDescrption As String _ 225 | , Optional ByVal errorNumbr As FrameScrollerErrors = -1 _ 226 | ) 227 | With mError 228 | If Not .HasError Then Exit Sub 229 | 230 | If LenB(errorDescrption) = 0 Then 231 | errorDescrption = .Description 232 | Else 233 | errorDescrption = .Description & vbCrLf & errorDescrption 234 | End If 235 | 236 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 237 | 238 | If errorNumbr = -1 Then errorNumbr = .Number 239 | 240 | Select Case errorNumbr 241 | Case NotInitted 242 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 243 | & "Please call " & TypeName(Me) _ 244 | & ".Init() before " & currntProcedure & "." 245 | 246 | Case Else 247 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 248 | End Select 249 | 250 | Err.Raise errorNumbr, .Source, errorDescrption 251 | 252 | End With 253 | End Sub 254 | -------------------------------------------------------------------------------- /Controls/RtbSubclass.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "RtbSubclass" 2 | Option Explicit 3 | 4 | 'http://www.xtremevbtalk.com/showthread.php?t=78306 5 | 6 | Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" _ 7 | (ByVal lpPrevWndFunc As Long, _ 8 | ByVal hwnd As Long, _ 9 | ByVal msg As Long, _ 10 | ByVal wParam As Long, _ 11 | ByVal lParam As Long) As Long 12 | Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _ 13 | (ByVal hwnd As Long, _ 14 | ByVal nIndex As Long, _ 15 | ByVal dwNewLong As Long) As Long 16 | 17 | ' A pointer to the old window procedure 18 | Public pOldWindPoc As Long 19 | 20 | Public Const GWL_WNDPROC& = (-4) 21 | 22 | ' Our new window procedure 23 | Public Function WndProc(ByVal hwnd As Long, _ 24 | ByVal uMsg As Long, _ 25 | ByVal wParam As Long, _ 26 | ByVal lParam As Long) As Long 27 | Dim handled As Long 28 | handled = False 29 | 30 | Const WM_KEYDOWN = &H100 31 | 32 | Select Case uMsg 33 | Case WM_KEYDOWN 34 | Select Case wParam 35 | Case vbKeyV 36 | 'just ignore this message 37 | handled = True 38 | End Select 39 | End Select 40 | 41 | If Not handled Then 42 | WndProc = CallWindowProc(pOldWindPoc, hwnd, uMsg, wParam, lParam) 43 | End If 44 | End Function 45 | 46 | -------------------------------------------------------------------------------- /Data Structures/CollectionWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "CollectionWrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum CollectionWrapperErrors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As CollectionWrapperErrors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | Private mCollection As VBA.Collection 32 | 33 | Private mTypeName$ 34 | 35 | 36 | 37 | Public Function Add(objToAdd As Variant) As Variant 38 | On Error GoTo ErrH 39 | 40 | If mTypeName = vbNullString _ 41 | Then mTypeName = TypeName(objToAdd) 42 | 43 | Call mCollection.Add(objToAdd) 44 | 45 | If IsObject(objToAdd) Then 46 | Set Add = objToAdd 47 | Else 48 | Add = objToAdd 49 | End If 50 | 51 | ErrH: Blame "Add" 52 | End Function 53 | 54 | 55 | Public Sub Clear() 56 | On Error GoTo ErrH 57 | With mCollection 58 | 59 | Dim i&: For i = 1 To .Count 60 | Call .Remove(1) 61 | Next i 62 | 63 | End With 64 | ErrH: Blame "Clear" 65 | End Sub 66 | 67 | 68 | Public Property Get Count() As Long 69 | Count = mCollection.Count 70 | End Property 71 | 72 | 73 | Public Property Get Item(zeroBasedIndx As Long) As Object 74 | On Error GoTo ErrH 75 | 76 | ErrorIf Me.Count = 0, "Collection has no items." 77 | 78 | ErrorIf zeroBasedIndx >= Me.Count _ 79 | , "Attempted to retrieve item at index [" & zeroBasedIndx & "]." & vbCrLf _ 80 | & "But collection is only up to index [" & Me.Count - 1 & "]." 81 | 82 | Set Item = mCollection.Item(zeroBasedIndx + 1) 83 | 84 | ErrH: Blame "[Get]Item" 85 | End Property 86 | 87 | 88 | Public Sub Remove(zeroBasedIndx As Long) 89 | On Error GoTo ErrH 90 | 91 | Call mCollection.Remove(zeroBasedIndx + 1) 92 | 93 | ErrH: Blame "Remove" 94 | End Sub 95 | 96 | 97 | Public Function NewEnum() As IUnknown 98 | Attribute NewEnum.VB_UserMemId = -4 99 | Attribute NewEnum.VB_MemberFlags = "40" 100 | Set NewEnum = mCollection.[_NewEnum] 101 | End Function 102 | 103 | 104 | 105 | 106 | 107 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 108 | ' 109 | ' Class Events 110 | ' 111 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 112 | 113 | Private Sub Class_Initialize() 114 | On Error GoTo ErrH 115 | 116 | Set mCollection = New VBA.Collection 117 | 118 | ErrH: Blame "Class_Initialize" 119 | End Sub 120 | 121 | Private Sub Class_Terminate() 122 | On Error GoTo ErrH 123 | 124 | Call Me.Clear 125 | 126 | Set mCollection = Nothing 127 | 128 | ErrH: Blame "Class_Terminate" 129 | End Sub 130 | 131 | 132 | 133 | 134 | 135 | 136 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 137 | ' 138 | ' Error Handlers 139 | ' 140 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 141 | 142 | Private Sub ErrorIf(errCondition As Boolean _ 143 | , errorMsg As String _ 144 | , Optional errorNumbr As CollectionWrapperErrors = -1 _ 145 | ) 146 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 147 | End Sub 148 | 149 | Private Sub SaveError() 150 | With mError 151 | If Err Then 152 | .HasError = True 153 | .Description = Err.Description 154 | .Number = Err.Number 155 | .Source = Err.Source 156 | 157 | Else 158 | .HasError = False 159 | .Description = vbNullString 160 | .Number = 0 161 | .Source = vbNullString 162 | End If 163 | End With 164 | Err.Clear 165 | End Sub 166 | 167 | Private Sub Blame(ByVal currntProcedure As String _ 168 | , Optional ByVal errorDescrption As String _ 169 | , Optional ByVal errorNumbr As CollectionWrapperErrors = -1 _ 170 | ) 171 | Call SaveError 172 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 173 | End Sub 174 | 175 | Private Sub LoadError(ByVal currntProcedure As String _ 176 | , Optional ByVal errorDescrption As String _ 177 | , Optional ByVal errorNumbr As CollectionWrapperErrors = -1 _ 178 | ) 179 | With mError 180 | If Not .HasError Then Exit Sub 181 | 182 | If LenB(errorDescrption) = 0 Then 183 | errorDescrption = .Description 184 | Else 185 | errorDescrption = .Description & vbCrLf & errorDescrption 186 | End If 187 | 188 | currntProcedure = mTypeName & "s" _ 189 | & "." & currntProcedure & "()" 190 | 191 | If errorNumbr = -1 Then errorNumbr = .Number 192 | 193 | Select Case errorNumbr 194 | Case NotInitted 195 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 196 | & "Please call " & TypeName(Me) _ 197 | & ".Init() before " & currntProcedure & "." 198 | 199 | Case Else 200 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 201 | End Select 202 | 203 | Err.Raise errorNumbr, .Source, errorDescrption 204 | 205 | End With 206 | End Sub 207 | 208 | -------------------------------------------------------------------------------- /Data Structures/ITreeNode.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "ITreeNode" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Public Label As String 17 | 18 | Public Property Get Key() As String 19 | End Property 20 | 21 | Public Property Get Parent() As ITreeNode 22 | End Property 23 | 24 | 25 | 26 | 27 | 28 | 29 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 30 | ' 31 | ' Level Methods 32 | ' 33 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 34 | 35 | Public Property Let LevelOverride(RHS As Long) 36 | End Property 37 | 38 | Public Property Get Level() As Long 39 | End Property 40 | 41 | Public Property Get MaxLevel() As Long 42 | End Property 43 | 44 | 45 | 46 | Public Property Get IsLeaf() As Boolean 47 | End Property 48 | 49 | 50 | 51 | Public Property Get HasNode(nodeIndxOrLabel As Variant) As Boolean 52 | End Property 53 | 54 | Public Property Get HasValue(valueIndxOrKey As Variant) As Boolean 55 | End Property 56 | 57 | Public Property Get Count() As Long 58 | End Property 59 | 60 | 61 | 62 | Public Property Get Node(nodeIndxOrLabel As Variant _ 63 | ) As ITreeNode 64 | End Property 65 | 66 | Public Property Get FirstNode() As ITreeNode 67 | End Property 68 | 69 | Public Property Get LastNode() As ITreeNode 70 | End Property 71 | 72 | 73 | 74 | Public Function AddBranch(strNodeLabel As String _ 75 | , branchNodeObj As ITreeNode _ 76 | ) As ITreeNode 77 | End Function 78 | 79 | Public Function AddLeaf(strNodeLabel As String _ 80 | , leafNodeObj As ITreeNode _ 81 | ) As ITreeNode 82 | End Function 83 | 84 | 85 | Public Property Get Value(uniqValueKey As Variant) As Variant 86 | End Property 87 | 88 | Public Property Let Value(uniqValueKey As Variant _ 89 | , RHS As Variant) 90 | End Property 91 | 92 | 93 | 94 | 95 | 96 | 97 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 98 | ' 99 | ' Constructor / Deconstructor 100 | ' 101 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 102 | 103 | Public Sub Init(uniqNodeKey As String _ 104 | , strNodeLabel As String _ 105 | , parentNodeObj As ITreeNode _ 106 | , treeNodeLevl As Long _ 107 | ) 108 | End Sub 109 | 110 | Public Sub Cleanup() 111 | End Sub 112 | -------------------------------------------------------------------------------- /Data Structures/tCollection_Wrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "tCollection_Wrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseSource 16 | 17 | Private SUT As CollectionWrapper 18 | 19 | 20 | 21 | Private Sub ITestCaseSource_GetTestCases(ByVal Test As SimplyVBComp.TestCaseCollector) 22 | Select Case Test.MethodName 23 | 24 | Case "BasicFunctions1" 25 | Test.Use "obj1" 26 | Test.Use "obj2", "obj2" 27 | Test.Use "obj1", "obj2", "obj3" 28 | Test.Use "obj1", "obj2", "obj3", "obj4", "obj5", "obj6", "obj7", "obj8", "obj9" 29 | Test.Use "obj9", "obj8", "obj7", "obj6", "obj4", "obj5", "obj3", "obj2", "obj1" 30 | 31 | End Select 32 | End Sub 33 | 34 | 35 | 36 | Public Sub BasicFunctions1(ParamArray objNames() As Variant) 37 | Dim obj As TestSuite 38 | With SUT 39 | 40 | Assert.That .Count, Iz.EqualTo(0) _ 41 | , "Should initially have no items." 42 | 43 | 44 | Dim i&: For i = 0 To UBound(objNames) 45 | 46 | Set obj = Nothing 47 | Set obj = Sim.NewTestSuite(CStr(objNames(i))) 48 | 49 | 50 | ' Execute method under test. 51 | ' 52 | Call .Add(obj) 53 | 54 | 55 | Assert.That .Count, Iz.EqualTo(i + 1) _ 56 | , "Add() should update item Count()." 57 | 58 | Assert.That .Item(i).Name, Iz.EqualTo(objNames(i)) _ 59 | , "Add() should update item Count()." 60 | Next i 61 | 62 | Set obj = Nothing: i = 0 63 | 64 | 65 | 66 | ' Attempt enumeration. 67 | ' 68 | For Each obj In SUT 69 | Assert.That obj.Name, Iz.EqualTo(objNames(i)) _ 70 | , "Collection should be enumerable." 71 | i = i + 1 72 | Next obj 73 | 74 | 75 | 76 | ' Execute method under test. 77 | ' 78 | Call .Clear 79 | 80 | Assert.That .Count, Iz.EqualTo(0) _ 81 | , "Clear() should remove all items." 82 | 83 | End With 84 | End Sub 85 | 86 | 87 | 88 | 89 | 90 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 91 | ' 92 | ' Test Utility Methods 93 | ' 94 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 95 | 96 | Private Sub DoSomething() 97 | 98 | End Sub 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 107 | ' 108 | ' Fixture Framework Methods 109 | ' 110 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 111 | 112 | Public Sub Setup() 113 | Set SUT = New CollectionWrapper 114 | End Sub 115 | 116 | 117 | Public Sub Teardown() 118 | Set SUT = Nothing 119 | End Sub 120 | -------------------------------------------------------------------------------- /Data Structures/t_CollectionWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_CollectionWrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseData 16 | 17 | Private SUT As CollectionWrapper 18 | Private mMethodsRan&, mMethodCount& 19 | 20 | 21 | 22 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 23 | Select Case Test.MethodName 24 | 25 | Case "BasicFunctions1" 26 | Test.Use "obj1" 27 | Test.Use "obj2", "obj2" 28 | Test.Use "obj1", "obj2", "obj3" 29 | Test.Use "obj1", "obj2", "obj3", "obj4", "obj5", "obj6", "obj7", "obj8", "obj9" 30 | Test.Use "obj9", "obj8", "obj7", "obj6", "obj4", "obj5", "obj3", "obj2", "obj1" 31 | 32 | End Select 33 | End Sub 34 | 35 | 36 | Public Sub BasicFunctions1(ParamArray objNames() As Variant) 37 | Dim obj As TestSuite 38 | With SUT 39 | 40 | Assert.That .Count, Iz.EqualTo(0) _ 41 | , "Should initially have no items." 42 | 43 | 44 | Dim i&: For i = 0 To UBound(objNames) 45 | 46 | Set obj = Nothing 47 | Set obj = Sim.NewTestSuite(objNames(i)) 48 | 49 | 50 | ' Execute method under test. 51 | ' 52 | Call .Add(obj) 53 | 54 | 55 | Assert.That .Count, Iz.EqualTo(i + 1) _ 56 | , "Add() should update item Count()." 57 | 58 | Assert.That .Item(i).Name, Iz.EqualTo(objNames(i)) _ 59 | , "Add() should update item Count()." 60 | Next i 61 | 62 | Set obj = Nothing: i = 0 63 | 64 | 65 | 66 | ' Attempt enumeration. 67 | ' 68 | For Each obj In SUT 69 | Assert.That obj.Name, Iz.EqualTo(objNames(i)) _ 70 | , "Collection should be enumerable." 71 | i = i + 1 72 | Next obj 73 | 74 | 75 | 76 | ' Execute method under test. 77 | ' 78 | Call .Clear 79 | 80 | Assert.That .Count, Iz.EqualTo(0) _ 81 | , "Clear() should remove all items." 82 | 83 | End With 84 | End Sub 85 | 86 | 87 | 88 | 89 | 90 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 91 | ' 92 | ' Test Utility Methods 93 | ' 94 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 95 | 96 | Private Sub DoSomething() 97 | 98 | End Sub 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 107 | ' 108 | ' Fixture Framework Methods 109 | ' 110 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 111 | 112 | Public Sub FixtureSetup() 113 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 114 | 115 | End Sub 116 | 117 | 118 | Public Sub Setup() 119 | Set SUT = New CollectionWrapper 120 | 121 | End Sub 122 | 123 | 124 | Public Sub Teardown() 125 | Set SUT = Nothing 126 | 127 | mMethodsRan = mMethodsRan + 1 128 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 129 | End Sub 130 | 131 | 132 | Public Sub FixtureTeardown() 133 | If mMethodsRan < mMethodCount Then Exit Sub 134 | 135 | 'TestBed.QuitExcel 136 | End Sub 137 | -------------------------------------------------------------------------------- /Excel/Excel12HelperTests.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "Excel12HelperTests" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseSource 16 | 17 | Private SUT As Excel12Helper 18 | Private mSampleTree As TreeSampler 19 | 20 | Private Sub ITestCaseSource_GetTestCases(ByVal Test As SimplyVBComp.TestCaseCollector) 21 | Select Case Test.MethodName 22 | 23 | Case "ColumnNumber" 24 | Test.Use("a").Expect 1 25 | Test.Use("A").Expect 1 26 | Test.Use("b").Expect 2 27 | Test.Use("B").Expect 2 28 | Test.Use("z").Expect 26 29 | Test.Use("Z").Expect 26 30 | 'Test.Use("AA").Expect 27 31 | 32 | Case "ColumnLetter" 33 | Test.Use(1).Expect "A" 34 | Test.Use(2).Expect "B" 35 | Test.Use(25).Expect "Y" 36 | Test.Use(26).Expect "Z" 37 | Test.Use(27).Expect "AA" 38 | Test.Use(28).Expect "AB" 39 | Test.Use(128).Expect "DX" 40 | 41 | Case "CompliantRangeName" 42 | Test.Use("no space allowed").Expect "no_space_allowed" 43 | Test.Use("UPPER or lower case ReTaInEd").Expect "UPPER_or_lower_case_ReTaInEd" 44 | Test.Use("_underscores_ are allowed").Expect "_underscores_are_allowed" 45 | Test.Use(".dots. are allowed.").Expect ".dots._are_allowed." 46 | Test.Use("BS Elim Inv_Eqty").Expect "BS_Elim_Inv_Eqty" 47 | Test.Use("with [square] brackets").Expect "with_square_brackets" 48 | Test.Use("with (parenthesis) and: colon").Expect "with_parenthesis_and_colon" 49 | 50 | End Select 51 | End Sub 52 | 53 | 54 | Public Sub DrawTreeCollection() 55 | Dim treeModl As ITreeNode, t2D(), i&, wrkbook As Workbook 56 | Set treeModl = mSampleTree.AsTreeNodes(tr_CreatureNames) 57 | 58 | With New Excel.Application 59 | ' With .Workbooks.Open("C:\Dropbox\Aldrus\Lorrie\etc\Schema-AINA Conso.xlsx", , True) 60 | ' With .Worksheets("SCOA") 61 | ' t2D = .Range(.Range("A3").End(xlDown) _ 62 | ' , .Range("A3").End(xlToRight)).Value 63 | ' End With 64 | ' .Close False 65 | ' End With 66 | ' Set treeModl = New TreeBranch 67 | ' Call treeModl.FromArray2D(t2D) 68 | 69 | Set wrkbook = .Workbooks.Add 70 | 71 | With treeModl 72 | For i = 0 To .Count - 1 73 | SUT.DrawTreeNodes .Node(i) _ 74 | , wrkbook.Worksheets.Add, "A", 1 75 | Next i 76 | End With 77 | 78 | wrkbook.Application.Visible = True 79 | MsgBox Rand.mPearl 80 | wrkbook.Close False 81 | End With 82 | 83 | 84 | End Sub 85 | 86 | 87 | 88 | 89 | Public Function CompliantRangeName(strText$) As String 90 | CompliantRangeName = SUT.CompliantRangeName(strText) 91 | End Function 92 | 93 | 94 | Public Function ColumnLetter(columnIndx&) As String 95 | ColumnLetter = SUT.ColumnLetter(columnIndx) 96 | End Function 97 | 98 | 99 | Public Function ColumnNumber(columnLettr$) As Long 100 | ColumnNumber = SUT.ColumnNumber(columnLettr) 101 | End Function 102 | 103 | 104 | Public Sub Setup() 105 | Set mSampleTree = New TreeSampler 106 | Set SUT = New Excel12Helper 107 | End Sub 108 | 109 | 110 | Public Sub Teardown() 111 | Set SUT = Nothing 112 | Set mSampleTree = Nothing 113 | End Sub 114 | -------------------------------------------------------------------------------- /FileSystem/FileSystemHelper.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/FileSystem/FileSystemHelper.bas -------------------------------------------------------------------------------- /FileSystem/ShellTester.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmShellTester 3 | Caption = "Shell Tester" 4 | ClientHeight = 2955 5 | ClientLeft = 60 6 | ClientTop = 345 7 | ClientWidth = 4920 8 | BeginProperty Font 9 | Name = "Verdana" 10 | Size = 8.25 11 | Charset = 0 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LinkTopic = "Form1" 18 | ScaleHeight = 2955 19 | ScaleWidth = 4920 20 | StartUpPosition = 2 'CenterScreen 21 | Begin VB.TextBox txtTimeout 22 | Alignment = 1 'Right Justify 23 | Height = 315 24 | Left = 3840 25 | TabIndex = 3 26 | Text = "-1" 27 | Top = 1920 28 | Width = 495 29 | End 30 | Begin VB.TextBox txtCommand 31 | Height = 315 32 | Left = 1320 33 | TabIndex = 2 34 | Text = "Notepad" 35 | Top = 240 36 | Width = 3135 37 | End 38 | Begin VB.CommandButton cmdResponsize 39 | Caption = "Remain Responsive" 40 | Height = 855 41 | Left = 1320 42 | TabIndex = 1 43 | Top = 840 44 | Width = 1575 45 | End 46 | Begin VB.CommandButton cmdFreeze 47 | Caption = "Freeze Calling Window" 48 | Height = 855 49 | Left = 3120 50 | TabIndex = 0 51 | Top = 840 52 | Width = 1335 53 | End 54 | Begin VB.Label Label 55 | AutoSize = -1 'True 56 | Caption = "command" 57 | BeginProperty Font 58 | Name = "Verdana" 59 | Size = 6.75 60 | Charset = 0 61 | Weight = 400 62 | Underline = 0 'False 63 | Italic = 0 'False 64 | Strikethrough = 0 'False 65 | EndProperty 66 | Height = 180 67 | Index = 1 68 | Left = 480 69 | TabIndex = 5 70 | Top = 360 71 | Width = 720 72 | End 73 | Begin VB.Label Label 74 | AutoSize = -1 'True 75 | Caption = "timeout (s)" 76 | BeginProperty Font 77 | Name = "Verdana" 78 | Size = 6.75 79 | Charset = 0 80 | Weight = 400 81 | Underline = 0 'False 82 | Italic = 0 'False 83 | Strikethrough = 0 'False 84 | EndProperty 85 | Height = 180 86 | Index = 0 87 | Left = 2880 88 | TabIndex = 4 89 | Top = 2040 90 | Width = 825 91 | End 92 | End 93 | Attribute VB_Name = "frmShellTester" 94 | Attribute VB_GlobalNameSpace = False 95 | Attribute VB_Creatable = False 96 | Attribute VB_PredeclaredId = True 97 | Attribute VB_Exposed = False 98 | Option Explicit 99 | 100 | 101 | Private Sub cmdResponsize_Click() 102 | Call F_.ShellWait(txtCommand.Text _ 103 | , False _ 104 | , _ 105 | , vbNormalFocus) 106 | 107 | MsgBox "Execution resumed." 108 | 109 | End Sub 110 | 111 | Private Sub cmdFreeze_Click() 112 | Call F_.ShellWait(txtCommand.Text _ 113 | , True _ 114 | , CLng(txtTimeout.Text) * 1000 _ 115 | , vbNormalFocus) 116 | 117 | MsgBox "Execution resumed." 118 | 119 | End Sub 120 | 121 | -------------------------------------------------------------------------------- /Fonts/Fonts.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Fonts" 2 | Option Explicit 3 | Const MODULE_NAME$ = "Fonts" 4 | 5 | Private Enum FontsErrors ' you may make this Public for tests 6 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 7 | NotInitted 8 | AlreadyInitted 9 | ' add error numbers here 10 | End Enum 11 | 12 | Private Type ErrorHolder ' 13 | HasError As Boolean ' temp storage for errors 14 | Source As String ' 15 | Number As FontsErrors ' 16 | Description As String 17 | End Type 18 | Private mError As ErrorHolder 19 | 20 | 21 | 22 | Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long 23 | Private Declare Function RemoveFontResource Lib "gdi32" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long 24 | Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 25 | 26 | 'Private Sub Form_Load() 27 | ' Dim res As Long 28 | ' ' add the font 29 | ' res = AddFontResource("C:\Fonts\Nordic__.ttf") 30 | ' If res > 0 Then 31 | ' ' alert all windows that a font was added 32 | ' SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0 33 | ' MsgBox res & " fonts were added!" 34 | ' End If 35 | 'End Sub 36 | 37 | 38 | 39 | ' http://www.answers.com/topic/addfontresource#ixzz28OZFIhAo 40 | Public Sub Add(pathOfFontFile As String) 41 | On Error GoTo ErrH 42 | 43 | Const HWND_BROADCAST = &HFFFF& 44 | Const WM_FONTCHANGE = &H1D 45 | 46 | If AddFontResource(pathOfFontFile) > 0 Then 47 | ' alert all windows that a font was added 48 | SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0 49 | End If 50 | 51 | ErrH: Blame "Add" 52 | End Sub 53 | 54 | ' http://www.answers.com/topic/removefontresource#ixzz28ObHwbqn 55 | Public Sub Remove(pathOfFontFile As String) 56 | On Error GoTo ErrH 57 | 58 | Call RemoveFontResource(pathOfFontFile) 59 | 60 | ErrH: Blame "Remove" 61 | End Sub 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 71 | ' 72 | ' Error Handlers 73 | ' 74 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 75 | 76 | Private Sub ErrorIf(errCondition As Boolean _ 77 | , errorMsg As String _ 78 | , Optional errorNumbr As FontsErrors = -1 _ 79 | ) 80 | If errCondition Then Err.Raise errorNumbr, MODULE_NAME, errorMsg 81 | End Sub 82 | 83 | Private Sub SaveError() 84 | With mError 85 | If Err Then 86 | .HasError = True 87 | .Description = Err.Description 88 | .Number = Err.Number 89 | .Source = Err.Source 90 | 91 | Else 92 | .HasError = False 93 | .Description = vbNullString 94 | .Number = 0 95 | .Source = vbNullString 96 | End If 97 | End With 98 | Err.Clear 99 | End Sub 100 | 101 | Private Sub Blame(ByVal currntProcedure As String _ 102 | , Optional ByVal errorDescrption As String _ 103 | , Optional ByVal errorNumbr As FontsErrors = -1 _ 104 | ) 105 | Call SaveError 106 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 107 | End Sub 108 | 109 | Private Sub LoadError(ByVal currntProcedure As String _ 110 | , Optional ByVal errorDescrption As String _ 111 | , Optional ByVal errorNumbr As FontsErrors = -1 _ 112 | ) 113 | With mError 114 | If Not .HasError Then Exit Sub 115 | 116 | If LenB(errorDescrption) = 0 Then 117 | errorDescrption = .Description 118 | Else 119 | errorDescrption = .Description & vbCrLf & errorDescrption 120 | End If 121 | 122 | currntProcedure = MODULE_NAME & "." & currntProcedure & "()" 123 | 124 | If errorNumbr = -1 Then errorNumbr = .Number 125 | 126 | Select Case errorNumbr 127 | Case NotInitted 128 | errorDescrption = MODULE_NAME & " not initted." & vbCrLf _ 129 | & "Please call " & MODULE_NAME _ 130 | & ".Init() before " & currntProcedure & "." 131 | 132 | Case Else 133 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 134 | End Select 135 | 136 | Err.Raise errorNumbr, .Source, errorDescrption 137 | 138 | End With 139 | End Sub 140 | 141 | -------------------------------------------------------------------------------- /Html/HtmlWrapper1.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "HtmlWrapper1" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum HtmlWrapper1Errors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As HtmlWrapper1Errors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | Private mDOM As cSimpleDOM 32 | 33 | 34 | Public Function BodyTags() As cElementWrappers 35 | On Error GoTo ErrH 36 | 37 | Set BodyTags = New cElementWrappers 38 | 39 | With E_(mDOM.Root).Tag("body") 40 | Dim i&: For i = 0 To .ChildCount - 1 41 | 42 | BodyTags.Add E_(.Children(i)) 43 | 44 | Next i 45 | End With 46 | 47 | ErrH: Blame "BodyTags" 48 | End Function 49 | 50 | 51 | 52 | 53 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 54 | ' 55 | ' Constructor 56 | ' 57 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 58 | 59 | Public Sub Init(pathOfHtmlFile As String) 60 | On Error GoTo ErrH 61 | 62 | Call Class_Terminate 63 | Set mDOM = New_RC4.SimpleDOM(pathOfHtmlFile, True) 64 | 65 | ErrH: Blame "Init" 66 | End Sub 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 77 | ' 78 | ' Class Events 79 | ' 80 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 81 | 82 | Private Sub Class_Initialize() 83 | On Error GoTo ErrH 84 | 85 | 'Set mSomeObject = New Something 86 | 87 | ErrH: Blame "Class_Initialize" 88 | End Sub 89 | 90 | Private Sub Class_Terminate() 91 | On Error GoTo ErrH 92 | 93 | Set mDOM = Nothing 94 | 95 | ErrH: Blame "Class_Terminate" 96 | End Sub 97 | 98 | 99 | 100 | 101 | 102 | 103 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 104 | ' 105 | ' Error Handlers 106 | ' 107 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 108 | 109 | Private Sub ErrorIf(errCondition As Boolean _ 110 | , errorMsg As String _ 111 | , Optional errorNumbr As HtmlWrapper1Errors = -1 _ 112 | ) 113 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 114 | End Sub 115 | 116 | Private Sub SaveError() 117 | With mError 118 | If Err Then 119 | .HasError = True 120 | .Description = Err.Description 121 | .Number = Err.Number 122 | .Source = Err.Source 123 | 124 | Else 125 | .HasError = False 126 | .Description = vbNullString 127 | .Number = 0 128 | .Source = vbNullString 129 | End If 130 | End With 131 | Err.Clear 132 | End Sub 133 | 134 | Private Sub Blame(ByVal currntProcedure As String _ 135 | , Optional ByVal errorDescrption As String _ 136 | , Optional ByVal errorNumbr As HtmlWrapper1Errors = -1 _ 137 | ) 138 | Call SaveError 139 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 140 | End Sub 141 | 142 | Private Sub LoadError(ByVal currntProcedure As String _ 143 | , Optional ByVal errorDescrption As String _ 144 | , Optional ByVal errorNumbr As HtmlWrapper1Errors = -1 _ 145 | ) 146 | With mError 147 | If Not .HasError Then Exit Sub 148 | 149 | If LenB(errorDescrption) = 0 Then 150 | errorDescrption = .Description 151 | Else 152 | errorDescrption = .Description & vbCrLf & errorDescrption 153 | End If 154 | 155 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 156 | 157 | If errorNumbr = -1 Then errorNumbr = .Number 158 | 159 | Select Case errorNumbr 160 | Case NotInitted 161 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 162 | & "Please call " & TypeName(Me) _ 163 | & ".Init() before " & currntProcedure & "." 164 | 165 | Case Else 166 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 167 | End Select 168 | 169 | Err.Raise errorNumbr, .Source, errorDescrption 170 | 171 | End With 172 | End Sub 173 | 174 | -------------------------------------------------------------------------------- /Html/t_HtmlWrapper1.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_HtmlWrapper1" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseData 16 | 17 | Private SUT As HtmlWrapper1 18 | Private mTempFile$ 19 | Private mMethodsRan&, mMethodCount& 20 | 21 | 22 | 23 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 24 | Select Case Test.MethodName 25 | 26 | Case "MethodName_GoesHere" 27 | 28 | End Select 29 | End Sub 30 | 31 | 32 | Public Sub BodyTags_Enumerable() 33 | Dim i&, tNames$(), tTexts$(), e As cElementWrapper 34 | 35 | i = Rand.mNumber(1, 10) 36 | tNames = Rand.mWords(i, i) 37 | tTexts = Rand.mWords(i, i) 38 | 39 | 40 | ' compose test html 41 | ' 42 | With New_Xml("html") 43 | .Tag("head").InnerText = "empty" 44 | With .Tag("body") 45 | 46 | For i = 0 To UBound(tNames) 47 | .Tag(tNames(i)).InnerText = tTexts(i) 48 | Next i 49 | 50 | End With 51 | Debug.Print .ToString(True) 52 | Call .ToFile(mTempFile, True) 53 | End With 54 | 55 | ' parse 56 | Call SUT.Init(mTempFile) 57 | 58 | ' verify 59 | i = 0 60 | For Each e In SUT.BodyTags() 61 | 62 | Assert.That e.Name, Iz.EqualTo(tNames(i)) 63 | Assert.That e.Text, Iz.EqualTo(tTexts(i)) 64 | 65 | i = i + 1 66 | Next e 67 | 68 | Erase tNames, tTexts 69 | End Sub 70 | 71 | 72 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 73 | ' 74 | ' Test Utility Methods 75 | ' 76 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 77 | 78 | Private Sub DoSomething() 79 | 80 | End Sub 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 89 | ' 90 | ' Fixture Framework Methods 91 | ' 92 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 93 | 94 | Public Sub FixtureSetup() 95 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 96 | 97 | End Sub 98 | 99 | 100 | Public Sub Setup() 101 | 102 | mTempFile = F_.TempFile("test", "temp", ".html") 103 | 104 | Set SUT = New HtmlWrapper1 105 | 'Call SUT.Init( mPath$ 106 | End Sub 107 | 108 | 109 | Public Sub Teardown() 110 | Set SUT = Nothing 111 | 112 | F_.Delete mTempFile 113 | 114 | mMethodsRan = mMethodsRan + 1 115 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 116 | End Sub 117 | 118 | 119 | Public Sub FixtureTeardown() 120 | If mMethodsRan < mMethodCount Then Exit Sub 121 | 122 | 'TestBed.QuitExcel 123 | End Sub 124 | -------------------------------------------------------------------------------- /Kindle/KindleGenWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "KindleGenWrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Public Enum KindleGenCompressionModes 17 | c0_NoCompression = 0 18 | c1_StandardDOC = 1 19 | c2_KindleHuffdic = 2 20 | End Enum 21 | 22 | Private Enum KindleGenWrapperErrors ' you may make this Public for tests 23 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 24 | NotInitted 25 | AlreadyInitted 26 | BuildError 27 | ' add error numbers here 28 | End Enum 29 | 30 | Private Type ErrorHolder ' 31 | HasError As Boolean ' temp storage for errors 32 | Source As String ' 33 | Number As KindleGenWrapperErrors ' 34 | Description As String 35 | End Type 36 | Private mError As ErrorHolder 37 | 38 | Private mKindleGenExe$, mPreviewerExe$ 39 | 40 | 41 | Public Sub MakeAndView(pathOfKindleOpf As String _ 42 | , Optional compressionMethd As KindleGenCompressionModes = c0_NoCompression _ 43 | , Optional nameOfmobiFile As String = "draft.mobi" _ 44 | ) 45 | Dim outputF$ 46 | On Error GoTo ErrH 47 | 48 | RunCommand "taskkill /IM javaw.exe /T", , , vbNormalFocus 49 | 50 | outputF = Me.Make(pathOfKindleOpf, compressionMethd, nameOfmobiFile) 51 | 52 | Shell """" & mPreviewerExe & """ """ & outputF & """", vbNormalFocus 53 | 54 | ErrH: Blame "MakeAndView" 55 | End Sub 56 | 57 | Public Function Make(pathOfKindleOpf As String _ 58 | , Optional compressionMethd As KindleGenCompressionModes = c2_KindleHuffdic _ 59 | , Optional nameOfmobiFile As String = "draft.mobi" _ 60 | ) As String 61 | Dim cmd$, extCode&, outputF$, cmdOut$ 62 | On Error GoTo Cleanup 63 | 64 | 65 | ' delete target file as needed 66 | ' 67 | outputF = F_.Parent(pathOfKindleOpf) & nameOfmobiFile 68 | Call F_.Delete(outputF) 69 | 70 | 71 | ' compose command with args 72 | ' 73 | cmd = """" & mKindleGenExe & """ " _ 74 | & """" & pathOfKindleOpf & """ " _ 75 | & "-c" & compressionMethd & " " _ 76 | & "-o " & nameOfmobiFile 77 | 78 | 79 | ' run the command 80 | ' 81 | extCode = F_.ShellWait(cmd, , , vbNormalFocus) 82 | 83 | 84 | If extCode = 0 Then 85 | ErrorIf Not F_.Found(outputF) _ 86 | , "Failed to create """ & nameOfmobiFile & """, but exit code was [0]." 87 | 88 | ElseIf extCode <> 0 Then 89 | cmdOut = GetCommandOutput(cmd) 90 | Err.Raise BuildError, , GetError(cmdOut, extCode) 91 | End If 92 | 93 | 94 | ' return path of .mobi file 95 | ' 96 | Make = outputF 97 | 98 | 99 | Cleanup: SaveError 100 | 'F_.Delete redirectF 101 | 'Erase someArray 102 | LoadError "Make" ', "details of error" 103 | End Function 104 | 105 | 106 | 107 | 108 | 109 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 110 | ' 111 | ' Constructor 112 | ' 113 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 114 | 115 | Public Sub Init(kindlGenExePath As String _ 116 | , Optional kindlePreviewrExePath As String _ 117 | ) 118 | On Error GoTo ErrH 119 | 120 | 121 | ErrorIf Not Found(kindlGenExePath) _ 122 | , "KindleGen.exe not found in:" & vbCrLf & kindlGenExePath 123 | mKindleGenExe = kindlGenExePath 124 | 125 | If LenB(kindlePreviewrExePath) <> 0 Then 126 | ErrorIf Not Found(kindlePreviewrExePath) _ 127 | , "KindlePreviewer .exe not found in:" & vbCrLf & kindlePreviewrExePath 128 | mPreviewerExe = kindlePreviewrExePath 129 | End If 130 | 131 | ErrH: Blame "Init" 132 | End Sub 133 | 134 | 135 | 136 | 137 | 138 | 139 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 140 | ' 141 | ' Private Utilities 142 | ' 143 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 144 | 145 | Private Function GetError(CmdOutput As String _ 146 | , extCode As Long _ 147 | ) As String 148 | Dim markr$, errStart&, errEnd& 149 | On Error GoTo ErrH 150 | 151 | Select Case extCode 152 | 153 | Case 1 'warnings 154 | markr = "Warning(" 155 | errStart = InStr(CmdOutput, markr) 156 | errEnd = InStr(errStart, CmdOutput, vbCrLf) 157 | GetError = Mid$(CmdOutput, errStart + Len(markr), errEnd - errStart - Len(markr) - 1) 158 | 159 | Case 2 'error 160 | markr = "Error(" 161 | errStart = InStrRev(CmdOutput, markr) 162 | GetError = Mid$(CmdOutput, errStart + Len(markr)) 163 | 164 | End Select 165 | 166 | ErrH: Blame "GetError" 167 | End Function 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 178 | ' 179 | ' Class Events 180 | ' 181 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 182 | 183 | Private Sub Class_Initialize() 184 | On Error GoTo ErrH 185 | 186 | 'Set mSomeObject = New Something 187 | 188 | ErrH: Blame "Class_Initialize" 189 | End Sub 190 | 191 | Private Sub Class_Terminate() 192 | On Error GoTo ErrH 193 | 194 | 'Set mSomeObject = Nothing 195 | 196 | ErrH: Blame "Class_Terminate" 197 | End Sub 198 | 199 | 200 | 201 | 202 | 203 | 204 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 205 | ' 206 | ' Error Handlers 207 | ' 208 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 209 | 210 | Private Sub ErrorIf(errCondition As Boolean _ 211 | , errorMsg As String _ 212 | , Optional errorNumbr As KindleGenWrapperErrors = -1 _ 213 | ) 214 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 215 | End Sub 216 | 217 | Private Sub SaveError() 218 | With mError 219 | If Err Then 220 | .HasError = True 221 | .Description = Err.Description 222 | .Number = Err.Number 223 | .Source = Err.Source 224 | 225 | Else 226 | .HasError = False 227 | .Description = vbNullString 228 | .Number = 0 229 | .Source = vbNullString 230 | End If 231 | End With 232 | Err.Clear 233 | End Sub 234 | 235 | Private Sub Blame(ByVal currntProcedure As String _ 236 | , Optional ByVal errorDescrption As String _ 237 | , Optional ByVal errorNumbr As KindleGenWrapperErrors = -1 _ 238 | ) 239 | Call SaveError 240 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 241 | End Sub 242 | 243 | Private Sub LoadError(ByVal currntProcedure As String _ 244 | , Optional ByVal errorDescrption As String _ 245 | , Optional ByVal errorNumbr As KindleGenWrapperErrors = -1 _ 246 | ) 247 | With mError 248 | If Not .HasError Then Exit Sub 249 | 250 | If LenB(errorDescrption) = 0 Then 251 | errorDescrption = .Description 252 | Else 253 | errorDescrption = .Description & vbCrLf & errorDescrption 254 | End If 255 | 256 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 257 | 258 | If errorNumbr = -1 Then errorNumbr = .Number 259 | 260 | Select Case errorNumbr 261 | Case NotInitted 262 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 263 | & "Please call " & TypeName(Me) _ 264 | & ".Init() before " & currntProcedure & "." 265 | 266 | Case Else 267 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 268 | End Select 269 | 270 | Err.Raise errorNumbr, .Source, errorDescrption 271 | 272 | End With 273 | End Sub 274 | 275 | -------------------------------------------------------------------------------- /Language/Pluralizer.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Plu" 2 | Option Explicit 3 | 4 | Private mSingular$ 5 | 6 | ' usage: 7 | ' 8 | ' Plu.ral("apple") <-- returns "apples" 9 | ' Plu.ral("glass", 8) <-- returns "8 glasses" 10 | ' Plu.ral("file", 0) & " found" <-- returns "No files found" 11 | ' 12 | Public Property Get ral(singulrNoun As String _ 13 | , Optional quantty As Long = -1 _ 14 | , Optional use_No_ifZero As Boolean = True _ 15 | ) As String 16 | 17 | Dim plurlForm$: plurlForm = PluralForm(singulrNoun) 18 | 19 | Select Case quantty 20 | 21 | Case -1 ' do NOT include quantity 22 | ral = plurlForm 23 | 24 | 25 | Case 0 ' append plural form to "No" or "0" 26 | ral = IIf(use_No_ifZero, "No ", "0 ") & plurlForm 27 | 28 | 29 | Case 1 ' use singular form 30 | ral = "1 " & singulrNoun 31 | 32 | 33 | Case Else ' append plural form to formatted number 34 | ral = Format$(quantty, "#,# ") & plurlForm 35 | 36 | End Select 37 | End Property 38 | 39 | 40 | 41 | Public Property Get PluralForm(singulrNoun As String) As String 42 | 43 | Select Case LCase$(singulrNoun) 44 | 45 | ' except proper nouns 46 | Case "nationwide", "nestle", "getz" 47 | PluralForm = singulrNoun 48 | 49 | ' except other nouns 50 | Case "all" 51 | PluralForm = singulrNoun 52 | 53 | Case Else 54 | PluralForm = EnglishPlural(singulrNoun) 55 | 56 | End Select 57 | End Property 58 | 59 | 60 | Private Function EnglishPlural(singulrNoun As String) As String 61 | mSingular = singulrNoun 62 | 63 | If Ends("s") Then 64 | EnglishPlural = ChangeEndTo("s", "es") 65 | 66 | ElseIf Ends("y") Then 67 | EnglishPlural = ChangeEndTo("i", "es") 68 | 69 | ElseIf Ends("fe") Then 70 | EnglishPlural = ChangeEndTo("ve", "s") 71 | 72 | Else 73 | EnglishPlural = ChangeEndTo("", "s") 74 | End If 75 | 76 | End Function 77 | 78 | 79 | Private Function Ends(lastChars$) As Boolean 80 | Ends = UCase$(Right$(mSingular, Len(lastChars))) = UCase$(lastChars) 81 | End Function 82 | 83 | Private Function ChangeEndTo(replacemnt As String _ 84 | , suffx As String _ 85 | ) As String 86 | 87 | ChangeEndTo = Left$(mSingular, Len(mSingular) _ 88 | - Len(replacemnt)) _ 89 | & IIf(IsUppercase(Right$(mSingular, 1)) _ 90 | , UCase$(replacemnt & suffx) _ 91 | , replacemnt & suffx) 92 | End Function 93 | 94 | Private Function IsUppercase(charactr$) As Boolean 95 | Dim a%: a = Asc(charactr) 96 | ' Asc(A)=65 Asc(Z)=90 97 | IsUppercase = (a > 64) And (a < 91) 98 | 99 | End Function 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | -------------------------------------------------------------------------------- /Language/QuotePresenter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "QuotePresenter" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum QuotePresenterErrors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As QuotePresenterErrors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | Private WithEvents mText As VB.TextBox _ 32 | , WithEvents mCaption As VB.Label _ 33 | , WithEvents mScroll As VB.HScrollBar _ 34 | , WithEvents mRandom As VB.CommandButton 35 | Attribute mText.VB_VarHelpID = -1 36 | Attribute mCaption.VB_VarHelpID = -1 37 | Attribute mScroll.VB_VarHelpID = -1 38 | Attribute mRandom.VB_VarHelpID = -1 39 | 40 | Private mPanel As MSComctlLib.Panel _ 41 | , WithEvents mPanelUpdate As SelfTimer 42 | Attribute mPanelUpdate.VB_VarHelpID = -1 43 | 44 | Private mInitted As Boolean 45 | 46 | 47 | Public Sub Resize() 48 | On Error GoTo ErrH 49 | 50 | If Not mInitted Then Exit Sub 51 | 52 | With mScroll 53 | .Left = .Container.Width - .Width - 100 54 | .Top = 200 55 | mRandom.Top = .Top 56 | mRandom.Left = .Left + 240 57 | End With 58 | 59 | With mText 60 | '.BorderStyle = 1 61 | 62 | .Width = .Container.Width / 2 63 | .Left = .Width - (.Width / 2) 64 | 65 | .Height = TextBoxHeight(mText, .Text) 66 | .Top = .Container.Height / 2 - .Height / 2 - 600 67 | End With 68 | 69 | With mCaption 70 | .Top = mText.Top + mText.Height + 150 71 | .Left = mText.Left 72 | .Width = mText.Width 73 | End With 74 | 75 | ErrH: Blame "Resize" 76 | End Sub 77 | 78 | Private Function TextBoxHeight(textBoxCtrl As VB.TextBox _ 79 | , strText As String _ 80 | ) As Double 81 | Dim numRows&, c As cCairoContext 82 | On Error GoTo Cleanup 83 | 84 | 85 | With textBoxCtrl 86 | 87 | Set c = New_RC4.Cairo.CreateSurface(.Width, .Height).CreateContext 88 | 89 | With .Font 90 | c.SelectFont .Name, .Size, _ 91 | , .Bold, .Italic _ 92 | , .Underline, .Strikethrough 93 | End With 94 | 95 | numRows = c.DrawText(0, 0 _ 96 | , (.Width - 0) / Screen.TwipsPerPixelX _ 97 | , 0, strText) 98 | 99 | TextBoxHeight = numRows * c.GetFontHeight() 100 | 101 | TextBoxHeight = TextBoxHeight * Screen.TwipsPerPixelY + 100 102 | 103 | End With 104 | 105 | Cleanup: SaveError 106 | Set c = Nothing 107 | 'Erase someArray 108 | LoadError "TextBoxHeight" ', "details of error" 109 | End Function 110 | 111 | 112 | 113 | Private Sub mPanelUpdate_Timer(ByVal Seconds As Currency) 114 | On Error GoTo ErrH 115 | With mPanel 116 | 117 | .Text = " Blessed Mother, guide my work. " 118 | 119 | Select Case .Alignment 120 | Case sbrCenter: .Alignment = sbrRight 121 | Case sbrLeft: .Alignment = sbrCenter 122 | Case sbrRight: .Alignment = sbrLeft 123 | End Select 124 | 125 | End With 126 | ErrH: Blame "mPanelUpdate_Timer" 127 | End Sub 128 | 129 | 130 | 131 | Private Sub mRandom_Click() 132 | On Error GoTo ErrH 133 | With mScroll 134 | 135 | .Value = Rand.mNumber(.Min, .Max) 136 | 137 | End With 138 | ErrH: Blame "mRandom_Click" 139 | End Sub 140 | 141 | Private Sub mScroll_Change() 142 | On Error GoTo ErrH 143 | 144 | Call DrawQuote 145 | 146 | ErrH: Blame "mScroll_Change" 147 | End Sub 148 | 149 | 150 | 151 | 152 | Private Sub DrawQuote() 153 | Dim quot$, capt$ 154 | On Error GoTo ErrH 155 | 156 | quot = Rand.mPearl(capt, mScroll.Value) 157 | 158 | ' double the line breaks 159 | mText.Text = Replace(quot, vbCrLf, vbCrLf & vbCrLf) 160 | 161 | mCaption.Caption = "-- " & capt 162 | 163 | Call Me.Resize 164 | 165 | ErrH: Blame "DrawQuote" 166 | End Sub 167 | 168 | 169 | 170 | 171 | 172 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 173 | ' 174 | ' Constructor 175 | ' 176 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 177 | 178 | Public Sub Init(txtBoxForQuoteText As VB.TextBox _ 179 | , labelForQuoteCaption As VB.Label _ 180 | , scrollBarForQuoteNav As VB.HScrollBar _ 181 | , cmdBtnForRandom As VB.CommandButton _ 182 | , scrolBarPanelForBottomQuotes As MSComctlLib.Panel _ 183 | ) 184 | On Error GoTo ErrH 185 | 186 | Set mText = txtBoxForQuoteText 187 | Set mCaption = labelForQuoteCaption 188 | Set mScroll = scrollBarForQuoteNav 189 | Set mRandom = cmdBtnForRandom 190 | Set mPanel = scrolBarPanelForBottomQuotes 191 | 192 | Set mPanelUpdate = New SelfTimer 193 | mPanelUpdate.Interval = 1000! * 60 * 5 'five minutes 194 | 195 | With mScroll 196 | .Min = 1 197 | .Max = PEARLS_MAX 198 | End With 199 | 200 | mInitted = True 201 | 202 | Call mRandom_Click 203 | 204 | ErrH: Blame "Init" 205 | End Sub 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 214 | ' 215 | ' Class Events 216 | ' 217 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 218 | 219 | Private Sub Class_Initialize() 220 | On Error GoTo Cleanup 221 | 222 | 'Set mSomeObject = New Something 223 | 224 | Cleanup: SaveError 225 | 'Set someObj = Nothing 226 | 'Erase someArray 227 | LoadError "Class_Initialize" 228 | End Sub 229 | 230 | Private Sub Class_Terminate() 231 | On Error GoTo Cleanup 232 | 233 | Set mText = Nothing 234 | Set mCaption = Nothing 235 | Set mScroll = Nothing 236 | Set mRandom = Nothing 237 | Set mPanel = Nothing 238 | Set mPanelUpdate = Nothing 239 | 240 | Cleanup: SaveError 241 | 'Set someObj = Nothing 242 | 'Erase someArray 243 | LoadError "Class_Terminate" 244 | End Sub 245 | 246 | 247 | 248 | 249 | 250 | 251 | 252 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 253 | ' 254 | ' Error Handlers 255 | ' 256 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 257 | 258 | Private Sub ErrorIf(errCondition As Boolean _ 259 | , errorMsg As String _ 260 | , Optional errorNumbr As QuotePresenterErrors = -1 _ 261 | ) 262 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 263 | End Sub 264 | 265 | Private Sub SaveError() 266 | With mError 267 | If Err Then 268 | .HasError = True 269 | .Description = Err.Description 270 | .Number = Err.Number 271 | .Source = Err.Source 272 | 273 | Else 274 | .HasError = False 275 | .Description = vbNullString 276 | .Number = 0 277 | .Source = vbNullString 278 | End If 279 | End With 280 | Err.Clear 281 | End Sub 282 | 283 | Private Sub Blame(ByVal currntProcedure As String _ 284 | , Optional ByVal errorDescrption As String _ 285 | , Optional ByVal errorNumbr As QuotePresenterErrors = -1 _ 286 | ) 287 | Call SaveError 288 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 289 | End Sub 290 | 291 | Private Sub LoadError(ByVal currntProcedure As String _ 292 | , Optional ByVal errorDescrption As String _ 293 | , Optional ByVal errorNumbr As QuotePresenterErrors = -1 _ 294 | ) 295 | With mError 296 | If Not .HasError Then Exit Sub 297 | 298 | If LenB(errorDescrption) = 0 Then 299 | errorDescrption = .Description 300 | Else 301 | errorDescrption = .Description & vbCrLf & errorDescrption 302 | End If 303 | 304 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 305 | 306 | If errorNumbr = -1 Then errorNumbr = .Number 307 | 308 | Select Case errorNumbr 309 | Case NotInitted 310 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 311 | & "Please call " & TypeName(Me) _ 312 | & ".Init() before " & currntProcedure & "." 313 | 314 | Case Else 315 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 316 | End Select 317 | 318 | Err.Raise errorNumbr, .Source, errorDescrption 319 | 320 | End With 321 | End Sub 322 | -------------------------------------------------------------------------------- /Language/t_Pluralizer.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_Pluralizer" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseSource 16 | 17 | Private mMethodsRan&, mMethodCount& 18 | 19 | 20 | 21 | Private Sub ITestCaseSource_GetTestCases(ByVal Test As SimplyVBComp.TestCaseCollector) 22 | Select Case Test.MethodName 23 | 24 | Case "Plu_ral" 25 | Test.Use("apple").Expect "apples" 26 | Test.Use("apple", -1).Expect "apples" 27 | Test.Use("apple", 0).Expect "No apples" 28 | Test.Use("apple", 1).Expect "1 apple" 29 | Test.Use("apple", 2).Expect "2 apples" 30 | Test.Use("apple", 1234).Expect "1,234 apples" 31 | Test.Use("apple", 1234567).Expect "1,234,567 apples" 32 | Test.Use("Apple", 9).Expect "9 Apples" 33 | Test.Use("APPLE", 4567).Expect "4,567 APPLES" 34 | 35 | 36 | ' test ~y 37 | ' 38 | Test.Use("Category").Expect "Categories" 39 | Test.Use("category").Expect "categories" 40 | Test.Use("CATEGORY").Expect "CATEGORIES" 41 | Test.Use("agency").Expect "agencies" 42 | Test.Use("Agency").Expect "Agencies" 43 | Test.Use("AGENCY").Expect "AGENCIES" 44 | 45 | 46 | ' test "~fe" 47 | Test.Use("knife").Expect "knives" 48 | Test.Use("Knife").Expect "Knives" 49 | Test.Use("KNIFE").Expect "KNIVES" 50 | 51 | 52 | ' test ~ss 53 | Test.Use("glass", -1).Expect "glasses" 54 | Test.Use("glass", 0).Expect "No glasses" 55 | Test.Use("glass", 1).Expect "1 glass" 56 | Test.Use("glass", 8).Expect "8 glasses" 57 | 58 | 59 | 60 | ' test exceptions 61 | ' 62 | Test.Use("all").Expect "all" 63 | Test.Use("All").Expect "All" 64 | Test.Use("ALL").Expect "ALL" 65 | 66 | ' test proper nouns 67 | ' 68 | Test.Use("Nationwide").Expect "Nationwide" 69 | Test.Use("NESTLE").Expect "NESTLE" 70 | Test.Use("getz").Expect "getz" 71 | End Select 72 | End Sub 73 | 74 | 75 | 76 | Public Function Plu_ral(singulrNoun As String _ 77 | , Optional quantty As Long = -1 _ 78 | , Optional use_No_ifZero As Boolean = True _ 79 | ) As String 80 | 81 | Plu_ral = Plu.ral(singulrNoun, quantty, use_No_ifZero) 82 | 83 | End Function 84 | 85 | 86 | 87 | 88 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 89 | ' 90 | ' Test Utility Methods 91 | ' 92 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 93 | 94 | Private Sub DoSomething() 95 | 96 | End Sub 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 105 | ' 106 | ' Fixture Framework Methods 107 | ' 108 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 109 | 110 | Public Sub FixtureSetup() 111 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 112 | 113 | End Sub 114 | 115 | 116 | Public Sub Setup() 117 | ' 118 | End Sub 119 | 120 | 121 | Public Sub Teardown() 122 | ' 123 | 124 | mMethodsRan = mMethodsRan + 1 125 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 126 | End Sub 127 | 128 | 129 | Public Sub FixtureTeardown() 130 | If mMethodsRan < mMethodCount Then Exit Sub 131 | 132 | 'TestBed.QuitExcel 133 | End Sub 134 | -------------------------------------------------------------------------------- /Markdown/MarkdownExe.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/Markdown/MarkdownExe.cls -------------------------------------------------------------------------------- /Markdown/multimarkdown.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/Markdown/multimarkdown.exe -------------------------------------------------------------------------------- /Markdown/t_MarkdownExe.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/Markdown/t_MarkdownExe.cls -------------------------------------------------------------------------------- /Obfuscation/Randomizer.bas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/Obfuscation/Randomizer.bas -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | vb6-toolbox 2 | =========== 3 | 4 | Convenient classes for extending the functionality of VB6 apps. 5 | -------------------------------------------------------------------------------- /Shell/CmdOutput.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "CmdOutput" 2 | Option Explicit 3 | '''''''''''''''''''''''''''''''''''''''' 4 | ' Joacim Andersson, Brixoft Software 5 | ' http://www.brixoft.net 6 | '''''''''''''''''''''''''''''''''''''''' 7 | 8 | ' STARTUPINFO flags 9 | Private Const STARTF_USESHOWWINDOW = &H1 10 | Private Const STARTF_USESTDHANDLES = &H100 11 | 12 | ' ShowWindow flags 13 | Private Const SW_HIDE = 0 14 | 15 | ' DuplicateHandle flags 16 | Private Const DUPLICATE_CLOSE_SOURCE = &H1 17 | Private Const DUPLICATE_SAME_ACCESS = &H2 18 | 19 | ' Error codes 20 | Private Const ERROR_BROKEN_PIPE = 109 21 | 22 | Private Type SECURITY_ATTRIBUTES 23 | nLength As Long 24 | lpSecurityDescriptor As Long 25 | bInheritHandle As Long 26 | End Type 27 | 28 | Private Type STARTUPINFO 29 | cb As Long 30 | lpReserved As String 31 | lpDesktop As String 32 | lpTitle As String 33 | dwX As Long 34 | dwY As Long 35 | dwXSize As Long 36 | dwYSize As Long 37 | dwXCountChars As Long 38 | dwYCountChars As Long 39 | dwFillAttribute As Long 40 | dwFlags As Long 41 | wShowWindow As Integer 42 | cbReserved2 As Integer 43 | lpReserved2 As Long 44 | hStdInput As Long 45 | hStdOutput As Long 46 | hStdError As Long 47 | End Type 48 | 49 | Private Type PROCESS_INFORMATION 50 | hProcess As Long 51 | hThread As Long 52 | dwProcessId As Long 53 | dwThreadId As Long 54 | End Type 55 | 56 | Private Declare Function CreatePipe _ 57 | Lib "kernel32" ( _ 58 | phReadPipe As Long, _ 59 | phWritePipe As Long, _ 60 | lpPipeAttributes As Any, _ 61 | ByVal nSize As Long) As Long 62 | 63 | Private Declare Function ReadFile _ 64 | Lib "kernel32" ( _ 65 | ByVal hFile As Long, _ 66 | lpBuffer As Any, _ 67 | ByVal nNumberOfBytesToRead As Long, _ 68 | lpNumberOfBytesRead As Long, _ 69 | lpOverlapped As Any) As Long 70 | 71 | Private Declare Function CreateProcess _ 72 | Lib "kernel32" Alias "CreateProcessA" ( _ 73 | ByVal lpApplicationName As String, _ 74 | ByVal lpCommandLine As String, _ 75 | lpProcessAttributes As Any, _ 76 | lpThreadAttributes As Any, _ 77 | ByVal bInheritHandles As Long, _ 78 | ByVal dwCreationFlags As Long, _ 79 | lpEnvironment As Any, _ 80 | ByVal lpCurrentDriectory As String, _ 81 | lpStartupInfo As STARTUPINFO, _ 82 | lpProcessInformation As PROCESS_INFORMATION) As Long 83 | 84 | Private Declare Function GetCurrentProcess _ 85 | Lib "kernel32" () As Long 86 | 87 | Private Declare Function DuplicateHandle _ 88 | Lib "kernel32" ( _ 89 | ByVal hSourceProcessHandle As Long, _ 90 | ByVal hSourceHandle As Long, _ 91 | ByVal hTargetProcessHandle As Long, _ 92 | lpTargetHandle As Long, _ 93 | ByVal dwDesiredAccess As Long, _ 94 | ByVal bInheritHandle As Long, _ 95 | ByVal dwOptions As Long) As Long 96 | 97 | Private Declare Function CloseHandle _ 98 | Lib "kernel32" ( _ 99 | ByVal hObject As Long) As Long 100 | 101 | Private Declare Function OemToCharBuff _ 102 | Lib "user32" Alias "OemToCharBuffA" ( _ 103 | lpszSrc As Any, _ 104 | ByVal lpszDst As String, _ 105 | ByVal cchDstLength As Long) As Long 106 | 107 | ' Function GetCommandOutput 108 | ' 109 | ' sCommandLine: [in] Command line to launch 110 | ' blnStdOut [in,opt] True (defualt) to capture output to STDOUT 111 | ' blnStdErr [in,opt] True to capture output to STDERR. False is default. 112 | ' blnOEMConvert: [in,opt] True (default) to convert DOS characters to Windows, False to skip conversion 113 | ' 114 | ' Returns: String with STDOUT and/or STDERR output 115 | ' 116 | Public Function GetCommandOutput( _ 117 | sCommandLine As String, _ 118 | Optional blnStdOut As Boolean = True, _ 119 | Optional blnStdErr As Boolean = False, _ 120 | Optional blnOEMConvert As Boolean = True _ 121 | ) As String 122 | 123 | Dim hPipeRead As Long, hPipeWrite1 As Long, hPipeWrite2 As Long 124 | Dim hCurProcess As Long 125 | Dim sa As SECURITY_ATTRIBUTES 126 | Dim si As STARTUPINFO 127 | Dim pi As PROCESS_INFORMATION 128 | Dim baOutput() As Byte 129 | Dim sNewOutput As String 130 | Dim lBytesRead As Long 131 | Dim fTwoHandles As Boolean 132 | 133 | Dim lRet As Long 134 | 135 | Const BUFSIZE = 1024 ' pipe buffer size 136 | 137 | ' At least one of them should be True, otherwise there's no point in calling the function 138 | If (Not blnStdOut) And (Not blnStdErr) Then 139 | Err.Raise 5 ' Invalid Procedure call or Argument 140 | End If 141 | 142 | ' If both are true, we need two write handles. If not, one is enough. 143 | fTwoHandles = blnStdOut And blnStdErr 144 | 145 | ReDim baOutput(BUFSIZE - 1) As Byte 146 | 147 | With sa 148 | .nLength = Len(sa) 149 | .bInheritHandle = 1 ' get inheritable pipe handles 150 | End With 151 | 152 | If CreatePipe(hPipeRead, hPipeWrite1, sa, BUFSIZE) = 0 Then 153 | Exit Function 154 | End If 155 | 156 | hCurProcess = GetCurrentProcess() 157 | 158 | ' Replace our inheritable read handle with an non-inheritable. Not that it 159 | ' seems to be necessary in this case, but the docs say we should. 160 | Call DuplicateHandle(hCurProcess, hPipeRead, hCurProcess, hPipeRead, 0&, _ 161 | 0&, DUPLICATE_SAME_ACCESS Or DUPLICATE_CLOSE_SOURCE) 162 | 163 | ' If both STDOUT and STDERR should be redirected, get an extra handle. 164 | If fTwoHandles Then 165 | Call DuplicateHandle(hCurProcess, hPipeWrite1, hCurProcess, hPipeWrite2, 0&, _ 166 | 1&, DUPLICATE_SAME_ACCESS) 167 | End If 168 | 169 | With si 170 | .cb = Len(si) 171 | .dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES 172 | .wShowWindow = SW_HIDE ' hide the window 173 | 174 | If fTwoHandles Then 175 | .hStdOutput = hPipeWrite1 176 | .hStdError = hPipeWrite2 177 | ElseIf blnStdOut Then 178 | .hStdOutput = hPipeWrite1 179 | Else 180 | .hStdError = hPipeWrite1 181 | End If 182 | End With 183 | 184 | If CreateProcess(vbNullString, sCommandLine, ByVal 0&, ByVal 0&, 1, 0&, _ 185 | ByVal 0&, vbNullString, si, pi) Then 186 | 187 | ' Close thread handle - we don't need it 188 | Call CloseHandle(pi.hThread) 189 | 190 | ' Also close our handle(s) to the write end of the pipe. This is important, since 191 | ' ReadFile will *not* return until all write handles are closed or the buffer is full. 192 | Call CloseHandle(hPipeWrite1) 193 | hPipeWrite1 = 0 194 | If hPipeWrite2 Then 195 | Call CloseHandle(hPipeWrite2) 196 | hPipeWrite2 = 0 197 | End If 198 | 199 | Do 200 | ' Add a DoEvents to allow more data to be written to the buffer for each call. 201 | ' This results in fewer, larger chunks to be read. 202 | 'DoEvents 203 | 204 | If ReadFile(hPipeRead, baOutput(0), BUFSIZE, lBytesRead, ByVal 0&) = 0 Then 205 | Exit Do 206 | End If 207 | 208 | If blnOEMConvert Then 209 | ' convert from "DOS" to "Windows" characters 210 | sNewOutput = String$(lBytesRead, 0) 211 | Call OemToCharBuff(baOutput(0), sNewOutput, lBytesRead) 212 | Else 213 | ' perform no conversion (except to Unicode) 214 | sNewOutput = Left$(StrConv(baOutput(), vbUnicode), lBytesRead) 215 | End If 216 | 217 | GetCommandOutput = GetCommandOutput & sNewOutput 218 | 219 | ' If you are executing an application that outputs data during a long time, 220 | ' and don't want to lock up your application, it might be a better idea to 221 | ' wrap this code in a class module in an ActiveX EXE and execute it asynchronously. 222 | ' Then you can raise an event here each time more data is available. 223 | 'RaiseEvent OutputAvailabele(sNewOutput) 224 | Loop 225 | 226 | ' When the process terminates successfully, Err.LastDllError will be 227 | ' ERROR_BROKEN_PIPE (109). Other values indicates an error. 228 | 229 | Call CloseHandle(pi.hProcess) 230 | Else 231 | GetCommandOutput = "Failed to create process, check the path of the command line." 232 | End If 233 | 234 | ' clean up 235 | Call CloseHandle(hPipeRead) 236 | If hPipeWrite1 Then 237 | Call CloseHandle(hPipeWrite1) 238 | End If 239 | If hPipeWrite2 Then 240 | Call CloseHandle(hPipeWrite2) 241 | End If 242 | End Function 243 | -------------------------------------------------------------------------------- /SimplyVbUnit/FileSystemConstraints.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Path" 2 | Option Explicit 3 | 4 | Private mFS As New FileSystemConstraints 5 | 6 | 7 | Public Function DoesNotExist() As IConstraint 8 | 9 | Call mFS.Init(fn_DoesNotExist) 10 | 11 | Set DoesNotExist = mFS 12 | 13 | End Function 14 | 15 | 16 | Public Function Exists() As IConstraint 17 | 18 | Call mFS.Init(fn_Exists) 19 | 20 | Set Exists = mFS 21 | 22 | End Function 23 | -------------------------------------------------------------------------------- /SimplyVbUnit/FileSystemConstraints.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "FileSystemConstraints" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements IConstraint 16 | Const MODULE_NAME$ = "FileSystemConstraints" 17 | 18 | Public Enum FileSystemConstraintMethods 19 | fn_Undefined = -1 20 | fn_Exists 21 | fn_DoesNotExist 22 | End Enum 23 | Private mMethod As FileSystemConstraintMethods 24 | 25 | Private Enum FileSystemConstraintsErrors ' you may make this Public for tests 26 | ErrorBase = 3000 ' you may adjust this minimum 27 | NotInitted 28 | UnsupportedMethod 29 | ' add error numbers here 30 | End Enum 31 | 32 | Private Type ErrorHolder ' 33 | HasError As Boolean ' temp storage for errors 34 | Source As String ' 35 | Number As FileSystemConstraintsErrors ' 36 | Description As String 37 | End Type 38 | Private mError As ErrorHolder 39 | 40 | 41 | Private mPath As String 42 | 43 | 44 | 45 | Private Function IConstraint_Matches(Actual As Variant) As Boolean 46 | On Error GoTo Cleanup 47 | 48 | mPath = CStr(Actual) 49 | 50 | Select Case mMethod 51 | 52 | Case fn_Exists 53 | IConstraint_Matches = Found(mPath) 54 | 55 | 56 | Case fn_DoesNotExist 57 | IConstraint_Matches = Not Found(mPath) 58 | 59 | 60 | Case fn_Undefined: Err.Raise NotInitted 61 | Case Else: Err.Raise UnsupportedMethod 62 | End Select 63 | 64 | Cleanup: SaveError 65 | 'Set someObj = Nothing 66 | 'Erase someArray 67 | LoadError "IConstraint_Matches" ', "details of error" 68 | End Function 69 | 70 | 71 | Private Sub IConstraint_WriteMessageTo(ByVal Writer As SimplyVBUnit.TextMessageWriter) 72 | Dim msg$ 73 | On Error GoTo Cleanup 74 | 75 | Select Case mMethod 76 | 77 | Case fn_Exists 78 | Writer.WriteLine vbCrLf _ 79 | & "Expected file/folder does not exist:" _ 80 | & vbCrLf & """" & mPath & """" 81 | 82 | Case fn_DoesNotExist 83 | Writer.WriteLine vbCrLf _ 84 | & "File/folder should NOT exist:" _ 85 | & vbCrLf & """" & mPath & """" 86 | 87 | 88 | Case fn_Undefined: Err.Raise NotInitted 89 | Case Else: Err.Raise UnsupportedMethod 90 | End Select 91 | 92 | Cleanup: SaveError 93 | 'Set someObj = Nothing 94 | 'Erase someArray 95 | LoadError "IConstraint_WriteMessageTo" ', "details of error" 96 | End Sub 97 | 98 | 99 | 100 | Private Sub IConstraint_WriteActualValueTo(ByVal Writer As SimplyVBUnit.TextMessageWriter) 101 | 102 | End Sub 103 | 104 | Private Sub IConstraint_WriteDescriptionTo(ByVal Writer As SimplyVBUnit.TextMessageWriter) 105 | 106 | End Sub 107 | 108 | 109 | 110 | 111 | 112 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 113 | ' 114 | ' Private Utilities 115 | ' 116 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 117 | 118 | Private Function Found(fileOrFoldrPath As String _ 119 | ) As Boolean 120 | On Error GoTo Cleanup 121 | 122 | If FileFound(fileOrFoldrPath) Then 123 | Found = True 124 | 125 | ElseIf FolderFound(fileOrFoldrPath) Then 126 | Found = True 127 | End If 128 | 129 | Cleanup: SaveError 130 | 'Set someObj = Nothing 131 | 'Erase someArray 132 | LoadError "Found" ', "details of error" 133 | End Function 134 | 135 | Private Function FileFound(pathOfFile As String) As Boolean 136 | If LenB(pathOfFile) <> 0 Then ' because Dir("") returns something 137 | On Error Resume Next 138 | FileFound = LenB(Dir(pathOfFile)) <> 0 139 | On Error GoTo 0 140 | End If 141 | End Function 142 | 143 | Private Function FolderFound(targetFoldrPath As String) As Boolean 144 | On Error Resume Next 145 | FolderFound = GetAttr(targetFoldrPath) And vbDirectory 146 | On Error GoTo 0 147 | End Function 148 | 149 | 150 | 151 | 152 | 153 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 154 | ' 155 | ' Constructor 156 | ' 157 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 158 | 159 | Public Sub Init(constraintMethd As FileSystemConstraintMethods) 160 | On Error GoTo Cleanup 161 | 162 | mMethod = constraintMethd 163 | 164 | Cleanup: SaveError 165 | 'Set someObj = Nothing 166 | 'Erase someArray 167 | LoadError "Init" ', "details of error" 168 | End Sub 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 179 | ' 180 | ' Class Events 181 | ' 182 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 183 | 184 | Private Sub Class_Initialize() 185 | On Error GoTo Cleanup 186 | 187 | mMethod = fn_Undefined 188 | 189 | Cleanup: SaveError 190 | 'Set someObj = Nothing 191 | 'Erase someArray 192 | LoadError "Class_Initialize" 193 | End Sub 194 | 195 | Private Sub Class_Terminate() 196 | On Error GoTo Cleanup 197 | 198 | 'Set mSomeObject = Nothing 199 | 200 | Cleanup: SaveError 201 | 'Set someObj = Nothing 202 | 'Erase someArray 203 | LoadError "Class_Terminate" 204 | End Sub 205 | 206 | 207 | 208 | 209 | 210 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 211 | ' 212 | ' Error Handlers 213 | ' 214 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 215 | 216 | Private Sub ErrorIf(errCondition As Boolean _ 217 | , errorMsg As String _ 218 | , Optional errorNumbr As FileSystemConstraintsErrors = -1 _ 219 | ) 220 | If errCondition Then Err.Raise errorNumbr, MODULE_NAME, errorMsg 221 | End Sub 222 | 223 | Private Sub SaveError() 224 | With mError 225 | If Err Then 226 | .HasError = True 227 | .Description = Err.Description 228 | .Number = Err.Number 229 | .Source = Err.Source 230 | 231 | Else 232 | .HasError = False 233 | .Description = vbNullString 234 | .Number = 0 235 | .Source = vbNullString 236 | End If 237 | End With 238 | Err.Clear 239 | End Sub 240 | 241 | Private Sub LoadError(ByVal currntProcedure As String _ 242 | , Optional ByVal errorDescrption As String _ 243 | , Optional ByVal errorNumbr As FileSystemConstraintsErrors = -1 _ 244 | ) 245 | With mError 246 | If Not .HasError Then Exit Sub 247 | 248 | If LenB(errorDescrption) = 0 Then 249 | errorDescrption = .Description 250 | Else 251 | errorDescrption = .Description & vbCrLf & errorDescrption 252 | End If 253 | 254 | currntProcedure = MODULE_NAME & "." & currntProcedure & "()" 255 | 256 | If errorNumbr = -1 Then errorNumbr = .Number 257 | 258 | Select Case errorNumbr 259 | Case NotInitted 260 | errorDescrption = MODULE_NAME & " not initted." & vbCrLf _ 261 | & "Please call " & MODULE_NAME _ 262 | & ".Init() before " & currntProcedure & "." 263 | 264 | Case UnsupportedMethod 265 | errorDescrption = "Unsupported constraint method: [" & mMethod & "]." 266 | 267 | Case Else 268 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 269 | End Select 270 | 271 | Err.Raise errorNumbr, .Source, errorDescrption 272 | 273 | End With 274 | End Sub 275 | -------------------------------------------------------------------------------- /SimplyVbUnit/XmlConstraints.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "Tag_" 2 | Option Explicit 3 | 4 | Private mXML As New XmlConstraints 5 | 6 | 7 | Public Function NameIs(nameOfTag As String _ 8 | ) As IConstraint 9 | Call mXML.Init(fn_NameIs, nameOfTag) 10 | Set NameIs = mXML 11 | End Function 12 | 13 | 14 | Public Function HasTag(nameOfTag As String _ 15 | ) As IConstraint 16 | Call mXML.Init(fn_HasTag, nameOfTag) 17 | Set HasTag = mXML 18 | End Function 19 | 20 | 21 | Public Function ValueIs(attrbuteValue As Variant _ 22 | ) As IConstraint 23 | Call mXML.Init(fn_ValueIs, attrbuteValue) 24 | Set ValueIs = mXML 25 | End Function 26 | 27 | 28 | Public Function TextIs(textOfTag As String _ 29 | ) As IConstraint 30 | Call mXML.Init(fn_TextIs, textOfTag) 31 | Set TextIs = mXML 32 | End Function 33 | 34 | 35 | Public Function Tag(nameOfTag As String _ 36 | ) As XmlConstraints 37 | mXML.ParentTag = nameOfTag 38 | Set Tag = mXML 39 | End Function 40 | 41 | Public Function Find(searchFiltr As String _ 42 | ) As XmlConstraints 43 | mXML.SearchFilter = searchFiltr 44 | Set Find = mXML 45 | End Function 46 | -------------------------------------------------------------------------------- /Strings/StringBuilder.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "StringBuilder" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = False 9 | Attribute VB_Exposed = False 10 | Option Explicit 11 | 12 | '! StringBuilder class is similar to other SringBuilder classes available by 13 | '! programming language libraries such as java. It is intended to simplify 14 | '! long string concatenation sequences and to simplify padding strings with 15 | '! quotes or other markup. 16 | '! 17 | '! It is also anywhere from 30 - 200+ times faster than concatenating strings using the '&' or '+' 18 | '! operators. Since it makes appending strings a linear operation, the longer the string being 19 | '! appended, the better the run-time improvement. 20 | '! @see http://support.microsoft.com/kb/170964 21 | '! @see http://roymacleanvba.wordpress.com/2010/01/14/performance-strings/ 22 | '! 23 | '! @author Dave Parillo, Rite Solutions, Inc. 24 | '! $Date: 2010-01-14 08:32:34 -0800 (Thu, 14 Jan 2010) $ 25 | '! $Revision: 703 $ 26 | '! 27 | 28 | 29 | Private Const pInitial As Long = 32 '* Initial Length of the string buffer 30 | 31 | Private pTotal As Long '* Total Length of the buffer 32 | Private pCurrent As Long '* Length of the string value within the buffer 33 | Private pBuf As String '* The string buffer 34 | 35 | '* Definitions for various ways to return strings surrounded by other text. 36 | '* Typically quotation marks, but other styles are used also. 37 | '* 38 | '* @see Quotify 39 | Enum sbQuoteStyle 40 | sbNone = 0 41 | sbDouble = 1 42 | sbSingle = 2 43 | sbSquareBrackets = 3 44 | sbExcelDateString = 4 45 | sbADODBSheetReference = 5 46 | End Enum 47 | 48 | '* Set up the string buffer. 49 | '* It's defined to have an initial buffer size, 50 | '* but the 'string size' (current length) of the buffer is 0 51 | Private Sub Class_Initialize() 52 | pCurrent = 0 53 | pTotal = pInitial 54 | pBuf = Space(pTotal) 55 | End Sub 56 | 57 | '* Tear down the string buffer. 58 | Private Sub Class_Terminate() 59 | pBuf = vbNullString 60 | End Sub 61 | 62 | '* Sets or resets the string to a value. 63 | Private Sub SetString(ByRef StringValue As String) 64 | pBuf = Space(pTotal) 65 | pCurrent = 0 66 | Me.Append (StringValue) 67 | End Sub 68 | 69 | '* Returns the current StringBuilder string. 70 | '* 71 | '* Value is the default StringBuilder class member. Given: 72 | '* 73 | '* Dim foo As StringBuilder 74 | '* Set foo = New StringBuilder 75 | '* foo.Value = "Hello, world!" 76 | '* 77 | '* Then: 78 | '* - foo.Value 79 | '* - foo 80 | '* 81 | '* both refer to the current value of foo. 82 | Property Get Value() As String 83 | Attribute Value.VB_UserMemId = 0 84 | Value = Left$(pBuf, pCurrent) 85 | End Property 86 | 87 | '* Sets the string to a value. 88 | '* @param StringValue The string property is set to this value. 89 | Property Let Value(ByRef StringValue As String) 90 | SetString StringValue 91 | End Property 92 | 93 | '* Get the raw string buffer string, including all extra space in the buffer. 94 | '* Used primarily for testing, you won't typically refer to the buffer. 95 | '* Use StringBuilder::Value instead. 96 | Property Get Buffer() As String 97 | Buffer = pBuf 98 | End Property 99 | 100 | '* Returns the current StringBuilder string, optionally surrounded by 101 | '* some type of markup. 102 | '* 103 | '* Given: 104 | '* 105 | '* Dim foo As StringBuilder 106 | '* Set foo = New StringBuilder 107 | '* foo = "Hello, world!" 108 | '* 109 | '* Then: 110 | '* - foo.Value 111 | '* - foo 112 | '* - foo.ToString 113 | '* - foo.ToString(sbNone) 114 | '* 115 | '* All refer to the current value of foo. 116 | '* @param QuotationType surrounds the string with quotation marks 117 | '* (or some other character) if desired. 118 | '* - the StringBuilder string is not modified when specifying 119 | '* a QuotationType. 120 | '* @return the current value of the StringBuilder string 121 | '* surrounded by the specified sbQuoteStyle 122 | Property Get ToString(Optional ByVal QuotationType As sbQuoteStyle) As String 123 | ToString = Quotify(Me.Value, QuotationType) 124 | End Property 125 | 126 | '* Request the length of the StringBuilder string. 127 | '* @return Current length of the StringBuilder string. 128 | Property Get Length() As Long 129 | Length = pCurrent 130 | End Property 131 | 132 | '* Request the length of the StringBuilder raw string buffer. 133 | '* Used primarily for testing, you won't typically refer to the buffer. 134 | '* Use StringBuilder::Length instead. 135 | Property Get BufferLength() As Long 136 | Debug.Assert pTotal = Len(pBuf) 137 | BufferLength = pTotal 138 | End Property 139 | 140 | '* Reinitalizes the string buffer. 141 | Sub Clear(Optional ByVal TotalLength As Long) 142 | pCurrent = 0 143 | If TotalLength = 0 Then 144 | pTotal = pInitial 145 | Else 146 | pTotal = TotalLength 147 | End If 148 | pBuf = Space(pTotal) 149 | End Sub 150 | 151 | '* Attempts to reduce storage used for the string. 152 | '* 153 | '* Removes both leading and trailing blank spaces from pBuf and sets 154 | '* the buffer lengths to match. 155 | Sub TrimToSize() 156 | pBuf = Trim$(pBuf) 157 | pCurrent = Len(pBuf) 158 | pTotal = pCurrent 159 | End Sub 160 | 161 | '* Appends to the end of the string property. 162 | '* @param theString The string that is appended to the string property. 163 | '* Passed by Reference only for speed. 164 | '* @param QuoteType the Type of Quotation Style to apply to the StringBuilder string 165 | Sub Append(ByRef theString As String, _ 166 | Optional ByVal QuoteType As sbQuoteStyle) 167 | Dim s As String 168 | Dim bufLen As Long 169 | Dim sLen As Long 170 | 171 | s = Quotify(theString, QuoteType) 172 | sLen = Len(s) 173 | bufLen = pCurrent + sLen 'length of new string 174 | 175 | If bufLen <= pTotal Then 176 | 'MUCH faster than pBuf = pBuf & s 177 | Mid(pBuf, pCurrent + 1, sLen) = s 178 | Else 179 | ' Increase buffer size 180 | While pTotal < bufLen 181 | pTotal = pTotal * 2 182 | Wend 183 | pBuf = Left$(pBuf, pCurrent) _ 184 | & s _ 185 | & Space$(pTotal - bufLen) 186 | End If 187 | pCurrent = bufLen 188 | End Sub 189 | 190 | '* Inserts a string at a specific index of the string property 191 | '* @param theString The string being inserted. 192 | '* @param theIndex The index location where the string is to be inserted 193 | '* @param QuoteType the Type of Quotation Style to apply to the StringBuilder string 194 | Sub Insert(ByRef theString As String, _ 195 | ByVal theIndex As Integer, _ 196 | Optional ByVal QuoteType As sbQuoteStyle) 197 | Dim s As String 198 | Dim lhs As String 199 | Dim rhs As String 200 | Dim sLen As Long 201 | 202 | s = Quotify(theString, QuoteType) 203 | sLen = Me.Length + Len(s) 204 | lhs = Left$(pBuf, theIndex) 205 | rhs = Mid$(pBuf, theIndex + 1, Me.Length - theIndex) 206 | SetString lhs 207 | Me.Append s 208 | Me.Append rhs 209 | End Sub 210 | 211 | '* Places mark up around a string. 212 | '* @note theStr is not modified by Quotify. 213 | '* @param QuoteType the Type of Quotation Style to apply to the StringBuilder string 214 | '* @return the current value of the theStr string 215 | '* surrounded by the specified sbQuoteStyle 216 | Private Function Quotify(ByRef theStr As String, _ 217 | ByVal QuoteType As sbQuoteStyle) As String 218 | Dim leftChar As String 219 | Dim rightChar As String 220 | If QuoteType = sbNone Then 221 | Quotify = theStr 222 | Else 223 | Select Case QuoteType 224 | Case sbDouble 225 | leftChar = Chr(34) 226 | rightChar = leftChar 227 | Case sbSingle 228 | leftChar = Chr(39) 229 | rightChar = leftChar 230 | Case sbSquareBrackets 231 | leftChar = "[" 232 | rightChar = "]" 233 | Case sbExcelDateString 234 | leftChar = "#" 235 | rightChar = leftChar 236 | Case sbADODBSheetReference 237 | leftChar = " [" 238 | rightChar = "$] " 239 | Case Else 240 | leftChar = "" 241 | rightChar = leftChar 242 | End Select 243 | Quotify = leftChar & theStr & rightChar 244 | End If 245 | End Function 246 | 247 | -------------------------------------------------------------------------------- /Strings/t_StringWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_StringWrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseSource 16 | 17 | Private SUT As StringWrapper 18 | Private mMethodsRan&, mMethodCount& 19 | 20 | 21 | 22 | 23 | 24 | Private Sub ITestCaseSource_GetTestCases(ByVal Test As SimplyVBComp.TestCaseCollector) 25 | Select Case Test.MethodName 26 | 27 | Case "Has_GetBoolean" 28 | Test.Use("abcd", "a", True).Expect (True) 29 | Test.Use("abcd", "b", True).Expect (True) 30 | Test.Use("abcd", "c", True).Expect (True) 31 | Test.Use("abcd", "d", True).Expect (True) 32 | Test.Use("abcd", "e", True).Expect (False) 33 | Test.Use("abcd", "a", False).Expect (True) 34 | Test.Use("abcd", "b", False).Expect (True) 35 | Test.Use("abcd", "c", False).Expect (True) 36 | Test.Use("abcd", "d", False).Expect (True) 37 | Test.Use("abcd", "e", False).Expect (False) 38 | 39 | Test.Use("ABCD", "a", True).Expect (False) 40 | Test.Use("ABCD", "b", True).Expect (False) 41 | Test.Use("ABCD", "c", True).Expect (False) 42 | Test.Use("ABCD", "d", True).Expect (False) 43 | Test.Use("ABCD", "e", True).Expect (False) 44 | Test.Use("ABCD", "a", False).Expect (True) 45 | Test.Use("ABCD", "b", False).Expect (True) 46 | Test.Use("ABCD", "c", False).Expect (True) 47 | Test.Use("ABCD", "d", False).Expect (True) 48 | Test.Use("ABCD", "e", False).Expect (False) 49 | 50 | Test.Use("abcd", "A", True).Expect (False) 51 | Test.Use("abcd", "B", True).Expect (False) 52 | Test.Use("abcd", "C", True).Expect (False) 53 | Test.Use("abcd", "D", True).Expect (False) 54 | Test.Use("abcd", "E", True).Expect (False) 55 | Test.Use("abcd", "A", False).Expect (True) 56 | Test.Use("abcd", "B", False).Expect (True) 57 | Test.Use("abcd", "C", False).Expect (True) 58 | Test.Use("abcd", "D", False).Expect (True) 59 | Test.Use("abcd", "E", False).Expect (False) 60 | 61 | Test.Use("ABCD", "A", True).Expect (True) 62 | Test.Use("ABCD", "B", True).Expect (True) 63 | Test.Use("ABCD", "C", True).Expect (True) 64 | Test.Use("ABCD", "D", True).Expect (True) 65 | Test.Use("ABCD", "E", True).Expect (False) 66 | Test.Use("ABCD", "A", False).Expect (True) 67 | Test.Use("ABCD", "B", False).Expect (True) 68 | Test.Use("ABCD", "C", False).Expect (True) 69 | Test.Use("ABCD", "D", False).Expect (True) 70 | Test.Use("ABCD", "E", False).Expect (False) 71 | 72 | 73 | Case "Has_GetPosition" 74 | Test.Use("abcd", "a", True).Expect (1) 75 | Test.Use("abcd", "b", True).Expect (2) 76 | Test.Use("abcd", "c", True).Expect (3) 77 | Test.Use("abcd", "d", True).Expect (4) 78 | Test.Use("abcd", "e", True).Expect (0) 79 | Test.Use("abcd", "a", False).Expect (1) 80 | Test.Use("abcd", "b", False).Expect (2) 81 | Test.Use("abcd", "c", False).Expect (3) 82 | Test.Use("abcd", "d", False).Expect (4) 83 | Test.Use("abcd", "e", False).Expect (0) 84 | 85 | Test.Use("ABCD", "a", True).Expect (0) 86 | Test.Use("ABCD", "b", True).Expect (0) 87 | Test.Use("ABCD", "c", True).Expect (0) 88 | Test.Use("ABCD", "d", True).Expect (0) 89 | Test.Use("ABCD", "e", True).Expect (0) 90 | Test.Use("ABCD", "a", False).Expect (1) 91 | Test.Use("ABCD", "b", False).Expect (2) 92 | Test.Use("ABCD", "c", False).Expect (3) 93 | Test.Use("ABCD", "d", False).Expect (4) 94 | Test.Use("ABCD", "e", False).Expect (0) 95 | 96 | Test.Use("abcd", "A", True).Expect (0) 97 | Test.Use("abcd", "B", True).Expect (0) 98 | Test.Use("abcd", "C", True).Expect (0) 99 | Test.Use("abcd", "D", True).Expect (0) 100 | Test.Use("abcd", "E", True).Expect (0) 101 | Test.Use("abcd", "A", False).Expect (1) 102 | Test.Use("abcd", "B", False).Expect (2) 103 | Test.Use("abcd", "C", False).Expect (3) 104 | Test.Use("abcd", "D", False).Expect (4) 105 | Test.Use("abcd", "E", False).Expect (0) 106 | 107 | Test.Use("ABCD", "A", True).Expect (1) 108 | Test.Use("ABCD", "B", True).Expect (2) 109 | Test.Use("ABCD", "C", True).Expect (3) 110 | Test.Use("ABCD", "D", True).Expect (4) 111 | Test.Use("ABCD", "E", True).Expect (0) 112 | Test.Use("ABCD", "A", False).Expect (1) 113 | Test.Use("ABCD", "B", False).Expect (2) 114 | Test.Use("ABCD", "C", False).Expect (3) 115 | Test.Use("ABCD", "D", False).Expect (4) 116 | Test.Use("ABCD", "E", False).Expect (0) 117 | 118 | End Select 119 | End Sub 120 | 121 | 122 | Public Function Has_GetBoolean(fullStrng As String _ 123 | , subStrng As String _ 124 | , caseSensitiv As Boolean _ 125 | ) As Boolean 126 | 127 | ' Execute method under test. 128 | ' Then return result. 129 | ' 130 | Has_GetBoolean = S_(fullStrng).Has(subStrng, caseSensitiv) 131 | 132 | End Function 133 | 134 | 135 | Public Function Has_GetPosition(fullStrng As String _ 136 | , subStrng As String _ 137 | , caseSensitiv As Boolean _ 138 | ) As Long 139 | 140 | ' Execute method under test. 141 | ' Then return result. 142 | ' 143 | Has_GetPosition = S_(fullStrng).Has(subStrng, caseSensitiv) 144 | 145 | End Function 146 | 147 | 148 | 149 | 150 | 151 | 152 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 153 | ' 154 | ' Test Utility Methods 155 | ' 156 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 157 | 158 | Private Property Get S_(strText As String) As StringWrapper 159 | Call SUT.Init(strText) 160 | Set S_ = SUT 161 | End Property 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 170 | ' 171 | ' Fixture Framework Methods 172 | ' 173 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 174 | 175 | Public Sub FixtureSetup() 176 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 177 | 178 | Set SUT = New StringWrapper 179 | 180 | End Sub 181 | 182 | 183 | Public Sub Setup() 184 | ' 185 | End Sub 186 | 187 | 188 | Public Sub Teardown() 189 | ' 190 | 191 | mMethodsRan = mMethodsRan + 1 192 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 193 | End Sub 194 | 195 | 196 | Public Sub FixtureTeardown() 197 | If mMethodsRan < mMethodCount Then Exit Sub 198 | 199 | Set SUT = Nothing 200 | 'TestBed.QuitExcel 201 | End Sub 202 | -------------------------------------------------------------------------------- /Strings/t_Strings.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_Strings" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseData 16 | 17 | Private SUT1 As wgtTextField 18 | 19 | Private mMethodsRan&, mMethodCount& 20 | 21 | 22 | 23 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 24 | Select Case Test.MethodName 25 | 26 | Case "TrimRight" 27 | Test.Use("tanggal isa", 1).Expect("tanggal is").TestName "Trim 1 char" 28 | Test.Use("tanggal adwa", 2).Expect("tanggal ad").TestName "Trim 2 chars" 29 | Test.Use("tanggal apat", 4).Expect("tanggal ").TestName "Trim 4 chars" 30 | 31 | Test.Use("tanggal wala", 0).Expect("tanggal wala").TestName "Trim 0 chars" 32 | Test.Use("", 1).Expect("").TestName "Trim blank string" 33 | 34 | Test.Use("sobra", 10).Expect("sobra").TestName "Trim too much" 35 | Test.Use("lahat", 5).Expect("").TestName "Trim all" 36 | 37 | End Select 38 | End Sub 39 | 40 | 41 | 42 | Public Function TrimRight(origText As String _ 43 | , Optional charsToTrim As Long = 1 _ 44 | ) As String 45 | 46 | TrimRight = SUT1.TrimRight(origText, charsToTrim) 47 | 48 | End Function 49 | 50 | 51 | 52 | 53 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 54 | ' 55 | ' Test Utility Methods 56 | ' 57 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 58 | 59 | Private Sub DoSomething() 60 | 61 | End Sub 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 70 | ' 71 | ' Fixture Framework Methods 72 | ' 73 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 74 | 75 | Public Sub FixtureSetup() 76 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 77 | 78 | End Sub 79 | 80 | 81 | Public Sub Setup() 82 | Set SUT1 = New wgtTextField 83 | End Sub 84 | 85 | 86 | Public Sub Teardown() 87 | Set SUT1 = Nothing 88 | 89 | mMethodsRan = mMethodsRan + 1 90 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 91 | End Sub 92 | 93 | 94 | Public Sub FixtureTeardown() 95 | If mMethodsRan < mMethodCount Then Exit Sub 96 | 97 | 'TestBed.QuitExcel 98 | End Sub 99 | -------------------------------------------------------------------------------- /Timers/SelfTimerDemo.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Form=frmDemo.frm 3 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#..\..\WINDOWS\system32\stdole2.tlb#OLE Automation 4 | Class=SelfTimer; SelfTimer.cls 5 | IconForm="frmDemo" 6 | Startup="frmDemo" 7 | Command32="" 8 | Name="SelfTimerDemo" 9 | HelpContextID="0" 10 | CompatibleMode="0" 11 | MajorVer=1 12 | MinorVer=0 13 | RevisionVer=0 14 | AutoIncrementVer=0 15 | ServerSupportFiles=0 16 | VersionCompanyName="n/a" 17 | CompilationType=0 18 | OptimizationType=0 19 | FavorPentiumPro(tm)=0 20 | CodeViewDebugInfo=0 21 | NoAliasing=0 22 | BoundsCheck=0 23 | OverflowCheck=0 24 | FlPointCheck=0 25 | FDIVCheck=0 26 | UnroundedFP=0 27 | StartMode=0 28 | Unattended=0 29 | Retained=0 30 | ThreadPerObject=0 31 | MaxNumberOfThreads=1 32 | 33 | [MS Transaction Server] 34 | AutoRefresh=1 35 | -------------------------------------------------------------------------------- /Timers/SelfTimerDemo.vbw: -------------------------------------------------------------------------------- 1 | frmDemo = 110, 386, 701, 878, , 66, 66, 459, 688, C 2 | SelfTimer = 22, 22, 701, 749, 3 | -------------------------------------------------------------------------------- /Timers/TickCounter.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "TickCounter" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = True 14 | Option Explicit 15 | 16 | Private mStartTick As Long 17 | Private mCallCount As Long 18 | Private mSecondsElapsed As Double 19 | 20 | Public Enum TickCounterErrors 21 | ErrorBase = 9999 22 | 23 | End Enum 24 | 25 | ' Number of milliseconds since Windows was started 26 | Private Declare Function GetTickCount Lib "kernel32" () As Long 27 | Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 28 | 29 | 30 | Public Function CalledTooOften(thresholdOfCalls As Long _ 31 | ) As Boolean 32 | If mCallCount = thresholdOfCalls Then 33 | mCallCount = 0 34 | Else 35 | CalledTooOften = True 36 | mCallCount = mCallCount + 1 37 | End If 38 | End Function 39 | 40 | 41 | Public Sub Pause(forHowManySeconds As Single) 42 | On Error GoTo ErrH 43 | 44 | Call Sleep(forHowManySeconds * 1000) 45 | 46 | On Error GoTo 0 47 | Exit Sub 48 | ErrH: ThrowError "Pause" ', "Line: " & Erl 49 | End Sub 50 | 51 | 52 | Public Property Get SecondIsDivisibleBy(lSecondsDivisor As Long _ 53 | ) As Boolean 54 | 55 | If (GetTickCount Mod lSecondsDivisor * 1000) = 0 _ 56 | Then SecondIsDivisibleBy = True 57 | 58 | End Property 59 | 60 | 61 | Public Property Get CurrentTick() As Long 62 | CurrentTick = GetTickCount 63 | End Property 64 | 65 | 66 | Public Function CalledTooSoon(Optional milliSecs As Long = 1000 _ 67 | ) As Boolean 68 | CalledTooSoon = GetTickCount() < mStartTick + milliSecs 69 | End Function 70 | 71 | 72 | Public Function StartTiming() As Long 73 | On Error GoTo ErrH 74 | 75 | mStartTick = GetTickCount ' store starting tickCount in private var 76 | StartTiming = mStartTick ' return stored tickCount 77 | 78 | On Error GoTo 0 79 | Exit Function 80 | ErrH: ThrowError "StartTiming" 81 | End Function 82 | 83 | 84 | Public Function StopTiming(Optional formatted As Boolean = True _ 85 | , Optional formt As String = "#,0.000 sec" _ 86 | ) As Variant 87 | On Error GoTo ErrH 88 | 89 | mSecondsElapsed = (GetTickCount - mStartTick) / 1000 90 | 91 | If formatted Then 92 | StopTiming = Format$(mSecondsElapsed, formt) 93 | 94 | Else 95 | StopTiming = mSecondsElapsed 96 | End If 97 | 98 | On Error GoTo 0 99 | Exit Function 100 | ErrH: ThrowError "StopTiming" 101 | End Function 102 | 103 | 104 | Public Function Rate(amountOfWork As Variant _ 105 | , unitOfMeasure As String _ 106 | , Optional numberFmt As String = "#,#" _ 107 | ) As String 108 | Dim workPerSec As Double 109 | On Error GoTo ErrH 110 | 111 | If mSecondsElapsed < 1 Then 112 | workPerSec = CDbl(amountOfWork) 113 | Else 114 | workPerSec = CDbl(amountOfWork) / mSecondsElapsed 115 | End If 116 | 117 | Rate = Format$(workPerSec, numberFmt) & " " & unitOfMeasure 118 | 119 | On Error GoTo 0 120 | Exit Function 121 | ErrH: ThrowError "Rate" ', "Line: " & Erl 122 | End Function 123 | 124 | 125 | 'Public Function fmtTicks(tickCount As Long _ 126 | ' ) As String 127 | ' Dim tickSec As Double 128 | ' Dim t1 As Double, t2 As Double, t3 As Double 129 | ' 130 | ' tickSec = tickCount / 1000 131 | ' 132 | ' If tickSec > 60 * 60 * 2 Then ' if greater than 2 hours... 133 | ' t1 = tickSec \ (60 * 60) 134 | ' t2 = (tickSec - (t1 * 60 * 60)) \ 60 135 | ' t3 = tickSec Mod 60 136 | ' 'fmtTicks = CInt(t1) & " hr, " & CInt(t2) & " min, " & CInt(t3) & " sec" 137 | ' fmtTicks = u.plural("hr", CLng(t1), False) _ 138 | ' & ", " & u.plural("min", CLng(t2), False) _ 139 | ' & ", " & u.plural("sec", CLng(t3), False) 140 | ' 141 | ' 142 | ' ElseIf tickSec > 100 Then ' if greater than 100 seconds... 143 | ' t1 = tickSec \ 60 144 | ' t2 = tickSec Mod 60 145 | ' 'fmtTicks = CInt(t1) & " min, " & CInt(t2) & " sec" 146 | ' fmtTicks = u.plural("min", CLng(t1), False) _ 147 | ' & ", " & u.plural("sec", CLng(t2), False) 148 | ' 149 | ' Else 150 | ' fmtTicks = Format$(tickSec, "#,0.00") & " sec" 151 | ' End If 152 | 'End Function 153 | 154 | 155 | 156 | 157 | 158 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 159 | ' 160 | ' Error Handler Override 161 | ' 162 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 163 | 164 | Private Sub ThrowError(ByVal currentProcedure As String _ 165 | , Optional ByVal errorDescrption As String _ 166 | , Optional ByVal errorNumber As TickCounterErrors = -1 _ 167 | ) 168 | Const MOD_NAME = "TickCounter" 169 | 170 | Call ErrorHandler.ThrowError(MOD_NAME _ 171 | , currentProcedure _ 172 | , errorDescrption _ 173 | , errorNumber) 174 | End Sub 175 | 176 | 177 | 178 | 179 | 180 | -------------------------------------------------------------------------------- /Timers/frmDemo.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmDemo 3 | BorderStyle = 1 'Fixed Single 4 | Caption = "SelfTimer demo" 5 | ClientHeight = 495 6 | ClientLeft = 45 7 | ClientTop = 420 8 | ClientWidth = 4335 9 | LinkTopic = "Form1" 10 | MaxButton = 0 'False 11 | ScaleHeight = 495 12 | ScaleWidth = 4335 13 | StartUpPosition = 3 'Windows Default 14 | Begin VB.Label lblTimer 15 | AutoSize = -1 'True 16 | Height = 195 17 | Left = 120 18 | TabIndex = 0 19 | Top = 120 20 | Width = 45 21 | End 22 | End 23 | Attribute VB_Name = "frmDemo" 24 | Attribute VB_GlobalNameSpace = False 25 | Attribute VB_Creatable = False 26 | Attribute VB_PredeclaredId = True 27 | Attribute VB_Exposed = False 28 | Option Explicit 29 | 30 | Dim WithEvents Timer As SelfTimer 31 | Attribute Timer.VB_VarHelpID = -1 32 | 33 | Private Sub Form_Load() 34 | Set Timer = New SelfTimer 35 | Timer.Interval = 1 36 | End Sub 37 | 38 | Private Sub Form_Terminate() 39 | Set Timer = Nothing 40 | End Sub 41 | 42 | Private Sub Timer_Timer(ByVal Seconds As Currency) 43 | lblTimer.Caption = Format$(Seconds, "0.000") & " seconds has passed" 44 | End Sub 45 | -------------------------------------------------------------------------------- /VLC/axvlc.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/VLC/axvlc.dll -------------------------------------------------------------------------------- /VLC/libvlc.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/VLC/libvlc.dll -------------------------------------------------------------------------------- /VLC/libvlccore.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/VLC/libvlccore.dll -------------------------------------------------------------------------------- /VLC/npvlc.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/VLC/npvlc.dll -------------------------------------------------------------------------------- /Web API/IWebApiClient.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "IWebApiClient" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Public Enum WebApiResponseCodes 17 | resp_OK = 200 18 | resp_Created = 201 19 | resp_BadRequest = 400 20 | resp_Unauthorized = 401 21 | resp_NotFound = 404 22 | resp_ServerError = 500 23 | End Enum 24 | 25 | 26 | Public UserName As String 27 | Public Password As String 28 | 29 | Public ContentType As String 30 | Public BaseURL As String 31 | 32 | 33 | Public Property Get ResponseText() As String 34 | End Property 35 | 36 | 37 | 38 | 39 | 40 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 41 | ' 42 | ' Main Method 43 | ' 44 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 45 | 46 | Public Function SendRequest(httpMethd As String _ 47 | , url_withParams_withoutBase As String _ 48 | , Optional reqstBody As String _ 49 | , Optional raiseErrs As Boolean = True _ 50 | ) As cCollection 51 | End Function 52 | 53 | 54 | 55 | 56 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 57 | ' 58 | ' Constructor 59 | ' 60 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 61 | 62 | Public Sub Init(wbApiBaseUrl As String _ 63 | , Optional userNme As String _ 64 | , Optional passwrd As String _ 65 | , Optional contentTyp$ = "application/json; charset=utf-8" _ 66 | ) 67 | End Sub 68 | 69 | 70 | 71 | 72 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 73 | ' 74 | ' Status Accessors 75 | ' 76 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 77 | 78 | Public Property Get StatusCode() As WebApiResponseCodes 79 | End Property 80 | 81 | Public Property Get StatusText() As String 82 | End Property 83 | 84 | -------------------------------------------------------------------------------- /Wiki/WikiParser1.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "WikiParser1" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum WikiParser1Errors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As WikiParser1Errors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | 32 | 33 | 34 | 35 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 36 | ' 37 | ' Constructor 38 | ' 39 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 40 | 41 | Public Sub Init() 42 | 43 | End Sub 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 54 | ' 55 | ' Class Events 56 | ' 57 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 58 | 59 | Private Sub Class_Initialize() 60 | On Error GoTo ErrH 61 | 62 | 'Set mSomeObject = New Something 63 | 64 | ErrH: Blame "Class_Initialize" 65 | End Sub 66 | 67 | Private Sub Class_Terminate() 68 | On Error GoTo ErrH 69 | 70 | 'Set mSomeObject = Nothing 71 | 72 | ErrH: Blame "Class_Terminate" 73 | End Sub 74 | 75 | 76 | 77 | 78 | 79 | 80 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 81 | ' 82 | ' Error Handlers 83 | ' 84 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 85 | 86 | Private Sub ErrorIf(errCondition As Boolean _ 87 | , errorMsg As String _ 88 | , Optional errorNumbr As WikiParser1Errors = -1 _ 89 | ) 90 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 91 | End Sub 92 | 93 | Private Sub SaveError() 94 | With mError 95 | If Err Then 96 | .HasError = True 97 | .Description = Err.Description 98 | .Number = Err.Number 99 | .Source = Err.Source 100 | 101 | Else 102 | .HasError = False 103 | .Description = vbNullString 104 | .Number = 0 105 | .Source = vbNullString 106 | End If 107 | End With 108 | Err.Clear 109 | End Sub 110 | 111 | Private Sub Blame(ByVal currntProcedure As String _ 112 | , Optional ByVal errorDescrption As String _ 113 | , Optional ByVal errorNumbr As WikiParser1Errors = -1 _ 114 | ) 115 | Call SaveError 116 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 117 | End Sub 118 | 119 | Private Sub LoadError(ByVal currntProcedure As String _ 120 | , Optional ByVal errorDescrption As String _ 121 | , Optional ByVal errorNumbr As WikiParser1Errors = -1 _ 122 | ) 123 | With mError 124 | If Not .HasError Then Exit Sub 125 | 126 | If LenB(errorDescrption) = 0 Then 127 | errorDescrption = .Description 128 | Else 129 | errorDescrption = .Description & vbCrLf & errorDescrption 130 | End If 131 | 132 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 133 | 134 | If errorNumbr = -1 Then errorNumbr = .Number 135 | 136 | Select Case errorNumbr 137 | Case NotInitted 138 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 139 | & "Please call " & TypeName(Me) _ 140 | & ".Init() before " & currntProcedure & "." 141 | 142 | Case Else 143 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 144 | End Select 145 | 146 | Err.Raise errorNumbr, .Source, errorDescrption 147 | 148 | End With 149 | End Sub 150 | 151 | -------------------------------------------------------------------------------- /Wiki/t_WikiParser1.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_WikiParser1" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Implements ITestCaseData 17 | 18 | Private SUT As WikiParser1 19 | Private mMethodsRan&, mMethodCount& 20 | 21 | 22 | 23 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 24 | Select Case Test.MethodName 25 | 26 | Case "MethodName_GoesHere" 27 | 28 | End Select 29 | End Sub 30 | 31 | 32 | 33 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 34 | ' 35 | ' Test Utility Methods 36 | ' 37 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 38 | 39 | Private Sub DoSomething() 40 | 41 | End Sub 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 50 | ' 51 | ' Fixture Framework Methods 52 | ' 53 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 54 | 55 | Public Sub FixtureSetup() 56 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 57 | 58 | End Sub 59 | 60 | 61 | Public Sub Setup() 62 | Set SUT = New WikiParser1 63 | End Sub 64 | 65 | 66 | Public Sub Teardown() 67 | Set SUT = Nothing 68 | 69 | mMethodsRan = mMethodsRan + 1 70 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 71 | End Sub 72 | 73 | 74 | Public Sub FixtureTeardown() 75 | If mMethodsRan < mMethodCount Then Exit Sub 76 | 77 | 'TestBed.QuitExcel 78 | End Sub 79 | -------------------------------------------------------------------------------- /XML/XmlWriter.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/XML/XmlWriter.cls -------------------------------------------------------------------------------- /XML/cElementWrappers.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "cElementWrappers" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | Private Enum cElementWrappersErrors ' you may make this Public for tests 17 | ErrorBase = vbObjectError + 513 ' you may adjust this minimum 18 | NotInitted 19 | AlreadyInitted 20 | ' add error numbers here 21 | End Enum 22 | 23 | Private Type ErrorHolder ' 24 | HasError As Boolean ' temp storage for errors 25 | Source As String ' 26 | Number As cElementWrappersErrors ' 27 | Description As String 28 | End Type 29 | Private mError As ErrorHolder 30 | 31 | Private mCollection As CollectionWrapper 32 | 33 | 34 | 35 | Public Function Add(cElementWrapprObj As cElementWrapper) As cElementWrapper 36 | Set Add = mCollection.Add(cElementWrapprObj) 37 | End Function 38 | 39 | 40 | Public Sub Clear() 41 | mCollection.Clear 42 | End Sub 43 | 44 | 45 | Public Property Get Count() As Long 46 | Count = mCollection.Count 47 | End Property 48 | 49 | 50 | Public Property Get Item(zeroBasedIndx As Long) As cElementWrapper 51 | Attribute Item.VB_UserMemId = 0 52 | Set Item = mCollection.Item(zeroBasedIndx) 53 | End Property 54 | 55 | 56 | Public Function NewEnum() As IUnknown 57 | Attribute NewEnum.VB_UserMemId = -4 58 | Attribute NewEnum.VB_MemberFlags = "40" 59 | Set NewEnum = mCollection.NewEnum 60 | End Function 61 | 62 | 63 | Public Sub Remove(zeroBasedIndx As Long) 64 | Call mCollection.Remove(zeroBasedIndx) 65 | End Sub 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 76 | ' 77 | ' Class Events 78 | ' 79 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 80 | 81 | Private Sub Class_Initialize() 82 | On Error GoTo ErrH 83 | 84 | Set mCollection = New CollectionWrapper 85 | 86 | ErrH: Blame "Class_Initialize" 87 | End Sub 88 | 89 | Private Sub Class_Terminate() 90 | On Error GoTo ErrH 91 | 92 | If Not mCollection Is Nothing _ 93 | Then mCollection.Clear 94 | 95 | Set mCollection = Nothing 96 | 97 | ErrH: Blame "Class_Terminate" 98 | End Sub 99 | 100 | 101 | 102 | 103 | 104 | 105 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 106 | ' 107 | ' Error Handlers 108 | ' 109 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 110 | 111 | Private Sub ErrorIf(errCondition As Boolean _ 112 | , errorMsg As String _ 113 | , Optional errorNumbr As cElementWrappersErrors = -1 _ 114 | ) 115 | If errCondition Then Err.Raise errorNumbr, TypeName(Me), errorMsg 116 | End Sub 117 | 118 | Private Sub SaveError() 119 | With mError 120 | If Err Then 121 | .HasError = True 122 | .Description = Err.Description 123 | .Number = Err.Number 124 | .Source = Err.Source 125 | 126 | Else 127 | .HasError = False 128 | .Description = vbNullString 129 | .Number = 0 130 | .Source = vbNullString 131 | End If 132 | End With 133 | Err.Clear 134 | End Sub 135 | 136 | Private Sub Blame(ByVal currntProcedure As String _ 137 | , Optional ByVal errorDescrption As String _ 138 | , Optional ByVal errorNumbr As cElementWrappersErrors = -1 _ 139 | ) 140 | Call SaveError 141 | Call LoadError(currntProcedure, errorDescrption, errorNumbr) 142 | End Sub 143 | 144 | Private Sub LoadError(ByVal currntProcedure As String _ 145 | , Optional ByVal errorDescrption As String _ 146 | , Optional ByVal errorNumbr As cElementWrappersErrors = -1 _ 147 | ) 148 | With mError 149 | If Not .HasError Then Exit Sub 150 | 151 | If LenB(errorDescrption) = 0 Then 152 | errorDescrption = .Description 153 | Else 154 | errorDescrption = .Description & vbCrLf & errorDescrption 155 | End If 156 | 157 | currntProcedure = TypeName(Me) & "." & currntProcedure & "()" 158 | 159 | If errorNumbr = -1 Then errorNumbr = .Number 160 | 161 | Select Case errorNumbr 162 | Case NotInitted 163 | errorDescrption = TypeName(Me) & " not initted." & vbCrLf _ 164 | & "Please call " & TypeName(Me) _ 165 | & ".Init() before " & currntProcedure & "." 166 | 167 | Case Else 168 | errorDescrption = currntProcedure & vbCrLf & errorDescrption 169 | End Select 170 | 171 | Err.Raise errorNumbr, .Source, errorDescrption 172 | 173 | End With 174 | End Sub 175 | 176 | -------------------------------------------------------------------------------- /XML/t_XmlWriter.cls: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/XML/t_XmlWriter.cls -------------------------------------------------------------------------------- /XML/t_cElementWrapper.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_cElementWrapper" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseData 16 | 17 | Private SUT As cElementWrapper _ 18 | , mDOM As cSimpleDOM 19 | 20 | Private mMethodsRan&, mMethodCount& 21 | 22 | 23 | 24 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 25 | Select Case Test.MethodName 26 | 27 | Case "Find" 28 | Test.Use("id=item4").Expect("Text of item4").TestName "id: no space between" 29 | Test.Use("id =item3").Expect("Text of item3").TestName "id: space before" 30 | Test.Use("id= item2").Expect("Text of item2").TestName "id: space after" 31 | Test.Use("id = item1").Expect("Text of item1").TestName "id: space both" 32 | 33 | Test.Use("att=att4").Expect("Text of item4").TestName "att: no space between" 34 | Test.Use("att =att3").Expect("Text of item3").TestName "att: space before" 35 | Test.Use("att= att2").Expect("Text of item2").TestName "att: space after" 36 | Test.Use("att = att1").Expect("Text of item1").TestName "att: space both" 37 | 38 | Case "Tag" 39 | Test.Use("a").Expect "item a" 40 | Test.Use("c").Expect "item c" 41 | Test.Use("1").Expect "item b" 42 | Test.Use("3").Expect "item d" 43 | Test.Use(0).Expect "item a" 44 | Test.Use(2).Expect "item c" 45 | 46 | Case "Text" 47 | Test.Use("123").Expect "123" 48 | Test.Use("123").Expect "123" 49 | Test.Use("123234").Expect "123234" 50 | Test.Use("
").Expect "" 51 | Test.Use("
").Expect "" 52 | 53 | Case "Enumerable" 54 | Test.Use "oneTag" 55 | Test.Use "tag1", "tag2" 56 | Test.Use "t1", "t2", "t3", "t4", "t5", "t6", "t7" 57 | 58 | 59 | Case "ChildCount" 60 | Test.Use("Hi!").Expect 1 61 | Test.Use("
").Expect 1 62 | Test.Use("

").Expect 2 63 | Test.Use("").Expect 2 64 | Test.Use("").Expect 0 65 | Test.Use("").Expect 0 66 | 67 | End Select 68 | End Sub 69 | 70 | 71 | Public Function ChildCount(xmlStr$) As Long 72 | 73 | Call SUT.Init(Parse(xmlStr)) 74 | 75 | ChildCount = SUT.ChildCount 76 | 77 | End Function 78 | 79 | 'Public Sub Enumerable(ParamArray tagNmes() As Variant) 80 | ' Dim i&, e As Object 81 | ' 82 | ' 83 | ' ' compose and load XML 84 | ' ' 85 | ' With New_Xml("root") 86 | ' For i = 0 To UBound(tagNmes) 87 | ' .Tag(tagNmes(i)).InnerText = Rand.mWord 88 | ' Next i 89 | ' 90 | ' Call SUT.Init(Parse(.ToString)) 91 | ' End With 92 | ' 93 | ' 94 | ' ' attempt Enumeration 95 | ' ' 96 | ' For Each e In SUT 97 | ' 98 | ' Assert.That e.Name, Iz.EqualTo(tagNmes(i)) _ 99 | ' , "Should be support 'For-Each' enumeration." 100 | ' 101 | ' i = i + 1 102 | ' Next e 103 | ' 104 | ' Set e = Nothing 105 | 'End Sub 106 | 107 | 108 | 109 | Public Function Text(xmlStr As String) As String 110 | 111 | Call SUT.Init(Parse(xmlStr)) 112 | 113 | Text = SUT.Text 114 | End Function 115 | 116 | Public Function Tag(tagNameOrIndx) As String 117 | Dim xmlStr$: xmlStr _ 118 | = "" _ 119 | & " item a" _ 120 | & " item b" _ 121 | & " item c" _ 122 | & " item d" _ 123 | & "" 124 | 125 | Call SUT.Init(Parse(xmlStr)) 126 | 127 | Tag = SUT.Tag(tagNameOrIndx).Text 128 | 129 | End Function 130 | 131 | 132 | Public Function Find(searchFiltr$) As String 133 | Dim xmlStr$: xmlStr _ 134 | = "" _ 135 | & " Text of item1" _ 136 | & " Text of item2" _ 137 | & " Text of item3" _ 138 | & " Text of item4" _ 139 | & "" 140 | 141 | Call SUT.Init(Parse(xmlStr)) 142 | 143 | Find = SUT.Find(searchFiltr).Text 144 | 145 | End Function 146 | 147 | 148 | Public Sub Find_ErrorIfNotFound() 149 | Dim xmlStr$: xmlStr _ 150 | = "" _ 151 | & " Text of item1" _ 152 | & " Text of item2" _ 153 | & "" 154 | 155 | Call SUT.Init(Parse(xmlStr)) 156 | 157 | Assert.Throws cElementWrapperErrors.ItemNotFound 158 | 159 | Call SUT.Find("id = item3") 160 | 161 | End Sub 162 | 163 | Public Sub Find_NoErrorIfNotFound() 164 | Dim xmlStr$: xmlStr _ 165 | = "" _ 166 | & " Text of item1" _ 167 | & " Text of item2" _ 168 | & "" 169 | 170 | Call SUT.Init(Parse(xmlStr)) 171 | 172 | Assert.That SUT.Find("id = item3", False), Iz.Nothing _ 173 | , "Should not raise error if we don't want it to." 174 | End Sub 175 | 176 | Public Sub Find_ErrorIfNoChildren() 177 | Dim xmlStr$: xmlStr _ 178 | = "" _ 179 | & "" 180 | 181 | Call SUT.Init(Parse(xmlStr)) 182 | 183 | Assert.Throws cElementWrapperErrors.NoChildren 184 | 185 | Call SUT.Find("child=any") 186 | 187 | End Sub 188 | 189 | Public Sub Find_NoErrorIfNoChildren() 190 | Dim xmlStr$: xmlStr _ 191 | = "" _ 192 | & "" 193 | 194 | Call SUT.Init(Parse(xmlStr)) 195 | 196 | Assert.That SUT.Find("child=any", False), Iz.Nothing _ 197 | , "Should not raise error if we don't want it to." 198 | End Sub 199 | 200 | 201 | 202 | 203 | Public Sub Tag_ErrorIfNotFound() 204 | Dim xmlStr$: xmlStr _ 205 | = "" _ 206 | & " Text of tag1" _ 207 | & " Text of tag2" _ 208 | & "" 209 | 210 | Call SUT.Init(Parse(xmlStr)) 211 | 212 | Assert.Throws cElementWrapperErrors.ItemNotFound 213 | 214 | Call SUT.Tag("tag3") 215 | 216 | End Sub 217 | 218 | Public Sub Tag_NoErrorIfNotFound() 219 | Dim xmlStr$: xmlStr _ 220 | = "" _ 221 | & " Text of tag1" _ 222 | & " Text of tag2" _ 223 | & "" 224 | 225 | Call SUT.Init(Parse(xmlStr)) 226 | 227 | Assert.That SUT.Tag("tag3", False), Iz.Nothing _ 228 | , "Should not raise error if we don't want it to." 229 | End Sub 230 | 231 | Public Sub Tag_ErrorIfNoChildren() 232 | Dim xmlStr$: xmlStr _ 233 | = "" _ 234 | & "" 235 | 236 | Call SUT.Init(Parse(xmlStr)) 237 | 238 | Assert.Throws cElementWrapperErrors.NoChildren 239 | 240 | Call SUT.Tag("child") 241 | 242 | End Sub 243 | 244 | Public Sub Tag_NoErrorIfNoChildren() 245 | Dim xmlStr$: xmlStr _ 246 | = "" _ 247 | & "" 248 | 249 | Call SUT.Init(Parse(xmlStr)) 250 | 251 | Assert.That SUT.Tag("child", False), Iz.Nothing _ 252 | , "Should not raise error if we don't want it to." 253 | End Sub 254 | 255 | 256 | 257 | 258 | 259 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 260 | ' 261 | ' Test Utility Methods 262 | ' 263 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 264 | 265 | Private Function Parse(xmlStr$) As cElement 266 | 267 | Set mDOM = Nothing 268 | Set mDOM = New_RC4.SimpleDOM(xmlStr) 269 | 270 | Set Parse = mDOM.Root 271 | 272 | End Function 273 | 274 | 275 | 276 | 277 | 278 | 279 | 280 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 281 | ' 282 | ' Fixture Framework Methods 283 | ' 284 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 285 | 286 | Public Sub FixtureSetup() 287 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 288 | 289 | End Sub 290 | 291 | 292 | Public Sub Setup() 293 | Set SUT = New cElementWrapper 294 | 295 | End Sub 296 | 297 | 298 | Public Sub Teardown() 299 | Set SUT = Nothing 300 | Set mDOM = Nothing 301 | 302 | mMethodsRan = mMethodsRan + 1 303 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 304 | End Sub 305 | 306 | 307 | Public Sub FixtureTeardown() 308 | If mMethodsRan < mMethodCount Then Exit Sub 309 | 310 | 'TestBed.QuitExcel 311 | End Sub 312 | -------------------------------------------------------------------------------- /t_Replacements.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_Replacements" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | Implements ITestCaseData 16 | 17 | Private mMethodsRan&, mMethodCount& 18 | 19 | 20 | 21 | Private Sub ITestCaseData_GetTestData(ByVal Test As SimplyVBUnit.TestDataBuilder) 22 | Dim s$(), d$, v, a$ 23 | Select Case Test.MethodName 24 | 25 | Case "Join_SameResult" 26 | s = Rand.mWords: d = Rand.mSyllable 27 | Test.Use(s, d).TestName "words, syllable" 28 | 29 | s = Rand.mSyllables: d = Rand.mWord 30 | Test.Use(s, d).TestName "syllables, word" 31 | 32 | s = Rand.mPhrases: d = Rand.mWord 33 | Test.Use(s, d).TestName "phrases, word" 34 | 35 | 36 | Case "IsNumeric_Replacement" 37 | v = Null: Test.Use(v).Expect(False).TestName "Null" 38 | v = Empty: Test.Use(v).Expect(False).TestName "Empty" 39 | v = 0: Test.Use(v).Expect(True).TestName v & "%" 40 | v = "0": Test.Use(v).Expect(True).TestName v & "$" 41 | v = True: Test.Use(v).Expect(False).TestName v 42 | v = False: Test.Use(v).Expect(False).TestName v 43 | 44 | v = 567: Test.Use(v).Expect(True).TestName v 45 | v = 123.45: Test.Use(v).Expect(True).TestName v 46 | v = "abcd": Test.Use(v).Expect(False).TestName v 47 | 48 | v = "123-": Test.Use(v).Expect(False).TestName v 49 | v = "-123": Test.Use(v).Expect(True).TestName v 50 | v = "234+": Test.Use(v).Expect(False).TestName v 51 | v = "+63917": Test.Use(v).Expect(False).TestName v 52 | v = "0917": Test.Use(v).Expect(False).TestName v 53 | 54 | v = 0.5: Test.Use(v).Expect(True).TestName v & "&" 55 | v = "0.5": Test.Use(v).Expect(True).TestName v & "$" 56 | 57 | v = "12e45": Test.Use(v).Expect(False).TestName v & "$ lower" 58 | v = "12E45": Test.Use(v).Expect(False).TestName v & "$ upper" 59 | v = 1.2E+46: Test.Use(v).Expect(True).TestName v & "#" 60 | v = "1.2E+46": Test.Use(v).Expect(True).TestName v & "$" 61 | v = "1e3.4": Test.Use(v).Expect(False).TestName v & "$" 62 | v = "1e+34": Test.Use(v).Expect(True).TestName v & "$" 63 | v = 1E+34: Test.Use(v).Expect(True).TestName v & "#" 64 | 65 | v = "1d34": Test.Use(v).Expect(False).TestName v & "$ lower" 66 | v = "1D34": Test.Use(v).Expect(False).TestName v & "$ upper" 67 | 68 | v = "1,23": Test.Use(v).Expect(False).TestName v 69 | 70 | 71 | Case "CustomTrim" 72 | Test.Use(" abc ").Expect "abc" 73 | Test.Use(" abc ").Expect "abc" 74 | Test.Use(" abc ").Expect "abc" 75 | Test.Use(Space(5) & "abc" & Space(10)).Expect "abc" 76 | Test.Use(vbCrLf & "abc ").Expect "abc" 77 | Test.Use(" abc" & vbCrLf).Expect "abc" 78 | Test.Use("").Expect "" 79 | Test.Use(" ").Expect "" 80 | Test.Use(vbCrLf).Expect "" 81 | 82 | 83 | Case "GetTokens" 84 | d = "[a]bc": Test.Use(d).Expect(Array("a")).TestName d 85 | d = "a[b]c": Test.Use(d).Expect(Array("b")).TestName d 86 | d = "ab[c]": Test.Use(d).Expect(Array("c")).TestName d 87 | d = "[ab]c": Test.Use(d).Expect(Array("ab")).TestName d 88 | d = "a[bc]": Test.Use(d).Expect(Array("bc")).TestName d 89 | d = "[abc]": Test.Use(d).Expect(Array("abc")).TestName d 90 | d = "[a]b[c]de[f]g": Test.Use(d).Expect(Array("a", "c", "f")).TestName d 91 | d = "a[b]c[d][e]f[g]": Test.Use(d).Expect(Array("b", "d", "e", "g")).TestName d 92 | d = "a~[b]~c": Test.Use(d, "~[", "]~").Expect(Array("b")).TestName d 93 | d = "a~~[bcde]f": Test.Use(d, "~~[", "]").Expect(Array("bcde")).TestName d 94 | 95 | Case "Occurence" 96 | d = "abcde": a = "f": Test.Use(d, a).Expect(0).TestName d & " | " & a 97 | d = "a.b.c": a = ".": Test.Use(d, a).Expect(2).TestName d & " | " & a 98 | d = "a.b.c": a = "a.": Test.Use(d, a).Expect(1).TestName d & " | " & a 99 | d = "a.b.c": a = "c": Test.Use(d, a).Expect(1).TestName d & " | " & a 100 | d = "a.b.c": a = "a.b": Test.Use(d, a).Expect(1).TestName d & " | " & a 101 | d = "a.b.c": a = ".b.c": Test.Use(d, a).Expect(1).TestName d & " | " & a 102 | d = "abccc": a = "c": Test.Use(d, a).Expect(3).TestName d & " | " & a 103 | d = "abCcC": a = "c": Test.Use(d, a, vbTextCompare).Expect(3).TestName d & " || " & a 104 | d = "bbbbc": a = "b": Test.Use(d, a).Expect(4).TestName d & " | " & a 105 | d = "aaabc": a = "a": Test.Use(d, a).Expect(3).TestName d & " | " & a 106 | d = "Count
occur
ences of
the tag
.": a = "
": Test.Use(d, a).Expect(4).TestName d & " | " & a 107 | 108 | End Select 109 | End Sub 110 | 111 | 112 | Public Sub ArrayEmpty_String1D_Unredimmed() 113 | Dim ss$() 114 | 115 | Assert.That ((Not ss) = -1), Iz.True 116 | 117 | End Sub 118 | 119 | Public Sub ArrayEmpty_String1D_1stItemBlank() 120 | Dim ss$() 121 | 122 | ReDim ss(0) 123 | 124 | Assert.That ((Not ss) = -1), Iz.False 125 | 126 | End Sub 127 | 128 | Public Sub ArrayEmpty_String1D_2Items() 129 | Dim ss$() 130 | 131 | ReDim ss(1) 132 | ss(1) = "blah" 133 | 134 | Assert.That ((Not ss) = -1), Iz.False 135 | 136 | End Sub 137 | 138 | Public Sub ArrayEmpty_String1D_Erased() 139 | Dim ss$() 140 | 141 | ReDim ss(1) 142 | ss(1) = "blah" 143 | 144 | Erase ss 145 | 146 | Assert.That ((Not ss) = -1), Iz.True 147 | 148 | End Sub 149 | 150 | 151 | 152 | Public Function GetTokens(strWithTokens As String _ 153 | , Optional startMarkr As String = "[" _ 154 | , Optional endMarkr As String = "]" _ 155 | ) As String() 156 | GetTokens = Replacements.GetTokens(strWithTokens, startMarkr, endMarkr) 157 | End Function 158 | 159 | Public Function Occurence(strText$, findThisStr$ _ 160 | , Optional compareMethd As VbCompareMethod = vbBinaryCompare _ 161 | ) As Long 162 | Occurence = Replacements.Occurence(strText, findThisStr, compareMethd) 163 | End Function 164 | 165 | 166 | Public Function CustomTrim(strUntrimmed$) As String 167 | CustomTrim = Trim$(strUntrimmed) 168 | End Function 169 | 170 | 171 | Public Sub Join_SameResult(strArray() As String _ 172 | , Optional delimtr$ = vbNullString _ 173 | ) 174 | Dim replacemnt$, nativeProc$ 175 | 176 | ' call native method 177 | nativeProc = VBA.Join(strArray, delimtr) 178 | 179 | ' call replacement method 180 | replacemnt = Replacements.Join(strArray, delimtr) 181 | 182 | ' compare 183 | Assert.That replacemnt, Iz.EqualTo(nativeProc) _ 184 | , "Result of Replacements.Join() should match native method." 185 | End Sub 186 | 187 | 188 | Public Function IsNumeric_Replacement(exprssion) As Boolean 189 | IsNumeric_Replacement = Replacements.IsNumeric(exprssion) 190 | End Function 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 199 | ' 200 | ' Test Utility Methods 201 | ' 202 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 203 | 204 | Private Sub DoSomething() 205 | 206 | End Sub 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 215 | ' 216 | ' Fixture Framework Methods 217 | ' 218 | ' = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = 219 | 220 | Public Sub FixtureSetup() 221 | mMethodsRan = 0: mMethodCount = Sim.NewTestFixture(Me).TestCount 222 | 223 | End Sub 224 | 225 | 226 | Public Sub Setup() 227 | ' 228 | End Sub 229 | 230 | 231 | Public Sub Teardown() 232 | 233 | mMethodsRan = mMethodsRan + 1 234 | If mMethodsRan = mMethodCount Then Me.FixtureTeardown 235 | End Sub 236 | 237 | 238 | Public Sub FixtureTeardown() 239 | If mMethodsRan < mMethodCount Then Exit Sub 240 | 241 | End Sub 242 | -------------------------------------------------------------------------------- /vbRichClient/4.0.0.6/DirectCOM.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/4.0.0.6/DirectCOM.dll -------------------------------------------------------------------------------- /vbRichClient/4.0.0.6/_Library-Licenses.txt: -------------------------------------------------------------------------------- 1 | Maybe I should start with the good news, that all 2 | the libraries which are used and available in this 3 | toolset, allow you also commercial usage (without 4 | opening-up your Application-Code under one of the 5 | OpenSource-licenses ... VB-Classic does not offer 6 | any static linking) - but that is of course not 7 | saying, that "we" (as the VB-community) should 8 | not "give back" something under one of these 9 | licenses too - your choice of course... :-) 10 | 11 | 12 | So, I will go this route in the next months at least - 13 | by opening up the sources of the ActiveX- (COM-) Dll 14 | vbRichClient4.dll to the VB6-community under LGPL, 15 | to offer a "larger security", for those who make use of 16 | these wrapper-libs already in their projects - 17 | (since "closed source One-Man-shows" are always considered 18 | a little bit risky in the long run) - but also to 19 | "give something back" into the general OpenSource-community, 20 | since without their generousity and efforts something like 21 | this "free usable package" here would not be possible at all. 22 | 23 | Ok, what now follows is a short description of the 24 | contents of the build OpenSource-based library: 25 | vb_cairo_sqlite.dll 26 | 27 | which does the underlying "basic-work" here in this small 28 | framework ... The ActiveX-Dll: 29 | vbRichClient4.dll 30 | 31 | is a ActiveX- (or COM-) wrapper "on top", which allows to deal 32 | with the functionality of the OpenSource-libs in a comfortable, 33 | objectoriented and secure (VB-)way (secure here means, that 34 | you will not need to take care with regards to handle- and/or 35 | memory-freeing yourself. 36 | 37 | But I digress... 38 | 39 | The opensource-libs were build and linked from C-Source 40 | with VS-2008, the MS-runtime-lib is statically linked-in + 41 | any suitable speed-optimization was applied, therefore its 42 | somewhat larger size, compared with MingW-builds... 43 | 44 | So, whilst this file describes, what's in vb_cairo_sqlite.dll, 45 | the optional \WebKitCairo\-SubFolder contains an additional 46 | file like this one here, to describe the contents, libs and 47 | licenses for all the WebKit-binaries... 48 | 49 | -------- please place at least the following license-info in a file -------- 50 | -------- (license.txt) beside the RC4-libs in your own deployments -------- 51 | The sqlite3-engine vb_cairo_sqlite contains, is public domain 52 | due to the generous D.R. Hipp (www.sqlite.org)- but the DB- 53 | functionality also contains some differently licensed sub-parts 54 | as are: 55 | 56 | - FastLZ (compression-algos, included as Source-Modules) 57 | http://www.fastlz.org/ 58 | MIT-license 59 | 60 | - ZLib (higher compression, well-balanced compr./decomp. Speed) 61 | http://www.gzip.org/zlib/zlib_license.html 62 | ZLib-license (very liberal too) 63 | 64 | - LZMA (highest compression, decomp. fast, compr. slow) 65 | http://www.7-zip.org/sdk.html 66 | Public Domain license 67 | 68 | All of the different compression-algos are available over 69 | cCrypt of the vbRichClient4.dll - and come internally into 70 | play for example, when transferring serialized SQLite-Recordsets 71 | over TCP/IP (using the RPC-Server-Classes of vbRichClient4). 72 | 73 | 74 | Ok, and here the "more cairo-related" Sub-Libs and their licenses: 75 | 76 | The "main-parts" come of course from the cairo-project, 77 | which is licensed under LGPL/MPL: (http://cairographics.org/) 78 | 79 | - libpixman (fast, optimized pixel-surface-routines) 80 | BSD-like license, e.g. mentioned here: 81 | http://wiki.mozilla.org/License_Policy 82 | 83 | - libPng 84 | http://www.libpng.org/pub/png/src/libpng-LICENSE.txt 85 | PNG-license 86 | 87 | - ZLib (again, but used here mainly by libPng in CDecl-fashion) 88 | http://www.gzip.org/zlib/zlib_license.html 89 | ZLib-license 90 | 91 | - chipmunk (2D-physics engine) 92 | http://howlingmoonsoftware.com/chipmunk.php 93 | MIT-license 94 | 95 | - libjpeg-turbo (superfast JPG De- and Encoding) 96 | http://www.wxwidgets.org/about/licence3.txt 97 | wxWindows-license (resembling and in many parts identical to LGPL) 98 | ------------- end of the minimum license-info-section ----------------- 99 | 100 | What I hope is, that this text-file here now offers more clarity on 101 | "what's in there, in the package" - and it is also a necessitiy 102 | now, to deploy these license-infos along with the 3 framework-dlls, 103 | since other than the former "plain sqlite36_engine.dll", the 104 | new, combined vb_cairo_sqlite.dll has LGPL- and other parts linked in. 105 | 106 | So, please make sure, you include at least this file here along 107 | with the RC4-binaries, when you plan to deploy your solutions 108 | in a "correct way". 109 | 110 | And maybe an additional note about using the wrappers new 111 | SVG-functionality, which was implemented directly in 112 | vbRichClient4.dll in plain VB6-code, so - the usual 113 | (and somewhat large with all its additional dependencies) 114 | librsvg was not needed and linked in the cairo-C-build). 115 | The new cairo-tutorial "RC4cairoTutorial.zip", downloadable 116 | from here: www.datenhaus.de/Downloads/RC4cairoTutorial.zip 117 | 118 | ...now contains a few SVG-Icons from the modern (and huge) Oxygen- 119 | Iconset - I've already placed a License-Info for these Images in 120 | the Demo-Zip-package, but at this occassion let me write something 121 | here too, since we are at it. 122 | 123 | This will get perhaps a bit longwinded, and some parts are 124 | repeated (from different angles) more than once, but please 125 | make your way through it anyways, I know that the VB6-community 126 | is generally "not that fluent" with all the OpenSource-licenses 127 | and the implications (I know, I was not ... 3 years ago or so). 128 | 129 | The Oxygen-IconTheme is now under LGPL too: 130 | http://www.oxygen-icons.org/?page_id=4 131 | 132 | Which means, that you can use this nice artwork now also 133 | commercially in your VB-Apps (rendered over the wrapper) - 134 | but take care, that you do *not* link any Oxygen-Icon-resources 135 | (no matter if as *.svg, *.svgz or as a "derived" *.png) as 136 | resource-file-content directly into your VB-Apps binaries 137 | (in case you don't want to open the sources of your Main-Project 138 | under LGPL too). 139 | 140 | You may link them as resource into a VB-dll-binary - but *only* 141 | if you open up the sources for this "Icon-resource.dll" under 142 | LGPL too (Your Main.exe will not need to be opened then, since 143 | it links to your Icon-resource.dll only dynamically). 144 | So the background is, that the LGPL forbids any *static* linking - 145 | any part which comes under LGPL (be it a C-compiled static library, 146 | or an icon), may not be "hidden within" (or merged into) your 147 | own (non-LGPL) Project-Sources or the resulting Binaries. 148 | 149 | So, to be on the safe side with Binaries under LGPL, this usually 150 | means dynamic linking against them (which e.g. vbRichClient4.dll 151 | does per dynamic Declare-Statements against vb_cairo_sqlite.dll) - 152 | and for LGPL-icons that means "dynamic linking" (or better 153 | "dynamic loading") too ... either from iconfiles in a SubFolder 154 | under your Apps path - or over a Resource-Dll which comes 155 | under LGPL itself. 156 | 157 | Ok, I hope all these "license-issues" are now somewhat more 158 | clear for all you "new potential cairo-users out there" - 159 | and I didn't "scared you away" with all that... ;-) 160 | 161 | But I think (aside from the necessitiy of this file), that 162 | the infos within here are useful for our community, which 163 | is IMO (as already said above) somewhat inexperienced yet 164 | with regards to opensource-licenses. 165 | 166 | Maybe as a "final upshot" again (in simple words), and to 167 | avoid any confusion: 168 | Commercial usage of "all the cairo- and opensource-stuff" 169 | in this toolset is allowed, as well as the usage of the 170 | huge reservoir of the Oxygen-IconTheme - just don't try 171 | to "hide" where all the "helpful parts" originated from - 172 | give infos about their websites and licenses (as done here) 173 | in your own deployment as well. 174 | "Play fair, give credit, inform the user", so to say... 175 | (a small licenseinfo.txt file alongside the RC4-libs 176 | will be enough). 177 | 178 | 179 | Olaf Schmidt 180 | 181 | (in August 2011) 182 | 183 | 184 | -------------------------------------------------------------------------------- /vbRichClient/4.0.0.6/_Version-History.txt: -------------------------------------------------------------------------------- 1 | Current Version: 4.0.6 2 | 3 | Version 4.0.6 4 | - new cWidgetRoot.Windowless-Property 5 | - new cWidgetBase.ToolTipDuration-Property 6 | - new Class cWebArchive (a File- and InMemory-Archiver, which can load 7 | its Content also from Resources) 8 | 9 | Version 4.0.5 10 | - fixed cWidgetForm.Load, which didn't behave exactly right in conjunction with 11 | cWidgetForm.Show 12 | - new Method on cFSO (cFSO.IsFileWritable) 13 | - new Method on cThreadHandler (cThreadHandler.WaitForEmptyJobQueue) 14 | - new Version of vb_cairo_sqlite.dll (SQLite now again at recent version 3.7.14) 15 | 16 | Version 4.0.4 17 | - fixed TimeOut of 1.3sec whilst opening SQLite-Files on ReadOnly-Folders 18 | (or if the File itself got the ReadOnly-Attribute - using sqlite3_open_v2) 19 | - changed the chinese Default-Fallback-Font to the better matching "SimSun" 20 | in case of "mixed Unicode-TextOutput" (thanks to Boxian Zhou, for pointing that out) 21 | 22 | Version 4.0.3 23 | - bugfix in cTCPServer.SendData (in case the connection was reset by 24 | the remote side) thanks to Wolfgang Wolf for catching that 25 | - Added a new EnumValue for the first Param in cWidgetForms.Create 26 | (Value 6 now ensures Borderless-Alpha-Windows, which behave similar 27 | to PopUps, but do have a TaskBar-Entry and are not "TopMost" 28 | 29 | Version 4.0.2 30 | - companion Dll vb_cairo_sqlite now includes latest SQLite 3.7.10 - 31 | also fixed the contained chipmunk-based static-lib, so that it 32 | doesn't depend on SSE2 capable CPUs anymore 33 | - fixed a Bug in cWidgetForms, when created on a separate Thread 34 | (They need GetDeskTopWindow as a Parent then) 35 | - Workaround for missing RealmName-Prop in cWebResponse (now it's 36 | possible to use: cWebResponse.ServerName = "ServerName (RealmName)" 37 | 38 | Version 4.0.1 39 | - stabilized the cWidgetForms-engine for Debugging-Safety 40 | - did the same enhancements also in cSubClass 41 | - Fixes/Performance-Enhancements in the Widget-Rendering-Stack 42 | - cFSO.ReadByteContent/ReadTextContent was fixed, to also give correct 43 | results on existing Files with no content (an empty ByteArray or String) 44 | - Rs.UpdateBatch Fix, when working against an "attached Table" (when said 45 | table was similarly named to an already existing table in the main-DB) 46 | -------------------------------------------------------------------------------- /vbRichClient/4.0.0.6/vbRichClient4.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/4.0.0.6/vbRichClient4.dll -------------------------------------------------------------------------------- /vbRichClient/4.0.0.6/vb_cairo_sqlite.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/4.0.0.6/vb_cairo_sqlite.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.6/DirectCOM.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.6/DirectCOM.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.6/_Library-Licenses.txt: -------------------------------------------------------------------------------- 1 | Maybe I should start with the good news, that all 2 | the libraries which are used and available in this 3 | toolset, allow you also commercial usage (without 4 | opening-up your Application-Code under one of the 5 | OpenSource-licenses ... VB-Classic does not offer 6 | any static linking) - but that is of course not 7 | saying, that "we" (as the VB-community) should 8 | not "give back" something under one of these 9 | licenses too - your choice of course... :-) 10 | 11 | 12 | So, I will go this route in the next months at least - 13 | by opening up the sources of the ActiveX- (COM-) Dll 14 | vbRichClient5.dll to the VB6-community under LGPL, 15 | to offer a "larger security", for those who make use of 16 | these wrapper-libs already in their projects - 17 | (since "closed source One-Man-shows" are always considered 18 | a little bit risky in the long run) - but also to 19 | "give something back" into the general OpenSource-community, 20 | since without their generousity and efforts something like 21 | this "free usable package" here would not be possible at all. 22 | 23 | Ok, what now follows is a short description of the 24 | contents of the build OpenSource-based library: 25 | vb_cairo_sqlite.dll 26 | 27 | which does the underlying "basic-work" here in this small 28 | framework ... The ActiveX-Dll: 29 | vbRichClient5.dll 30 | 31 | is a ActiveX- (or COM-) wrapper "on top", which allows to deal 32 | with the functionality of the OpenSource-libs in a comfortable, 33 | objectoriented and secure (VB-)way (secure here means, that 34 | you will not need to take care with regards to handle- and/or 35 | memory-freeing yourself. 36 | 37 | But I digress... 38 | 39 | The opensource-libs were build and linked from C-Source 40 | with VS-2008, the MS-runtime-lib is statically linked-in + 41 | any suitable speed-optimization was applied, therefore its 42 | somewhat larger size, compared with MingW-builds... 43 | 44 | So, whilst this file describes, what's in vb_cairo_sqlite.dll, 45 | the optional \WebKitCairo\-SubFolder contains an additional 46 | file like this one here, to describe the contents, libs and 47 | licenses for all the WebKit-binaries... 48 | 49 | -------- please place at least the following license-info in a file -------- 50 | -------- (license.txt) beside the RC5-libs in your own deployments -------- 51 | The sqlite3-engine vb_cairo_sqlite contains, is public domain 52 | due to the generous D.R. Hipp (www.sqlite.org)- but the DB- 53 | functionality also contains some differently licensed sub-parts 54 | as are: 55 | 56 | - FastLZ (compression-algos, included as Source-Modules) 57 | http://www.fastlz.org/ 58 | MIT-license 59 | 60 | - ZLib (higher compression, well-balanced compr./decomp. Speed) 61 | http://www.gzip.org/zlib/zlib_license.html 62 | ZLib-license (very liberal too) 63 | 64 | - LZMA (highest compression, decomp. fast, compr. slow) 65 | http://www.7-zip.org/sdk.html 66 | Public Domain license 67 | 68 | All of the different compression-algos are available over 69 | cCrypt of the vbRichClient5.dll - and come internally into 70 | play for example, when transferring serialized SQLite-Recordsets 71 | over TCP/IP (using the RPC-Server-Classes of vbRichClient5). 72 | 73 | 74 | Ok, and here the "more cairo-related" Sub-Libs and their licenses: 75 | 76 | The "main-parts" come of course from the cairo-project, 77 | which is licensed under LGPL/MPL: (http://cairographics.org/) 78 | 79 | - libpixman (fast, optimized pixel-surface-routines) 80 | BSD-like license, e.g. mentioned here: 81 | http://wiki.mozilla.org/License_Policy 82 | 83 | - libPng 84 | http://www.libpng.org/pub/png/src/libpng-LICENSE.txt 85 | PNG-license 86 | 87 | - ZLib (again, but used here mainly by libPng in CDecl-fashion) 88 | http://www.gzip.org/zlib/zlib_license.html 89 | ZLib-license 90 | 91 | - chipmunk (2D-physics engine) 92 | http://howlingmoonsoftware.com/chipmunk.php 93 | MIT-license 94 | 95 | - libjpeg-turbo (superfast JPG De- and Encoding) 96 | http://www.wxwidgets.org/about/licence3.txt 97 | wxWindows-license (resembling and in many parts identical to LGPL) 98 | ------------- end of the minimum license-info-section ----------------- 99 | 100 | What I hope is, that this text-file here now offers more clarity on 101 | "what's in there, in the package" - and it is also a necessitiy 102 | now, to deploy these license-infos along with the 3 framework-dlls, 103 | since other than the former "plain sqlite36_engine.dll", the 104 | new, combined vb_cairo_sqlite.dll has LGPL- and other parts linked in. 105 | 106 | So, please make sure, you include at least this file here along 107 | with the RC5-binaries, when you plan to deploy your solutions 108 | in a "correct way". 109 | 110 | And maybe an additional note about using the wrappers new 111 | SVG-functionality, which was implemented directly in 112 | vbRichClient5.dll in plain VB6-code, so - the usual 113 | (and somewhat large with all its additional dependencies) 114 | librsvg was not needed and linked in the cairo-C-build). 115 | The new cairo-tutorial "RC4cairoTutorial.zip", downloadable 116 | from here: www.datenhaus.de/Downloads/RC4cairoTutorial.zip 117 | 118 | ...now contains a few SVG-Icons from the modern (and huge) Oxygen- 119 | Iconset - I've already placed a License-Info for these Images in 120 | the Demo-Zip-package, but at this occassion let me write something 121 | here too, since we are at it. 122 | 123 | This will get perhaps a bit longwinded, and some parts are 124 | repeated (from different angles) more than once, but please 125 | make your way through it anyways, I know that the VB6-community 126 | is generally "not that fluent" with all the OpenSource-licenses 127 | and the implications (I know, I was not ... 3 years ago or so). 128 | 129 | The Oxygen-IconTheme is now under LGPL too: 130 | http://www.oxygen-icons.org/?page_id=4 131 | 132 | Which means, that you can use this nice artwork now also 133 | commercially in your VB-Apps (rendered over the wrapper) - 134 | but take care, that you do *not* link any Oxygen-Icon-resources 135 | (no matter if as *.svg, *.svgz or as a "derived" *.png) as 136 | resource-file-content directly into your VB-Apps binaries 137 | (in case you don't want to open the sources of your Main-Project 138 | under LGPL too). 139 | 140 | You may link them as resource into a VB-dll-binary - but *only* 141 | if you open up the sources for this "Icon-resource.dll" under 142 | LGPL too (Your Main.exe will not need to be opened then, since 143 | it links to your Icon-resource.dll only dynamically). 144 | So the background is, that the LGPL forbids any *static* linking - 145 | any part which comes under LGPL (be it a C-compiled static library, 146 | or an icon), may not be "hidden within" (or merged into) your 147 | own (non-LGPL) Project-Sources or the resulting Binaries. 148 | 149 | So, to be on the safe side with Binaries under LGPL, this usually 150 | means dynamic linking against them (which e.g. vbRichClient5.dll 151 | does per dynamic Declare-Statements against vb_cairo_sqlite.dll) - 152 | and for LGPL-icons that means "dynamic linking" (or better 153 | "dynamic loading") too ... either from iconfiles in a SubFolder 154 | under your Apps path - or over a Resource-Dll which comes 155 | under LGPL itself. 156 | 157 | Ok, I hope all these "license-issues" are now somewhat more 158 | clear for all you "new potential cairo-users out there" - 159 | and I didn't "scared you away" with all that... ;-) 160 | 161 | But I think (aside from the necessitiy of this file), that 162 | the infos within here are useful for our community, which 163 | is IMO (as already said above) somewhat inexperienced yet 164 | with regards to opensource-licenses. 165 | 166 | Maybe as a "final upshot" again (in simple words), and to 167 | avoid any confusion: 168 | Commercial usage of "all the cairo- and opensource-stuff" 169 | in this toolset is allowed, as well as the usage of the 170 | huge reservoir of the Oxygen-IconTheme - just don't try 171 | to "hide" where all the "helpful parts" originated from - 172 | give infos about their websites and licenses (as done here) 173 | in your own deployment as well. 174 | "Play fair, give credit, inform the user", so to say... 175 | (a small licenseinfo.txt file alongside the RC5-libs 176 | will be enough). 177 | 178 | 179 | Olaf Schmidt 180 | 181 | (in August 2011) 182 | 183 | 184 | -------------------------------------------------------------------------------- /vbRichClient/5.0.0.6/vbRichClient5.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.6/vbRichClient5.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.6/vb_cairo_sqlite.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.6/vb_cairo_sqlite.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.9/DirectCOM.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.9/DirectCOM.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.9/_Library-Licenses.txt: -------------------------------------------------------------------------------- 1 | Maybe I should start with the good news, that all 2 | the libraries which are used and available in this 3 | toolset, allow you also commercial usage (without 4 | opening-up your Application-Code under one of the 5 | OpenSource-licenses ... VB-Classic does not offer 6 | any static linking) - but that is of course not 7 | saying, that "we" (as the VB-community) should 8 | not "give back" something under one of these 9 | licenses too - your choice of course... :-) 10 | 11 | 12 | So, I will go this route in the next months at least - 13 | by opening up the sources of the ActiveX- (COM-) Dll 14 | vbRichClient5.dll to the VB6-community under LGPL, 15 | to offer a "larger security", for those who make use of 16 | these wrapper-libs already in their projects - 17 | (since "closed source One-Man-shows" are always considered 18 | a little bit risky in the long run) - but also to 19 | "give something back" into the general OpenSource-community, 20 | since without their generousity and efforts something like 21 | this "free usable package" here would not be possible at all. 22 | 23 | Ok, what now follows is a short description of the 24 | contents of the build OpenSource-based library: 25 | vb_cairo_sqlite.dll 26 | 27 | which does the underlying "basic-work" here in this small 28 | framework ... The ActiveX-Dll: 29 | vbRichClient5.dll 30 | 31 | is a ActiveX- (or COM-) wrapper "on top", which allows to deal 32 | with the functionality of the OpenSource-libs in a comfortable, 33 | objectoriented and secure (VB-)way (secure here means, that 34 | you will not need to take care with regards to handle- and/or 35 | memory-freeing yourself. 36 | 37 | But I digress... 38 | 39 | The opensource-libs were build and linked from C-Source 40 | with VS-2008, the MS-runtime-lib is statically linked-in + 41 | any suitable speed-optimization was applied, therefore its 42 | somewhat larger size, compared with MingW-builds... 43 | 44 | So, whilst this file describes, what's in vb_cairo_sqlite.dll, 45 | the optional \WebKitCairo\-SubFolder contains an additional 46 | file like this one here, to describe the contents, libs and 47 | licenses for all the WebKit-binaries... 48 | 49 | -------- please place at least the following license-info in a file -------- 50 | -------- (license.txt) beside the RC5-libs in your own deployments -------- 51 | The sqlite3-engine vb_cairo_sqlite contains, is public domain 52 | due to the generous D.R. Hipp (www.sqlite.org)- but the DB- 53 | functionality also contains some differently licensed sub-parts 54 | as are: 55 | 56 | - FastLZ (compression-algos, included as Source-Modules) 57 | http://www.fastlz.org/ 58 | MIT-license 59 | 60 | - ZLib (higher compression, well-balanced compr./decomp. Speed) 61 | http://www.gzip.org/zlib/zlib_license.html 62 | ZLib-license (very liberal too) 63 | 64 | - LZMA (highest compression, decomp. fast, compr. slow) 65 | http://www.7-zip.org/sdk.html 66 | Public Domain license 67 | 68 | All of the different compression-algos are available over 69 | cCrypt of the vbRichClient5.dll - and come internally into 70 | play for example, when transferring serialized SQLite-Recordsets 71 | over TCP/IP (using the RPC-Server-Classes of vbRichClient5). 72 | 73 | 74 | Ok, and here the "more cairo-related" Sub-Libs and their licenses: 75 | 76 | The "main-parts" come of course from the cairo-project, 77 | which is licensed under LGPL/MPL: (http://cairographics.org/) 78 | 79 | - libpixman (fast, optimized pixel-surface-routines) 80 | BSD-like license, e.g. mentioned here: 81 | http://wiki.mozilla.org/License_Policy 82 | 83 | - libPng 84 | http://www.libpng.org/pub/png/src/libpng-LICENSE.txt 85 | PNG-license 86 | 87 | - ZLib (again, but used here mainly by libPng in CDecl-fashion) 88 | http://www.gzip.org/zlib/zlib_license.html 89 | ZLib-license 90 | 91 | - chipmunk (2D-physics engine) 92 | http://howlingmoonsoftware.com/chipmunk.php 93 | MIT-license 94 | 95 | - libjpeg-turbo (superfast JPG De- and Encoding) 96 | http://www.wxwidgets.org/about/licence3.txt 97 | wxWindows-license (resembling and in many parts identical to LGPL) 98 | ------------- end of the minimum license-info-section ----------------- 99 | 100 | What I hope is, that this text-file here now offers more clarity on 101 | "what's in there, in the package" - and it is also a necessitiy 102 | now, to deploy these license-infos along with the 3 framework-dlls, 103 | since other than the former "plain sqlite36_engine.dll", the 104 | new, combined vb_cairo_sqlite.dll has LGPL- and other parts linked in. 105 | 106 | So, please make sure, you include at least this file here along 107 | with the RC5-binaries, when you plan to deploy your solutions 108 | in a "correct way". 109 | 110 | And maybe an additional note about using the wrappers new 111 | SVG-functionality, which was implemented directly in 112 | vbRichClient5.dll in plain VB6-code, so - the usual 113 | (and somewhat large with all its additional dependencies) 114 | librsvg was not needed and linked in the cairo-C-build). 115 | The new cairo-tutorial "RC4cairoTutorial.zip", downloadable 116 | from here: www.datenhaus.de/Downloads/RC4cairoTutorial.zip 117 | 118 | ...now contains a few SVG-Icons from the modern (and huge) Oxygen- 119 | Iconset - I've already placed a License-Info for these Images in 120 | the Demo-Zip-package, but at this occassion let me write something 121 | here too, since we are at it. 122 | 123 | This will get perhaps a bit longwinded, and some parts are 124 | repeated (from different angles) more than once, but please 125 | make your way through it anyways, I know that the VB6-community 126 | is generally "not that fluent" with all the OpenSource-licenses 127 | and the implications (I know, I was not ... 3 years ago or so). 128 | 129 | The Oxygen-IconTheme is now under LGPL too: 130 | http://www.oxygen-icons.org/?page_id=4 131 | 132 | Which means, that you can use this nice artwork now also 133 | commercially in your VB-Apps (rendered over the wrapper) - 134 | but take care, that you do *not* link any Oxygen-Icon-resources 135 | (no matter if as *.svg, *.svgz or as a "derived" *.png) as 136 | resource-file-content directly into your VB-Apps binaries 137 | (in case you don't want to open the sources of your Main-Project 138 | under LGPL too). 139 | 140 | You may link them as resource into a VB-dll-binary - but *only* 141 | if you open up the sources for this "Icon-resource.dll" under 142 | LGPL too (Your Main.exe will not need to be opened then, since 143 | it links to your Icon-resource.dll only dynamically). 144 | So the background is, that the LGPL forbids any *static* linking - 145 | any part which comes under LGPL (be it a C-compiled static library, 146 | or an icon), may not be "hidden within" (or merged into) your 147 | own (non-LGPL) Project-Sources or the resulting Binaries. 148 | 149 | So, to be on the safe side with Binaries under LGPL, this usually 150 | means dynamic linking against them (which e.g. vbRichClient5.dll 151 | does per dynamic Declare-Statements against vb_cairo_sqlite.dll) - 152 | and for LGPL-icons that means "dynamic linking" (or better 153 | "dynamic loading") too ... either from iconfiles in a SubFolder 154 | under your Apps path - or over a Resource-Dll which comes 155 | under LGPL itself. 156 | 157 | Ok, I hope all these "license-issues" are now somewhat more 158 | clear for all you "new potential cairo-users out there" - 159 | and I didn't "scared you away" with all that... ;-) 160 | 161 | But I think (aside from the necessitiy of this file), that 162 | the infos within here are useful for our community, which 163 | is IMO (as already said above) somewhat inexperienced yet 164 | with regards to opensource-licenses. 165 | 166 | Maybe as a "final upshot" again (in simple words), and to 167 | avoid any confusion: 168 | Commercial usage of "all the cairo- and opensource-stuff" 169 | in this toolset is allowed, as well as the usage of the 170 | huge reservoir of the Oxygen-IconTheme - just don't try 171 | to "hide" where all the "helpful parts" originated from - 172 | give infos about their websites and licenses (as done here) 173 | in your own deployment as well. 174 | "Play fair, give credit, inform the user", so to say... 175 | (a small licenseinfo.txt file alongside the RC5-libs 176 | will be enough). 177 | 178 | 179 | Olaf Schmidt 180 | 181 | (in August 2011) 182 | 183 | 184 | -------------------------------------------------------------------------------- /vbRichClient/5.0.0.9/vbRichClient5.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.9/vbRichClient5.dll -------------------------------------------------------------------------------- /vbRichClient/5.0.0.9/vb_cairo_sqlite.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/5.0.0.9/vb_cairo_sqlite.dll -------------------------------------------------------------------------------- /vbRichClient/DirectCOM.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/DirectCOM.dll -------------------------------------------------------------------------------- /vbRichClient/Tests/t_vbRichClient.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | Persistable = 0 'NotPersistable 5 | DataBindingBehavior = 0 'vbNone 6 | DataSourceBehavior = 0 'vbNone 7 | MTSTransactionMode = 0 'NotAnMTSObject 8 | END 9 | Attribute VB_Name = "t_vbRichClient" 10 | Attribute VB_GlobalNameSpace = False 11 | Attribute VB_Creatable = True 12 | Attribute VB_PredeclaredId = False 13 | Attribute VB_Exposed = False 14 | Option Explicit 15 | 16 | 17 | Public Sub Base64Enc_WontAppendVbCrLf() 18 | Dim s$ 19 | With New_c.Crypt 20 | 21 | s = .Base64Enc("abc") 22 | 23 | Assert.That Right$(s, 2), Iz.Not.EqualTo(vbCrLf) _ 24 | , "Last 2 chars shouldn't be linebreak." 25 | 26 | ' If Right$(s, 2) = vbCrLf Then _ 27 | ' Debug.Print "String ends in vbCrLf" _ 28 | ' , "Length: " & Len(s) 29 | ' 30 | ' Debug.Print .Base64Dec(s) _ 31 | ' , "Length: " & Len(.Base64Dec(s)) 32 | End With 33 | End Sub 34 | -------------------------------------------------------------------------------- /vbRichClient/_Library-Licenses.txt: -------------------------------------------------------------------------------- 1 | Maybe I should start with the good news, that all 2 | the libraries which are used and available in this 3 | toolset, allow you also commercial usage (without 4 | opening-up your Application-Code under one of the 5 | OpenSource-licenses ... VB-Classic does not offer 6 | any static linking) - but that is of course not 7 | saying, that "we" (as the VB-community) should 8 | not "give back" something under one of these 9 | licenses too - your choice of course... :-) 10 | 11 | 12 | So, I will go this route in the next months at least - 13 | by opening up the sources of the ActiveX- (COM-) Dll 14 | vbRichClient5.dll to the VB6-community under LGPL, 15 | to offer a "larger security", for those who make use of 16 | these wrapper-libs already in their projects - 17 | (since "closed source One-Man-shows" are always considered 18 | a little bit risky in the long run) - but also to 19 | "give something back" into the general OpenSource-community, 20 | since without their generousity and efforts something like 21 | this "free usable package" here would not be possible at all. 22 | 23 | Ok, what now follows is a short description of the 24 | contents of the build OpenSource-based library: 25 | vb_cairo_sqlite.dll 26 | 27 | which does the underlying "basic-work" here in this small 28 | framework ... The ActiveX-Dll: 29 | vbRichClient5.dll 30 | 31 | is a ActiveX- (or COM-) wrapper "on top", which allows to deal 32 | with the functionality of the OpenSource-libs in a comfortable, 33 | objectoriented and secure (VB-)way (secure here means, that 34 | you will not need to take care with regards to handle- and/or 35 | memory-freeing yourself. 36 | 37 | But I digress... 38 | 39 | The opensource-libs were build and linked from C-Source 40 | with VS-2008, the MS-runtime-lib is statically linked-in + 41 | any suitable speed-optimization was applied, therefore its 42 | somewhat larger size, compared with MingW-builds... 43 | 44 | So, whilst this file describes, what's in vb_cairo_sqlite.dll, 45 | the optional \WebKitCairo\-SubFolder contains an additional 46 | file like this one here, to describe the contents, libs and 47 | licenses for all the WebKit-binaries... 48 | 49 | -------- please place at least the following license-info in a file -------- 50 | -------- (license.txt) beside the RC5-libs in your own deployments -------- 51 | The sqlite3-engine vb_cairo_sqlite contains, is public domain 52 | due to the generous D.R. Hipp (www.sqlite.org)- but the DB- 53 | functionality also contains some differently licensed sub-parts 54 | as are: 55 | 56 | - FastLZ (compression-algos, included as Source-Modules) 57 | http://www.fastlz.org/ 58 | MIT-license 59 | 60 | - ZLib (higher compression, well-balanced compr./decomp. Speed) 61 | http://www.gzip.org/zlib/zlib_license.html 62 | ZLib-license (very liberal too) 63 | 64 | - LZMA (highest compression, decomp. fast, compr. slow) 65 | http://www.7-zip.org/sdk.html 66 | Public Domain license 67 | 68 | All of the different compression-algos are available over 69 | cCrypt of the vbRichClient5.dll - and come internally into 70 | play for example, when transferring serialized SQLite-Recordsets 71 | over TCP/IP (using the RPC-Server-Classes of vbRichClient5). 72 | 73 | 74 | Ok, and here the "more cairo-related" Sub-Libs and their licenses: 75 | 76 | The "main-parts" come of course from the cairo-project, 77 | which is licensed under LGPL/MPL: (http://cairographics.org/) 78 | 79 | - libpixman (fast, optimized pixel-surface-routines) 80 | BSD-like license, e.g. mentioned here: 81 | http://wiki.mozilla.org/License_Policy 82 | 83 | - libPng 84 | http://www.libpng.org/pub/png/src/libpng-LICENSE.txt 85 | PNG-license 86 | 87 | - ZLib (again, but used here mainly by libPng in CDecl-fashion) 88 | http://www.gzip.org/zlib/zlib_license.html 89 | ZLib-license 90 | 91 | - chipmunk (2D-physics engine) 92 | http://howlingmoonsoftware.com/chipmunk.php 93 | MIT-license 94 | 95 | - libjpeg-turbo (superfast JPG De- and Encoding) 96 | http://www.wxwidgets.org/about/licence3.txt 97 | wxWindows-license (resembling and in many parts identical to LGPL) 98 | ------------- end of the minimum license-info-section ----------------- 99 | 100 | What I hope is, that this text-file here now offers more clarity on 101 | "what's in there, in the package" - and it is also a necessitiy 102 | now, to deploy these license-infos along with the 3 framework-dlls, 103 | since other than the former "plain sqlite36_engine.dll", the 104 | new, combined vb_cairo_sqlite.dll has LGPL- and other parts linked in. 105 | 106 | So, please make sure, you include at least this file here along 107 | with the RC5-binaries, when you plan to deploy your solutions 108 | in a "correct way". 109 | 110 | And maybe an additional note about using the wrappers new 111 | SVG-functionality, which was implemented directly in 112 | vbRichClient5.dll in plain VB6-code, so - the usual 113 | (and somewhat large with all its additional dependencies) 114 | librsvg was not needed and linked in the cairo-C-build). 115 | The new cairo-tutorial "RC4cairoTutorial.zip", downloadable 116 | from here: www.datenhaus.de/Downloads/RC4cairoTutorial.zip 117 | 118 | ...now contains a few SVG-Icons from the modern (and huge) Oxygen- 119 | Iconset - I've already placed a License-Info for these Images in 120 | the Demo-Zip-package, but at this occassion let me write something 121 | here too, since we are at it. 122 | 123 | This will get perhaps a bit longwinded, and some parts are 124 | repeated (from different angles) more than once, but please 125 | make your way through it anyways, I know that the VB6-community 126 | is generally "not that fluent" with all the OpenSource-licenses 127 | and the implications (I know, I was not ... 3 years ago or so). 128 | 129 | The Oxygen-IconTheme is now under LGPL too: 130 | http://www.oxygen-icons.org/?page_id=4 131 | 132 | Which means, that you can use this nice artwork now also 133 | commercially in your VB-Apps (rendered over the wrapper) - 134 | but take care, that you do *not* link any Oxygen-Icon-resources 135 | (no matter if as *.svg, *.svgz or as a "derived" *.png) as 136 | resource-file-content directly into your VB-Apps binaries 137 | (in case you don't want to open the sources of your Main-Project 138 | under LGPL too). 139 | 140 | You may link them as resource into a VB-dll-binary - but *only* 141 | if you open up the sources for this "Icon-resource.dll" under 142 | LGPL too (Your Main.exe will not need to be opened then, since 143 | it links to your Icon-resource.dll only dynamically). 144 | So the background is, that the LGPL forbids any *static* linking - 145 | any part which comes under LGPL (be it a C-compiled static library, 146 | or an icon), may not be "hidden within" (or merged into) your 147 | own (non-LGPL) Project-Sources or the resulting Binaries. 148 | 149 | So, to be on the safe side with Binaries under LGPL, this usually 150 | means dynamic linking against them (which e.g. vbRichClient5.dll 151 | does per dynamic Declare-Statements against vb_cairo_sqlite.dll) - 152 | and for LGPL-icons that means "dynamic linking" (or better 153 | "dynamic loading") too ... either from iconfiles in a SubFolder 154 | under your Apps path - or over a Resource-Dll which comes 155 | under LGPL itself. 156 | 157 | Ok, I hope all these "license-issues" are now somewhat more 158 | clear for all you "new potential cairo-users out there" - 159 | and I didn't "scared you away" with all that... ;-) 160 | 161 | But I think (aside from the necessitiy of this file), that 162 | the infos within here are useful for our community, which 163 | is IMO (as already said above) somewhat inexperienced yet 164 | with regards to opensource-licenses. 165 | 166 | Maybe as a "final upshot" again (in simple words), and to 167 | avoid any confusion: 168 | Commercial usage of "all the cairo- and opensource-stuff" 169 | in this toolset is allowed, as well as the usage of the 170 | huge reservoir of the Oxygen-IconTheme - just don't try 171 | to "hide" where all the "helpful parts" originated from - 172 | give infos about their websites and licenses (as done here) 173 | in your own deployment as well. 174 | "Play fair, give credit, inform the user", so to say... 175 | (a small licenseinfo.txt file alongside the RC5-libs 176 | will be enough). 177 | 178 | 179 | Olaf Schmidt 180 | 181 | (in August 2011) 182 | 183 | 184 | -------------------------------------------------------------------------------- /vbRichClient/vbRichClient5.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/vbRichClient5.dll -------------------------------------------------------------------------------- /vbRichClient/vb_cairo_sqlite.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/peterson1/vb6-toolbox/6d616696d7ad94b12565caadd4f9c6806a4a02ff/vbRichClient/vb_cairo_sqlite.dll --------------------------------------------------------------------------------