├── .gitattributes ├── BlankDB.mdb ├── ComponentDocumenter.vbp ├── LICENSE.md ├── README.md ├── databases └── sample.mdb ├── release ├── Bin │ ├── COMCTL32.OCX │ ├── TLBINF32.DLL │ ├── richtx32.ocx │ └── tabctl32.ocx ├── BlankDB.mdb ├── CompDoc.exe └── databases │ └── sample.mdb └── source ├── bas ├── mBrowseForFolder.bas ├── mGeneral.bas └── mOrderVector.bas ├── cls ├── cDlg.cls └── cSmartConcat.cls ├── frm ├── frmBlankFieldsOptions.frm ├── frmComponentProperties.frm ├── frmConfigureHTML.frm ├── frmConfigureHTML.frx ├── frmFieldsModifAlert.frm ├── frmFieldsModifAlert.frx ├── frmMain.frm ├── frmMain.frx ├── frmMessage.frm ├── frmPDFNote.frm ├── frmPDFNote.frx ├── frmPreferences.frm ├── frmReportOptions.frm ├── frmReportSelection.frm ├── frmReportingOptions.frm ├── frmSelectComponentDB.frm ├── frmSelectItems.frm ├── frmSelectMemberDefinition.frm ├── frmSelectMemberDefinition.frx ├── frmSelectOrpahnMember.frm └── frmSelectPrinter.frm └── misc ├── CDoc.ico └── VisualStyle_DPIAware_Manifest.res /.gitattributes: -------------------------------------------------------------------------------- 1 | * binary 2 | 3 | *.bas working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 4 | *.cls working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 5 | *.ctl working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 6 | *.dob working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 7 | *.dsr working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 8 | *.frm working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 9 | *.pag working-tree-encoding=CP1252 text eol=crlf linguist-language=vb6 10 | *.vbg working-tree-encoding=CP1252 text eol=crlf 11 | *.vbl working-tree-encoding=CP1252 text eol=crlf 12 | *.vbp working-tree-encoding=CP1252 text eol=crlf 13 | *.vbr working-tree-encoding=CP1252 text eol=crlf 14 | 15 | *.asm text 16 | *.asp text 17 | *.bat text 18 | *.c text 19 | *.cpp text 20 | *.dsp text 21 | *.dsw text 22 | *.h text 23 | *.idl text 24 | *.java text 25 | *.js text 26 | *.manifest text 27 | *.odl text 28 | *.php text 29 | *.php3 text 30 | *.rc text 31 | *.sln text 32 | *.sql text 33 | *.vb text 34 | *.vbs text 35 | -------------------------------------------------------------------------------- /BlankDB.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/BlankDB.mdb -------------------------------------------------------------------------------- /ComponentDocumenter.vbp: -------------------------------------------------------------------------------- 1 | Type=Exe 2 | Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\Windows\SysWOW64\stdole2.tlb#OLE Automation 3 | Reference=*\G{00025E01-0000-0000-C000-000000000046}#5.0#0#C:\Program Files (x86)\Common Files\Microsoft Shared\DAO\dao360.dll#Microsoft DAO 3.6 Object Library 4 | Reference=*\G{8B217740-717D-11CE-AB5B-D41203C10000}#1.0#0#C:\Windows\SysWow64\TLBINF32.DLL#TypeLib Information 5 | Object={3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0; RICHTX32.OCX 6 | Object={6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0; COMCTL32.OCX 7 | Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX 8 | Form=source\frm\frmMain.frm 9 | Form=source\frm\frmReportSelection.frm 10 | Form=source\frm\frmSelectComponentDB.frm 11 | Form=source\frm\frmReportingOptions.frm 12 | Form=source\frm\frmSelectPrinter.frm 13 | Form=source\frm\frmConfigureHTML.frm 14 | Form=source\frm\frmComponentProperties.frm 15 | Form=source\frm\frmPDFNote.frm 16 | Form=source\frm\frmMessage.frm 17 | Form=source\frm\frmSelectItems.frm 18 | Form=source\frm\frmSelectOrpahnMember.frm 19 | Form=source\frm\frmSelectMemberDefinition.frm 20 | Form=source\frm\frmBlankFieldsOptions.frm 21 | Form=source\frm\frmFieldsModifAlert.frm 22 | Class=cDlg; source\cls\cDlg.cls 23 | Class=SmartConcat; source\cls\cSmartConcat.cls 24 | Module=mGeneral; source\bas\mGeneral.bas 25 | Module=mOrderVector; source\bas\mOrderVector.bas 26 | Module=mBrowseForFolder; source\bas\mBrowseForFolder.bas 27 | Form=source\frm\frmPreferences.frm 28 | ResFile32="source\misc\VisualStyle_DPIAware_Manifest.res" 29 | IconForm="frmMain" 30 | Startup="frmMain" 31 | HelpFile="" 32 | Title="Component Documenter" 33 | ExeName32="CompDoc.exe" 34 | Path32="Release" 35 | Command32="" 36 | Name="CompDoc" 37 | HelpContextID="0" 38 | CompatibleMode="0" 39 | MajorVer=1 40 | MinorVer=0 41 | RevisionVer=40 42 | AutoIncrementVer=1 43 | ServerSupportFiles=0 44 | CompilationType=0 45 | OptimizationType=0 46 | FavorPentiumPro(tm)=0 47 | CodeViewDebugInfo=0 48 | NoAliasing=0 49 | BoundsCheck=0 50 | OverflowCheck=0 51 | FlPointCheck=0 52 | FDIVCheck=0 53 | UnroundedFP=0 54 | StartMode=0 55 | Unattended=0 56 | Retained=0 57 | ThreadPerObject=0 58 | MaxNumberOfThreads=1 59 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 EduardoVB 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ComponentDocumenter 2 | Tool for documenting ActiveX components 3 | [For more information please go to vbForums thread](https://www.vbforums.com/showthread.php?891747-(VB6)-Component-Documenter) 4 | 5 | ![imagen](https://user-images.githubusercontent.com/42319299/175790644-f10d6053-e98a-4f4d-bdaa-dd1270ed6d7d.png) 6 | -------------------------------------------------------------------------------- /databases/sample.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/databases/sample.mdb -------------------------------------------------------------------------------- /release/Bin/COMCTL32.OCX: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/Bin/COMCTL32.OCX -------------------------------------------------------------------------------- /release/Bin/TLBINF32.DLL: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/Bin/TLBINF32.DLL -------------------------------------------------------------------------------- /release/Bin/richtx32.ocx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/Bin/richtx32.ocx -------------------------------------------------------------------------------- /release/Bin/tabctl32.ocx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/Bin/tabctl32.ocx -------------------------------------------------------------------------------- /release/BlankDB.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/BlankDB.mdb -------------------------------------------------------------------------------- /release/CompDoc.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/CompDoc.exe -------------------------------------------------------------------------------- /release/databases/sample.mdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/release/databases/sample.mdb -------------------------------------------------------------------------------- /source/bas/mBrowseForFolder.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mBrowseForFolder" 2 | Option Explicit 3 | 4 | Private Declare Function SendMessageString Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long 5 | Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long 6 | Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long 7 | Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 8 | 9 | Private Const WM_USER = &H400 10 | Private Const BFFM_INITIALIZED = 1 11 | Private Const BFFM_SELCHANGED = 2 12 | Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100) 13 | Private Const BFFM_SETSELECTION = (WM_USER + 102) 14 | Private Const BFFM_VALIDATEFAILED = 3 15 | 16 | Private Const MAX_PATH = 260 17 | 18 | Public gWindowTitle As String 19 | Public gCommonDialogEx_ShowFolder_StartFolder As String 20 | 21 | Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long 22 | On Error Resume Next 23 | Dim ret As Long 24 | Dim sBuffer As String 25 | Dim iEh As Long 26 | 27 | Select Case uMsg 28 | Case BFFM_INITIALIZED 29 | Call SendMessageString(hWnd, BFFM_SETSELECTION, 1, gCommonDialogEx_ShowFolder_StartFolder) 30 | SetWindowText hWnd, gWindowTitle 31 | iEh = FindWindowEx(hWnd, 0, "Edit", "") 32 | SetWindowText iEh, gCommonDialogEx_ShowFolder_StartFolder 33 | Case BFFM_SELCHANGED 34 | sBuffer = Space(MAX_PATH) 35 | ret = SHGetPathFromIDList(lp, sBuffer) 36 | If ret = 1 Then 37 | Call SendMessageString(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer) 38 | iEh = FindWindowEx(hWnd, 0, "Edit", "") 39 | SetWindowText iEh, sBuffer 40 | End If 41 | Case BFFM_VALIDATEFAILED 42 | Call SendMessageString(hWnd, BFFM_SETSELECTION, 1, "") 43 | End Select 44 | BrowseCallbackProc = 0 45 | End Function 46 | -------------------------------------------------------------------------------- /source/bas/mGeneral.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mGeneral" 2 | Option Explicit 3 | 4 | Private Type RECT 5 | Left As Long 6 | Top As Long 7 | Right As Long 8 | Bottom As Long 9 | End Type 10 | 11 | Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long 12 | Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long 13 | Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long 14 | Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long 15 | 16 | Private Const DT_CALCRECT As Long = &H400 17 | Private Const SM_CXEDGE As Long = 45 18 | Private Const SM_CXVSCROLL As Long = 2 19 | Private Const CB_GETMINVISIBLE As Long = &H1702& 20 | Private Const CB_SETDROPPEDWIDTH = &H160 21 | Private Const CB_GETDROPPEDWIDTH = &H15F 22 | 23 | Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long 24 | Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long 25 | 26 | Private Const gstrSEP_DIR$ = "\" ' Directory separator character 27 | 'Private Const gstrAT$ = "@" 28 | Private Const gstrSEP_DRIVE$ = ":" ' Driver separater character, e.g., C:\ 29 | Private Const gstrSEP_DIRALT$ = "/" ' Alternate directory separator character 30 | 'Private Const gstrSEP_EXT$ = "." ' Filename extension separator character 31 | Private Const gstrSEP_URLDIR$ = "/" ' Separator for dividing directories in URL addresses. 32 | 33 | Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long 34 | Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpDefaultChar As Long, lpUsedDefaultChar As Long) As Long 35 | Private Declare Function GetACP Lib "kernel32" () As Long 36 | 37 | Private Const CP_UTF8 As Long = 65001 38 | 39 | Public gIcon As StdPicture 40 | 41 | Public Function ConvertToUTF8(ByRef Source As String) As Byte() 42 | Dim length As Long 43 | Dim Pointer As Long 44 | Dim Size As Long 45 | Dim Buffer() As Byte 46 | Const CP_ACP As Long = 0 47 | 48 | If Len(Source) > 0 Then 49 | length = Len(Source) 50 | Pointer = StrPtr(Source) 51 | Size = WideCharToMultiByte(CP_UTF8, 0, Pointer, length, 0, 0, 0, 0) 52 | If Size > 0 Then 53 | ReDim Buffer(0 To Size - 1) 54 | 55 | WideCharToMultiByte CP_UTF8, 0, Pointer, length, VarPtr(Buffer(0)), Size, 0, 0 56 | ConvertToUTF8 = Buffer 57 | Else 58 | Size = WideCharToMultiByte(CP_ACP, 0, Pointer, length, 0, 0, 0, 0) 59 | If Size > 0 Then 60 | ReDim Buffer(0 To Size - 1) 61 | 62 | WideCharToMultiByte CP_ACP, 0, Pointer, length, VarPtr(Buffer(0)), Size, 0, 0 63 | ConvertToUTF8 = Buffer 64 | End If 65 | End If 66 | End If 67 | End Function 68 | 69 | Public Function GetTempDir() As String 70 | Dim lChar As Long 71 | 72 | GetTempDir = String$(255, 0) 73 | lChar = GetTempPath(255, GetTempDir) 74 | GetTempDir = Left$(GetTempDir, lChar) 75 | AddDirSep GetTempDir 76 | End Function 77 | 78 | Public Sub AddDirSep(strPathName As String) 79 | strPathName = RTrim$(strPathName) 80 | If Right$(strPathName, Len(gstrSEP_URLDIR)) <> gstrSEP_URLDIR Then 81 | If Right$(strPathName, Len(gstrSEP_DIR)) <> gstrSEP_DIR Then 82 | strPathName = strPathName & gstrSEP_DIR 83 | End If 84 | End If 85 | End Sub 86 | 87 | 88 | Public Function FileExists(ByVal strPathName As String) As Boolean 89 | Dim intFileNum As Integer 90 | 91 | On Error Resume Next 92 | 93 | ' 94 | 'Attempt to open the file, return value of this function is False 95 | 'if an error occurs on open, True otherwise 96 | ' 97 | intFileNum = FreeFile 98 | Open strPathName For Input As intFileNum 99 | 100 | ' Debug.Print Err.Number, Err.Description 101 | FileExists = (Err.Number = 0) Or (Err.Number = 70) 102 | 103 | Close intFileNum 104 | 105 | Err.Clear 106 | End Function 107 | 108 | Private Sub SeparatePathAndFileName(FullPath As String, _ 109 | Optional ByRef Path As String, _ 110 | Optional ByRef FileName As String) 111 | 112 | Dim nSepPos As Long 113 | Dim nSepPos2 As Long 114 | Dim fUsingDriveSep As Boolean 115 | 116 | nSepPos = InStrRev(FullPath, gstrSEP_DIR) 117 | nSepPos2 = InStrRev(FullPath, gstrSEP_DIRALT) 118 | If nSepPos2 > nSepPos Then 119 | nSepPos = nSepPos2 120 | End If 121 | nSepPos2 = InStrRev(FullPath, gstrSEP_DRIVE) 122 | If nSepPos2 > nSepPos Then 123 | nSepPos = nSepPos2 124 | fUsingDriveSep = True 125 | End If 126 | 127 | If nSepPos = 0 Then 128 | 'Separator was not found. 129 | Path = CurDir$ 130 | FileName = FullPath 131 | Else 132 | If fUsingDriveSep Then 133 | Path = Left$(FullPath, nSepPos) 134 | Else 135 | Path = Left$(FullPath, nSepPos - 1) 136 | End If 137 | FileName = Mid$(FullPath, nSepPos + 1) 138 | End If 139 | End Sub 140 | 141 | Public Function GetFileName(nFileFullPath As String) As String 142 | Dim iFileName As String 143 | 144 | SeparatePathAndFileName nFileFullPath, , iFileName 145 | GetFileName = iFileName 146 | End Function 147 | 148 | Public Function GetFolder(nFileFullPath As String) As String 149 | Dim iFolderPath As String 150 | 151 | SeparatePathAndFileName nFileFullPath, iFolderPath 152 | GetFolder = iFolderPath 153 | AddDirSep GetFolder 154 | End Function 155 | 156 | Public Function FolderExists(ByVal nFolderPath As String) As Boolean 157 | On Error Resume Next 158 | 159 | FolderExists = (GetAttr(nFolderPath) And vbDirectory) = vbDirectory 160 | 161 | Err.Clear 162 | End Function 163 | 164 | Public Function RTFBold(nText As String) As String 165 | RTFBold = "\b " & nText & "\b0 " 166 | End Function 167 | 168 | Public Function RTFUnderline(nText As String) As String 169 | RTFUnderline = "\ul " & nText & "\ul0 " 170 | End Function 171 | 172 | Public Function RTFItalic(nText As String) As String 173 | RTFItalic = "\i " & nText & "\i0 " 174 | End Function 175 | 176 | Public Function AddToList(nList As Variant, nValue As Variant, Optional nOnlyIfMissing As Boolean, Optional nFirstElement As Long = 0) As Boolean 177 | Dim i As Long 178 | Dim iAdd As Boolean 179 | 180 | If Not nOnlyIfMissing Then 181 | iAdd = True 182 | Else 183 | iAdd = Not IsInList(nList, nValue, nFirstElement) 184 | End If 185 | If iAdd Then 186 | i = UBound(nList) + 1 187 | ReDim Preserve nList(LBound(nList) To i) 188 | nList(i) = nValue 189 | AddToList = True 190 | End If 191 | End Function 192 | 193 | Public Function IsInList(nList As Variant, nValue As Variant, Optional nFirstElement As Long = 0, Optional nLastElement As Long = -1) As Boolean 194 | Dim c As Long 195 | 196 | If nLastElement = -1 Then 197 | nLastElement = UBound(nList) 198 | Else 199 | If nLastElement > UBound(nList) Then 200 | nLastElement = UBound(nList) 201 | End If 202 | End If 203 | 204 | For c = nFirstElement To nLastElement 205 | If nList(c) = nValue Then 206 | IsInList = True 207 | Exit For 208 | End If 209 | Next c 210 | End Function 211 | 212 | Public Function IndexInList(nList As Variant, nValue As Variant) As Long 213 | Dim c As Long 214 | 215 | IndexInList = LBound(nList) - 1 216 | For c = LBound(nList) To UBound(nList) 217 | If nList(c) = nValue Then 218 | IndexInList = c 219 | Exit For 220 | End If 221 | Next c 222 | End Function 223 | 224 | Public Function Trim2(nText As String) As String 225 | Dim iChar As String 226 | 227 | Trim2 = nText 228 | iChar = Left$(Trim2, 1) 229 | Do While (iChar = " ") Or (iChar = vbTab) Or (iChar = vbCr) Or (iChar = vbLf) Or (iChar = Chr(160)) 230 | Trim2 = Mid$(Trim2, 2) 231 | iChar = Left$(Trim2, 1) 232 | Loop 233 | iChar = Right$(Trim2, 1) 234 | Do While (iChar = " ") Or (iChar = vbTab) Or (iChar = vbCr) Or (iChar = vbLf) Or (iChar = Chr(160)) 235 | Trim2 = Left$(Trim2, Len(Trim2) - 1) 236 | iChar = Right$(Trim2, 1) 237 | Loop 238 | End Function 239 | 240 | Public Sub SaveBinaryFile(nFilePath As String, nBytes() As Byte) 241 | Dim iFreeFile As Long 242 | 243 | iFreeFile = FreeFile 244 | Open nFilePath For Binary Access Write As #iFreeFile 245 | Put #iFreeFile, , nBytes 246 | Close #iFreeFile 247 | End Sub 248 | 249 | Public Function AppPath4Reg() As String 250 | Static sValue As String 251 | 252 | If sValue = "" Then 253 | sValue = Replace(App_Path, "\", "_") 254 | End If 255 | 256 | AppPath4Reg = sValue 257 | End Function 258 | 259 | Public Function AutoSizeDropDownWidth(Combo As Object) As Long 260 | '************************************************************** 261 | 'PURPOSE: Automatically size the combo box drop down width 262 | ' based on the width of the longest item in the combo box 263 | 264 | 'PARAMETERS: Combo - ComboBox to size 265 | 266 | 'RETURNS: True if successful, false otherwise 267 | 268 | 'ASSUMPTIONS: 1. Form's Scale Mode is vbTwips, which is why 269 | ' conversion from twips to pixels are made. 270 | ' API functions require units in pixels 271 | ' 272 | ' 2. Combo Box's parent is a form or other 273 | ' container that support the hDC property 274 | 275 | 'EXAMPLE: AutoSizeDropDownWidth Combo1 276 | '**************************************************************** 277 | Dim LRet As Long 278 | Dim lCurrentWidth As Single 279 | Dim rectCboText As RECT 280 | Dim lParentHDC As Long 281 | Dim lListCount As Long 282 | Dim lCtr As Long 283 | Dim lTempWidth As Long 284 | Dim lWidth As Long 285 | Dim sSavedFont As String 286 | Dim sngSavedSize As Single 287 | Dim bSavedBold As Boolean 288 | Dim bSavedItalic As Boolean 289 | Dim bSavedUnderline As Boolean 290 | Dim bFontSaved As Boolean 291 | Dim iRc As RECT 292 | Dim iMaxItemsWithoutScrollBar As Long 293 | 294 | On Error GoTo errorHandler 295 | 296 | If Not TypeOf Combo Is ComboBox Then Exit Function 297 | 298 | lParentHDC = Combo.Parent.hDC 299 | If lParentHDC = 0 Then Exit Function 300 | lListCount = Combo.ListCount 301 | If lListCount = 0 Then Exit Function 302 | 303 | 'Change font of parent to combo box's font 304 | 'Save first so it can be reverted when finished 305 | 'this is necessary for drawtext API Function 306 | 'which is used to determine longest string in combo box 307 | With Combo.Parent 308 | sSavedFont = .FontName 309 | sngSavedSize = .FontSize 310 | bSavedBold = .FontBold 311 | bSavedItalic = .FontItalic 312 | bSavedUnderline = .FontUnderLine 313 | 314 | .FontName = Combo.FontName 315 | .FontSize = Combo.FontSize 316 | .FontBold = Combo.FontBold 317 | .FontItalic = Combo.FontItalic 318 | .FontUnderLine = Combo.FontItalic 319 | End With 320 | 321 | bFontSaved = True 322 | 323 | 'Get the width of the largest item 324 | For lCtr = 0 To lListCount 325 | DrawText lParentHDC, Combo.List(lCtr), -1, rectCboText, DT_CALCRECT 326 | 'adjust the number added (20 in this case to 327 | 'achieve desired right margin 328 | lTempWidth = rectCboText.Right - rectCboText.Left + GetSystemMetrics(SM_CXEDGE) * 2 329 | 330 | If (lTempWidth > lWidth) Then 331 | lWidth = lTempWidth 332 | End If 333 | Next 334 | 335 | iMaxItemsWithoutScrollBar = SendMessageLong(Combo.hWnd, CB_GETMINVISIBLE, 0&, 0&) 336 | 337 | If Combo.ListCount > iMaxItemsWithoutScrollBar Then 338 | lTempWidth = lTempWidth + GetSystemMetrics(SM_CXVSCROLL) 339 | End If 340 | 341 | 342 | GetWindowRect Combo.hWnd, iRc 343 | LRet = SendMessageLong(Combo.hWnd, CB_SETDROPPEDWIDTH, iRc.Right - iRc.Left, 0) 344 | 345 | lCurrentWidth = SendMessageLong(Combo.hWnd, CB_GETDROPPEDWIDTH, 0, 0) 346 | 347 | If lCurrentWidth > lWidth Then 'current drop-down width is 348 | ' sufficient 349 | ' AutoSizeDropDownWidth = True 350 | AutoSizeDropDownWidth = lCurrentWidth 351 | GoTo errorHandler 352 | Exit Function 353 | End If 354 | 355 | 'don't allow drop-down width to 356 | 'exceed screen.width 357 | If lWidth > Screen.Width \ Screen.TwipsPerPixelX - 20 Then lWidth = Screen.Width \ Screen.TwipsPerPixelX - 20 358 | 359 | LRet = SendMessageLong(Combo.hWnd, CB_SETDROPPEDWIDTH, lWidth, 0) 360 | AutoSizeDropDownWidth = lWidth 361 | ' AutoSizeDropDownWidth = LRet > 0 362 | 363 | errorHandler: 364 | On Error Resume Next 365 | If bFontSaved Then 366 | 'restore parent's font settings 367 | With Combo.Parent 368 | .FontName = sSavedFont 369 | .FontSize = sngSavedSize 370 | .FontUnderLine = bSavedUnderline 371 | .FontBold = bSavedBold 372 | .FontItalic = bSavedItalic 373 | End With 374 | End If 375 | End Function 376 | 377 | Public Property Get App_Path() As String 378 | Static sValue As String 379 | 380 | If sValue = "" Then 381 | sValue = App.Path 382 | If Right$(sValue, 1) = "\" Then 383 | sValue = Left$(sValue, Len(sValue) - 1) 384 | End If 385 | End If 386 | App_Path = sValue 387 | End Property 388 | -------------------------------------------------------------------------------- /source/bas/mOrderVector.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "mOrderVector" 2 | Option Explicit 3 | Option Compare Text 4 | 5 | Private mMainVector As Variant 6 | Private mSecondaryVector1 As Variant 7 | Private mHasSecondaryVector1 As Boolean 8 | Private mSecondaryVector1_IsObject As Boolean 9 | Private mSecondaryVector2 As Variant 10 | Private mHasSecondaryVector2 As Boolean 11 | Private mSecondaryVector2_IsObject As Boolean 12 | Private mSecondaryVector3 As Variant 13 | Private mHasSecondaryVector3 As Boolean 14 | Private mSecondaryVector3_IsObject As Boolean 15 | Private mSecondaryVector4 As Variant 16 | Private mHasSecondaryVector4 As Boolean 17 | Private mSecondaryVector4_IsObject As Boolean 18 | Private mSecondaryVector5 As Variant 19 | Private mHasSecondaryVector5 As Boolean 20 | Private mSecondaryVector5_IsObject As Boolean 21 | Private mSecondaryVector6 As Variant 22 | Private mHasSecondaryVector6 As Boolean 23 | Private mSecondaryVector6_IsObject As Boolean 24 | 25 | Private mBinaryCompare As Boolean 26 | Private mOrderDescending As Boolean 27 | 28 | Public Sub OrderVector(ByRef nMainVector As Variant, Optional ByRef nSecondaryVector1 As Variant, Optional ByRef nSecondaryVector2 As Variant, Optional ByRef nSecondaryVector3 As Variant, Optional ByRef nSecondaryVector4 As Variant, Optional ByRef nSecondaryVector5 As Variant, Optional ByRef nSecondaryVector6 As Variant, Optional nBynaryCompare As Boolean, Optional nOrderDescending As Boolean) 29 | 30 | mOrderDescending = nOrderDescending 31 | mBinaryCompare = nBynaryCompare 32 | mMainVector = nMainVector 33 | 34 | mSecondaryVector1_IsObject = False 35 | mSecondaryVector2_IsObject = False 36 | mSecondaryVector3_IsObject = False 37 | mSecondaryVector4_IsObject = False 38 | mSecondaryVector5_IsObject = False 39 | mSecondaryVector6_IsObject = False 40 | 41 | If IsMissing(nSecondaryVector1) Then 42 | mHasSecondaryVector1 = False 43 | Else 44 | mHasSecondaryVector1 = True 45 | mSecondaryVector1 = nSecondaryVector1 46 | If VarType(nSecondaryVector1(UBound(nSecondaryVector1))) = vbObject Then mSecondaryVector1_IsObject = True 47 | End If 48 | 49 | If IsMissing(nSecondaryVector2) Then 50 | mHasSecondaryVector2 = False 51 | Else 52 | mHasSecondaryVector2 = True 53 | mSecondaryVector2 = nSecondaryVector2 54 | If VarType(nSecondaryVector2(UBound(nSecondaryVector2))) = vbObject Then mSecondaryVector2_IsObject = True 55 | End If 56 | 57 | If IsMissing(nSecondaryVector3) Then 58 | mHasSecondaryVector3 = False 59 | Else 60 | mHasSecondaryVector3 = True 61 | mSecondaryVector3 = nSecondaryVector3 62 | If VarType(nSecondaryVector3(UBound(nSecondaryVector3))) = vbObject Then mSecondaryVector3_IsObject = True 63 | End If 64 | 65 | If IsMissing(nSecondaryVector4) Then 66 | mHasSecondaryVector4 = False 67 | Else 68 | mHasSecondaryVector4 = True 69 | mSecondaryVector4 = nSecondaryVector4 70 | If VarType(nSecondaryVector4(UBound(nSecondaryVector4))) = vbObject Then mSecondaryVector4_IsObject = True 71 | End If 72 | 73 | If IsMissing(nSecondaryVector5) Then 74 | mHasSecondaryVector5 = False 75 | Else 76 | mHasSecondaryVector5 = True 77 | mSecondaryVector5 = nSecondaryVector5 78 | If VarType(nSecondaryVector5(UBound(nSecondaryVector5))) = vbObject Then mSecondaryVector5_IsObject = True 79 | End If 80 | 81 | If IsMissing(nSecondaryVector6) Then 82 | mHasSecondaryVector6 = False 83 | Else 84 | mHasSecondaryVector6 = True 85 | mSecondaryVector6 = nSecondaryVector6 86 | If VarType(nSecondaryVector6(UBound(nSecondaryVector6))) = vbObject Then mSecondaryVector6_IsObject = True 87 | End If 88 | 89 | OrderElements 90 | 91 | nMainVector = mMainVector 92 | 93 | If mHasSecondaryVector1 Then 94 | nSecondaryVector1 = mSecondaryVector1 95 | End If 96 | 97 | If mHasSecondaryVector2 Then 98 | nSecondaryVector2 = mSecondaryVector2 99 | End If 100 | 101 | If mHasSecondaryVector3 Then 102 | nSecondaryVector3 = mSecondaryVector3 103 | End If 104 | 105 | If mHasSecondaryVector4 Then 106 | nSecondaryVector4 = mSecondaryVector4 107 | End If 108 | 109 | If mHasSecondaryVector5 Then 110 | nSecondaryVector5 = mSecondaryVector5 111 | End If 112 | 113 | If mHasSecondaryVector6 Then 114 | nSecondaryVector6 = mSecondaryVector6 115 | End If 116 | 117 | End Sub 118 | 119 | Private Sub OrderElements(Optional nFirstElement As Variant, Optional nLastElement As Variant) 120 | Dim iFirstElement As Long 121 | Dim iLastElement As Long 122 | Dim iMin As Long 123 | Dim iMax As Long 124 | Dim iLb As Long 125 | 126 | If IsMissing(nFirstElement) Then 127 | iLb = LBound(mMainVector) 128 | Select Case VarType(mMainVector(iLb)) 129 | Case vbString 130 | If mMainVector(iLb) <> "" Then 131 | iFirstElement = iLb 132 | Else 133 | If iLb = 0 Then 134 | iFirstElement = 1 135 | Else 136 | iFirstElement = iLb 137 | End If 138 | End If 139 | Case Else 140 | If mMainVector(iLb) <> 0 Then 141 | iFirstElement = iLb 142 | Else 143 | If iLb = 0 Then 144 | iFirstElement = 1 145 | Else 146 | iFirstElement = iLb 147 | End If 148 | End If 149 | End Select 150 | Else 151 | iFirstElement = nFirstElement 152 | End If 153 | If IsMissing(nLastElement) Then 154 | iLastElement = UBound(mMainVector) 155 | Else 156 | iLastElement = nLastElement 157 | End If 158 | 159 | On Error GoTo TheExit: 160 | 161 | If iFirstElement < iLastElement Then 162 | If (iLastElement - iFirstElement) = 1 Then 163 | If CompareElements(mMainVector(iFirstElement), mMainVector(iLastElement)) > 0 Then 164 | Call ExchangeElements(iFirstElement, iLastElement) 165 | End If 166 | Else 167 | Call ExchangeElements(iLastElement, Random(iFirstElement, iLastElement)) 168 | iMin = iFirstElement 169 | iMax = iLastElement 170 | Do 171 | Do While (iMin < iMax) And CompareElements(mMainVector(iMin), mMainVector(iLastElement)) <= 0 172 | iMin = iMin + 1 173 | Loop 174 | Do While (iMin < iMax) And CompareElements(mMainVector(iMax), mMainVector(iLastElement)) >= 0 175 | iMax = iMax - 1 176 | Loop 177 | If iMin < iMax Then 178 | Call ExchangeElements(iMin, iMax) 179 | End If 180 | Loop While iMin < iMax 181 | Call ExchangeElements(iMin, iLastElement) 182 | If (iMin - iFirstElement) < (iLastElement - iMin) Then 183 | Call OrderElements(iFirstElement, (iMin - 1)) 184 | Call OrderElements((iMin + 1), iLastElement) 185 | Else 186 | Call OrderElements((iMin + 1), iLastElement) 187 | Call OrderElements(iFirstElement, (iMin - 1)) 188 | End If 189 | End If 190 | End If 191 | Exit Sub 192 | 193 | TheExit: 194 | End Sub 195 | 196 | Private Function CompareElements(nValue1 As Variant, nValue2 As Variant) As Integer 197 | If mBinaryCompare Then 198 | CompareElements = StrComp(nValue1, nValue2, vbBinaryCompare) 199 | Else 200 | If nValue1 < nValue2 Then 201 | CompareElements = -1 202 | Else 203 | If nValue1 = nValue2 Then 204 | CompareElements = 0 205 | Else 206 | CompareElements = 1 207 | End If 208 | End If 209 | End If 210 | If mOrderDescending Then 211 | CompareElements = CompareElements * -1 212 | End If 213 | End Function 214 | 215 | 216 | Private Sub ExchangeElements(nIndex1 As Long, nIndex2 As Long) 217 | Dim Aux As Variant 218 | Dim iObj As Object 219 | 220 | Aux = mMainVector(nIndex1) 221 | mMainVector(nIndex1) = mMainVector(nIndex2) 222 | mMainVector(nIndex2) = Aux 223 | 224 | If mHasSecondaryVector1 Then 225 | If mSecondaryVector1_IsObject Then 226 | Set iObj = mSecondaryVector1(nIndex1) 227 | Set mSecondaryVector1(nIndex1) = mSecondaryVector1(nIndex2) 228 | Set mSecondaryVector1(nIndex2) = iObj 229 | Else 230 | Aux = mSecondaryVector1(nIndex1) 231 | mSecondaryVector1(nIndex1) = mSecondaryVector1(nIndex2) 232 | mSecondaryVector1(nIndex2) = Aux 233 | End If 234 | End If 235 | 236 | If mHasSecondaryVector2 Then 237 | If mSecondaryVector2_IsObject Then 238 | Set iObj = mSecondaryVector2(nIndex1) 239 | Set mSecondaryVector2(nIndex1) = mSecondaryVector2(nIndex2) 240 | Set mSecondaryVector2(nIndex2) = iObj 241 | Else 242 | Aux = mSecondaryVector2(nIndex1) 243 | mSecondaryVector2(nIndex1) = mSecondaryVector2(nIndex2) 244 | mSecondaryVector2(nIndex2) = Aux 245 | End If 246 | End If 247 | 248 | If mHasSecondaryVector3 Then 249 | If mSecondaryVector3_IsObject Then 250 | Set iObj = mSecondaryVector3(nIndex1) 251 | Set mSecondaryVector3(nIndex1) = mSecondaryVector3(nIndex2) 252 | Set mSecondaryVector3(nIndex2) = iObj 253 | Else 254 | Aux = mSecondaryVector3(nIndex1) 255 | mSecondaryVector3(nIndex1) = mSecondaryVector3(nIndex2) 256 | mSecondaryVector3(nIndex2) = Aux 257 | End If 258 | End If 259 | 260 | If mHasSecondaryVector4 Then 261 | If mSecondaryVector4_IsObject Then 262 | Set iObj = mSecondaryVector4(nIndex1) 263 | Set mSecondaryVector4(nIndex1) = mSecondaryVector4(nIndex2) 264 | Set mSecondaryVector4(nIndex2) = iObj 265 | Else 266 | Aux = mSecondaryVector4(nIndex1) 267 | mSecondaryVector4(nIndex1) = mSecondaryVector4(nIndex2) 268 | mSecondaryVector4(nIndex2) = Aux 269 | End If 270 | End If 271 | 272 | If mHasSecondaryVector5 Then 273 | If mSecondaryVector5_IsObject Then 274 | Set iObj = mSecondaryVector5(nIndex1) 275 | Set mSecondaryVector5(nIndex1) = mSecondaryVector5(nIndex2) 276 | Set mSecondaryVector5(nIndex2) = iObj 277 | Else 278 | Aux = mSecondaryVector5(nIndex1) 279 | mSecondaryVector5(nIndex1) = mSecondaryVector5(nIndex2) 280 | mSecondaryVector5(nIndex2) = Aux 281 | End If 282 | End If 283 | 284 | If mHasSecondaryVector6 Then 285 | If mSecondaryVector6_IsObject Then 286 | Set iObj = mSecondaryVector6(nIndex1) 287 | Set mSecondaryVector6(nIndex1) = mSecondaryVector6(nIndex2) 288 | Set mSecondaryVector6(nIndex2) = iObj 289 | Else 290 | Aux = mSecondaryVector6(nIndex1) 291 | mSecondaryVector6(nIndex1) = mSecondaryVector6(nIndex2) 292 | mSecondaryVector6(nIndex2) = Aux 293 | End If 294 | End If 295 | 296 | End Sub 297 | 298 | 299 | Private Function Random(nFirst As Long, nLast As Long) As Long 300 | Random = nFirst + Rnd * (nLast - nFirst) 301 | End Function 302 | -------------------------------------------------------------------------------- /source/cls/cDlg.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 = "cDlg" 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 | Const DC_PAPERS = 2 17 | 'Const DC_PAPERNAMES = 16 18 | Const DC_PAPERSIZE = 3 19 | 20 | Private Declare Function GetForegroundWindow Lib "user32" () As Long 21 | Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, ByRef lpdwProcessId As Long) As Long 22 | 23 | 'Private Declare Function ResetDC Lib "gdi32" Alias "ResetDCA" (ByVal hDC As Long, lpInitData As Any) As Long 24 | Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, lpDevMode As Any) As Long 25 | 26 | Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long 27 | Private Const CLR_INVALID = -1 28 | 29 | 'API function called by ChooseColor method 30 | Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As T_ChooseColor) As Long 31 | 32 | 'API function called by ChooseFont method 33 | Private Declare Function CHOOSEFONT Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As T_CHOOSEFONT) As Long 34 | 35 | 'API function inside ShowHelp method 36 | Private Declare Function WinHelp Lib "user32" Alias "WinHelpA" (ByVal hWnd As Long, ByVal lpHelpFile As String, ByVal wCommand As Long, ByVal dwData As Long) As Long 37 | 38 | 'API function called by ShowOpen method 39 | Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As T_OpenFilename) As Long 40 | 41 | 'API function called by ShowSave method 42 | Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As T_OpenFilename) As Long 43 | 44 | 'API function called by ShowPrint method 45 | Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As T_PrintDlg) As Long 46 | 47 | 48 | 'API function to retrieve extended error information 49 | Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long 50 | 51 | Private Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long 52 | Private Const LOCALE_USER_DEFAULT As Long = &H400& 53 | Private Const LOCALE_IMEASURE As Long = &HD& 54 | 55 | 'API memory functions 56 | Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long 57 | Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long 58 | Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long 59 | Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long 60 | 61 | Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) 62 | Private Declare Function lstrlenPtr Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long 63 | 64 | Private Type BrowseInfo 65 | hwndOwner As Long 66 | pIDLRoot As Long 67 | pszDisplayName As String 68 | lpszTitle As String 69 | ulFlags As Long 70 | lpfnCallback As Long 71 | lParam As Long 72 | iImage As Long 73 | End Type 74 | 75 | Private Type SHITEMID 76 | cb As Long 77 | abID As Byte 78 | End Type 79 | 80 | Private Type ITEMIDLIST 81 | mkid As SHITEMID 82 | End Type 83 | 84 | Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long 85 | Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long 86 | Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) 87 | Private Declare Function SHGetFolderLocation Lib "shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, ByVal hToken As Long, ByVal dwReserved As Long, pidl As ITEMIDLIST) As Long 88 | Private Declare Function PathIsDirectory Lib "shlwapi.dll" Alias "PathIsDirectoryA" (ByVal pszPath As String) As Long 89 | Private Declare Function SHParseDisplayName Lib "shell32.dll" (ByVal pszName As Long, ByVal pbc As Long, ByRef ppidl As Long, ByVal sfgaoIn As Long, ByRef psfgaoOut As Long) As Long 90 | 91 | Private Const S_OK As Long = 0& 92 | Private Const CSIDL_PERSONAL As Long = &H5 93 | Private Const CSIDL_DRIVES As Long = &H11 94 | Private Const CSIDL_PRINTERS As Long = &H4 95 | 96 | 'constants for API memory functions 97 | Private Const GMEM_MOVEABLE = &H2 98 | Private Const GMEM_ZEROINIT = &H40 99 | Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT) 100 | 101 | 'data buffer for the ChooseColor function 102 | Private Type T_ChooseColor 103 | lStructSize As Long 104 | hwndOwner As Long 105 | hInstance As Long 106 | RGBResult As Long 107 | lpCustColors As Long 108 | Flags As Long 109 | lCustData As Long 110 | lpfnHook As Long 111 | lpTemplateName As String 112 | End Type 113 | 114 | 'constants for LOGFONT 115 | Private Const LF_FACESIZE As Long = 32 116 | 'Private Const LF_FULLFACESIZE As Long = 64 117 | 118 | 'Private Const FW_THIN As Long = 100 119 | 'Private Const FW_EXTRALIGHT As Long = 200 120 | 'Private Const FW_LIGHT As Long = 300 121 | Private Const FW_NORMAL As Long = 400 122 | 'Private Const FW_MEDIUM As Long = 500 123 | 'Private Const FW_SEMIBOLD As Long = 600 124 | Private Const FW_BOLD As Long = 700 125 | 'Private Const FW_EXTRABOLD As Long = 800 126 | 'Private Const FW_HEAVY As Long = 900 127 | 128 | 129 | 'data buffer for the ChooseFont function 130 | Private Type LOGFONT 131 | lfHeight As Long 132 | lfWidth As Long 133 | lfEscapement As Long 134 | lfOrientation As Long 135 | lfWeight As Long 136 | lfItalic As Byte 137 | lfUnderline As Byte 138 | lfStrikeOut As Byte 139 | lfCharSet As Byte 140 | lfOutPrecision As Byte 141 | lfClipPrecision As Byte 142 | lfQuality As Byte 143 | lfPitchAndFamily As Byte 144 | lfFaceName(0 To LF_FACESIZE - 1) As Byte 145 | End Type 146 | 147 | 'data buffer for the ChooseFont function 148 | Private Type T_CHOOSEFONT 149 | lStructSize As Long 150 | hwndOwner As Long 151 | hDC As Long 152 | lpLogFont As Long 153 | iPointSize As Long 154 | Flags As Long 155 | rgbColors As Long 156 | lCustData As Long 157 | lpfnHook As Long 158 | lpTemplateName As String 159 | hInstance As Long 160 | lpszStyle As String 161 | nFontType As Integer 162 | MISSING_ALIGNMENT As Integer 163 | nSizeMin As Long 164 | nSizeMax As Long 165 | End Type 166 | 167 | Private Type RECT 168 | Left As Long 169 | Top As Long 170 | Right As Long 171 | Bottom As Long 172 | End Type 173 | 174 | Private Type POINTAPI 175 | X As Long 176 | Y As Long 177 | End Type 178 | 179 | Private Type T_PAGESETUPDLG 180 | lStructSize As Long 181 | hwndOwner As Long 182 | hDevMode As Long 183 | hDevNames As Long 184 | Flags As Long 185 | ptPaperSize As POINTAPI 186 | rtMinMargin As RECT 187 | rtMargin As RECT 188 | hInstance As Long 189 | lCustData As Long 190 | lpfnPageSetupHook As Long 191 | lpfnPagePaintHook As Long 192 | lpPageSetupTemplateName As Long 193 | hPageSetupTemplate As Long 194 | End Type 195 | 196 | Private Declare Function PageSetupDlg Lib "COMDLG32" Alias "PageSetupDlgA" (lppage As T_PAGESETUPDLG) As Boolean 197 | 198 | Private Const CC_ENABLEHOOK = &H10& 199 | Private Const CC_ENABLETEMPLATE = &H20& 200 | Private Const CC_RGBINIT = &H1& 201 | 202 | Private Const CF_PRINTERFONTS As Long = &H2 203 | Private Const CF_SCREENFONTS As Long = &H1 204 | Private Const CF_INITTOLOGFONTSTRUCT As Long = &H40& 205 | 'Private Const CF_BOTH As Long = (CF_SCREENFONTS Or CF_PRINTERFONTS) 206 | Private Const CF_EFFECTS As Long = &H100 207 | Private Const CF_APPLY As Long = &H200 208 | Private Const CF_ENABLEHOOK As Long = &H8 209 | Private Const CF_ENABLETEMPLATE As Long = &H10 210 | Private Const CF_LIMITSIZE As Long = &H2000 211 | 212 | Private Const PD_ENABLEPRINTHOOK = &H1000& 213 | Private Const PD_ENABLESETUPHOOK = &H2000& 214 | Private Const PD_ENABLEPRINTTEMPLATE = &H4000& 215 | Private Const PD_ENABLESETUPTEMPLATE = &H8000& 216 | 217 | Private Const PSD_ENABLEPAGEPAINTHOOK As Long = &H40000 218 | Private Const PSD_ENABLEPAGESETUPHOOK As Long = &H2000& 219 | Private Const PSD_ENABLEPAGESETUPTEMPLATE As Long = &H8000& 220 | 221 | 222 | 'data buffer for the GetOpenFileName and GetSaveFileName functions 223 | Private Type T_OpenFilename 224 | lStructSize As Long 225 | hwndOwner As Long 226 | hInstance As Long 227 | lpstrFilter As String 228 | lpstrCustomFilter As String 229 | nMaxCustFilter As Long 230 | mFilterIndex As Long 231 | lpstrFile As String 232 | nMaxFile As Long 233 | lpstrFileTitle As String 234 | nMaxFileTitle As Long 235 | lpstrInitialDir As String 236 | lpstrTitle As String 237 | Flags As Long 238 | nFileOffset As Integer 239 | nFileExtension As Integer 240 | lpstrDefExt As String 241 | lCustData As Long 242 | lpfnHook As Long 243 | lpTemplateName As String 244 | End Type 245 | 246 | 247 | 'data buffer for the PrintDlg function 248 | Private Type T_PrintDlg 249 | lStructSize As Long 250 | hwndOwner As Long 251 | hDevMode As Long 252 | hDevNames As Long 253 | hDC As Long 254 | Flags As Long 255 | nFromPage As Integer 256 | nToPage As Integer 257 | nMinPage As Integer 258 | nMaxPage As Integer 259 | nCopies As Integer 260 | hInstance As Long 261 | lCustData As Long 262 | lpfnPrintHook As Long 263 | lpfnSetupHook As Long 264 | lpPrintTemplateName As String 265 | lpSetupTemplateName As String 266 | hPrintTemplate As Long 267 | hSetupTemplate As Long 268 | End Type 269 | 270 | 'constants for color dialog 271 | 272 | 'Private Const CDERR_DIALOGFAILURE = &HFFFF 273 | 'Private Const CDERR_FINDRESFAILURE = &H6 274 | 'Private Const CDERR_GENERALCODES = &H0 275 | 'Private Const CDERR_INITIALIZATION = &H2 276 | 'Private Const CDERR_LOADRESFAILURE = &H7 277 | 'Private Const CDERR_LOADSTRFAILURE = &H5 278 | 'Private Const CDERR_LOCKRESFAILURE = &H8 279 | 'Private Const CDERR_MEMALLOCFAILURE = &H9 280 | 'Private Const CDERR_MEMLOCKFAILURE = &HA 281 | 'Private Const CDERR_NOHINSTANCE = &H4 282 | 'Private Const CDERR_NOHOOK = &HB 283 | 'Private Const CDERR_NOTEMPLATE = &H3 284 | 'Private Const CDERR_REGISTERMSGFAIL = &HC 285 | 'Private Const CDERR_STRUCTSIZE = &H1 286 | 287 | 288 | 'constants for file dialog 289 | 290 | 'Private Const FNERR_BUFFERTOOSMALL As Long = &H3003 291 | 'Private Const FNERR_FILENAMECODES As Long = &H3000 292 | 'Private Const FNERR_INVALIDFILENAME As Long = &H3002 293 | 'Private Const FNERR_SUBCLASSFAILURE As Long = &H3001 294 | 295 | ' other constants 296 | Private Const CLEARTYPE_QUALITY As Byte = 6 297 | Private Const DEFAULT_CHARSET As Byte = 1 298 | 299 | Private Const CCHDEVICENAME = 32 300 | Private Const CCHFORMNAME = 32 301 | 302 | Private Const PSD_MARGINS As Long = &H2& 303 | Private Const PSD_INHUNDREDTHSOFMILLIMETERS = &H8& 304 | Private Const PSD_INTHOUSANDTHSOFINCHES = &H4& 305 | 306 | Private Type DEVMODE 307 | dmDeviceName As String * CCHDEVICENAME 308 | dmSpecVersion As Integer 309 | dmDriverVersion As Integer 310 | dmSize As Integer 311 | dmDriverExtra As Integer 312 | dmFields As Long 313 | dmOrientation As Integer 314 | dmPaperSize As Integer 315 | dmPaperLength As Integer 316 | dmPaperWidth As Integer 317 | dmScale As Integer 318 | dmCopies As Integer 319 | dmDefaultSource As Integer 320 | dmPrintQuality As Integer 321 | dmColor As Integer 322 | dmDuplex As Integer 323 | dmYResolution As Integer 324 | dmTTOption As Integer 325 | dmCollate As Integer 326 | dmFormName As String * CCHFORMNAME 327 | dmUnusedPadding As Integer 328 | dmBitsPerPel As Integer 329 | dmPelsWidth As Long 330 | dmPelsHeight As Long 331 | dmDisplayFlags As Long 332 | dmDisplayFrequency As Long 333 | End Type 334 | 335 | Private Type DEVNAMES 336 | wDriverOffset As Integer 337 | wDeviceOffset As Integer 338 | wOutputOffset As Integer 339 | wDefault As Integer 340 | End Type 341 | 342 | 343 | Public Enum CommonDialogsFlags 344 | 345 | ' File Open, Save as 346 | cdlOFNAllowMultiselect = &H200& 347 | cdlOFNCreatePrompt = &H2000& 348 | cdlOFNExplorer = &H80000 349 | cdlOFNExtensionDifferent = &H400& 350 | cdlOFNFileMustExist = &H1000& 351 | cdlOFNHelpButton = &H10& 352 | cdlOFNHideReadOnly = &H4& 353 | cdlOFNLongNames = &H200000 354 | cdlOFNNoChangeDir = &H8& 355 | cdlOFNNoDereferenceLinks = &H100000 356 | cdlOFNNoLongNames = &H40000 357 | cdlOFNNoReadOnlyReturn = &H8000& 358 | cdlOFNNoValidate = &H100& 359 | cdlOFNOverwritePrompt = &H2& 360 | cdlOFNPathMustExist = &H800& 361 | cdlOFNReadOnly = &H1& 362 | cdlOFNShareAware = &H4000& 363 | 364 | 'PrintFlags 365 | cdlPDAllPages = &H0& 366 | cdlPDSelection = &H1& 367 | cdlPDPageNums = &H2& 368 | cdlPDNoSelection = &H4& 369 | cdlPDNoPageNums = &H8& 370 | cdlPDCollate = &H10& 371 | cdlPDPrintToFile = &H20& 372 | cdlPDPrintSetup = &H40& 373 | cdlPDNoWarning = &H80& 374 | cdlPDReturnDC = &H100& 375 | cdlPDReturnIC = &H200& 376 | cdlPDReturnDefault = &H400& 377 | cdlPDHelpButton = &H800& 378 | cdlPDUseDevModeCopies = &H40000 379 | cdlPDDisablePrintToFile = &H80000 380 | cdlPDHidePrintToFile = &H100000 381 | 382 | 'ColorFlags 383 | cdlCCFullOpen = &H2& 384 | cdlCCShowHelpButton = &H8& 385 | cdlCCPreventFullOpen = &H4& 386 | cdlCCRGBInit = &H1& 387 | 388 | 'FontFlags 389 | cdlCFANSIOnly = &H400& 390 | cdlCFApply = &H200& 391 | cdlCFBoth = &H3& 392 | cdlCFEffects = &H100& 393 | cdlCFFixedPitchOnly = &H4000& 394 | cdlCFForceFontExist = &H10000 395 | cdlCFHelpButton = &H4& 396 | cdlCFLimitSize = &H2000& 397 | cdlCFNoFaceSel = &H80000 398 | cdlCFNoSimulations = &H1000& 399 | cdlCFNoSizeSel = &H200000 400 | cdlCFNoStyleSel = &H100000 401 | cdlCFNoVectorFonts = &H800& 402 | cdlCFPrinterFonts = &H2& 403 | cdlCFScalableOnly = &H20000 404 | cdlCFScreenFonts = &H1& 405 | cdlCFTTOnly = &H40000 406 | cdlCFWYSIWYG = &H8000& 407 | 408 | ' Page setup flags 409 | cdlPSDefaultMinMargins = &H0& 410 | cdlPSDisableMargins = &H10& 411 | cdlPSDisableOrientation = &H100& 412 | cdlPSDisablePagePainting = &H80000 413 | cdlPSDisablePaper = &H200& 414 | cdlPSDisablePrinter = &H20& 415 | 'cdlPSMargins = &H2& 416 | cdlPSMinMargins = &H1& 417 | cdlPSNoNetworkButton = &H200000 418 | cdlPSNoWarning = &H80& 419 | cdlPSReturnDefault = &H400& 420 | cdlPSShowHelp = &H800& 421 | 422 | ' Show Folder 423 | cdlSFReturnOnlyFSDirs = &H1& 424 | cdlSFDontGoBelowDomain = &H2& 425 | cdlSFStatusText = &H4& 426 | cdlSFReturnFSAncestors = &H8& 427 | cdlSFEditBox = &H10& 428 | cdlSFValidate = &H20& 429 | cdlSFNewDialogStyle = &H40& 430 | cdlSFUseNewUI = (cdlSFNewDialogStyle Or cdlSFEditBox) 431 | cdlSFBrowseIncludeURLs = &H80& 432 | cdlSFUAHint = &H100& 433 | cdlSFNoNewFolderButton = &H200& 434 | cdlSFNoTranslateTargets = &H400& 435 | cdlSFNoReturnOnlyFSDirs = &H800& 436 | cdlSFBrowseForComputer = &H1000& 437 | cdlSFBrowseForPrinter = &H2000& 438 | cdlSFBrowseIncludeFiles = &H4000& 439 | cdlSFShareable = &H8000& 440 | End Enum 441 | 442 | Public Enum cdeCommonDialogExFileFlagsConstants 443 | cdeOFNAllowMultiselect = CommonDialogsFlags.cdlOFNAllowMultiselect 444 | cdeOFNCreatePrompt = CommonDialogsFlags.cdlOFNCreatePrompt 445 | cdeOFNExplorer = CommonDialogsFlags.cdlOFNExplorer 446 | cdeOFNExtensionDifferent = CommonDialogsFlags.cdlOFNExtensionDifferent 447 | cdeOFNFileMustExist = CommonDialogsFlags.cdlOFNFileMustExist 448 | cdeOFNHelpButton = CommonDialogsFlags.cdlOFNHelpButton 449 | cdeOFNHideReadOnly = CommonDialogsFlags.cdlOFNHideReadOnly 450 | cdeOFNLongNames = CommonDialogsFlags.cdlOFNLongNames 451 | cdeOFNNoChangeDir = CommonDialogsFlags.cdlOFNNoChangeDir 452 | cdeOFNNoDereferenceLinks = CommonDialogsFlags.cdlOFNNoDereferenceLinks 453 | cdeOFNNoLongNames = CommonDialogsFlags.cdlOFNNoLongNames 454 | cdeOFNNoReadOnlyReturn = CommonDialogsFlags.cdlOFNNoReadOnlyReturn 455 | cdeOFNNoValidate = CommonDialogsFlags.cdlOFNNoValidate 456 | cdeOFNOverwritePrompt = CommonDialogsFlags.cdlOFNOverwritePrompt 457 | cdeOFNPathMustExist = CommonDialogsFlags.cdlOFNPathMustExist 458 | cdeOFNReadOnly = CommonDialogsFlags.cdlOFNReadOnly 459 | cdeOFNShareAware = CommonDialogsFlags.cdlOFNShareAware 460 | End Enum 461 | 462 | Public Enum cdeCommonDialogExPrinterFlagsConstants 463 | cdePDAllPages = CommonDialogsFlags.cdlPDAllPages 464 | cdePDSelection = CommonDialogsFlags.cdlPDSelection 465 | cdePDPageNums = CommonDialogsFlags.cdlPDPageNums 466 | cdePDNoSelection = CommonDialogsFlags.cdlPDNoSelection 467 | cdePDNoPageNums = CommonDialogsFlags.cdlPDNoPageNums 468 | cdePDCollate = CommonDialogsFlags.cdlPDCollate 469 | cdePDPrintToFile = CommonDialogsFlags.cdlPDPrintToFile 470 | cdePDPrintSetup = CommonDialogsFlags.cdlPDPrintSetup 471 | cdePDNoWarning = CommonDialogsFlags.cdlPDNoWarning 472 | cdePDReturnDC = CommonDialogsFlags.cdlPDReturnDC 473 | cdePDReturnIC = CommonDialogsFlags.cdlPDReturnIC 474 | cdePDReturnDefault = CommonDialogsFlags.cdlPDReturnDefault 475 | cdePDHelpButton = CommonDialogsFlags.cdlPDHelpButton 476 | cdePDUseDevModeCopies = CommonDialogsFlags.cdlPDUseDevModeCopies 477 | cdePDDisablePrintToFile = CommonDialogsFlags.cdlPDDisablePrintToFile 478 | cdePDHidePrintToFile = CommonDialogsFlags.cdlPDHidePrintToFile 479 | End Enum 480 | 481 | Public Enum cdeCommonDialogExColorFlagsConstants 482 | cdeCCFullOpen = CommonDialogsFlags.cdlCCFullOpen 483 | cdeCCShowHelpButton = CommonDialogsFlags.cdlCCShowHelpButton 484 | cdeCCPreventFullOpen = CommonDialogsFlags.cdlCCPreventFullOpen 485 | ' cdeCCRGBInit = CommonDialogsFlags.cdlCCRGBInit 486 | End Enum 487 | 488 | Public Enum cdeCommonDialogExFontFlagsConstants 489 | cdeCFANSIOnly = CommonDialogsFlags.cdlCFANSIOnly 490 | cdeCFApply = CommonDialogsFlags.cdlCFApply 491 | cdeCFBoth = CommonDialogsFlags.cdlCFBoth 492 | cdeCFEffects = CommonDialogsFlags.cdlCFEffects 493 | cdeCFFixedPitchOnly = CommonDialogsFlags.cdlCFFixedPitchOnly 494 | cdeCFForceFontExist = CommonDialogsFlags.cdlCFForceFontExist 495 | cdeCFHelpButton = CommonDialogsFlags.cdlCFHelpButton 496 | cdeCFLimitSize = CommonDialogsFlags.cdlCFLimitSize 497 | cdeCFNoFaceSel = CommonDialogsFlags.cdlCFNoFaceSel 498 | cdeCFNoSimulations = CommonDialogsFlags.cdlCFNoSimulations 499 | cdeCFNoSizeSel = CommonDialogsFlags.cdlCFNoSizeSel 500 | cdeCFNoStyleSel = CommonDialogsFlags.cdlCFNoStyleSel 501 | cdeCFNoVectorFonts = CommonDialogsFlags.cdlCFNoVectorFonts 502 | cdeCFPrinterFonts = CommonDialogsFlags.cdlCFPrinterFonts 503 | cdeCFScalableOnly = CommonDialogsFlags.cdlCFScalableOnly 504 | cdeCFScreenFonts = CommonDialogsFlags.cdlCFScreenFonts 505 | cdeCFTTOnly = CommonDialogsFlags.cdlCFTTOnly 506 | cdeCFWYSIWYG = CommonDialogsFlags.cdlCFWYSIWYG 507 | End Enum 508 | 509 | Public Enum cdeCommonDialogExPageSetupFlagsConstants 510 | cdePSDefaultMinMargins = CommonDialogsFlags.cdlPSDefaultMinMargins 511 | cdePSDisableMargins = CommonDialogsFlags.cdlPSDisableMargins 512 | cdePSDisableOrientation = CommonDialogsFlags.cdlPSDisableOrientation 513 | cdePSDisablePagePainting = CommonDialogsFlags.cdlPSDisablePagePainting 514 | cdePSDisablePaper = CommonDialogsFlags.cdlPSDisablePaper 515 | cdePSDisablePrinter = CommonDialogsFlags.cdlPSDisablePrinter 516 | ' cdePSMargins = CommonDialogsFlags.cdlPSMargins 517 | cdePSMinMargins = CommonDialogsFlags.cdlPSMinMargins 518 | cdePSNoNetworkButton = CommonDialogsFlags.cdlPSNoNetworkButton 519 | cdePSNoWarning = CommonDialogsFlags.cdlPSNoWarning 520 | cdePSReturnDefault = CommonDialogsFlags.cdlPSReturnDefault 521 | cdePSShowHelp = CommonDialogsFlags.cdlPSShowHelp 522 | End Enum 523 | 524 | Public Enum cdeCommonDialogExFolderFlagsConstants 525 | cdeSFReturnOnlyFSDirs = CommonDialogsFlags.cdlSFReturnOnlyFSDirs 526 | cdeSFDontGoBelowDomain = CommonDialogsFlags.cdlSFDontGoBelowDomain 527 | cdeSFStatusText = CommonDialogsFlags.cdlSFStatusText 528 | cdeSFReturnFSAncestors = CommonDialogsFlags.cdlSFReturnFSAncestors 529 | cdeSFEditBox = CommonDialogsFlags.cdlSFEditBox 530 | cdeSFValidate = CommonDialogsFlags.cdlSFValidate 531 | cdeSFNewDialogStyle = CommonDialogsFlags.cdlSFNewDialogStyle 532 | cdeSFUseNewUI = CommonDialogsFlags.cdlSFUseNewUI 533 | cdeSFBrowseIncludeURLs = CommonDialogsFlags.cdlSFBrowseIncludeURLs 534 | cdeSFUAHint = CommonDialogsFlags.cdlSFUAHint 535 | cdeSFNoNewFolderButton = CommonDialogsFlags.cdlSFNoNewFolderButton 536 | cdeSFNoTranslateTargets = CommonDialogsFlags.cdlSFNoTranslateTargets 537 | cdeSFNoReturnOnlyFSDirs = CommonDialogsFlags.cdlSFNoReturnOnlyFSDirs 538 | cdeSFBrowseForComputer = CommonDialogsFlags.cdlSFBrowseForComputer 539 | cdeSFBrowseForPrinter = CommonDialogsFlags.cdlSFBrowseForPrinter 540 | cdeSFBrowseIncludeFiles = CommonDialogsFlags.cdlSFBrowseIncludeFiles 541 | cdeSFShareable = CommonDialogsFlags.cdlSFShareable 542 | 543 | End Enum 544 | 545 | 546 | ' Other Public enumerations 547 | Public Enum cdePageOrientationConstants 548 | vbPRORPrinterDefault = 0& 549 | vbPRORPortrait = 1& 550 | vbPRORLandscape = 2& 551 | End Enum 552 | 553 | Public Enum cdeColorModeConstants 554 | vbPRCMPrinterDefault = 0& 555 | vbPRCMColor = 2& 556 | vbPRCMMonochrome = 1& 557 | End Enum 558 | 559 | Public Enum cdePaperBinConstants 560 | vbPRBNPrinterDefault = 0& 561 | vbPRBNUpper = 1& 562 | vbPRBNLower = 2& 563 | vbPRBNMiddle = 3& 564 | vbPRBNManual = 4& 565 | vbPRBNEnvelope = 5& 566 | vbPRBNEnvManual = 6& 567 | vbPRBNAuto = 7& 568 | vbPRBNTractor = 8& 569 | vbPRBNSmallFmt = 9& 570 | vbPRBNLargeFmt = 10& 571 | vbPRBNLargeCapacity = 11& 572 | vbPRBNCassette = 14& 573 | End Enum 574 | 575 | Public Enum cdePaperSizeConstants 576 | vbPRPSPrinterDefault = 0& 577 | vbPRPSLetter = 1& 578 | vbPRPSLetterSmall = 2& 579 | vbPRPSTabloid = 3& 580 | vbPRPSLedger = 4& 581 | vbPRPSLegal = 5& 582 | vbPRPSStatement = 6& 583 | vbPRPSExecutive = 7& 584 | vbPRPSA3 = 8& 585 | vbPRPSA4 = 9& 586 | vbPRPSA4Small = 10& 587 | vbPRPSA5 = 11& 588 | vbPRPSB4 = 12& 589 | vbPRPSB5 = 13& 590 | vbPRPSFolio = 14& 591 | vbPRPSQuarto = 15& 592 | vbPRPS10x14 = 16& 593 | vbPRPS11x17 = 17& 594 | vbPRPSNote = 18& 595 | vbPRPSEnv9 = 19& 596 | vbPRPSEnv10 = 20& 597 | vbPRPSEnv11 = 21& 598 | vbPRPSEnv12 = 22& 599 | vbPRPSEnv14 = 23& 600 | vbPRPSCSheet = 24& 601 | vbPRPSDSheet = 25& 602 | vbPRPSESheet = 26& 603 | vbPRPSEnvDL = 27& 604 | vbPRPSEnvC3 = 29& 605 | vbPRPSEnvC4 = 30& 606 | vbPRPSEnvC5 = 28& 607 | vbPRPSEnvC6 = 31& 608 | vbPRPSEnvC65 = 32& 609 | vbPRPSEnvB4 = 33& 610 | vbPRPSEnvB5 = 34& 611 | vbPRPSEnvB6 = 35& 612 | vbPRPSEnvItaly = 36& 613 | vbPRPSEnvMonarch = 37& 614 | vbPRPSEnvPersonal = 38& 615 | vbPRPSFanfoldUS = 39& 616 | vbPRPSFanfoldStdGerman = 40& 617 | vbPRPSFanfoldLglGerman = 41& 618 | vbPRPSUser = 256& 619 | End Enum 620 | 621 | Public Enum cdePrintQualityConstants 622 | vbPRPQPrinterDefault = 0& 623 | vbPRPQDraft = -1& 624 | vbPRPQLow = -2& 625 | vbPRPQMedium = -3& 626 | vbPRPQHigh = -4& 627 | End Enum 628 | 629 | Public Enum cdeDuplexConstants 630 | vbPRDPPrinterDefault = 0& 631 | vbPRDPSimplex = 1& 632 | vbPRDPHorizontal = 2& 633 | vbPRDPVertical = 3& 634 | End Enum 635 | 636 | Public Enum cdeUnits 637 | vbMillimeters = 6& 638 | vbInches = 5& 639 | End Enum 640 | 641 | Public Enum cdeUnitsForUser 642 | cdeMUUserLocale = 0& 643 | cdeMUMillimeters = 6& 644 | cdeMUInches = 5& 645 | End Enum 646 | 647 | 'Properties 648 | 649 | Private mAction As Integer 650 | Private mCancelError As Boolean 651 | Private mColor As Long 652 | Private mCopies As Long 653 | Private mCollate As Boolean 654 | Private mDefaultExt As String 655 | Private mDialogTitle As String 656 | Private mFileName As String 657 | Private mFileTitle As String 658 | Private mFilter As String 659 | Private mFilterIndex As Integer 660 | Private mFlags As Long 661 | Private mFont As StdFont 662 | 'Private mFont.Bold As Boolean 663 | 'Private mFont.Italic As Boolean 664 | 'Private mFont.Name As String 665 | 'Private mFont.Size As Long 666 | 'Private mFont.Strikethrough As Boolean 667 | 'Private mFont.Underline As Boolean 668 | Private mFromPage As Long 669 | Private mhDc As Long 670 | Private mHelpCommand As Long 671 | Private mHelpContext As Long 672 | Private mHelpFile As String 673 | Private mHelpKey As String 674 | Private mInitDir As String 675 | Private mMax As Long 676 | Private mMaxFileSize As Long 677 | Private mMin As Long 678 | 'Private mPrinterDefault As Integer 679 | Private mToPage As Long 680 | Private mOrientation As Long 681 | Private mCustomColors(0 To 15) As Long 682 | Private mAutoSaveCustomColors As Boolean 683 | Private mCustomColorsLoaded As Boolean 684 | 685 | ' added property for show folder 686 | Private mFolderName As String 687 | Private mFolderDisplayName As String 688 | Private mRootFolder As String 689 | Private mFolderDialogHeader As String 690 | 691 | Private mApiReturn As Long 692 | Private mExtendedError As Long 693 | Private mCanceled As Boolean 694 | Private mChanged As Boolean 695 | 696 | ' Added properties special for printer and page setup 697 | Private mPaperSize As Long 698 | Private mPaperBin As Long 699 | Private mPrintQuality As Long 700 | Private mColorMode As Long 701 | Private mDuplex As Long 702 | ' read only 703 | Private mDeviceName As String 704 | Private mDriverName As String 705 | Private mPort As String 706 | Private mPaperWidth As Long 707 | Private mPaperHeight As Long 708 | Private mDefaultPaperWidth As Long 709 | Private mDefaultPaperHeight As Long 710 | 711 | ' added properties special for page setup 712 | Private mLeftMargin As Single 713 | Private mRightMargin As Single 714 | Private mTopMargin As Single 715 | Private mBottomMargin As Single 716 | Private mMinLeftMargin As Single 717 | Private mMinRightMargin As Single 718 | Private mMinTopMargin As Single 719 | Private mMinBottomMargin As Single 720 | 'Private mMarginSet As Boolean 721 | Private mUnits As Long 722 | Private mUnitsForUser As Long 723 | 724 | Private Const cLeftMarginDefault As Single = 20 725 | Private Const cRightMarginDefault As Single = 15 726 | Private Const cTopMarginDefault As Single = 20 727 | Private Const cBottomMarginDefault As Single = 20 728 | 729 | 730 | ' added property for show folder 731 | Private mDialogHeader As String 732 | 733 | ' auxiliary variables 734 | Private mDevMode As DEVMODE 735 | Private mDevNames As DEVNAMES 736 | Private mDevModePtr As Long 737 | Private mDevNamesPtr As Long 738 | Private mhDevNames As Long 739 | Private mhDevMode As Long 740 | Private mPageSet As Boolean 741 | 742 | Private mAmbientUserMode As Boolean 743 | 744 | Public Sub ShowColor(Optional ByVal nFlags As cdeCommonDialogExColorFlagsConstants = -1) 745 | 'display the color dialog box 746 | 747 | Dim tChooseColor As T_ChooseColor 748 | Dim lCustomColorSize As Long 749 | Dim lCustomColorAddress As Long 750 | Dim lMemHandle As Long 751 | Dim iHwndOwner As Long 752 | Dim iFlags As Long 753 | 754 | On Error GoTo ShowColorError 755 | 756 | iHwndOwner = GetActiveWindowHwnd 757 | iFlags = mFlags 758 | If nFlags <> -1 Then 759 | iFlags = iFlags Or nFlags 760 | End If 761 | 762 | mAction = 3 'Action property - ShowColor 763 | mApiReturn = 0 'APIReturn property 764 | mExtendedError = 0 'ExtendedError property 765 | 766 | ' If mAutoSaveCustomColors Then 767 | ' If Not mCustomColorsLoaded Then LoadCustomColors 768 | ' End If 769 | 770 | tChooseColor.lStructSize = Len(tChooseColor) 771 | 772 | tChooseColor.hwndOwner = iHwndOwner 773 | 774 | ' Get size of memory needed for custom colors 775 | lCustomColorSize = Len(mCustomColors(0)) * 16 776 | ' Get a global memory block to hold a copy of the custom colors 777 | lMemHandle = GlobalAlloc(GHND, lCustomColorSize) 778 | 779 | If lMemHandle = 0 Then 780 | Exit Sub 781 | End If 782 | ' Lock the custom color's global memory block 783 | lCustomColorAddress = GlobalLock(lMemHandle) 784 | If lCustomColorAddress = 0 Then 785 | Exit Sub 786 | End If 787 | ' Copy custom colors to the global memory block 788 | CopyMemory ByVal lCustomColorAddress, mCustomColors(0), lCustomColorSize 789 | 790 | tChooseColor.lpCustColors = lCustomColorAddress 791 | 792 | tChooseColor.Flags = iFlags And Not (CC_ENABLEHOOK Or CC_ENABLETEMPLATE) Or CC_RGBINIT 793 | 794 | tChooseColor.RGBResult = TranslateAColor(mColor) 795 | 796 | 797 | '*** call the ChooseColor API function 798 | mApiReturn = ChooseColor(tChooseColor) 799 | 800 | '*** handle return from ChooseColor API function 801 | mCanceled = False 802 | Select Case mApiReturn 803 | 804 | Case 0 'user canceled 805 | mCanceled = True 806 | If mCancelError Then 807 | 'generate an error 808 | On Error GoTo 0 809 | Err.Raise 32755, "Cancel Pressed" 810 | Exit Sub 811 | End If 812 | 813 | Case 1 'user selected a color 814 | 'update property buffer 815 | mColor = tChooseColor.RGBResult 816 | 817 | ' CopyMemory mCustomColors(0), ByVal lCustomColorAddress, lCustomColorSize 818 | ' If mAutoSaveCustomColors Then 819 | ' SaveCustomColors 820 | ' End If 821 | 822 | Case Else 'an error occured 823 | 'call CommDlgExtendedError 824 | mExtendedError = CommDlgExtendedError 825 | 826 | End Select 827 | 828 | GlobalFree lMemHandle 829 | 830 | Exit Sub 831 | 832 | ShowColorError: 833 | Exit Sub 834 | End Sub 835 | 836 | Public Sub ShowFont(Optional ByVal nFlags As cdeCommonDialogExFontFlagsConstants = -1) 837 | 'display the font dialog box 838 | 839 | Dim tLogFont As LOGFONT 840 | Dim tChooseFont As T_CHOOSEFONT 841 | Dim lLogFontSize As Long 842 | Dim lLogFontAddress As Long 843 | Dim lMemHandle As Long 844 | Dim i As Long 845 | Dim iHwndOwner As Long 846 | Dim iFlags As Long 847 | 848 | On Error GoTo ShowFontError 849 | 850 | iHwndOwner = GetActiveWindowHwnd 851 | iFlags = mFlags 852 | If nFlags <> -1 Then 853 | iFlags = iFlags Or nFlags 854 | End If 855 | 856 | '*** init property buffers 857 | 858 | mAction = 4 'Action property - ShowFont 859 | mApiReturn = 0 'APIReturn property 860 | mExtendedError = 0 'ExtendedError property 861 | 862 | 863 | '*** prepare tChooseFont data 864 | 865 | 866 | tLogFont.lfHeight = mFont.Size * 20 / Screen.TwipsPerPixelY * -1 ' PointsPerTwip = 1440 / 72 = 20 867 | 'tLogFont.lfWidth As Long 868 | 'tLogFont.lfEscapement As Long 869 | 'tLogFont.lfOrientation As Long 870 | 871 | 'tLogFont.lfWeight As Long - init from FontBold property 872 | If mFont.Bold Then 873 | tLogFont.lfWeight = FW_BOLD 874 | Else 875 | tLogFont.lfWeight = FW_NORMAL 876 | End If 877 | 878 | 'tLogFont.lfItalic As Byte - init from FontItalic property 879 | If mFont.Italic Then 880 | tLogFont.lfItalic = 1 881 | End If 882 | 883 | 'tLogFont.lfUnderline As Byte - init from FontUnderline property 884 | If mFont.Underline Then 885 | tLogFont.lfUnderline = 1 886 | End If 887 | 888 | 'tLogFont.lfStrikeOut As Byte - init from FontStrikethru property 889 | If mFont.Strikethrough Then 890 | tLogFont.lfStrikeOut = 1 891 | End If 892 | 893 | 894 | tLogFont.lfCharSet = DEFAULT_CHARSET 895 | 'tLogFont.lfOutPrecision As Byte 896 | 'tLogFont.lfClipPrecision As Byte 897 | tLogFont.lfQuality = CLEARTYPE_QUALITY 898 | 'tLogFont.lfPitchAndFamily As Byte 899 | 900 | For i = 0 To Len(mFont.Name) - 1 901 | If i > 31 Then Exit For 902 | tLogFont.lfFaceName(i) = Asc(Mid$(mFont.Name, i + 1, 1)) 903 | Next 904 | 905 | lLogFontSize = Len(tLogFont) 906 | 907 | 908 | tChooseFont.lStructSize = Len(tChooseFont) 909 | tChooseFont.hwndOwner = iHwndOwner 910 | tChooseFont.rgbColors = mColor 911 | ' tChooseFont.lCustData = 0 912 | ' tChooseFont.lpfnHook = 0 913 | tChooseFont.lpTemplateName = Space$(2048) 914 | 'tChooseFont.hInstance As Long 915 | 916 | 'tChooseFont.lpszStyle As String 917 | 'sFont = Chr$(0) & Space$(20) & Chr$(0) 918 | 'tChooseFont.lpszStyle = sFont 919 | 920 | ' tChooseFont.nFontType = Screen.FontCount 921 | 'tChooseFont.MISSING_ALIGNMENT As Integer 922 | tChooseFont.nSizeMin = mMin 923 | tChooseFont.nSizeMax = mMax 924 | 925 | 926 | 'tChooseFont.lpLogFont As Long 927 | 928 | ' Get a global memory block to hold a copy of tLogFont - exit on failure 929 | lMemHandle = GlobalAlloc(GHND, lLogFontSize) 930 | If lMemHandle = 0 Then 931 | Exit Sub 932 | End If 933 | 934 | ' Lock tLogFont's global memory block - exit on failure 935 | lLogFontAddress = GlobalLock(lMemHandle) 936 | If lLogFontAddress = 0 Then 937 | Exit Sub 938 | End If 939 | 940 | ' Copy tLogFont to the global memory block 941 | Call CopyMemory(ByVal lLogFontAddress, tLogFont, lLogFontSize) 942 | 943 | tChooseFont.lpLogFont = lLogFontAddress 944 | 945 | 'tChooseFont.iPointSize As Long - init from FontSize property 946 | tChooseFont.iPointSize = mFont.Size * 10 947 | 948 | ' Flags can get reference variable or constant with bit flags 949 | tChooseFont.Flags = iFlags Or CF_INITTOLOGFONTSTRUCT And Not (CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE) 950 | 951 | If mhDc = 0 Then 952 | If Not Printer Is Nothing Then 953 | If ((tChooseFont.Flags And CF_PRINTERFONTS) = CF_PRINTERFONTS) Then tChooseFont.hDC = Printer.hDC 954 | End If 955 | Else 956 | tChooseFont.Flags = tChooseFont.Flags Or CF_PRINTERFONTS 957 | tChooseFont.hDC = mhDc 958 | End If 959 | ' Must have some fonts 960 | If (tChooseFont.Flags And CF_PRINTERFONTS) = 0 Then tChooseFont.Flags = tChooseFont.Flags Or CF_SCREENFONTS 961 | ' Color can take initial color, receive chosen color 962 | If mColor <> 0 Then tChooseFont.Flags = tChooseFont.Flags Or CF_EFFECTS 963 | ' MinSize can be minimum size accepted 964 | If (mMin <> 0) Then tChooseFont.Flags = tChooseFont.Flags Or CF_LIMITSIZE 965 | ' MaxSize can be maximum size accepted 966 | If (mMax <> 0) Then tChooseFont.Flags = tChooseFont.Flags Or CF_LIMITSIZE 967 | 968 | 'tChooseFont.Flags = tChooseFont.Flags And Not CF_LIMITSIZE 969 | 970 | '*** call the CHOOSEFONT API function 971 | mApiReturn = CHOOSEFONT(tChooseFont) 'store to APIReturn property 972 | 973 | 974 | '*** handle return from CHOOSEFONT API function 975 | mCanceled = False 976 | Select Case mApiReturn 977 | 978 | Case 0 'user canceled 979 | mCanceled = True 980 | If mCancelError Then 981 | 'generate an error 982 | Err.Raise 32755, "Cancel Pressed" 983 | Exit Sub 984 | End If 985 | 986 | Case 1 'user selected a font 987 | ' Copy global memory block to tLogFont 988 | Call CopyMemory(tLogFont, ByVal lLogFontAddress, lLogFontSize) 989 | 990 | 'tLogFont.lfWeight As Long - store to FontBold property 991 | If tLogFont.lfWeight >= FW_BOLD Then 992 | mFont.Bold = True 993 | Else 994 | mFont.Bold = False 995 | End If 996 | 997 | 'tLogFont.lfItalic As Byte - store to FontItalic property 998 | If tLogFont.lfItalic <> 0 Then 999 | mFont.Italic = True 1000 | Else 1001 | mFont.Italic = False 1002 | End If 1003 | 1004 | 'tLogFont.lfUnderline As Byte - store to FontUnderline property 1005 | If tLogFont.lfUnderline <> 0 Then 1006 | mFont.Underline = True 1007 | Else 1008 | mFont.Underline = False 1009 | End If 1010 | 1011 | 'tLogFont.lfStrikeOut As Byte - store to FontStrikethru property 1012 | If tLogFont.lfStrikeOut <> 0 Then 1013 | mFont.Strikethrough = True 1014 | Else 1015 | mFont.Strikethrough = False 1016 | End If 1017 | 1018 | mColor = tChooseFont.rgbColors 1019 | 1020 | 'tLogFont.lfFaceName(LF_FACESIZE) As Byte - store to FontName property 1021 | FontName = sByteArrayToString(tLogFont.lfFaceName()) 1022 | 1023 | 'tChooseFont.iPointSize As Long - store to FontSize property 1024 | mFont.Size = CLng(tChooseFont.iPointSize / 10) 1025 | 1026 | Case Else 'an error occured 1027 | 'call CommDlgExtendedError 1028 | mExtendedError = CommDlgExtendedError 'store to ExtendedError property 1029 | 1030 | End Select 1031 | Exit Sub 1032 | 1033 | ShowFontError: 1034 | Exit Sub 1035 | End Sub 1036 | 1037 | 1038 | Public Property Set Font(nFont As StdFont) 1039 | If nFont Is Nothing Then Exit Property 1040 | Set mFont = CloneFont(nFont) 1041 | End Property 1042 | 1043 | Public Property Get Font() As StdFont 1044 | Set Font = CloneFont(mFont) 1045 | End Property 1046 | 1047 | 1048 | Public Sub ShowHelp() 1049 | 'run winhelp.exe with the specified help file 1050 | Dim sHelpFileBuff As String 1051 | Dim lData As Long 1052 | 1053 | On Error GoTo ShowHelpError 1054 | 1055 | '*** init Private properties 1056 | mAction = 6 'Action property - ShowHelp 1057 | mApiReturn = 0 'APIReturn property 1058 | mExtendedError = 0 'ExtendedError property 1059 | 1060 | '*** prepare the buffers and parameters for the API function 1061 | 'mHelpFile is a null terminated string 1062 | sHelpFileBuff = mHelpFile & Chr$(0) 1063 | 1064 | 'sData is dependent on mHelpCommand 1065 | Select Case mHelpCommand 1066 | Case 0 1067 | lData = 0 1068 | Case Else 1069 | lData = 0 1070 | End Select 1071 | 1072 | '*** call the API function 1073 | mApiReturn = WinHelp(0&, mHelpFile, mHelpCommand, lData) ' - Store to APIReturn property 1074 | 1075 | Select Case mApiReturn 1076 | 1077 | Case 0 ' 1078 | 'call CommDlgExtendedError 1079 | mExtendedError = CommDlgExtendedError ' - store to ExtendedError property 1080 | 1081 | Case Else ' 1082 | 'call CommDlgExtendedError 1083 | mExtendedError = CommDlgExtendedError 1084 | 1085 | End Select 1086 | 1087 | Exit Sub 1088 | 1089 | ShowHelpError: 1090 | Exit Sub 1091 | End Sub 1092 | 1093 | 1094 | Public Sub ShowOpen(Optional ByVal nFlags As cdeCommonDialogExFileFlagsConstants = -1) 1095 | Dim iHwndOwner As Long 1096 | Dim iFlags As Long 1097 | 1098 | 'display the file open dialog box 1099 | iHwndOwner = GetActiveWindowHwnd 1100 | iFlags = mFlags 1101 | If nFlags <> -1 Then 1102 | iFlags = iFlags Or nFlags 1103 | End If 1104 | ShowFileDialog 1, iFlags, iHwndOwner 'Action property - ShowOpen 1105 | 1106 | End Sub 1107 | 1108 | Public Sub ShowPrinter(Optional ByVal nFlags As cdeCommonDialogExPrinterFlagsConstants = -1) 1109 | Dim iHwndOwner As Long 1110 | Dim iFlags As Long 1111 | 1112 | 'display the print dialog 1113 | Dim tPrintDlg As T_PrintDlg 1114 | 1115 | On Error GoTo ShowPrinterError 1116 | 1117 | iHwndOwner = GetActiveWindowHwnd 1118 | iFlags = mFlags 1119 | If nFlags <> -1 Then 1120 | iFlags = iFlags Or nFlags 1121 | End If 1122 | 1123 | iFlags = iFlags And Not PD_ENABLEPRINTHOOK 1124 | iFlags = iFlags And Not PD_ENABLEPRINTTEMPLATE 1125 | iFlags = iFlags And Not PD_ENABLESETUPHOOK 1126 | iFlags = iFlags And Not PD_ENABLESETUPTEMPLATE 1127 | 1128 | 1129 | mAction = 5 'Action property - ShowPrint 1130 | mApiReturn = 0 'APIReturn property 1131 | mExtendedError = 0 'ExtendedError property 1132 | 1133 | 1134 | tPrintDlg.lStructSize = Len(tPrintDlg) 1135 | 1136 | tPrintDlg.hwndOwner = iHwndOwner 1137 | 1138 | If (iFlags And cdlPDReturnDefault) <> 0 Then 1139 | tPrintDlg.hDevMode = 0 1140 | tPrintDlg.hDevNames = 0 1141 | If mDevModePtr <> 0 Then 1142 | mDevModePtr = 0 1143 | mDevNamesPtr = 0 1144 | GlobalUnlock mhDevMode 1145 | GlobalUnlock mhDevNames 1146 | mhDevMode = 0 1147 | mhDevNames = 0 1148 | End If 1149 | Else 1150 | If mDevModePtr <> 0 Then 1151 | tPrintDlg.hDevMode = mhDevMode 1152 | UpdateDevModeWithCurrentSettings 1153 | tPrintDlg.hDevNames = mhDevNames 1154 | GlobalUnlock mhDevMode 1155 | GlobalUnlock mhDevNames 1156 | mDevModePtr = 0 1157 | mDevNamesPtr = 0 1158 | End If 1159 | End If 1160 | 1161 | 'hDevMode As Long 1162 | 1163 | 'hDevNames As Long 1164 | 1165 | 'flags As Long - init from Flags property 1166 | tPrintDlg.Flags = iFlags Or cdlPDUseDevModeCopies Or cdlPDReturnDC ' it requires these two flags to return the number of copies properly 1167 | 1168 | 'nFromPage As Integer - init from FromPage property 1169 | tPrintDlg.nFromPage = mFromPage 1170 | 1171 | 'nToPage As Integer - init from ToPage property 1172 | tPrintDlg.nToPage = mToPage 1173 | 1174 | 'nMinPage As Integer - init from Min property 1175 | tPrintDlg.nMinPage = mMin 1176 | 1177 | 'nMaxPage As Integer - init from Max property 1178 | tPrintDlg.nMaxPage = mMax 1179 | 1180 | 'nCopies As Integer - init from Copies property 1181 | tPrintDlg.nCopies = mCopies 1182 | 1183 | 'hInstance As Long 1184 | 1185 | 'lCustData As Long 1186 | 1187 | 1188 | '*** Call the PrintDlg API function 1189 | mApiReturn = PrintDlg(tPrintDlg) 1190 | 1191 | '*** handle return from PrintDlg API function 1192 | mCanceled = False 1193 | ' If (tPrintDlg.flags And cdlPDReturnDefault) <> 0 Then 1194 | ' mApiReturn = 1 1195 | ' End If 1196 | Select Case mApiReturn 1197 | 1198 | Case 0 'user canceled 1199 | If tPrintDlg.hDevMode <> 0 Then 1200 | mDevModePtr = GlobalLock(tPrintDlg.hDevMode) 1201 | mhDevMode = tPrintDlg.hDevMode 1202 | mDevNamesPtr = GlobalLock(tPrintDlg.hDevNames) 1203 | mhDevNames = tPrintDlg.hDevNames 1204 | End If 1205 | 1206 | mCanceled = True 1207 | If mCancelError Then 1208 | 'generate an error 1209 | Err.Raise 32755, "Cancel Pressed" 1210 | Exit Sub 1211 | End If 1212 | 1213 | Case 1 'user selected OK 1214 | 'nFromPage As Integer - store to FromPage property 1215 | 1216 | mFlags = mFlags And Not (cdlPDSelection Or cdlPDPageNums) 1217 | mFlags = mFlags Or (tPrintDlg.Flags And (cdlPDSelection Or cdlPDPageNums)) 1218 | 1219 | mFromPage = tPrintDlg.nFromPage 1220 | 1221 | 'nToPage As Integer - store to ToPage property 1222 | mToPage = tPrintDlg.nToPage 1223 | 1224 | 'nMinPage As Integer - store to Min property 1225 | mMin = tPrintDlg.nMinPage 1226 | 1227 | 'nMaxPage As Integer - store to Max property 1228 | mMax = tPrintDlg.nMaxPage 1229 | 1230 | mhDc = tPrintDlg.hDC 1231 | 1232 | If mDevModePtr = 0 Then 1233 | mDevModePtr = GlobalLock(tPrintDlg.hDevMode) 1234 | mhDevMode = tPrintDlg.hDevMode 1235 | Else 1236 | If mhDevMode <> tPrintDlg.hDevMode Then 1237 | GlobalUnlock mhDevMode 1238 | mDevModePtr = GlobalLock(tPrintDlg.hDevMode) 1239 | mhDevMode = tPrintDlg.hDevMode 1240 | End If 1241 | End If 1242 | CopyMemory mDevMode, ByVal mDevModePtr, Len(mDevMode) 1243 | mPaperSize = mDevMode.dmPaperSize 1244 | mPaperBin = mDevMode.dmDefaultSource 1245 | mDuplex = mDevMode.dmDuplex 1246 | mOrientation = mDevMode.dmOrientation 1247 | mPrintQuality = mDevMode.dmPrintQuality 1248 | mColorMode = mDevMode.dmColor 1249 | mDefaultPaperWidth = mDevMode.dmPaperWidth 1250 | mDefaultPaperHeight = mDevMode.dmPaperLength 1251 | mCopies = mDevMode.dmCopies 1252 | If mCopies < 1 Then 1253 | mCopies = 1 1254 | End If 1255 | mCollate = CBool(mDevMode.dmCollate) 1256 | 1257 | If mDevNamesPtr = 0 Then 1258 | mDevNamesPtr = GlobalLock(tPrintDlg.hDevNames) 1259 | mhDevNames = tPrintDlg.hDevNames 1260 | Else 1261 | If mhDevNames <> tPrintDlg.hDevNames Then 1262 | GlobalUnlock mhDevNames 1263 | mDevNamesPtr = GlobalLock(tPrintDlg.hDevNames) 1264 | mhDevNames = tPrintDlg.hDevNames 1265 | End If 1266 | End If 1267 | CopyMemory mDevNames, ByVal mDevNamesPtr, Len(mDevNames) 1268 | mDriverName = GetDevNameString(mDevNamesPtr, mDevNames.wDriverOffset) 1269 | mDeviceName = GetDevNameString(mDevNamesPtr, mDevNames.wDeviceOffset) 1270 | mPort = GetDevNameString(mDevNamesPtr, mDevNames.wOutputOffset) 1271 | 1272 | ' Debug.Print mDevMode.dmDeviceName 1273 | 1274 | PutPaperSize 1275 | mPageSet = True 1276 | 1277 | Case Else 'an error occured 1278 | 'call CommDlgExtendedError 1279 | mExtendedError = CommDlgExtendedError 'store to ExtendedError property 1280 | 1281 | End Select 1282 | 1283 | Exit Sub 1284 | 1285 | ShowPrinterError: 1286 | 1287 | Exit Sub 1288 | 1289 | End Sub 1290 | 1291 | 1292 | Public Sub ShowSave(Optional ByVal nFlags As cdeCommonDialogExFileFlagsConstants = -1) 1293 | Dim iHwndOwner As Long 1294 | Dim iFlags As Long 1295 | 1296 | 'display the file save dialog box 1297 | iHwndOwner = GetActiveWindowHwnd 1298 | iFlags = mFlags 1299 | If nFlags <> -1 Then 1300 | iFlags = iFlags Or nFlags 1301 | End If 1302 | 1303 | ShowFileDialog 2, iFlags, iHwndOwner 'Action property - ShowSave 1304 | 1305 | End Sub 1306 | 1307 | 1308 | Public Property Get FileName() As String 1309 | FileName = mFileName 1310 | End Property 1311 | 1312 | Public Property Let FileName(nValue As String) 1313 | mFileName = nValue 1314 | End Property 1315 | 1316 | 1317 | Public Property Get Filter() As String 1318 | Filter = mFilter 1319 | End Property 1320 | 1321 | Public Property Let Filter(nValue As String) 1322 | mFilter = nValue 1323 | End Property 1324 | 1325 | 1326 | Private Function sLeftOfNull(ByVal sIn As String) As String 1327 | 'returns the part of sIn preceding Chr$(0) 1328 | Dim lNullPos As Long 1329 | 1330 | 'init output 1331 | sLeftOfNull = sIn 1332 | 1333 | 'get position of first Chr$(0) in sIn 1334 | lNullPos = InStr(sIn, Chr$(0)) 1335 | 1336 | 'return part of sIn to Left of first Chr$(0) if found 1337 | If lNullPos > 0 Then 1338 | sLeftOfNull = Mid$(sIn, 1, lNullPos - 1) 1339 | End If 1340 | 1341 | End Function 1342 | 1343 | Private Function sLeftOfLastNull(ByVal sIn As String) As String 1344 | 'returns the part of sIn preceding Chr$(0) 1345 | Dim iNullPos As Long 1346 | Dim iChr As String 1347 | 1348 | 'init output 1349 | sLeftOfLastNull = sIn 1350 | 1351 | 'get position of first Chr$(0) in sIn 1352 | iNullPos = InStrRev(sIn, Chr$(0)) 1353 | 1354 | 'return part of sIn to Left of first Chr$(0) if found 1355 | If iNullPos > 0 Then 1356 | iChr = Mid$(sIn, iNullPos, 1) 1357 | Do Until (iChr <> Chr$(0)) And (iChr <> " ") 1358 | iNullPos = iNullPos - 1 1359 | If iNullPos = 0 Then 1360 | iNullPos = InStrRev(sIn, Chr$(0)) 1361 | Exit Do 1362 | End If 1363 | iChr = Mid$(sIn, iNullPos, 1) 1364 | Loop 1365 | iNullPos = iNullPos + 1 1366 | sLeftOfLastNull = Mid$(sIn, 1, iNullPos - 1) 1367 | End If 1368 | 1369 | End Function 1370 | 1371 | 1372 | Private Function sAPIFilter(sIn As String) As String 1373 | 'prepares sIn for use as a filter string in API common dialog functions 1374 | Dim lChrNdx As Long 1375 | Dim sOneChr As String 1376 | Dim sOutStr As String 1377 | 1378 | 'convert any | characters to nulls 1379 | For lChrNdx = 1 To Len(sIn) 1380 | sOneChr = Mid$(sIn, lChrNdx, 1) 1381 | If sOneChr = "|" Then 1382 | sOutStr = sOutStr & Chr$(0) 1383 | Else 1384 | sOutStr = sOutStr & sOneChr 1385 | End If 1386 | Next 1387 | 1388 | 'add a null to the end 1389 | sOutStr = sOutStr & Chr$(0) 1390 | 1391 | 'return sOutStr 1392 | sAPIFilter = sOutStr 1393 | 1394 | End Function 1395 | 1396 | Public Property Get FilterIndex() As Integer 1397 | FilterIndex = mFilterIndex 1398 | End Property 1399 | 1400 | Public Property Let FilterIndex(nValue As Integer) 1401 | mFilterIndex = nValue 1402 | End Property 1403 | 1404 | Public Property Get CancelError() As Boolean 1405 | CancelError = mCancelError 1406 | End Property 1407 | 1408 | Public Property Let CancelError(nValue As Boolean) 1409 | mCancelError = nValue 1410 | End Property 1411 | 1412 | Public Property Get Color() As Long 1413 | Color = mColor 1414 | End Property 1415 | 1416 | Public Property Let Color(nValue As Long) 1417 | mColor = nValue 1418 | End Property 1419 | 1420 | Public Property Get Copies() As Long 1421 | Copies = mCopies 1422 | End Property 1423 | 1424 | Public Property Let Copies(nValue As Long) 1425 | mCopies = nValue 1426 | End Property 1427 | 1428 | Public Property Get Collate() As Boolean 1429 | Collate = mCollate 1430 | End Property 1431 | 1432 | Public Property Let Collate(nValue As Boolean) 1433 | mCollate = nValue 1434 | End Property 1435 | 1436 | Public Property Get DefaultExt() As String 1437 | DefaultExt = mDefaultExt 1438 | End Property 1439 | 1440 | Public Property Let DefaultExt(nValue As String) 1441 | mDefaultExt = nValue 1442 | End Property 1443 | 1444 | Public Property Get DialogTitle() As String 1445 | DialogTitle = mDialogTitle 1446 | End Property 1447 | 1448 | Public Property Let DialogTitle(nValue As String) 1449 | mDialogTitle = nValue 1450 | End Property 1451 | 1452 | Public Property Get Flags() As CommonDialogsFlags 1453 | Flags = mFlags 1454 | End Property 1455 | 1456 | Public Property Let Flags(nValue As CommonDialogsFlags) 1457 | mFlags = nValue 1458 | End Property 1459 | 1460 | Public Property Get FontBold() As Boolean 1461 | FontBold = mFont.Bold 1462 | End Property 1463 | 1464 | Public Property Let FontBold(nValue As Boolean) 1465 | mFont.Bold = nValue 1466 | End Property 1467 | 1468 | Public Property Get FontItalic() As Boolean 1469 | FontItalic = mFont.Italic 1470 | End Property 1471 | 1472 | Public Property Let FontItalic(nValue As Boolean) 1473 | mFont.Italic = nValue 1474 | End Property 1475 | 1476 | Public Property Get FontName() As String 1477 | FontName = mFont.Name 1478 | End Property 1479 | 1480 | Public Property Let FontName(nValue As String) 1481 | mFont.Name = nValue 1482 | End Property 1483 | 1484 | Public Property Get FontSize() As Long 1485 | FontSize = mFont.Size 1486 | End Property 1487 | 1488 | Public Property Let FontSize(nValue As Long) 1489 | mFont.Size = nValue 1490 | End Property 1491 | 1492 | Public Property Get FontStrikeThru() As Boolean 1493 | FontStrikeThru = mFont.Strikethrough 1494 | End Property 1495 | 1496 | Public Property Let FontStrikeThru(nValue As Boolean) 1497 | mFont.Strikethrough = nValue 1498 | End Property 1499 | 1500 | Public Property Get FontUnderLine() As Boolean 1501 | FontUnderLine = mFont.Underline 1502 | End Property 1503 | 1504 | Public Property Let FontUnderLine(nValue As Boolean) 1505 | mFont.Underline = nValue 1506 | End Property 1507 | 1508 | Public Property Get FromPage() As Long 1509 | Attribute FromPage.VB_MemberFlags = "40" 1510 | FromPage = mFromPage 1511 | End Property 1512 | 1513 | Public Property Let FromPage(nValue As Long) 1514 | mFromPage = nValue 1515 | End Property 1516 | 1517 | Public Property Get hDC() As Long 1518 | EnsurePageSet 1519 | hDC = mhDc 1520 | End Property 1521 | 1522 | Public Property Let hDC(nValue As Long) 1523 | mhDc = nValue 1524 | End Property 1525 | 1526 | 1527 | Public Property Get HelpCommand() As Long 1528 | HelpCommand = mHelpCommand 1529 | End Property 1530 | 1531 | Public Property Let HelpCommand(nValue As Long) 1532 | mHelpCommand = nValue 1533 | End Property 1534 | 1535 | Public Property Get HelpContext() As Long 1536 | HelpContext = mHelpContext 1537 | End Property 1538 | 1539 | Public Property Let HelpContext(nValue As Long) 1540 | mHelpContext = nValue 1541 | End Property 1542 | 1543 | Public Property Get HelpFile() As String 1544 | HelpFile = mHelpFile 1545 | End Property 1546 | 1547 | Public Property Let HelpFile(nValue As String) 1548 | mHelpFile = nValue 1549 | End Property 1550 | 1551 | Public Property Get HelpKey() As String 1552 | HelpKey = mHelpKey 1553 | End Property 1554 | 1555 | Public Property Let HelpKey(nValue As String) 1556 | mHelpKey = nValue 1557 | End Property 1558 | 1559 | Public Property Get InitDir() As String 1560 | InitDir = mInitDir 1561 | End Property 1562 | 1563 | Public Property Let InitDir(nValue As String) 1564 | mInitDir = Trim$(nValue) 1565 | End Property 1566 | 1567 | Public Property Get Max() As Long 1568 | Max = mMax 1569 | End Property 1570 | 1571 | Public Property Let Max(nValue As Long) 1572 | mMax = nValue 1573 | If mMin > mMax Then 1574 | mMin = mMax 1575 | End If 1576 | End Property 1577 | 1578 | Public Property Get MaxFileSize() As Long 1579 | MaxFileSize = mMaxFileSize 1580 | End Property 1581 | 1582 | Public Property Let MaxFileSize(nValue As Long) 1583 | mMaxFileSize = nValue 1584 | End Property 1585 | 1586 | Public Property Get Min() As Long 1587 | Min = mMin 1588 | End Property 1589 | 1590 | Public Property Let Min(nValue As Long) 1591 | mMin = nValue 1592 | If mMax < mMin Then 1593 | mMax = mMin 1594 | End If 1595 | End Property 1596 | 1597 | Public Property Get Object() As Object 1598 | Set Object = Me 1599 | End Property 1600 | 1601 | 'Public Property Get PrinterDefault() As Integer 1602 | ' PrinterDefault = mPrinterDefault 1603 | 'End Property 1604 | ' 1605 | 'Public Property Let PrinterDefault(nValue As Integer) 1606 | ' mPrinterDefault = nValue 1607 | 'End Property 1608 | 1609 | Public Property Get ToPage() As Long 1610 | ToPage = mToPage 1611 | End Property 1612 | 1613 | Public Property Let ToPage(nValue As Long) 1614 | mToPage = nValue 1615 | End Property 1616 | 1617 | Public Property Get FileTitle() As String 1618 | FileTitle = mFileTitle 1619 | End Property 1620 | 1621 | Public Property Let FileTitle(nValue As String) 1622 | mFileTitle = nValue 1623 | End Property 1624 | 1625 | 'Private Property Get APIReturn() As Long 1626 | ' APIReturn = mApiReturn 1627 | 'End Property 1628 | ' 1629 | 'Private Property Get ExtendedError() As Long 1630 | ' ExtendedError = mExtendedError 1631 | 'End Property 1632 | 1633 | 1634 | Private Function sByteArrayToString(abBytes() As Byte) As String 1635 | 'return a string from a byte array 1636 | Dim lBytePoint As Long 1637 | Dim lByteVal As Long 1638 | Dim sOut As String 1639 | 1640 | 'init array pointer 1641 | lBytePoint = LBound(abBytes) 1642 | 1643 | 'fill sOut with characters in array 1644 | While lBytePoint <= UBound(abBytes) 1645 | 1646 | lByteVal = abBytes(lBytePoint) 1647 | 1648 | 'return sOut and stop if Chr$(0) is encountered 1649 | If lByteVal = 0 Then 1650 | sByteArrayToString = sOut 1651 | Exit Function 1652 | Else 1653 | sOut = sOut & Chr$(lByteVal) 1654 | End If 1655 | 1656 | lBytePoint = lBytePoint + 1 1657 | 1658 | Wend 1659 | 1660 | 'return sOut if Chr$(0) wasn't encountered 1661 | sByteArrayToString = sOut 1662 | 1663 | End Function 1664 | Private Sub ShowFileDialog(ByVal mAction As Integer, nFlags As Long, Optional ByVal nHwndOwner As Long) 1665 | 1666 | 'display the file dialog for ShowOpen or ShowSave 1667 | 1668 | Dim tOpenFile As T_OpenFilename 1669 | Dim lMaxSize As Long 1670 | Dim sFileNameBuff As String 1671 | Dim sFileTitleBuff As String 1672 | Dim iPos As Long 1673 | 1674 | On Error GoTo ShowFileDialogError 1675 | 1676 | mCanceled = False 1677 | 1678 | '*** init property buffers 1679 | 1680 | mAction = mAction 'Action property 1681 | mApiReturn = 0 'APIReturn property 1682 | mExtendedError = 0 'ExtendedError property 1683 | 1684 | 1685 | '*** prepare tOpenFile data 1686 | 1687 | 'tOpenFile.lStructSize As Long 1688 | tOpenFile.lStructSize = Len(tOpenFile) 1689 | 1690 | 'tOpenFile.hWndOwner As Long - init from hdc property 1691 | tOpenFile.hwndOwner = nHwndOwner 1692 | 1693 | 'tOpenFile.lpstrFilter As String - init from Filter property 1694 | tOpenFile.lpstrFilter = sAPIFilter(mFilter) 1695 | 1696 | 'tOpenFile.mFilterIndex As Long - init from FilterIndex property 1697 | tOpenFile.mFilterIndex = mFilterIndex 1698 | 1699 | 'tOpenFile.lpstrFile As String 1700 | 'determine size of buffer from MaxFileSize property 1701 | If mMaxFileSize > 0 Then 1702 | lMaxSize = mMaxFileSize 1703 | Else 1704 | lMaxSize = 255 1705 | End If 1706 | 1707 | 'tOpenFile.lpstrFile As Long - init from FileName property 1708 | 'prepare sFileNameBuff 1709 | sFileNameBuff = mFileName 1710 | If InStr(sFileNameBuff, "//") > 0 Then 1711 | Do Until InStr(sFileNameBuff, "//") = 0 1712 | sFileNameBuff = Replace(sFileNameBuff, "//", "/") 1713 | Loop 1714 | End If 1715 | If InStr(sFileNameBuff, "\\") > 0 Then 1716 | Do Until InStr(sFileNameBuff, "\\") = 0 1717 | sFileNameBuff = Replace(sFileNameBuff, "\\", "\") 1718 | Loop 1719 | End If 1720 | If InStr(sFileNameBuff, "\\") > 0 Then 1721 | Do Until InStr(sFileNameBuff, "\\") = 0 1722 | sFileNameBuff = Replace(sFileNameBuff, "\\", "\") 1723 | Loop 1724 | End If 1725 | iPos = InStr(sFileNameBuff, "\") 1726 | If InStr(sFileNameBuff, "/") < iPos Then 1727 | iPos = InStr(sFileNameBuff, "\") 1728 | End If 1729 | If iPos = 0 Then 1730 | iPos = Len(sFileNameBuff) 1731 | End If 1732 | 1733 | If InStr(iPos, sFileNameBuff, ":") > 0 Then 1734 | sFileNameBuff = Replace(sFileNameBuff, ":", "") 1735 | End If 1736 | If InStr(iPos, sFileNameBuff, "?") > 0 Then 1737 | sFileNameBuff = Replace(sFileNameBuff, "?", "") 1738 | End If 1739 | If InStr(iPos, sFileNameBuff, "*") > 0 Then 1740 | sFileNameBuff = Replace(sFileNameBuff, "*", "") 1741 | End If 1742 | If InStr(iPos, sFileNameBuff, """") > 0 Then 1743 | sFileNameBuff = Replace(sFileNameBuff, """", "") 1744 | End If 1745 | If InStr(iPos, sFileNameBuff, ">") > 0 Then 1746 | sFileNameBuff = Replace(sFileNameBuff, ">", "") 1747 | End If 1748 | If InStr(iPos, sFileNameBuff, "<") > 0 Then 1749 | sFileNameBuff = Replace(sFileNameBuff, "<", "") 1750 | End If 1751 | If InStr(iPos, sFileNameBuff, "|") > 0 Then 1752 | sFileNameBuff = Replace(sFileNameBuff, "|", "") 1753 | End If 1754 | 1755 | 'pad with spaces 1756 | If (nFlags And cdlOFNAllowMultiselect) <> 0 Then 1757 | sFileNameBuff = sFileNameBuff & Space$(100000 - Len(sFileNameBuff) - 1) 1758 | sFileNameBuff = Mid$(sFileNameBuff, 1, 99999) 1759 | Else 1760 | While Len(sFileNameBuff) < lMaxSize - 1 1761 | sFileNameBuff = sFileNameBuff & " " 1762 | Wend 1763 | 'Trim$ to length of mMaxFileSize - 1 1764 | sFileNameBuff = Mid$(sFileNameBuff, 1, lMaxSize - 1) 1765 | End If 1766 | 'null terminate 1767 | sFileNameBuff = sFileNameBuff & Chr$(0) 1768 | tOpenFile.lpstrFile = sFileNameBuff 1769 | 1770 | 'nMaxFile As Long - init from MaxFileSize property 1771 | 'If mMaxFileSize <> 255 Then 'default is 255 1772 | If (nFlags And cdlOFNAllowMultiselect) <> 0 Then 1773 | tOpenFile.nMaxFile = 100000 1774 | Else 1775 | tOpenFile.nMaxFile = lMaxSize 1776 | End If 1777 | 'End If 1778 | 1779 | 'lpstrFileTitle As String - init from FileTitle property 1780 | 'prepare sFileTitleBuff 1781 | sFileTitleBuff = mFileTitle 1782 | 'pad with spaces 1783 | While Len(sFileTitleBuff) < lMaxSize - 1 1784 | sFileTitleBuff = sFileTitleBuff & " " 1785 | Wend 1786 | 'Trim$ to length of mMaxFileSize - 1 1787 | sFileTitleBuff = Mid$(sFileTitleBuff, 1, lMaxSize - 1) 1788 | 'null terminate 1789 | sFileTitleBuff = sFileTitleBuff & Chr$(0) 1790 | tOpenFile.lpstrFileTitle = sFileTitleBuff 1791 | 1792 | 'tOpenFile.lpstrInitialDir As String - init from InitDir property 1793 | tOpenFile.lpstrInitialDir = mInitDir 1794 | 1795 | 'tOpenFile.lpstrTitle As String - init from DialogTitle property 1796 | tOpenFile.lpstrTitle = mDialogTitle 1797 | 1798 | 'tOpenFile.flags As Long - init from Flags property 1799 | tOpenFile.Flags = nFlags Or cdlOFNNoChangeDir 1800 | 1801 | 'tOpenFile.lpstrDefExt As String - init from DefaultExt property 1802 | tOpenFile.lpstrDefExt = mDefaultExt 1803 | 1804 | 1805 | '*** call the GetOpenFileName API function 1806 | Select Case mAction 1807 | Case 1 'ShowOpen 1808 | mApiReturn = GetOpenFileName(tOpenFile) 1809 | Case 2 'ShowSave 1810 | mApiReturn = GetSaveFileName(tOpenFile) 1811 | Case Else 'unknown action 1812 | Exit Sub 1813 | End Select 1814 | 1815 | 1816 | '*** handle return from GetOpenFileName API function 1817 | mCanceled = False 1818 | Select Case mApiReturn 1819 | 1820 | Case 0 'user canceled 1821 | mCanceled = True 1822 | mFileName = "" 1823 | mFileTitle = "" 1824 | If mCancelError Then 1825 | 'generate an error 1826 | On Error Resume Next 1827 | Err.Raise 32755, "Cancel Pressed" 1828 | Exit Sub 1829 | End If 1830 | 1831 | Case 1 'user selected or entered a file 1832 | 'mFileName gets part of tOpenFile.lpstrFile to the Left of first Chr$(0) 1833 | If (tOpenFile.Flags And cdlOFNAllowMultiselect) <> 0 Then 1834 | mFileName = sLeftOfLastNull(tOpenFile.lpstrFile) 1835 | Else 1836 | mFileName = sLeftOfNull(tOpenFile.lpstrFile) 1837 | End If 1838 | mFileTitle = sLeftOfNull(tOpenFile.lpstrFileTitle) 1839 | 1840 | Case Else 'an error occured 1841 | 'call CommDlgExtendedError 1842 | mExtendedError = CommDlgExtendedError 1843 | 1844 | End Select 1845 | 1846 | 1847 | Exit Sub 1848 | 1849 | ShowFileDialogError: 1850 | 1851 | Exit Sub 1852 | 1853 | End Sub 1854 | 1855 | 1856 | Public Property Get Canceled() As Boolean 1857 | Canceled = mCanceled 1858 | End Property 1859 | 1860 | Private Function TranslateAColor(ByVal clr As OLE_COLOR, _ 1861 | Optional hPal As Long = 0) As Long 1862 | If OleTranslateColor(clr, hPal, TranslateAColor) Then 1863 | TranslateAColor = CLR_INVALID 1864 | End If 1865 | End Function 1866 | 1867 | 1868 | Private Sub Class_Initialize() 1869 | mMaxFileSize = 255 1870 | mUnits = vbMillimeters 1871 | mAmbientUserMode = True 1872 | mCopies = 1 1873 | mLeftMargin = cLeftMarginDefault 1874 | mRightMargin = cRightMarginDefault 1875 | mTopMargin = cTopMarginDefault 1876 | mBottomMargin = cBottomMarginDefault 1877 | mAutoSaveCustomColors = True 1878 | InitCustomColors 1879 | 1880 | Set mFont = New StdFont 1881 | End Sub 1882 | 1883 | Public Property Let Action(nValue As Integer) 1884 | Select Case nValue 1885 | Case 0 1886 | ' 1887 | Case 1 1888 | ShowOpen 1889 | Case 2 1890 | ShowSave 1891 | Case 3 1892 | 1893 | Case 4 1894 | 1895 | Case 5 1896 | ShowPrinter 1897 | Case 6 1898 | ShowHelp 1899 | End Select 1900 | End Property 1901 | 1902 | 1903 | Public Property Get Orientation() As cdePageOrientationConstants 1904 | EnsurePageSet 1905 | Orientation = mOrientation 1906 | End Property 1907 | 1908 | Public Property Let Orientation(nValue As cdePageOrientationConstants) 1909 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1910 | EnsurePageSet 1911 | mOrientation = nValue 1912 | End Property 1913 | 1914 | 1915 | Public Property Get PaperSize() As cdePaperSizeConstants 1916 | EnsurePageSet 1917 | PaperSize = mPaperSize 1918 | End Property 1919 | 1920 | Public Property Let PaperSize(nValue As cdePaperSizeConstants) 1921 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1922 | EnsurePageSet 1923 | mPaperSize = nValue 1924 | End Property 1925 | 1926 | 1927 | Public Property Get PrintQuality() As cdePrintQualityConstants 1928 | EnsurePageSet 1929 | PrintQuality = mPrintQuality 1930 | End Property 1931 | 1932 | Public Property Let PrintQuality(nValue As cdePrintQualityConstants) 1933 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1934 | EnsurePageSet 1935 | mPrintQuality = nValue 1936 | End Property 1937 | 1938 | 1939 | Public Property Get ColorMode() As cdeColorModeConstants 1940 | EnsurePageSet 1941 | ColorMode = mColorMode 1942 | End Property 1943 | 1944 | Public Property Let ColorMode(nValue As cdeColorModeConstants) 1945 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1946 | EnsurePageSet 1947 | mColorMode = nValue 1948 | End Property 1949 | 1950 | 1951 | Public Property Get DriverName() As String 1952 | EnsurePageSet 1953 | DriverName = mDriverName 1954 | End Property 1955 | 1956 | 1957 | Public Property Get Duplex() As cdeDuplexConstants 1958 | EnsurePageSet 1959 | Duplex = mDuplex 1960 | End Property 1961 | 1962 | Public Property Let Duplex(nValue As cdeDuplexConstants) 1963 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1964 | EnsurePageSet 1965 | mDuplex = nValue 1966 | End Property 1967 | 1968 | 1969 | Public Property Get PaperBin() As cdePaperBinConstants 1970 | EnsurePageSet 1971 | PaperBin = mPaperBin 1972 | End Property 1973 | 1974 | Public Property Let PaperBin(nValue As cdePaperBinConstants) 1975 | If (nValue = 0) And mAmbientUserMode Then Exit Property 'If (nValue = 0) And mAmbientUserMode Then Err.Raise 1769, , "At run time this property must have a value other than 0." 1976 | EnsurePageSet 1977 | mPaperBin = nValue 1978 | End Property 1979 | 1980 | 1981 | Public Property Get Port() As String 1982 | EnsurePageSet 1983 | Port = mPort 1984 | End Property 1985 | 1986 | 1987 | Public Property Get DeviceName() As String 1988 | EnsurePageSet 1989 | DeviceName = mDeviceName 1990 | End Property 1991 | 1992 | 1993 | Public Property Get PaperWidth() As Single 1994 | EnsurePageSet 1995 | If Units = vbInches Then 1996 | PaperWidth = mPaperWidth / 254 1997 | Else 1998 | PaperWidth = mPaperWidth / 10 1999 | End If 2000 | End Property 2001 | 2002 | 2003 | Public Property Get PaperHeight() As Single 2004 | EnsurePageSet 2005 | If Units = vbInches Then 2006 | PaperHeight = mPaperHeight / 254 2007 | Else 2008 | PaperHeight = mPaperHeight / 10 2009 | End If 2010 | End Property 2011 | 2012 | 2013 | Public Property Get LeftMargin() As Single 2014 | EnsurePageSet 2015 | LeftMargin = mLeftMargin 2016 | End Property 2017 | 2018 | Public Property Let LeftMargin(nValue As Single) 2019 | EnsurePageSet 2020 | mLeftMargin = nValue 2021 | ' 'mMarginSet = True 2022 | If mLeftMargin < mMinLeftMargin Then 2023 | mLeftMargin = mMinLeftMargin 2024 | End If 2025 | End Property 2026 | 2027 | 2028 | Public Property Get MinLeftMargin() As Single 2029 | EnsurePageSet 2030 | MinLeftMargin = mMinLeftMargin 2031 | End Property 2032 | 2033 | Public Property Let MinLeftMargin(nValue As Single) 2034 | EnsurePageSet 2035 | mMinLeftMargin = nValue 2036 | 'mMarginSet = True 2037 | If mLeftMargin < mMinLeftMargin Then 2038 | mLeftMargin = mMinLeftMargin 2039 | End If 2040 | End Property 2041 | 2042 | 2043 | Public Property Get RightMargin() As Single 2044 | EnsurePageSet 2045 | RightMargin = mRightMargin 2046 | End Property 2047 | 2048 | Public Property Let RightMargin(nValue As Single) 2049 | EnsurePageSet 2050 | mRightMargin = nValue 2051 | 'mMarginSet = True 2052 | If mRightMargin < mMinRightMargin Then 2053 | mRightMargin = mMinRightMargin 2054 | End If 2055 | End Property 2056 | 2057 | 2058 | Public Property Get MinRightMargin() As Single 2059 | EnsurePageSet 2060 | MinRightMargin = mMinRightMargin 2061 | End Property 2062 | 2063 | Public Property Let MinRightMargin(nValue As Single) 2064 | EnsurePageSet 2065 | mMinRightMargin = nValue 2066 | 'mMarginSet = True 2067 | If mRightMargin < mMinRightMargin Then 2068 | mRightMargin = mMinRightMargin 2069 | End If 2070 | End Property 2071 | 2072 | 2073 | Public Property Get TopMargin() As Single 2074 | EnsurePageSet 2075 | TopMargin = mTopMargin 2076 | End Property 2077 | 2078 | Public Property Let TopMargin(nValue As Single) 2079 | EnsurePageSet 2080 | mTopMargin = nValue 2081 | 'mMarginSet = True 2082 | If mTopMargin < mMinTopMargin Then 2083 | mTopMargin = mMinTopMargin 2084 | End If 2085 | End Property 2086 | 2087 | 2088 | Public Property Get MinTopMargin() As Single 2089 | EnsurePageSet 2090 | MinTopMargin = mMinTopMargin 2091 | End Property 2092 | 2093 | Public Property Let MinTopMargin(nValue As Single) 2094 | EnsurePageSet 2095 | mMinTopMargin = nValue 2096 | 'mMarginSet = True 2097 | If mTopMargin < mMinTopMargin Then 2098 | mTopMargin = mMinTopMargin 2099 | End If 2100 | End Property 2101 | 2102 | 2103 | Public Property Get BottomMargin() As Single 2104 | EnsurePageSet 2105 | BottomMargin = mBottomMargin 2106 | End Property 2107 | 2108 | Public Property Let BottomMargin(nValue As Single) 2109 | EnsurePageSet 2110 | mBottomMargin = nValue 2111 | 'mMarginSet = True 2112 | If mBottomMargin < mMinBottomMargin Then 2113 | mBottomMargin = mMinBottomMargin 2114 | End If 2115 | End Property 2116 | 2117 | 2118 | Public Property Get MinBottomMargin() As Single 2119 | EnsurePageSet 2120 | MinBottomMargin = mMinBottomMargin 2121 | End Property 2122 | 2123 | Public Property Let MinBottomMargin(nValue As Single) 2124 | EnsurePageSet 2125 | mMinBottomMargin = nValue 2126 | 'mMarginSet = True 2127 | If mBottomMargin < mMinBottomMargin Then 2128 | mBottomMargin = mMinBottomMargin 2129 | End If 2130 | End Property 2131 | 2132 | 2133 | Public Property Get Units() As cdeUnits 2134 | Units = mUnits 2135 | End Property 2136 | 2137 | Public Property Let Units(nValue As cdeUnits) 2138 | If (nValue <> vbInches) And (nValue <> vbMillimeters) Then Exit Property 2139 | If nValue <> mUnits Then 2140 | mUnits = nValue 2141 | ConvertMarginValues 2142 | End If 2143 | End Property 2144 | 2145 | 2146 | Public Property Get UnitsForUser() As cdeUnitsForUser 2147 | UnitsForUser = mUnitsForUser 2148 | End Property 2149 | 2150 | Public Property Let UnitsForUser(nValue As cdeUnitsForUser) 2151 | If (nValue <> cdeMUInches) And (nValue <> cdeMUMillimeters) And (nValue <> cdeMUUserLocale) Then Exit Property 2152 | If nValue <> mUnitsForUser Then 2153 | mUnitsForUser = nValue 2154 | End If 2155 | End Property 2156 | 2157 | 2158 | Public Sub ShowPageSetup(Optional ByVal nFlags As cdeCommonDialogExPageSetupFlagsConstants = -1) 2159 | Dim iHwndOwner As Long 2160 | Dim iPsd As T_PAGESETUPDLG 2161 | Dim iUnitsMultiplier As Single 2162 | Dim iFlags As Long 2163 | Dim iUnits_Ant As Long 2164 | 2165 | On Error GoTo ShowPageSetupError 2166 | 2167 | iHwndOwner = GetActiveWindowHwnd 2168 | iFlags = mFlags 2169 | If nFlags <> -1 Then 2170 | iFlags = iFlags Or nFlags 2171 | End If 2172 | 2173 | iUnits_Ant = mUnits 2174 | If mUnits <> vbMillimeters Then 2175 | Units = vbMillimeters 2176 | End If 2177 | 2178 | iPsd.lStructSize = Len(iPsd) 2179 | 2180 | iPsd.Flags = iFlags And Not (PSD_ENABLEPAGEPAINTHOOK Or PSD_ENABLEPAGESETUPHOOK Or PSD_ENABLEPAGESETUPTEMPLATE) 2181 | 2182 | Select Case mUnitsForUser 2183 | Case cdeMUInches 2184 | iPsd.Flags = iPsd.Flags Or PSD_INTHOUSANDTHSOFINCHES 2185 | Case cdeMUMillimeters 2186 | iPsd.Flags = iPsd.Flags Or PSD_INHUNDREDTHSOFMILLIMETERS 2187 | Case Else 2188 | If GetLocaleMeasureSystem = 1 Then ' EEUU system, Inches 2189 | iPsd.Flags = iPsd.Flags Or PSD_INTHOUSANDTHSOFINCHES 2190 | Else 2191 | iPsd.Flags = iPsd.Flags Or PSD_INHUNDREDTHSOFMILLIMETERS 2192 | End If 2193 | End Select 2194 | 2195 | If (iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0 Then 2196 | iUnitsMultiplier = 1000 2197 | Else 2198 | iUnitsMultiplier = 100 2199 | End If 2200 | Select Case True 2201 | Case (Units = vbInches) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) = 0) 2202 | iUnitsMultiplier = iUnitsMultiplier * 25.4 2203 | Case (Units = vbInches) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0) 2204 | ' OK 2205 | Case (Units = vbMillimeters) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) = 0) 2206 | ' OK 2207 | Case (Units = vbMillimeters) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0) 2208 | iUnitsMultiplier = iUnitsMultiplier / 25.4 2209 | End Select 2210 | 2211 | 2212 | ' If mMarginSet Then 2213 | iPsd.Flags = iPsd.Flags Or PSD_MARGINS 2214 | ' End If 2215 | If (mMinTopMargin <> 0) Or (mMinLeftMargin <> 0) Or (mMinBottomMargin <> 0) Or (mMinRightMargin <> 0) Then 2216 | iPsd.Flags = iPsd.Flags Or cdlPSMinMargins 2217 | End If 2218 | 2219 | iPsd.hwndOwner = iHwndOwner 2220 | iPsd.rtMargin.Top = mTopMargin * iUnitsMultiplier 2221 | iPsd.rtMargin.Left = mLeftMargin * iUnitsMultiplier 2222 | iPsd.rtMargin.Bottom = mBottomMargin * iUnitsMultiplier 2223 | iPsd.rtMargin.Right = mRightMargin * iUnitsMultiplier 2224 | iPsd.rtMinMargin.Top = mMinTopMargin * iUnitsMultiplier 2225 | iPsd.rtMinMargin.Left = mMinLeftMargin * iUnitsMultiplier 2226 | iPsd.rtMinMargin.Bottom = mMinBottomMargin * iUnitsMultiplier 2227 | iPsd.rtMinMargin.Right = mMinRightMargin * iUnitsMultiplier 2228 | 2229 | If mDevModePtr <> 0 Then 2230 | iPsd.hDevMode = mhDevMode 2231 | UpdateDevModeWithCurrentSettings 2232 | iPsd.hDevNames = mhDevNames 2233 | GlobalUnlock mhDevMode 2234 | GlobalUnlock mhDevNames 2235 | mDevModePtr = 0 2236 | mDevNamesPtr = 0 2237 | End If 2238 | 2239 | mApiReturn = PageSetupDlg(iPsd) 2240 | mCanceled = False 2241 | 2242 | Select Case mApiReturn 2243 | 2244 | Case 0 'user canceled 2245 | 2246 | If iPsd.hDevMode <> 0 Then 2247 | mDevModePtr = GlobalLock(iPsd.hDevMode) 2248 | mhDevMode = iPsd.hDevMode 2249 | mDevNamesPtr = GlobalLock(iPsd.hDevNames) 2250 | mhDevNames = iPsd.hDevNames 2251 | End If 2252 | 2253 | mCanceled = True 2254 | If mCancelError Then 2255 | 'generate an error 2256 | On Error GoTo 0 2257 | Err.Raise 32755, "Cancel Pressed" 2258 | Exit Sub 2259 | End If 2260 | 2261 | Case 1 'user clicked OK 2262 | If (iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0 Then 2263 | iUnitsMultiplier = 1000 2264 | Else 2265 | iUnitsMultiplier = 100 2266 | End If 2267 | Select Case True 2268 | Case (Units = vbInches) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) = 0) 2269 | iUnitsMultiplier = iUnitsMultiplier * 25.4 2270 | Case (Units = vbInches) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0) 2271 | ' OK 2272 | Case (Units = vbMillimeters) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) = 0) 2273 | ' OK 2274 | Case (Units = vbMillimeters) And ((iPsd.Flags And PSD_INTHOUSANDTHSOFINCHES) <> 0) 2275 | iUnitsMultiplier = iUnitsMultiplier / 25.4 2276 | End Select 2277 | 2278 | mTopMargin = Int((iPsd.rtMargin.Top + 0.49) / iUnitsMultiplier * 100) / 100 2279 | mLeftMargin = Int((iPsd.rtMargin.Left + 0.49) / iUnitsMultiplier * 100) / 100 2280 | mBottomMargin = Int((iPsd.rtMargin.Bottom + 0.49) / iUnitsMultiplier * 100) / 100 2281 | mRightMargin = Int((iPsd.rtMargin.Right + 0.49) / iUnitsMultiplier * 100) / 100 2282 | mMinTopMargin = Int((iPsd.rtMinMargin.Top + 0.49) / iUnitsMultiplier * 100) / 100 2283 | mMinLeftMargin = Int((iPsd.rtMinMargin.Left + 0.49) / iUnitsMultiplier * 100) / 100 2284 | mMinBottomMargin = Int((iPsd.rtMinMargin.Bottom + 0.49) / iUnitsMultiplier * 100) / 100 2285 | mMinRightMargin = Int((iPsd.rtMinMargin.Right + 0.49) / iUnitsMultiplier * 100) / 100 2286 | 2287 | If mDevModePtr = 0 Then 2288 | mDevModePtr = GlobalLock(iPsd.hDevMode) 2289 | mhDevMode = iPsd.hDevMode 2290 | End If 2291 | CopyMemory mDevMode, ByVal mDevModePtr, Len(mDevMode) 2292 | mPaperSize = mDevMode.dmPaperSize 2293 | mPaperBin = mDevMode.dmDefaultSource 2294 | mDuplex = mDevMode.dmDuplex 2295 | mOrientation = mDevMode.dmOrientation 2296 | mPrintQuality = mDevMode.dmPrintQuality 2297 | mColorMode = mDevMode.dmColor 2298 | mDefaultPaperWidth = mDevMode.dmPaperWidth 2299 | mDefaultPaperHeight = mDevMode.dmPaperLength 2300 | PutPaperSize 2301 | 2302 | If mDevNamesPtr = 0 Then 2303 | mDevNamesPtr = GlobalLock(iPsd.hDevNames) 2304 | mhDevNames = iPsd.hDevNames 2305 | End If 2306 | CopyMemory mDevNames, ByVal mDevNamesPtr, Len(mDevNames) 2307 | mDriverName = GetDevNameString(mDevNamesPtr, mDevNames.wDriverOffset) 2308 | mDeviceName = GetDevNameString(mDevNamesPtr, mDevNames.wDeviceOffset) 2309 | mPort = GetDevNameString(mDevNamesPtr, mDevNames.wOutputOffset) 2310 | 2311 | mPageSet = True 2312 | Case Else 'an error occured 2313 | 'call CommDlgExtendedError 2314 | mExtendedError = CommDlgExtendedError 2315 | 2316 | End Select 2317 | 2318 | If mUnits <> iUnits_Ant Then 2319 | Units = iUnits_Ant 2320 | End If 2321 | 2322 | ' If Not mCanceled Then 2323 | ' If mhDc <> 0 Then 2324 | ' Dim iDevMode As DEVMODE 2325 | ' 2326 | ' CopyMemory iDevMode, ByVal mDevModePtr, Len(iDevMode) 2327 | ' ShowPrinter cdlPDReturnDefault Or cdePDReturnDC 2328 | ' ResetDC mhDc, iDevMode 2329 | ' mPaperSize = iDevMode.dmPaperSize 2330 | ' mPaperBin = iDevMode.dmDefaultSource 2331 | ' mDuplex = iDevMode.dmDuplex 2332 | ' mOrientation = iDevMode.dmOrientation 2333 | ' mPrintQuality = iDevMode.dmPrintQuality 2334 | ' mColorMode = iDevMode.dmColor 2335 | ' mDefaultPaperWidth = iDevMode.dmPaperWidth 2336 | ' mDefaultPaperHeight = iDevMode.dmPaperLength 2337 | ' PutPaperSize 2338 | ' UpdateDevModeWithCurrentSettings 2339 | ' End If 2340 | ' End If 2341 | 2342 | ShowPageSetupError: 2343 | End Sub 2344 | 2345 | Private Function GetDevNameString( _ 2346 | ByVal ptrDevNames As Long, _ 2347 | ByVal ptrOffset As Long _ 2348 | ) As String 2349 | Dim Ptr As Long 2350 | Dim lSize As Long 2351 | Dim b() As Byte 2352 | 2353 | Ptr = UnsignedAdd(ptrDevNames, ptrOffset) 2354 | lSize = lstrlenPtr(Ptr) 2355 | If (lSize > 0) Then 2356 | ReDim b(0 To lSize - 1) As Byte 2357 | CopyMemory b(0), ByVal Ptr, lSize 2358 | GetDevNameString = StrConv(b, vbUnicode) 2359 | End If 2360 | End Function 2361 | 2362 | Private Function UnsignedAdd(Start As Long, Incr As Long) As Long 2363 | ' This function is useful when doing pointer arithmetic, 2364 | ' but note it only works for positive values of Incr 2365 | 2366 | If Start And &H80000000 Then 'Start < 0 2367 | UnsignedAdd = Start + Incr 2368 | ElseIf (Start Or &H80000000) < -Incr Then 2369 | UnsignedAdd = Start + Incr 2370 | Else 2371 | UnsignedAdd = (Start + &H80000000) + (Incr + &H80000000) 2372 | End If 2373 | 2374 | End Function 2375 | 2376 | Private Sub Class_Terminate() 2377 | If mDevModePtr <> 0 Then 2378 | GlobalUnlock mhDevMode 2379 | GlobalUnlock mhDevNames 2380 | End If 2381 | End Sub 2382 | 2383 | Private Function GetLocaleMeasureSystem() As Long 2384 | Dim Buffer As String * 100 2385 | Dim nullpos& 2386 | Dim dl& 2387 | 2388 | dl& = GetLocaleInfo(LOCALE_USER_DEFAULT, LOCALE_IMEASURE, Buffer, 99) 2389 | nullpos& = InStr(Buffer, Chr$(0)) 2390 | GetLocaleMeasureSystem = Val(Left$(Buffer, nullpos - 1)) 2391 | End Function 2392 | 2393 | Private Sub EnsurePageSet() 2394 | If mAmbientUserMode Then 2395 | If Not mPageSet Then 2396 | ShowPrinter cdlPDReturnDefault Or cdePDReturnDC 2397 | End If 2398 | End If 2399 | End Sub 2400 | 2401 | 2402 | Public Property Get FolderName() As String 2403 | FolderName = mFolderName 2404 | End Property 2405 | 2406 | Public Property Let FolderName(nValue As String) 2407 | mFolderName = nValue 2408 | End Property 2409 | 2410 | 2411 | Public Property Get FolderTitle() As String 2412 | FolderTitle = mFileTitle 2413 | End Property 2414 | 2415 | Public Property Let FolderTitle(nValue As String) 2416 | mFileTitle = nValue 2417 | End Property 2418 | 2419 | 2420 | Public Property Get RootFolder() As String 2421 | RootFolder = mRootFolder 2422 | End Property 2423 | 2424 | Public Property Let RootFolder(nValue As String) 2425 | mRootFolder = Trim$(nValue) 2426 | End Property 2427 | 2428 | 2429 | Public Property Get DialogHeader() As String 2430 | DialogHeader = mDialogHeader 2431 | End Property 2432 | 2433 | Public Property Let DialogHeader(nValue As String) 2434 | mDialogHeader = nValue 2435 | End Property 2436 | 2437 | 2438 | 'Private Function GetFileFolderPath(nFileFullPath As String) As String 2439 | ' Dim iFolderPath As String 2440 | ' 2441 | ' SeparatePathAndFileName nFileFullPath, iFolderPath 2442 | ' GetFileFolderPath = iFolderPath 2443 | ' AddDirSep GetFileFolderPath 2444 | 'End Function 2445 | 2446 | 'Private Function GetFolderName(nFullFolderPath As String) As String 2447 | ' Dim iPath As String 2448 | ' Dim iFolder As String 2449 | ' 2450 | ' SeparatePathAndFileName nFullFolderPath, iPath, iFolder 2451 | ' GetFolderName = iFolder 2452 | 'End Function 2453 | 2454 | Private Function GetAddressofFunction(Add As Long) As Long 2455 | GetAddressofFunction = Add 2456 | End Function 2457 | 2458 | 2459 | Private Function IsPrinter(nName As String) As Boolean 2460 | Dim iPrn As Printer 2461 | 2462 | For Each iPrn In Printers 2463 | If LCase$(iPrn.DeviceName) = LCase$(nName) Then 2464 | IsPrinter = True 2465 | Exit For 2466 | End If 2467 | Next iPrn 2468 | 2469 | End Function 2470 | 2471 | Public Property Let AmbientUserMode(nValue As Boolean) 2472 | Attribute AmbientUserMode.VB_MemberFlags = "40" 2473 | mAmbientUserMode = nValue 2474 | End Property 2475 | 2476 | Private Sub UpdateDevModeWithCurrentSettings() 2477 | 2478 | ' Debug.Print mDevMode.dmDeviceName, mDeviceName & Chr(0) 2479 | mDevMode.dmPaperSize = mPaperSize 2480 | mDevMode.dmDefaultSource = mPaperBin 2481 | mDevMode.dmDuplex = mDuplex 2482 | mDevMode.dmOrientation = mOrientation 2483 | mDevMode.dmPrintQuality = mPrintQuality 2484 | mDevMode.dmColor = mColorMode 2485 | mDevMode.dmCopies = mCopies 2486 | mDevMode.dmCollate = Abs(CLng(mCollate)) 2487 | 2488 | CopyMemory ByVal mDevModePtr, mDevMode, Len(mDevMode) 2489 | 2490 | End Sub 2491 | 2492 | Private Sub ConvertMarginValues() 2493 | Dim iMultiplier As Single 2494 | 2495 | If mUnits = vbMillimeters Then 2496 | iMultiplier = 25.4 2497 | Else 2498 | iMultiplier = 1 / 25.4 2499 | End If 2500 | mLeftMargin = mLeftMargin * iMultiplier 2501 | mRightMargin = mRightMargin * iMultiplier 2502 | mTopMargin = mTopMargin * iMultiplier 2503 | mBottomMargin = mBottomMargin * iMultiplier 2504 | mMinLeftMargin = mMinLeftMargin * iMultiplier 2505 | mMinRightMargin = mMinRightMargin * iMultiplier 2506 | mMinTopMargin = mMinTopMargin * iMultiplier 2507 | mMinBottomMargin = mMinBottomMargin * iMultiplier 2508 | 2509 | End Sub 2510 | 2511 | 2512 | Private Sub PutPaperSize() 2513 | Dim iPs As POINTAPI 2514 | 2515 | iPs = GetPaperSize(mPaperSize) 2516 | 2517 | If iPs.X = 0 Then 2518 | mPaperWidth = mDefaultPaperWidth 2519 | mPaperHeight = mDefaultPaperHeight 2520 | Else 2521 | mPaperWidth = iPs.X 2522 | mPaperHeight = iPs.Y 2523 | End If 2524 | 2525 | End Sub 2526 | 2527 | Private Function GetPaperSize(nPaperSizeNumber As Long) As POINTAPI 2528 | Dim ret As Long 2529 | Dim iPaperSizesNumbers() As Integer 2530 | Dim iPaperSizes() As POINTAPI 2531 | Dim c As Long 2532 | Dim iLng As Long 2533 | 2534 | ret = DeviceCapabilities(mDeviceName, mPort, DC_PAPERS, ByVal 0&, ByVal 0&) 2535 | 2536 | ReDim iPaperSizesNumbers(1 To ret) 2537 | ReDim iPaperSizes(1 To ret) 2538 | 2539 | Call DeviceCapabilities(mDeviceName, mPort, DC_PAPERS, iPaperSizesNumbers(1), ByVal 0&) 2540 | Call DeviceCapabilities(mDeviceName, mPort, DC_PAPERSIZE, iPaperSizes(1), ByVal 0&) 2541 | 2542 | For c = 1 To UBound(iPaperSizesNumbers) 2543 | If iPaperSizesNumbers(c) = nPaperSizeNumber Then 2544 | GetPaperSize.X = iPaperSizes(c).X 2545 | GetPaperSize.Y = iPaperSizes(c).Y 2546 | If GetPaperSize.X > GetPaperSize.Y Then 2547 | iLng = GetPaperSize.X 2548 | GetPaperSize.X = GetPaperSize.Y 2549 | GetPaperSize.Y = iLng 2550 | End If 2551 | Exit Function 2552 | End If 2553 | Next c 2554 | End Function 2555 | 2556 | Public Property Get DevModePtr() As Long 2557 | DevModePtr = mDevModePtr 2558 | End Property 2559 | 2560 | 2561 | Public Property Let CustomColors(Index As Integer, nValue As Long) 2562 | If (Index < 0) Or (Index > 15) Then Exit Property 2563 | mCustomColors(Index) = nValue 2564 | End Property 2565 | 2566 | Public Property Get CustomColors(Index As Integer) As Long 2567 | CustomColors = mCustomColors(Index) 2568 | End Property 2569 | 2570 | 2571 | Public Property Let AutoSaveCustomColors(nValue As Boolean) 2572 | mAutoSaveCustomColors = nValue 2573 | End Property 2574 | 2575 | Public Property Get AutoSaveCustomColors() As Boolean 2576 | AutoSaveCustomColors = mAutoSaveCustomColors 2577 | End Property 2578 | 2579 | Private Sub InitCustomColors() 2580 | Dim c As Long 2581 | Dim iByte As Byte 2582 | 2583 | For c = 0 To 15 2584 | iByte = 255 - c * 16 2585 | mCustomColors(c) = RGB(iByte, iByte, iByte) 2586 | Next c 2587 | End Sub 2588 | 2589 | Public Property Get PrinterDefault() As Variant 2590 | Attribute PrinterDefault.VB_MemberFlags = "40" 2591 | ' 2592 | End Property 2593 | 2594 | Public Property Let PrinterDefault(ByVal vNewValue As Variant) 2595 | ' 2596 | End Property 2597 | 2598 | Private Function GetActiveWindowHwnd() As Long 2599 | GetActiveWindowHwnd = GetForegroundWindow 2600 | If GetWindowThreadProcessId(GetActiveWindowHwnd, 0&) <> App.ThreadID Then 2601 | GetActiveWindowHwnd = 0 2602 | End If 2603 | End Function 2604 | 2605 | Private Function CloneFont(nOrigFont As StdFont) As StdFont 2606 | Dim iFont As New StdFont 2607 | 2608 | If nOrigFont Is Nothing Then Exit Function 2609 | If Not TypeOf nOrigFont Is StdFont Then Exit Function 2610 | 2611 | iFont.Name = nOrigFont.Name 2612 | iFont.Size = nOrigFont.Size 2613 | iFont.Bold = nOrigFont.Bold 2614 | iFont.Italic = nOrigFont.Italic 2615 | iFont.Strikethrough = nOrigFont.Strikethrough 2616 | iFont.Underline = nOrigFont.Underline 2617 | iFont.Weight = nOrigFont.Weight 2618 | iFont.Charset = nOrigFont.Charset 2619 | 2620 | Set CloneFont = iFont 2621 | End Function 2622 | 2623 | Public Sub ShowFolder(Optional nFlags As cdeCommonDialogExFolderFlagsConstants = -1) 2624 | Dim bInf As BrowseInfo 2625 | Dim RetVal As Long 2626 | Dim PathID As Long 2627 | Dim RetPath As String 2628 | Dim Offset As Integer 2629 | Dim iHwndOwner As Long 2630 | Dim iRootFolder As String 2631 | Dim iCSIDL As Long 2632 | Dim iPidlRoot As ITEMIDLIST 2633 | Dim ipIDList2 As Long 2634 | Dim iFlags As Long 2635 | Dim iAuxFolderPath As String 2636 | Dim iFolder_Prev As String 2637 | 2638 | iFlags = mFlags 2639 | If nFlags <> -1 Then 2640 | iFlags = iFlags Or nFlags 2641 | End If 2642 | If (iFlags And Not cdeSFValidate And Not cdeSFUseNewUI And Not cdeSFUAHint And Not cdeSFStatusText And Not cdeSFNoNewFolderButton And Not cdeSFEditBox And Not cdeSFNewDialogStyle) = 0 Then 2643 | iFlags = iFlags Or cdeSFReturnOnlyFSDirs 2644 | End If 2645 | iFlags = iFlags And Not cdeSFNoReturnOnlyFSDirs 2646 | 2647 | gWindowTitle = mDialogTitle 2648 | iHwndOwner = GetActiveWindowHwnd 2649 | 'Set the properties of the folder dialog 2650 | bInf.hwndOwner = iHwndOwner 2651 | bInf.pszDisplayName = String(260, 32) 2652 | 2653 | iRootFolder = Replace(LCase$(mRootFolder), " ", "") 2654 | If (iRootFolder = "") Or iRootFolder = "desktop" Then 2655 | bInf.pIDLRoot = 0 2656 | Else 2657 | Select Case iRootFolder 2658 | Case "mycomputer" 2659 | iCSIDL = CSIDL_DRIVES 2660 | Case "mydocuments" 2661 | iCSIDL = CSIDL_PERSONAL 2662 | Case Else 2663 | ' nothing 2664 | End Select 2665 | If iCSIDL <> 0 Then 2666 | If SHGetFolderLocation(0&, iCSIDL, 0&, 0&, iPidlRoot) = S_OK Then 2667 | bInf.pIDLRoot = iPidlRoot.mkid.cb 2668 | End If 2669 | Else 2670 | If PathIsDirectory(mRootFolder) Then 2671 | SHParseDisplayName StrPtr(mRootFolder), ByVal 0&, ipIDList2, ByVal 0&, ByVal 0& 2672 | bInf.pIDLRoot = ipIDList2 2673 | End If 2674 | End If 2675 | End If 2676 | bInf.lpszTitle = mFolderDialogHeader 2677 | bInf.ulFlags = iFlags 2678 | If bInf.ulFlags = 0 Then 2679 | bInf.ulFlags = cdlSFReturnOnlyFSDirs Or cdlSFStatusText Or cdlSFUseNewUI Or cdlSFValidate 2680 | End If 2681 | 2682 | If (bInf.ulFlags And cdlSFBrowseIncludeURLs) <> 0 Then 2683 | bInf.ulFlags = bInf.ulFlags Or cdlSFUseNewUI Or cdlSFBrowseIncludeFiles 2684 | End If 2685 | If (bInf.ulFlags And cdlSFBrowseForPrinter) <> 0 Then 2686 | bInf.ulFlags = bInf.ulFlags And Not cdlSFBrowseForPrinter 2687 | If bInf.ulFlags = 0 Then 2688 | bInf.ulFlags = cdlSFBrowseForPrinter Or cdlSFNewDialogStyle Or cdlSFNoNewFolderButton Or cdlSFShareable 2689 | Else 2690 | bInf.ulFlags = bInf.ulFlags Or cdlSFBrowseForPrinter Or cdlSFNoNewFolderButton 2691 | End If 2692 | iCSIDL = CSIDL_PRINTERS 2693 | If SHGetFolderLocation(0&, iCSIDL, 0&, 0&, iPidlRoot) = S_OK Then 2694 | bInf.pIDLRoot = iPidlRoot.mkid.cb 2695 | End If 2696 | End If 2697 | If (bInf.ulFlags And cdlSFBrowseForComputer) <> 0 Then 2698 | bInf.ulFlags = bInf.ulFlags And Not cdlSFBrowseForComputer 2699 | If bInf.ulFlags = 0 Then 2700 | bInf.ulFlags = cdlSFBrowseForComputer Or cdlSFNoNewFolderButton Or cdlSFShareable 2701 | Else 2702 | bInf.ulFlags = bInf.ulFlags Or cdlSFBrowseForComputer Or cdlSFNoNewFolderButton 2703 | End If 2704 | End If 2705 | 2706 | If mInitDir <> "" Then 2707 | gCommonDialogEx_ShowFolder_StartFolder = mInitDir & vbNullChar 2708 | Else 2709 | If mFolderName <> "" Then 2710 | iAuxFolderPath = mFolderName 2711 | gCommonDialogEx_ShowFolder_StartFolder = iAuxFolderPath 2712 | End If 2713 | End If 2714 | bInf.lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function. 2715 | 2716 | mCanceled = False 2717 | mChanged = False 2718 | iFolder_Prev = mFolderName 2719 | 2720 | 'Show the Browse For Folder dialog 2721 | PathID = SHBrowseForFolder(bInf) 2722 | If PathID <> 0 Then 2723 | RetPath = Space$(512) 2724 | RetVal = SHGetPathFromIDList(ByVal PathID, ByVal RetPath) 2725 | 2726 | If RetVal Then 2727 | 'Trim$ off the null chars ending the path 2728 | 'and display the returned folder 2729 | Offset = InStr(RetPath, Chr$(0)) 2730 | mFolderName = Left$(RetPath, Offset - 1) 2731 | mFolderDisplayName = Left$(bInf.pszDisplayName, InStr(bInf.pszDisplayName, Chr(0)) - 1) 2732 | 'Free memory allocated for PIDL 2733 | CoTaskMemFree PathID 2734 | Else 2735 | mFolderDisplayName = Left$(bInf.pszDisplayName, InStr(bInf.pszDisplayName, Chr(0)) - 1) 2736 | If (bInf.ulFlags And cdlSFBrowseForPrinter) <> 0 Then 2737 | If Not IsPrinter(mFolderDisplayName) Then 2738 | mFolderDisplayName = "" 2739 | End If 2740 | End If 2741 | mFolderName = mFolderDisplayName 2742 | End If 2743 | Else 2744 | mCanceled = True 2745 | If mCancelError Then 2746 | 'generate an error 2747 | On Error GoTo 0 2748 | Err.Raise 32755, TypeName(Me), "Cancel Pressed" 2749 | Exit Sub 2750 | End If 2751 | End If 2752 | mChanged = mFolderName <> iFolder_Prev 2753 | End Sub 2754 | 2755 | 2756 | Public Property Get FolderDisplayName() As String 2757 | FolderDisplayName = mFolderDisplayName 2758 | End Property 2759 | 2760 | Public Property Get FolderDialogHeader() As String 2761 | FolderDialogHeader = mFolderDialogHeader 2762 | End Property 2763 | 2764 | Public Property Let FolderDialogHeader(ByVal nValue As String) 2765 | If mFolderDialogHeader <> nValue Then 2766 | mFolderDialogHeader = nValue 2767 | End If 2768 | End Property 2769 | 2770 | -------------------------------------------------------------------------------- /source/cls/cSmartConcat.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 = "SmartConcat" 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 m_Separator As String 17 | 18 | Private m_MediumGrowSize As Long 19 | Private m_CurrentMediumSize As Long 20 | Private m_CurrentMediumIndex As Long 21 | Private m_MediumStrings() As String 22 | 23 | Private m_MaxMediumLength As Long 24 | Private m_SmallTotalLength As Long 25 | 26 | Private m_MaxSmallEntries As Long 27 | Private m_SmallIndex As Long 28 | Private m_SmallStrings() As String 29 | 30 | Public Function GenerateCurrentString() As String 31 | If m_SmallIndex Then ClearSmallStrings 32 | If m_CurrentMediumIndex Then 33 | 'Shrink the size of the string array so that join doesn't get extra stuff 34 | ReDim Preserve m_MediumStrings(m_CurrentMediumIndex - 1) 35 | GenerateCurrentString = Join(m_MediumStrings, m_Separator) 36 | ReDim Preserve m_MediumStrings(m_CurrentMediumSize - 1) 37 | End If 38 | End Function 39 | 40 | Public Sub ClearStrings() 41 | Dim l As Long 42 | If m_SmallIndex Then 43 | For l = 0 To m_SmallIndex - 1 44 | m_SmallStrings(l) = vbNullString 45 | Next l 46 | End If 47 | m_SmallIndex = 0 48 | m_SmallTotalLength = 0 49 | m_CurrentMediumIndex = 0 50 | m_CurrentMediumSize = 0 51 | Erase m_MediumStrings 52 | End Sub 53 | 54 | Public Sub AddString(NewString As String) 55 | Dim NewLen As Long 56 | NewLen = Len(NewString) 57 | If m_SmallTotalLength + NewLen > m_MaxMediumLength Then 58 | ClearSmallStrings 59 | End If 60 | m_SmallTotalLength = m_SmallTotalLength + NewLen 61 | m_SmallStrings(m_SmallIndex) = NewString 62 | m_SmallIndex = m_SmallIndex + 1 63 | If m_SmallIndex = m_MaxSmallEntries Then 64 | 'Clear out now 65 | ClearSmallStrings 66 | End If 67 | End Sub 68 | 69 | Public Property Get TempStringCount() As Long 70 | TempStringCount = m_MaxSmallEntries 71 | End Property 72 | 73 | Public Property Let TempStringCount(ByVal RHS As Long) 74 | If RHS < 1 Then Err.Raise 5 75 | If m_SmallIndex Then ClearSmallStrings 76 | m_MaxSmallEntries = RHS 77 | ReDim Preserve m_SmallStrings(RHS - 1) 78 | End Property 79 | 80 | Public Property Get FinalCacheGrowSize() As Long 81 | FinalCacheGrowSize = m_MediumGrowSize 82 | End Property 83 | 84 | Public Property Let FinalCacheGrowSize(ByVal RHS As Long) 85 | If RHS < 1 Then Err.Raise 5 86 | If m_CurrentMediumIndex Then Err.Raise 5, , "Call before AddString or after ClearStrings" 87 | m_MediumGrowSize = RHS 88 | End Property 89 | 90 | Public Property Get MaxTempLength() As Long 91 | MaxTempLength = m_MaxMediumLength 92 | End Property 93 | 94 | Public Property Let MaxTempLength(ByVal RHS As Long) 95 | If RHS < 1 Then Err.Raise 5 96 | m_MaxMediumLength = RHS 97 | End Property 98 | 99 | Public Property Get Separator() As String 100 | Separator = m_Separator 101 | End Property 102 | 103 | Public Property Let Separator(ByVal RHS As String) 104 | m_Separator = RHS 105 | End Property 106 | 107 | Private Function NextMediumIndex() As Long 108 | If (m_CurrentMediumIndex Mod m_MediumGrowSize) = 0 Then 109 | m_CurrentMediumSize = m_CurrentMediumSize + m_MediumGrowSize 110 | ReDim Preserve m_MediumStrings(m_CurrentMediumSize - 1) 111 | End If 112 | NextMediumIndex = m_CurrentMediumIndex 113 | m_CurrentMediumIndex = m_CurrentMediumIndex + 1 114 | End Function 115 | 116 | 'Use the Join function to generate a medium length string 117 | 'and move it to our medium length 118 | Private Sub ClearSmallStrings() 119 | Dim iNextMediumIndex As Long 120 | 'Debug.Assert m_SmallIndex 121 | 122 | 'Temporarily shrink the array to stop Join from adding extra separators 123 | 'This isn't as bad as it seems because we'll be growing back to the same 124 | 'size, so it will likely reoccupy the same memory. Although you can 't Stop 125 | 'the memory from relocatin, you can see if it actually happened by looking 126 | 'at VarPtr(m_SmallStrings(0)) before and after each ReDim Preserve. 127 | If m_SmallIndex > 0 Then 128 | ReDim Preserve m_SmallStrings(m_SmallIndex - 1) 129 | 130 | iNextMediumIndex = NextMediumIndex 'Note: Native/Fast bug, don't do NextMediumIndex inline 131 | m_MediumStrings(iNextMediumIndex) = Join(m_SmallStrings, m_Separator) 132 | 133 | 'We could clear all of the current strings here, but 134 | 'it turns out that it is slightly faster to just leave them 135 | 'alone and let them clear out naturally as the buffer is reused 136 | 'Dim l As Long 137 | 'For l = 0 To m_SmallIndex - 1 138 | ' m_SmallStrings(l) = vbNullString 139 | 'Next l 140 | 141 | 'Put the array size back where it should be 142 | ReDim Preserve m_SmallStrings(m_MaxSmallEntries - 1) 143 | 144 | 'Clear the current length and index 145 | m_SmallIndex = 0 146 | m_SmallTotalLength = 0 147 | End If 148 | End Sub 149 | 150 | Private Sub Class_Initialize() 151 | 'Set default and initialize array 152 | m_MaxMediumLength = 4095 153 | m_MaxSmallEntries = 128 154 | m_MediumGrowSize = 64 155 | ReDim m_SmallStrings(m_MaxSmallEntries - 1) 156 | End Sub 157 | -------------------------------------------------------------------------------- /source/frm/frmBlankFieldsOptions.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmBlankFieldsOptions 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select fields" 5 | ClientHeight = 4692 6 | ClientLeft = 1932 7 | ClientTop = 2160 8 | ClientWidth = 5244 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 4692 23 | ScaleWidth = 5244 24 | ShowInTaskbar = 0 'False 25 | Begin VB.CommandButton cmdCancel 26 | Cancel = -1 'True 27 | Caption = "Cancel" 28 | Height = 420 29 | Left = 3708 30 | TabIndex = 1 31 | Top = 4020 32 | UseMaskColor = -1 'True 33 | Width = 1092 34 | End 35 | Begin VB.CommandButton cmdOK 36 | Caption = "OK" 37 | Height = 420 38 | Left = 2220 39 | TabIndex = 0 40 | Top = 4020 41 | UseMaskColor = -1 'True 42 | Width = 1092 43 | End 44 | Begin VB.CheckBox chkField 45 | Caption = "Enums descriptions" 46 | Height = 372 47 | Index = 5 48 | Left = 720 49 | TabIndex = 7 50 | Top = 2670 51 | Width = 3132 52 | End 53 | Begin VB.CheckBox chkField 54 | Caption = "Constants descriptions" 55 | Height = 372 56 | Index = 6 57 | Left = 720 58 | TabIndex = 8 59 | Top = 3120 60 | Width = 3132 61 | End 62 | Begin VB.CheckBox chkField 63 | Caption = "Members parameters info" 64 | Height = 372 65 | Index = 2 66 | Left = 720 67 | TabIndex = 4 68 | Top = 1320 69 | Value = 1 'Checked 70 | Width = 3132 71 | End 72 | Begin VB.CheckBox chkField 73 | Caption = "Members Long descriptions" 74 | Height = 372 75 | Index = 3 76 | Left = 720 77 | TabIndex = 5 78 | Top = 1770 79 | Value = 1 'Checked 80 | Width = 3132 81 | End 82 | Begin VB.CheckBox chkField 83 | Caption = "members Short descriptions" 84 | Height = 372 85 | Index = 4 86 | Left = 720 87 | TabIndex = 6 88 | Top = 2220 89 | Value = 1 'Checked 90 | Width = 3132 91 | End 92 | Begin VB.CheckBox chkField 93 | Caption = "Controls/Classes Short descriptions" 94 | Height = 372 95 | Index = 1 96 | Left = 720 97 | TabIndex = 3 98 | Top = 870 99 | Width = 3132 100 | End 101 | Begin VB.CheckBox chkField 102 | Caption = "Controls/Classes Long descriptions" 103 | Height = 372 104 | Index = 0 105 | Left = 720 106 | TabIndex = 2 107 | Top = 420 108 | Value = 1 'Checked 109 | Width = 3132 110 | End 111 | End 112 | Attribute VB_Name = "frmBlankFieldsOptions" 113 | Attribute VB_GlobalNameSpace = False 114 | Attribute VB_Creatable = False 115 | Attribute VB_PredeclaredId = True 116 | Attribute VB_Exposed = False 117 | Option Explicit 118 | 119 | Public OKPressed As Boolean 120 | Private mFields(6) As Boolean 121 | 122 | Private Sub cmdCancel_Click() 123 | Unload Me 124 | End Sub 125 | 126 | Private Sub cmdOK_Click() 127 | Dim c As Long 128 | 129 | For c = 0 To UBound(mFields) 130 | mFields(c) = (chkField(c).Value = 1) 131 | Next 132 | OKPressed = True 133 | Unload Me 134 | End Sub 135 | 136 | Private Sub Form_Load() 137 | Set Me.Icon = gIcon 138 | End Sub 139 | 140 | Public Property Get Field(nIndex As Long) As Boolean 141 | Field = mFields(nIndex) 142 | End Property 143 | 144 | Public Property Get FieldsString() As String 145 | Dim c As Long 146 | 147 | For c = 0 To UBound(mFields) 148 | FieldsString = FieldsString & CStr(Abs(CLng(mFields(c)))) 149 | Next 150 | End Property 151 | 152 | Public Property Let FieldsString(nValue As String) 153 | Dim c As Long 154 | 155 | For c = 0 To UBound(mFields) 156 | chkField(c).Value = Val(Mid$(nValue, c + 1, 1)) 157 | Next 158 | End Property 159 | -------------------------------------------------------------------------------- /source/frm/frmComponentProperties.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmComponentProperties 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Component properties" 5 | ClientHeight = 3048 6 | ClientLeft = 2820 7 | ClientTop = 2160 8 | ClientWidth = 4932 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 3048 23 | ScaleWidth = 4932 24 | ShowInTaskbar = 0 'False 25 | Begin VB.TextBox txtReleaseDate 26 | Appearance = 0 'Flat 27 | Height = 372 28 | Left = 1440 29 | MaxLength = 10 30 | TabIndex = 7 31 | Top = 1560 32 | Width = 1188 33 | End 34 | Begin VB.TextBox txtVersion 35 | Appearance = 0 'Flat 36 | Height = 372 37 | Left = 1440 38 | MaxLength = 2312 39 | TabIndex = 5 40 | Top = 1020 41 | Width = 1188 42 | End 43 | Begin VB.CommandButton cmdOK 44 | Caption = "OK" 45 | Default = -1 'True 46 | Height = 420 47 | Left = 1884 48 | TabIndex = 0 49 | Top = 2388 50 | UseMaskColor = -1 'True 51 | Width = 1092 52 | End 53 | Begin VB.CommandButton cmdCancel 54 | Cancel = -1 'True 55 | Caption = "Cancel" 56 | Height = 420 57 | Left = 3372 58 | TabIndex = 1 59 | Top = 2388 60 | UseMaskColor = -1 'True 61 | Width = 1092 62 | End 63 | Begin VB.TextBox txtName 64 | Appearance = 0 'Flat 65 | Height = 372 66 | Left = 1440 67 | MaxLength = 100 68 | TabIndex = 3 69 | Top = 456 70 | Width = 3228 71 | End 72 | Begin VB.Label Label3 73 | Alignment = 1 'Right Justify 74 | Caption = "Release date:" 75 | Height = 348 76 | Left = 240 77 | TabIndex = 6 78 | Top = 1644 79 | Width = 1080 80 | End 81 | Begin VB.Label Label2 82 | Alignment = 1 'Right Justify 83 | Caption = "Version:" 84 | Height = 348 85 | Left = 240 86 | TabIndex = 4 87 | Top = 1104 88 | Width = 1080 89 | End 90 | Begin VB.Label Label1 91 | Alignment = 1 'Right Justify 92 | Caption = "Name:" 93 | Height = 348 94 | Left = 240 95 | TabIndex = 2 96 | Top = 540 97 | Width = 1080 98 | End 99 | End 100 | Attribute VB_Name = "frmComponentProperties" 101 | Attribute VB_GlobalNameSpace = False 102 | Attribute VB_Creatable = False 103 | Attribute VB_PredeclaredId = True 104 | Attribute VB_Exposed = False 105 | Option Explicit 106 | 107 | Public OKPressed As Boolean 108 | Public ComponentName As String 109 | Public ComponentVersion As String 110 | Public ComponentReleaseDate As String 111 | 112 | Private Sub cmdCancel_Click() 113 | Unload Me 114 | End Sub 115 | 116 | Private Sub cmdOK_Click() 117 | txtReleaseDate.Text = Trim(txtReleaseDate.Text) 118 | If txtReleaseDate.Text <> "" Then 119 | If Not IsDate(txtReleaseDate.Text) Then 120 | MsgBox "Please enter a valid date or leave blank.", vbExclamation 121 | txtReleaseDate.SelStart = 0 122 | txtReleaseDate.SelLength = Len(txtReleaseDate.Text) 123 | txtReleaseDate.SetFocus 124 | Exit Sub 125 | End If 126 | End If 127 | ComponentName = txtName.Text 128 | ComponentVersion = txtVersion.Text 129 | ComponentReleaseDate = txtReleaseDate.Text 130 | OKPressed = True 131 | Unload Me 132 | End Sub 133 | 134 | Private Sub Form_Load() 135 | Set Me.Icon = gIcon 136 | End Sub 137 | 138 | -------------------------------------------------------------------------------- /source/frm/frmConfigureHTML.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Object = "{BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0"; "tabctl32.ocx" 3 | Begin VB.Form frmConfigureHTML 4 | Caption = "Configure HTML texts" 5 | ClientHeight = 7236 6 | ClientLeft = 7440 7 | ClientTop = 2148 8 | ClientWidth = 9384 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MinButton = 0 'False 21 | ScaleHeight = 7236 22 | ScaleWidth = 9384 23 | Begin VB.CommandButton cmdOK 24 | Caption = "OK" 25 | Height = 420 26 | Left = 5712 27 | TabIndex = 1 28 | Top = 6048 29 | UseMaskColor = -1 'True 30 | Width = 1092 31 | End 32 | Begin VB.CommandButton cmdCancel 33 | Cancel = -1 'True 34 | Caption = "Cancel" 35 | Height = 420 36 | Left = 7200 37 | TabIndex = 0 38 | Top = 6048 39 | UseMaskColor = -1 'True 40 | Width = 1092 41 | End 42 | Begin TabDlg.SSTab sst1 43 | Height = 5796 44 | Left = 96 45 | TabIndex = 2 46 | Top = 72 47 | Width = 8636 48 | _ExtentX = 15240 49 | _ExtentY = 10224 50 | _Version = 393216 51 | Style = 1 52 | Tabs = 5 53 | Tab = 4 54 | TabsPerRow = 5 55 | TabHeight = 529 56 | ForeColor = -2147483630 57 | BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 58 | Name = "Segoe UI" 59 | Size = 10.2 60 | Charset = 0 61 | Weight = 400 62 | Underline = 0 'False 63 | Italic = 0 'False 64 | Strikethrough = 0 'False 65 | EndProperty 66 | TabCaption(0) = "HEAD" 67 | TabPicture(0) = "frmConfigureHTML.frx":0000 68 | Tab(0).ControlEnabled= 0 'False 69 | Tab(0).Control(0)= "txt(0)" 70 | Tab(0).Control(1)= "lblTitle(0)" 71 | Tab(0).ControlCount= 2 72 | TabCaption(1) = "Style sheet" 73 | TabPicture(1) = "frmConfigureHTML.frx":001C 74 | Tab(1).ControlEnabled= 0 'False 75 | Tab(1).Control(0)= "txt(1)" 76 | Tab(1).Control(1)= "lblTitle(1)" 77 | Tab(1).ControlCount= 2 78 | TabCaption(2) = "Page header for multiple pages" 79 | TabPicture(2) = "frmConfigureHTML.frx":0038 80 | Tab(2).ControlEnabled= 0 'False 81 | Tab(2).Control(0)= "txt(2)" 82 | Tab(2).Control(1)= "lblTitle(2)" 83 | Tab(2).ControlCount= 2 84 | TabCaption(3) = "Page header for one page" 85 | TabPicture(3) = "frmConfigureHTML.frx":0054 86 | Tab(3).ControlEnabled= 0 'False 87 | Tab(3).Control(0)= "txt(3)" 88 | Tab(3).Control(1)= "lblTitle(3)" 89 | Tab(3).ControlCount= 2 90 | TabCaption(4) = "Page footer" 91 | TabPicture(4) = "frmConfigureHTML.frx":0070 92 | Tab(4).ControlEnabled= -1 'True 93 | Tab(4).Control(0)= "lblTitle(4)" 94 | Tab(4).Control(0).Enabled= 0 'False 95 | Tab(4).Control(1)= "txt(4)" 96 | Tab(4).Control(1).Enabled= 0 'False 97 | Tab(4).ControlCount= 2 98 | Begin VB.TextBox txt 99 | Appearance = 0 'Flat 100 | BeginProperty Font 101 | Name = "Consolas" 102 | Size = 12 103 | Charset = 0 104 | Weight = 400 105 | Underline = 0 'False 106 | Italic = 0 'False 107 | Strikethrough = 0 'False 108 | EndProperty 109 | Height = 5172 110 | Index = 4 111 | Left = 96 112 | MultiLine = -1 'True 113 | ScrollBars = 2 'Vertical 114 | TabIndex = 12 115 | Top = 700 116 | Width = 7788 117 | End 118 | Begin VB.TextBox txt 119 | Appearance = 0 'Flat 120 | BeginProperty Font 121 | Name = "Consolas" 122 | Size = 12 123 | Charset = 0 124 | Weight = 400 125 | Underline = 0 'False 126 | Italic = 0 'False 127 | Strikethrough = 0 'False 128 | EndProperty 129 | Height = 5172 130 | Index = 3 131 | Left = -74784 132 | MultiLine = -1 'True 133 | ScrollBars = 2 'Vertical 134 | TabIndex = 10 135 | Top = 700 136 | Width = 7788 137 | End 138 | Begin VB.TextBox txt 139 | Appearance = 0 'Flat 140 | BeginProperty Font 141 | Name = "Consolas" 142 | Size = 12 143 | Charset = 0 144 | Weight = 400 145 | Underline = 0 'False 146 | Italic = 0 'False 147 | Strikethrough = 0 'False 148 | EndProperty 149 | Height = 5412 150 | Index = 2 151 | Left = -74712 152 | MultiLine = -1 'True 153 | ScrollBars = 2 'Vertical 154 | TabIndex = 8 155 | Top = 700 156 | Width = 7788 157 | End 158 | Begin VB.TextBox txt 159 | Appearance = 0 'Flat 160 | BeginProperty Font 161 | Name = "Consolas" 162 | Size = 12 163 | Charset = 0 164 | Weight = 400 165 | Underline = 0 'False 166 | Italic = 0 'False 167 | Strikethrough = 0 'False 168 | EndProperty 169 | Height = 5412 170 | Index = 1 171 | Left = -74784 172 | MultiLine = -1 'True 173 | ScrollBars = 2 'Vertical 174 | TabIndex = 6 175 | Top = 700 176 | Width = 7788 177 | End 178 | Begin VB.TextBox txt 179 | Appearance = 0 'Flat 180 | BeginProperty Font 181 | Name = "Consolas" 182 | Size = 12 183 | Charset = 0 184 | Weight = 400 185 | Underline = 0 'False 186 | Italic = 0 'False 187 | Strikethrough = 0 'False 188 | EndProperty 189 | Height = 5412 190 | Index = 0 191 | Left = -74640 192 | MultiLine = -1 'True 193 | ScrollBars = 2 'Vertical 194 | TabIndex = 4 195 | Top = 648 196 | Width = 7788 197 | End 198 | Begin VB.Label lblTitle 199 | Caption = "HTML code that will be added inmediately before the closing tag" 200 | ForeColor = &H00FA0A22& 201 | Height = 300 202 | Index = 4 203 | Left = 60 204 | TabIndex = 11 205 | Top = 420 206 | Width = 8004 207 | End 208 | Begin VB.Label lblTitle 209 | Caption = "HTML code that will be added inmediately after the opening tag" 210 | ForeColor = &H00FA0A22& 211 | Height = 300 212 | Index = 2 213 | Left = -74880 214 | TabIndex = 7 215 | Top = 400 216 | Width = 8000 217 | End 218 | Begin VB.Label lblTitle 219 | Caption = "Stylesheet code" 220 | ForeColor = &H00FA0A22& 221 | Height = 300 222 | Index = 1 223 | Left = -74880 224 | TabIndex = 5 225 | Top = 400 226 | Width = 8000 227 | End 228 | Begin VB.Label lblTitle 229 | Caption = "HTML code correspondig to section" 230 | ForeColor = &H00FA0A22& 231 | Height = 300 232 | Index = 0 233 | Left = -74880 234 | TabIndex = 3 235 | Top = 400 236 | Width = 8000 237 | End 238 | Begin VB.Label lblTitle 239 | Caption = "HTML code that will be added inmediately after the opening tag when using the one page option" 240 | ForeColor = &H00FA0A22& 241 | Height = 300 242 | Index = 3 243 | Left = -74880 244 | TabIndex = 9 245 | Top = 400 246 | Width = 9000 247 | End 248 | End 249 | Begin VB.Label lblNote 250 | AutoSize = -1 'True 251 | Caption = "Note: leave blank to restore default. Placeholders are between braces (do not modify). Use valid HTM code, it won't be validated." 252 | Height = 720 253 | Left = 240 254 | TabIndex = 13 255 | Top = 5952 256 | Width = 4980 257 | WordWrap = -1 'True 258 | End 259 | End 260 | Attribute VB_Name = "frmConfigureHTML" 261 | Attribute VB_GlobalNameSpace = False 262 | Attribute VB_Creatable = False 263 | Attribute VB_PredeclaredId = True 264 | Attribute VB_Exposed = False 265 | Option Explicit 266 | 267 | Public OKPressed As Boolean 268 | 269 | Private mTxt(4) As String 270 | 271 | Private Sub cmdCancel_Click() 272 | Unload Me 273 | End Sub 274 | 275 | Private Sub cmdOK_Click() 276 | OKPressed = True 277 | Unload Me 278 | End Sub 279 | 280 | Private Sub Form_Load() 281 | Set Me.Icon = gIcon 282 | sst1.Tab = 0 283 | End Sub 284 | 285 | Private Sub Form_Resize() 286 | Dim t As Long 287 | Dim tp As Long 288 | Dim iExtraHeight As Long 289 | 290 | If Me.Width < 9400 Then Me.Width = 9400 291 | If Me.Height < 4000 Then Me.Height = 4000 292 | 293 | iExtraHeight = 800 294 | If (lblNote.Height + 100) > iExtraHeight Then iExtraHeight = lblNote.Height + 100 295 | 296 | cmdCancel.Move Me.ScaleWidth - cmdCancel.Width - 500, Me.ScaleHeight - cmdCancel.Height - 140 297 | cmdOK.Move cmdCancel.Left - cmdOK.Width - 500, cmdCancel.Top 298 | lblNote.Width = cmdOK.Left - lblNote.Left - 100 299 | 300 | sst1.Move 60, 60 + 60, Me.ScaleWidth - 120, Me.ScaleHeight - iExtraHeight 301 | tp = sst1.Tab 302 | For t = 0 To sst1.Tabs - 1 303 | sst1.Tab = t 304 | lblTitle(t).Move 120, 400 305 | txt(t).Move Screen.TwipsPerPixelX, Screen.TwipsPerPixelY + lblTitle(t).Top + lblTitle(t).Height, sst1.Width - Screen.TwipsPerPixelX * 2, sst1.Height - Screen.TwipsPerPixelY * 2 - (lblTitle(t).Top + lblTitle(t).Height) 306 | Next 307 | sst1.Tab = tp 308 | 309 | lblNote.Top = (sst1.Top + sst1.Height + Me.ScaleHeight - lblNote.Height) / 2 310 | End Sub 311 | 312 | Private Sub txt_Change(Index As Integer) 313 | mTxt(Index) = txt(Index).Text 314 | End Sub 315 | 316 | 317 | Public Property Let HTML_HeadSection(str As String) 318 | txt(0).Text = str 319 | End Property 320 | 321 | Public Property Get HTML_HeadSection() As String 322 | HTML_HeadSection = mTxt(0) 323 | End Property 324 | 325 | 326 | Public Property Let HTML_StyleSheet(str As String) 327 | txt(1).Text = str 328 | End Property 329 | 330 | Public Property Get HTML_StyleSheet() As String 331 | HTML_StyleSheet = mTxt(1) 332 | End Property 333 | 334 | 335 | Public Property Let HTML_PageHeaderMP(str As String) 336 | txt(2).Text = str 337 | End Property 338 | 339 | Public Property Get HTML_PageHeaderMP() As String 340 | HTML_PageHeaderMP = mTxt(2) 341 | End Property 342 | 343 | 344 | Public Property Let HTML_PageHeaderOP(str As String) 345 | txt(3).Text = str 346 | End Property 347 | 348 | Public Property Get HTML_PageHeaderOP() As String 349 | HTML_PageHeaderOP = mTxt(3) 350 | End Property 351 | 352 | 353 | Public Property Let HTML_PageFooter(str As String) 354 | txt(4).Text = str 355 | End Property 356 | 357 | Public Property Get HTML_PageFooter() As String 358 | HTML_PageFooter = mTxt(4) 359 | End Property 360 | 361 | 362 | -------------------------------------------------------------------------------- /source/frm/frmConfigureHTML.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/frm/frmConfigureHTML.frx -------------------------------------------------------------------------------- /source/frm/frmFieldsModifAlert.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmFieldsModifAlert 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Alert" 5 | ClientHeight = 2160 6 | ClientLeft = 1932 7 | ClientTop = 2160 8 | ClientWidth = 6060 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | MaxButton = 0 'False 20 | MinButton = 0 'False 21 | ScaleHeight = 2160 22 | ScaleWidth = 6060 23 | ShowInTaskbar = 0 'False 24 | StartUpPosition = 1 'CenterOwner 25 | Begin VB.CheckBox chkHide 26 | Caption = "OK, do not show me it again" 27 | Height = 372 28 | Left = 300 29 | TabIndex = 2 30 | Top = 1560 31 | Width = 2892 32 | End 33 | Begin VB.CommandButton cmdOK 34 | Cancel = -1 'True 35 | Caption = "OK" 36 | Height = 420 37 | Left = 4480 38 | TabIndex = 0 39 | Top = 1500 40 | UseMaskColor = -1 'True 41 | Width = 1092 42 | End 43 | Begin VB.Label Label1 44 | Alignment = 2 'Center 45 | Caption = $"frmFieldsModifAlert.frx":0000 46 | Height = 1212 47 | Left = 240 48 | TabIndex = 1 49 | Top = 240 50 | Width = 5632 51 | End 52 | End 53 | Attribute VB_Name = "frmFieldsModifAlert" 54 | Attribute VB_GlobalNameSpace = False 55 | Attribute VB_Creatable = False 56 | Attribute VB_PredeclaredId = True 57 | Attribute VB_Exposed = False 58 | Option Explicit 59 | 60 | Private Sub cmdOK_Click() 61 | Unload Me 62 | End Sub 63 | 64 | Private Sub Form_Load() 65 | Set Me.Icon = gIcon 66 | End Sub 67 | 68 | Private Sub Form_Unload(Cancel As Integer) 69 | If chkHide.Value = 1 Then 70 | SaveSetting App.Title, AppPath4Reg, "HideModifAlert", "1" 71 | End If 72 | End Sub 73 | -------------------------------------------------------------------------------- /source/frm/frmFieldsModifAlert.frx: -------------------------------------------------------------------------------- 1 | If you manually modify the parameters information or the short description fields of properties, methods and events (not controls, classes, enums and constants), be aware that they will be replaced the next time that you import from the component again (like after an update). -------------------------------------------------------------------------------- /source/frm/frmMain.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/frm/frmMain.frm -------------------------------------------------------------------------------- /source/frm/frmMain.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/frm/frmMain.frx -------------------------------------------------------------------------------- /source/frm/frmMessage.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmMessage 3 | Caption = "Results" 4 | ClientHeight = 5820 5 | ClientLeft = 1932 6 | ClientTop = 2160 7 | ClientWidth = 8544 8 | BeginProperty Font 9 | Name = "Segoe UI" 10 | Size = 9 11 | Charset = 0 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LinkTopic = "Form1" 18 | LockControls = -1 'True 19 | ScaleHeight = 5820 20 | ScaleWidth = 8544 21 | Begin VB.CommandButton cmdOK 22 | Caption = "OK" 23 | Default = -1 'True 24 | Height = 420 25 | Left = 7080 26 | TabIndex = 0 27 | Top = 5160 28 | UseMaskColor = -1 'True 29 | Width = 1092 30 | End 31 | Begin VB.TextBox txtMessage 32 | Appearance = 0 'Flat 33 | BeginProperty Font 34 | Name = "Segoe UI" 35 | Size = 10.2 36 | Charset = 0 37 | Weight = 400 38 | Underline = 0 'False 39 | Italic = 0 'False 40 | Strikethrough = 0 'False 41 | EndProperty 42 | Height = 4692 43 | Left = 120 44 | Locked = -1 'True 45 | MultiLine = -1 'True 46 | ScrollBars = 2 'Vertical 47 | TabIndex = 1 48 | Top = 240 49 | Width = 7932 50 | End 51 | Begin VB.Label lblNote 52 | AutoSize = -1 'True 53 | Height = 240 54 | Left = 120 55 | TabIndex = 2 56 | Top = 5040 57 | Width = 6612 58 | WordWrap = -1 'True 59 | End 60 | End 61 | Attribute VB_Name = "frmMessage" 62 | Attribute VB_GlobalNameSpace = False 63 | Attribute VB_Creatable = False 64 | Attribute VB_PredeclaredId = True 65 | Attribute VB_Exposed = False 66 | Option Explicit 67 | 68 | Private Sub cmdOK_Click() 69 | Unload Me 70 | End Sub 71 | 72 | Private Sub Form_Load() 73 | Set Me.Icon = gIcon 74 | End Sub 75 | 76 | Private Sub Form_Resize() 77 | If Me.Width < 6000 Then Me.Width = 6000 78 | If Me.Height < 6000 Then Me.Height = 6000 79 | 80 | txtMessage.Move 30, 30, Me.ScaleWidth - 60, Me.ScaleHeight - 750 81 | cmdOK.Move Me.ScaleWidth - cmdOK.Width - 500, Me.ScaleHeight - cmdOK.Height - 140 82 | lblNote.Top = txtMessage.Top + txtMessage.Height + 60 83 | lblNote.Width = cmdOK.Left - 300 - lblNote.Left 84 | If (lblNote.Height + lblNote.Top) > (Me.ScaleHeight - 90) Then 85 | txtMessage.Height = Me.ScaleHeight - 180 - lblNote.Height 86 | lblNote.Top = txtMessage.Top + txtMessage.Height + 60 87 | End If 88 | End Sub 89 | 90 | Public Property Let Message(nTxt As String) 91 | txtMessage.Text = nTxt 92 | End Property 93 | 94 | -------------------------------------------------------------------------------- /source/frm/frmPDFNote.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmPDFNote 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Note about PDF printer drivers" 5 | ClientHeight = 2484 6 | ClientLeft = 5256 7 | ClientTop = 4488 8 | ClientWidth = 5700 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 2484 23 | ScaleWidth = 5700 24 | ShowInTaskbar = 0 'False 25 | Begin VB.CommandButton cmdOK 26 | Cancel = -1 'True 27 | Caption = "OK" 28 | Default = -1 'True 29 | Height = 420 30 | Left = 3960 31 | TabIndex = 0 32 | Top = 1800 33 | UseMaskColor = -1 'True 34 | Width = 1092 35 | End 36 | Begin VB.CheckBox chkHide 37 | Caption = "OK, do not show me it again" 38 | Height = 372 39 | Left = 360 40 | TabIndex = 3 41 | Top = 1800 42 | Width = 2892 43 | End 44 | Begin VB.Label Label2 45 | Caption = $"frmPDFNote.frx":0000 46 | Height = 732 47 | Left = 360 48 | TabIndex = 2 49 | Top = 840 50 | Width = 5052 51 | End 52 | Begin VB.Label Label1 53 | Caption = "Note about PDF printer drivers:" 54 | BeginProperty Font 55 | Name = "Segoe UI" 56 | Size = 10.2 57 | Charset = 0 58 | Weight = 400 59 | Underline = 0 'False 60 | Italic = 0 'False 61 | Strikethrough = 0 'False 62 | EndProperty 63 | Height = 372 64 | Left = 360 65 | TabIndex = 1 66 | Top = 240 67 | Width = 3732 68 | End 69 | End 70 | Attribute VB_Name = "frmPDFNote" 71 | Attribute VB_GlobalNameSpace = False 72 | Attribute VB_Creatable = False 73 | Attribute VB_PredeclaredId = True 74 | Attribute VB_Exposed = False 75 | Option Explicit 76 | 77 | Private Sub cmdOK_Click() 78 | Unload Me 79 | End Sub 80 | 81 | Private Sub Form_Load() 82 | Set Me.Icon = gIcon 83 | End Sub 84 | 85 | Private Sub Form_Unload(Cancel As Integer) 86 | If chkHide.Value = 1 Then 87 | SaveSetting App.Title, AppPath4Reg, "HidePDFNote", "1" 88 | End If 89 | End Sub 90 | -------------------------------------------------------------------------------- /source/frm/frmPDFNote.frx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/frm/frmPDFNote.frx -------------------------------------------------------------------------------- /source/frm/frmPreferences.frm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/frm/frmPreferences.frm -------------------------------------------------------------------------------- /source/frm/frmReportOptions.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmReportOptions 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select items" 5 | ClientHeight = 5160 6 | ClientLeft = 2796 7 | ClientTop = 2160 8 | ClientWidth = 4056 9 | ControlBox = 0 'False 10 | BeginProperty Font 11 | Name = "Segoe UI" 12 | Size = 9 13 | Charset = 0 14 | Weight = 400 15 | Underline = 0 'False 16 | Italic = 0 'False 17 | Strikethrough = 0 'False 18 | EndProperty 19 | LinkTopic = "Form1" 20 | LockControls = -1 'True 21 | MaxButton = 0 'False 22 | MinButton = 0 'False 23 | ScaleHeight = 5160 24 | ScaleWidth = 4056 25 | ShowInTaskbar = 0 'False 26 | Begin VB.CheckBox chkInfoEndNotes 27 | Caption = "End Notes" 28 | Height = 444 29 | Left = 1080 30 | TabIndex = 6 31 | Top = 2040 32 | Width = 2532 33 | End 34 | Begin VB.CheckBox chkInfoIntroduction 35 | Caption = "Introduction" 36 | Height = 444 37 | Left = 1080 38 | TabIndex = 5 39 | Top = 1680 40 | Width = 2532 41 | End 42 | Begin VB.CheckBox chkInfoReleaseDate 43 | Caption = "Release date" 44 | Height = 444 45 | Left = 1080 46 | TabIndex = 4 47 | Top = 1320 48 | Width = 2532 49 | End 50 | Begin VB.CheckBox chkInfoVersion 51 | Caption = "Version" 52 | Height = 444 53 | Left = 1080 54 | TabIndex = 3 55 | Top = 960 56 | Width = 2532 57 | End 58 | Begin VB.CheckBox chkInfoName 59 | Caption = "Name" 60 | Height = 444 61 | Left = 1080 62 | TabIndex = 2 63 | Top = 600 64 | Width = 2532 65 | End 66 | Begin VB.CommandButton cmdSelect 67 | Caption = "Select" 68 | Height = 350 69 | Index = 3 70 | Left = 2400 71 | TabIndex = 12 72 | Top = 3636 73 | UseMaskColor = -1 'True 74 | Width = 1092 75 | End 76 | Begin VB.CommandButton cmdSelect 77 | Caption = "Select" 78 | Height = 350 79 | Index = 2 80 | Left = 2400 81 | TabIndex = 10 82 | Top = 3156 83 | UseMaskColor = -1 'True 84 | Width = 1092 85 | End 86 | Begin VB.CommandButton cmdSelect 87 | Caption = "Select" 88 | Height = 350 89 | Index = 1 90 | Left = 2400 91 | TabIndex = 8 92 | Top = 2676 93 | UseMaskColor = -1 'True 94 | Width = 1092 95 | End 96 | Begin VB.CheckBox chkInfo 97 | Caption = "Component information" 98 | Height = 444 99 | Left = 720 100 | TabIndex = 1 101 | Top = 240 102 | Value = 2 'Grayed 103 | Width = 2532 104 | End 105 | Begin VB.CheckBox chkType 106 | Caption = "Constants" 107 | Height = 444 108 | Index = 3 109 | Left = 720 110 | TabIndex = 11 111 | Top = 3600 112 | Width = 2532 113 | End 114 | Begin VB.CheckBox chkType 115 | Caption = "Classes" 116 | Height = 444 117 | Index = 2 118 | Left = 720 119 | TabIndex = 9 120 | Top = 3120 121 | Width = 2532 122 | End 123 | Begin VB.CheckBox chkType 124 | Caption = "Controls" 125 | Height = 444 126 | Index = 1 127 | Left = 720 128 | TabIndex = 7 129 | Top = 2640 130 | Width = 2532 131 | End 132 | Begin VB.CommandButton cmdOK 133 | Caption = "OK" 134 | Default = -1 'True 135 | Height = 420 136 | Left = 2400 137 | TabIndex = 0 138 | Top = 4560 139 | UseMaskColor = -1 'True 140 | Width = 1092 141 | End 142 | End 143 | Attribute VB_Name = "frmReportOptions" 144 | Attribute VB_GlobalNameSpace = False 145 | Attribute VB_Creatable = False 146 | Attribute VB_PredeclaredId = True 147 | Attribute VB_Exposed = False 148 | Option Explicit 149 | 150 | Public InfoVersionAvailable As Boolean 151 | Public InfoReleaseDateAvailable As Boolean 152 | Public InfoIntroductionAvailable As Boolean 153 | Public InfoEndNotesAvailable As Boolean 154 | 155 | Private mUnselectedItems(3) As Variant 156 | Private mRec(3) As Recordset 157 | 158 | Private Sub chkInfo_Click() 159 | If chkInfo.Value = 1 Then 160 | chkInfoName.Value = 1 161 | End If 162 | chkInfoName.Enabled = (chkInfo.Value = 1) 163 | chkInfoVersion.Enabled = (chkInfo.Value = 1) And InfoVersionAvailable 164 | chkInfoReleaseDate.Enabled = (chkInfo.Value = 1) And InfoReleaseDateAvailable 165 | chkInfoIntroduction.Enabled = (chkInfo.Value = 1) And InfoIntroductionAvailable 166 | chkInfoEndNotes.Enabled = (chkInfo.Value = 1) And InfoEndNotesAvailable 167 | End Sub 168 | 169 | Private Sub chkInfoName_Click() 170 | If chkInfoName.Value = 0 Then 171 | chkInfo.Value = 0 172 | End If 173 | End Sub 174 | 175 | Private Sub cmdOK_Click() 176 | Dim c As Long 177 | 178 | For c = 1 To chkType.UBound 179 | If chkType(c).Value = 2 Then chkType(c).Value = 1 180 | Next 181 | Me.Hide 182 | End Sub 183 | 184 | Private Sub cmdSelect_Click(Index As Integer) 185 | Dim iList() As String 186 | Dim c As Long 187 | Dim iStr As String 188 | Dim iSel As Boolean 189 | 190 | iList = mUnselectedItems(Index) 191 | mRec(Index).MoveFirst 192 | Do Until mRec(Index).EOF 193 | frmSelectItems.lstItems.AddItem mRec(Index)!Name 194 | If Not IsInList(iList, mRec(Index)!Name) Then 195 | frmSelectItems.lstItems.Selected(frmSelectItems.lstItems.NewIndex) = True 196 | End If 197 | mRec(Index).MoveNext 198 | Loop 199 | frmSelectItems.lstItems.TopIndex = 0 200 | frmSelectItems.lstItems.ListIndex = -1 201 | frmSelectItems.Show vbModal 202 | If frmSelectItems.OKPressed Then 203 | iStr = "" 204 | For c = 0 To frmSelectItems.lstItems.ListCount - 1 205 | If Not frmSelectItems.lstItems.Selected(c) Then 206 | If iStr <> "" Then iStr = iStr & "|" 207 | iStr = iStr & frmSelectItems.lstItems.List(c) 208 | Else 209 | iSel = True 210 | End If 211 | Next 212 | If iSel Then 213 | If iStr = "" Then 214 | chkType(Index).Value = 1 215 | Else 216 | chkType(Index).Value = 2 217 | End If 218 | mUnselectedItems(Index) = Split(iStr, "|") 219 | Else 220 | chkType(Index).Value = 0 221 | mUnselectedItems(Index) = Split("") 222 | End If 223 | Unload frmSelectItems 224 | End If 225 | Set frmSelectItems = Nothing 226 | End Sub 227 | 228 | Public Sub SetRec(nIndex As Long, nRec As Recordset) 229 | Set mRec(nIndex) = nRec 230 | End Sub 231 | 232 | Public Property Let UnselectedItems(nIndex As Long, nList As String) 233 | mUnselectedItems(nIndex) = Split(nList, "|") 234 | End Property 235 | 236 | Public Property Get UnselectedItems(nIndex As Long) As String 237 | UnselectedItems = Join(mUnselectedItems(nIndex), "|") 238 | End Property 239 | 240 | Public Function IsItemSelected(nIndex As Long, nItemName As String) As Boolean 241 | Dim iList() As String 242 | 243 | If chkType(nIndex).Value Then 244 | iList = mUnselectedItems(nIndex) 245 | IsItemSelected = Not IsInList(iList, nItemName) 246 | End If 247 | End Function 248 | 249 | Private Sub Form_Load() 250 | Set Me.Icon = gIcon 251 | End Sub 252 | 253 | Public Property Get GeneralInfoSettingsStr() As String 254 | GeneralInfoSettingsStr = chkInfoVersion.Value & "|" 255 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoReleaseDate.Value & "|" 256 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoIntroduction.Value & "|" 257 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoEndNotes.Value 258 | End Property 259 | 260 | Public Property Let GeneralInfoSettingsStr(nStr As String) 261 | Dim iStrs() As String 262 | 263 | chkInfoName.Value = 1 264 | iStrs = Split(nStr, "|") 265 | If UBound(iStrs) > 2 Then 266 | chkInfoVersion.Value = Val(iStrs(0)) 267 | chkInfoReleaseDate.Value = Val(iStrs(1)) 268 | chkInfoIntroduction.Value = Val(iStrs(2)) 269 | chkInfoEndNotes.Value = Val(iStrs(3)) 270 | End If 271 | End Property 272 | 273 | -------------------------------------------------------------------------------- /source/frm/frmReportSelection.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmReportSelection 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select items" 5 | ClientHeight = 5244 6 | ClientLeft = 2796 7 | ClientTop = 2160 8 | ClientWidth = 4056 9 | ControlBox = 0 'False 10 | BeginProperty Font 11 | Name = "Segoe UI" 12 | Size = 9 13 | Charset = 0 14 | Weight = 400 15 | Underline = 0 'False 16 | Italic = 0 'False 17 | Strikethrough = 0 'False 18 | EndProperty 19 | LinkTopic = "Form1" 20 | LockControls = -1 'True 21 | MaxButton = 0 'False 22 | MinButton = 0 'False 23 | ScaleHeight = 5244 24 | ScaleWidth = 4056 25 | ShowInTaskbar = 0 'False 26 | Begin VB.CheckBox chkInfoEndNotes 27 | Caption = "End Notes" 28 | Height = 444 29 | Left = 1080 30 | TabIndex = 6 31 | Top = 2040 32 | Width = 2532 33 | End 34 | Begin VB.CheckBox chkInfoIntroduction 35 | Caption = "Introduction" 36 | Height = 444 37 | Left = 1080 38 | TabIndex = 5 39 | Top = 1680 40 | Width = 2532 41 | End 42 | Begin VB.CheckBox chkInfoReleaseDate 43 | Caption = "Release date" 44 | Height = 444 45 | Left = 1080 46 | TabIndex = 4 47 | Top = 1320 48 | Width = 2532 49 | End 50 | Begin VB.CheckBox chkInfoVersion 51 | Caption = "Version" 52 | Height = 444 53 | Left = 1080 54 | TabIndex = 3 55 | Top = 960 56 | Width = 2532 57 | End 58 | Begin VB.CheckBox chkInfoName 59 | Caption = "Name" 60 | Height = 444 61 | Left = 1080 62 | TabIndex = 2 63 | Top = 600 64 | Width = 2532 65 | End 66 | Begin VB.CommandButton cmdSelect 67 | Caption = "Select" 68 | Height = 350 69 | Index = 3 70 | Left = 2400 71 | TabIndex = 12 72 | Top = 3636 73 | UseMaskColor = -1 'True 74 | Width = 1092 75 | End 76 | Begin VB.CommandButton cmdSelect 77 | Caption = "Select" 78 | Height = 350 79 | Index = 2 80 | Left = 2400 81 | TabIndex = 10 82 | Top = 3156 83 | UseMaskColor = -1 'True 84 | Width = 1092 85 | End 86 | Begin VB.CommandButton cmdSelect 87 | Caption = "Select" 88 | Height = 350 89 | Index = 1 90 | Left = 2400 91 | TabIndex = 8 92 | Top = 2676 93 | UseMaskColor = -1 'True 94 | Width = 1092 95 | End 96 | Begin VB.CheckBox chkInfo 97 | Caption = "Component information" 98 | Height = 444 99 | Left = 720 100 | TabIndex = 1 101 | Top = 240 102 | Value = 2 'Grayed 103 | Width = 2532 104 | End 105 | Begin VB.CheckBox chkType 106 | Caption = "Constants" 107 | Height = 444 108 | Index = 3 109 | Left = 720 110 | TabIndex = 11 111 | Top = 3600 112 | Width = 2532 113 | End 114 | Begin VB.CheckBox chkType 115 | Caption = "Classes" 116 | Height = 444 117 | Index = 2 118 | Left = 720 119 | TabIndex = 9 120 | Top = 3120 121 | Width = 2532 122 | End 123 | Begin VB.CheckBox chkType 124 | Caption = "Controls" 125 | Height = 444 126 | Index = 1 127 | Left = 720 128 | TabIndex = 7 129 | Top = 2640 130 | Width = 2532 131 | End 132 | Begin VB.CommandButton cmdOK 133 | Caption = "OK" 134 | Default = -1 'True 135 | Height = 420 136 | Left = 2400 137 | TabIndex = 0 138 | Top = 4560 139 | UseMaskColor = -1 'True 140 | Width = 1092 141 | End 142 | End 143 | Attribute VB_Name = "frmReportSelection" 144 | Attribute VB_GlobalNameSpace = False 145 | Attribute VB_Creatable = False 146 | Attribute VB_PredeclaredId = True 147 | Attribute VB_Exposed = False 148 | Option Explicit 149 | 150 | Public InfoVersionAvailable As Boolean 151 | Public InfoReleaseDateAvailable As Boolean 152 | Public InfoIntroductionAvailable As Boolean 153 | Public InfoEndNotesAvailable As Boolean 154 | 155 | Private mUnselectedItems(3) As Variant 156 | Private mRec(3) As Recordset 157 | 158 | Private Sub chkInfo_Click() 159 | If chkInfo.Value = 1 Then 160 | chkInfoName.Value = 1 161 | End If 162 | chkInfoName.Enabled = (chkInfo.Value = 1) 163 | chkInfoVersion.Enabled = (chkInfo.Value = 1) And InfoVersionAvailable 164 | chkInfoReleaseDate.Enabled = (chkInfo.Value = 1) And InfoReleaseDateAvailable 165 | chkInfoIntroduction.Enabled = (chkInfo.Value = 1) And InfoIntroductionAvailable 166 | chkInfoEndNotes.Enabled = (chkInfo.Value = 1) And InfoEndNotesAvailable 167 | End Sub 168 | 169 | Private Sub chkInfoName_Click() 170 | If chkInfoName.Value = 0 Then 171 | chkInfo.Value = 0 172 | End If 173 | End Sub 174 | 175 | Private Sub cmdOK_Click() 176 | Dim c As Long 177 | 178 | For c = 1 To chkType.UBound 179 | If chkType(c).Value = 2 Then chkType(c).Value = 1 180 | Next 181 | Me.Hide 182 | End Sub 183 | 184 | Private Sub cmdSelect_Click(Index As Integer) 185 | Dim iList() As String 186 | Dim c As Long 187 | Dim iStr As String 188 | Dim iSel As Boolean 189 | 190 | iList = mUnselectedItems(Index) 191 | mRec(Index).MoveFirst 192 | Do Until mRec(Index).EOF 193 | frmSelectItems.lstItems.AddItem mRec(Index)!Name 194 | If Not IsInList(iList, mRec(Index)!Name) Then 195 | frmSelectItems.lstItems.Selected(frmSelectItems.lstItems.NewIndex) = True 196 | End If 197 | mRec(Index).MoveNext 198 | Loop 199 | frmSelectItems.lstItems.TopIndex = 0 200 | frmSelectItems.lstItems.ListIndex = -1 201 | frmSelectItems.Show vbModal 202 | If frmSelectItems.OKPressed Then 203 | iStr = "" 204 | For c = 0 To frmSelectItems.lstItems.ListCount - 1 205 | If Not frmSelectItems.lstItems.Selected(c) Then 206 | If iStr <> "" Then iStr = iStr & "|" 207 | iStr = iStr & frmSelectItems.lstItems.List(c) 208 | Else 209 | iSel = True 210 | End If 211 | Next 212 | If iSel Then 213 | If iStr = "" Then 214 | chkType(Index).Value = 1 215 | Else 216 | chkType(Index).Value = 2 217 | End If 218 | mUnselectedItems(Index) = Split(iStr, "|") 219 | Else 220 | chkType(Index).Value = 0 221 | mUnselectedItems(Index) = Split("") 222 | End If 223 | Unload frmSelectItems 224 | End If 225 | Set frmSelectItems = Nothing 226 | End Sub 227 | 228 | Public Sub SetRec(nIndex As Long, nRec As Recordset) 229 | Set mRec(nIndex) = nRec 230 | End Sub 231 | 232 | Public Property Let UnselectedItems(nIndex As Long, nList As String) 233 | mUnselectedItems(nIndex) = Split(nList, "|") 234 | End Property 235 | 236 | Public Property Get UnselectedItems(nIndex As Long) As String 237 | UnselectedItems = Join(mUnselectedItems(nIndex), "|") 238 | End Property 239 | 240 | Public Function IsItemSelected(nIndex As Long, nItemName As String) As Boolean 241 | Dim iList() As String 242 | 243 | If chkType(nIndex).Value Then 244 | iList = mUnselectedItems(nIndex) 245 | IsItemSelected = Not IsInList(iList, nItemName) 246 | End If 247 | End Function 248 | 249 | Private Sub Form_Load() 250 | Set Me.Icon = gIcon 251 | End Sub 252 | 253 | Public Property Get GeneralInfoSettingsStr() As String 254 | GeneralInfoSettingsStr = chkInfoVersion.Value & "|" 255 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoReleaseDate.Value & "|" 256 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoIntroduction.Value & "|" 257 | GeneralInfoSettingsStr = GeneralInfoSettingsStr & chkInfoEndNotes.Value 258 | End Property 259 | 260 | Public Property Let GeneralInfoSettingsStr(nStr As String) 261 | Dim iStrs() As String 262 | 263 | chkInfoName.Value = 1 264 | iStrs = Split(nStr, "|") 265 | If UBound(iStrs) > 2 Then 266 | chkInfoVersion.Value = Val(iStrs(0)) 267 | chkInfoReleaseDate.Value = Val(iStrs(1)) 268 | chkInfoIntroduction.Value = Val(iStrs(2)) 269 | chkInfoEndNotes.Value = Val(iStrs(3)) 270 | End If 271 | End Property 272 | 273 | -------------------------------------------------------------------------------- /source/frm/frmReportingOptions.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmReportingOptions 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Reporting Options" 5 | ClientHeight = 6408 6 | ClientLeft = 2820 7 | ClientTop = 2160 8 | ClientWidth = 4416 9 | ControlBox = 0 'False 10 | BeginProperty Font 11 | Name = "Segoe UI" 12 | Size = 9 13 | Charset = 0 14 | Weight = 400 15 | Underline = 0 'False 16 | Italic = 0 'False 17 | Strikethrough = 0 'False 18 | EndProperty 19 | LinkTopic = "Form1" 20 | LockControls = -1 'True 21 | MaxButton = 0 'False 22 | MinButton = 0 'False 23 | ScaleHeight = 6408 24 | ScaleWidth = 4416 25 | ShowInTaskbar = 0 'False 26 | StartUpPosition = 1 'CenterOwner 27 | Begin VB.Frame Frame2 28 | Caption = "Print:" 29 | Height = 1352 30 | Left = 192 31 | TabIndex = 8 32 | Top = 4056 33 | Width = 3972 34 | Begin VB.OptionButton optPrint 35 | Caption = "One item per page" 36 | Height = 300 37 | Index = 1 38 | Left = 264 39 | TabIndex = 10 40 | Top = 816 41 | Width = 3492 42 | End 43 | Begin VB.OptionButton optPrint 44 | Caption = "Contiguous" 45 | Height = 300 46 | Index = 0 47 | Left = 264 48 | TabIndex = 9 49 | Top = 384 50 | Value = -1 'True 51 | Width = 3492 52 | End 53 | End 54 | Begin VB.Frame Frame1 55 | Caption = "HTML:" 56 | Height = 3684 57 | Left = 192 58 | TabIndex = 1 59 | Top = 192 60 | Width = 3972 61 | Begin VB.CheckBox chkReplaceCSSFile 62 | Caption = "Replace existent style file" 63 | Enabled = 0 'False 64 | Height = 396 65 | Left = 264 66 | TabIndex = 6 67 | Top = 2232 68 | Width = 3228 69 | End 70 | Begin VB.CommandButton cmdConfigHTML 71 | Caption = "Configure HTML texts" 72 | Height = 420 73 | Left = 264 74 | TabIndex = 7 75 | Top = 2904 76 | UseMaskColor = -1 'True 77 | Width = 2092 78 | End 79 | Begin VB.CheckBox chkExternalCSS 80 | Caption = "Stylesheet in external file (styles.css)" 81 | Height = 396 82 | Left = 264 83 | TabIndex = 5 84 | Top = 1800 85 | Width = 3228 86 | End 87 | Begin VB.OptionButton optHTML 88 | Caption = "One page per Property/Method/Event" 89 | Height = 300 90 | Index = 2 91 | Left = 264 92 | TabIndex = 4 93 | Top = 1296 94 | Width = 3492 95 | End 96 | Begin VB.OptionButton optHTML 97 | Caption = "One page per Control/Class" 98 | Height = 300 99 | Index = 1 100 | Left = 264 101 | TabIndex = 3 102 | Top = 864 103 | Width = 3492 104 | End 105 | Begin VB.OptionButton optHTML 106 | Caption = "One page for all" 107 | Height = 300 108 | Index = 0 109 | Left = 264 110 | TabIndex = 2 111 | Top = 432 112 | Value = -1 'True 113 | Width = 3492 114 | End 115 | End 116 | Begin VB.CommandButton cmdOK 117 | Caption = "OK" 118 | Default = -1 'True 119 | Height = 420 120 | Left = 3048 121 | TabIndex = 0 122 | Top = 5736 123 | UseMaskColor = -1 'True 124 | Width = 1092 125 | End 126 | Begin VB.Label Label1 127 | Alignment = 2 'Center 128 | Caption = "These settings are stored per component database" 129 | ForeColor = &H00FF0000& 130 | Height = 516 131 | Left = 240 132 | TabIndex = 11 133 | Top = 5566 134 | Width = 2464 135 | End 136 | End 137 | Attribute VB_Name = "frmReportingOptions" 138 | Attribute VB_GlobalNameSpace = False 139 | Attribute VB_Creatable = False 140 | Attribute VB_PredeclaredId = True 141 | Attribute VB_Exposed = False 142 | Option Explicit 143 | 144 | Public HTML_Mode As Long 145 | Public Print_Mode As Long 146 | Public ExternalCSS As Long 147 | Public ReplaceCSSFile As Long 148 | 149 | Public HTML_HeadSection As String 150 | Public HTML_StyleSheet As String 151 | Public HTML_PageHeaderMP As String 152 | Public HTML_PageHeaderOP As String 153 | Public HTML_PageFooter As String 154 | 155 | Private Sub cmdOK_Click() 156 | Unload Me 157 | End Sub 158 | 159 | Private Sub chkExternalCSS_Click() 160 | ExternalCSS = chkExternalCSS.Value 161 | chkReplaceCSSFile.Enabled = ExternalCSS 162 | End Sub 163 | 164 | Private Sub chkReplaceCSSFile_Click() 165 | ReplaceCSSFile = chkReplaceCSSFile.Value 166 | End Sub 167 | 168 | Private Sub cmdConfigHTML_Click() 169 | frmConfigureHTML.HTML_HeadSection = HTML_HeadSection 170 | frmConfigureHTML.HTML_StyleSheet = HTML_StyleSheet 171 | frmConfigureHTML.HTML_PageHeaderMP = HTML_PageHeaderMP 172 | frmConfigureHTML.HTML_PageHeaderOP = HTML_PageHeaderOP 173 | frmConfigureHTML.HTML_PageFooter = HTML_PageFooter 174 | frmConfigureHTML.Show vbModal 175 | If frmConfigureHTML.OKPressed Then 176 | HTML_HeadSection = frmConfigureHTML.HTML_HeadSection 177 | HTML_StyleSheet = frmConfigureHTML.HTML_StyleSheet 178 | HTML_PageHeaderMP = frmConfigureHTML.HTML_PageHeaderMP 179 | HTML_PageHeaderOP = frmConfigureHTML.HTML_PageHeaderOP 180 | HTML_PageFooter = frmConfigureHTML.HTML_PageFooter 181 | End If 182 | Set frmConfigureHTML = Nothing 183 | End Sub 184 | 185 | Private Sub Form_Load() 186 | Set Me.Icon = gIcon 187 | End Sub 188 | 189 | Private Sub optHTML_Click(Index As Integer) 190 | HTML_Mode = Index 191 | End Sub 192 | 193 | Private Sub optPrint_Click(Index As Integer) 194 | Print_Mode = Index 195 | End Sub 196 | -------------------------------------------------------------------------------- /source/frm/frmSelectComponentDB.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmSelectComponentDB 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Component databases" 5 | ClientHeight = 5376 6 | ClientLeft = 5940 7 | ClientTop = 2052 8 | ClientWidth = 5520 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 5376 23 | ScaleWidth = 5520 24 | ShowInTaskbar = 0 'False 25 | Begin VB.CommandButton cmdCancel 26 | Cancel = -1 'True 27 | Caption = "Cancel" 28 | Height = 420 29 | Left = 4096 30 | TabIndex = 0 31 | Top = 4752 32 | UseMaskColor = -1 'True 33 | Width = 1092 34 | End 35 | Begin VB.CommandButton cmdOK 36 | Caption = "OK" 37 | Default = -1 'True 38 | Height = 420 39 | Left = 2608 40 | TabIndex = 1 41 | Top = 4752 42 | UseMaskColor = -1 'True 43 | Width = 1092 44 | End 45 | Begin VB.ListBox lstComponentsDB 46 | Appearance = 0 'Flat 47 | BeginProperty Font 48 | Name = "Segoe UI" 49 | Size = 10.2 50 | Charset = 0 51 | Weight = 400 52 | Underline = 0 'False 53 | Italic = 0 'False 54 | Strikethrough = 0 'False 55 | EndProperty 56 | Height = 4440 57 | Left = 72 58 | TabIndex = 2 59 | Top = 96 60 | Width = 5380 61 | End 62 | End 63 | Attribute VB_Name = "frmSelectComponentDB" 64 | Attribute VB_GlobalNameSpace = False 65 | Attribute VB_Creatable = False 66 | Attribute VB_PredeclaredId = True 67 | Attribute VB_Exposed = False 68 | Option Explicit 69 | 70 | Public DBPath As String 71 | Private mDBPath As String 72 | Private mPaths() As String 73 | 74 | Private Sub cmdCancel_Click() 75 | Unload Me 76 | End Sub 77 | 78 | Private Sub cmdOK_Click() 79 | DBPath = mDBPath 80 | Unload Me 81 | End Sub 82 | 83 | Private Sub Form_Load() 84 | Dim iFile As String 85 | Dim iDb As Database 86 | Dim iGi As Recordset 87 | 88 | Set Me.Icon = gIcon 89 | If Not FolderExists(App_Path & "\databases") Then 90 | MsgBox "Database folders does not exist", vbCritical 91 | Unload Me 92 | Exit Sub 93 | End If 94 | mPaths = Split("") 95 | iFile = Dir(App_Path & "\databases\*.mdb") 96 | On Error GoTo FileErr 97 | Do Until iFile = "" 98 | Set iDb = DBEngine.OpenDatabase(App_Path & "\databases\" & iFile) 99 | Set iGi = iDb.OpenRecordset("General_Information") 100 | iGi.Index = "Name" 101 | iGi.Seek "=", "ComponentName" 102 | If Not iGi.NoMatch Then 103 | ReDim Preserve mPaths(UBound(mPaths) + 1) 104 | mPaths(UBound(mPaths)) = App_Path & "\databases\" & iFile 105 | lstComponentsDB.AddItem iGi!Value & " (" & iFile & ")" 106 | End If 107 | iDb.Close 108 | NextFile: 109 | iFile = Dir 110 | Loop 111 | Exit Sub 112 | 113 | FileErr: 114 | Resume NextFile 115 | End Sub 116 | 117 | Private Sub lstComponentsDB_Click() 118 | If lstComponentsDB.ListIndex > -1 Then 119 | mDBPath = mPaths(lstComponentsDB.ListIndex) 120 | End If 121 | End Sub 122 | 123 | Private Sub lstComponentsDB_DblClick() 124 | If lstComponentsDB.ListCount > 0 Then 125 | If lstComponentsDB.ListIndex = -1 Then 126 | lstComponentsDB.ListIndex = lstComponentsDB.ListCount - 1 127 | End If 128 | End If 129 | cmdOK.Value = 1 130 | End Sub 131 | -------------------------------------------------------------------------------- /source/frm/frmSelectItems.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmSelectItems 3 | Caption = "Selection" 4 | ClientHeight = 5244 5 | ClientLeft = 6348 6 | ClientTop = 2676 7 | ClientWidth = 5496 8 | BeginProperty Font 9 | Name = "Segoe UI" 10 | Size = 9 11 | Charset = 0 12 | Weight = 400 13 | Underline = 0 'False 14 | Italic = 0 'False 15 | Strikethrough = 0 'False 16 | EndProperty 17 | LinkTopic = "Form1" 18 | LockControls = -1 'True 19 | ScaleHeight = 5244 20 | ScaleWidth = 5496 21 | Begin VB.CommandButton cmdDeselectAll 22 | Caption = "Deselect all" 23 | Height = 420 24 | Left = 4320 25 | TabIndex = 4 26 | Top = 720 27 | UseMaskColor = -1 'True 28 | Width = 1092 29 | End 30 | Begin VB.CommandButton cmdSelectAll 31 | Caption = "Select all" 32 | Height = 420 33 | Left = 4320 34 | TabIndex = 3 35 | Top = 240 36 | UseMaskColor = -1 'True 37 | Width = 1092 38 | End 39 | Begin VB.CommandButton cmdCancel 40 | Caption = "Cancel" 41 | Height = 420 42 | Left = 3888 43 | TabIndex = 1 44 | Top = 4560 45 | UseMaskColor = -1 'True 46 | Width = 1092 47 | End 48 | Begin VB.CommandButton cmdOK 49 | Caption = "OK" 50 | Default = -1 'True 51 | Height = 420 52 | Left = 2400 53 | TabIndex = 0 54 | Top = 4560 55 | UseMaskColor = -1 'True 56 | Width = 1092 57 | End 58 | Begin VB.ListBox lstItems 59 | Appearance = 0 'Flat 60 | Height = 4248 61 | Left = 0 62 | Style = 1 'Checkbox 63 | TabIndex = 2 64 | Top = 0 65 | Width = 4212 66 | End 67 | End 68 | Attribute VB_Name = "frmSelectItems" 69 | Attribute VB_GlobalNameSpace = False 70 | Attribute VB_Creatable = False 71 | Attribute VB_PredeclaredId = True 72 | Attribute VB_Exposed = False 73 | Option Explicit 74 | 75 | Public OKPressed As Boolean 76 | 77 | Private Sub cmdCancel_Click() 78 | Unload Me 79 | End Sub 80 | 81 | Private Sub cmdOK_Click() 82 | OKPressed = True 83 | Me.Hide 84 | End Sub 85 | 86 | Private Sub cmdSelectAll_Click() 87 | Dim c As Long 88 | 89 | For c = 0 To lstItems.ListCount - 1 90 | lstItems.Selected(c) = True 91 | Next 92 | End Sub 93 | 94 | Private Sub cmdDeselectAll_Click() 95 | Dim c As Long 96 | 97 | For c = 0 To lstItems.ListCount - 1 98 | lstItems.Selected(c) = False 99 | Next 100 | End Sub 101 | 102 | Private Sub Form_Load() 103 | Set Me.Icon = gIcon 104 | End Sub 105 | -------------------------------------------------------------------------------- /source/frm/frmSelectMemberDefinition.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmSelectMemberDefinition 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select member definition" 5 | ClientHeight = 6228 6 | ClientLeft = 1932 7 | ClientTop = 2160 8 | ClientWidth = 7128 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 6228 23 | ScaleWidth = 7128 24 | ShowInTaskbar = 0 'False 25 | Begin VB.ComboBox cboDisplay 26 | Height = 336 27 | ItemData = "frmSelectMemberDefinition.frx":0000 28 | Left = 960 29 | List = "frmSelectMemberDefinition.frx":000D 30 | Style = 2 'Dropdown List 31 | TabIndex = 4 32 | Top = 1580 33 | Width = 3432 34 | End 35 | Begin VB.ListBox lstMembers 36 | Height = 1248 37 | Left = 0 38 | TabIndex = 2 39 | Top = 0 40 | Width = 7112 41 | End 42 | Begin VB.TextBox txtDetails 43 | Height = 3132 44 | Left = 0 45 | Locked = -1 'True 46 | MultiLine = -1 'True 47 | ScrollBars = 2 'Vertical 48 | TabIndex = 5 49 | Top = 2050 50 | Width = 7112 51 | End 52 | Begin VB.CommandButton cmdOK 53 | Caption = "OK" 54 | Height = 420 55 | Left = 4160 56 | TabIndex = 1 57 | Top = 5568 58 | UseMaskColor = -1 'True 59 | Width = 1092 60 | End 61 | Begin VB.CommandButton cmdCancel 62 | Cancel = -1 'True 63 | Caption = "Cancel" 64 | Height = 420 65 | Left = 5648 66 | TabIndex = 0 67 | Top = 5568 68 | UseMaskColor = -1 'True 69 | Width = 1092 70 | End 71 | Begin VB.Label Label1 72 | Caption = "Display:" 73 | Height = 252 74 | Left = 180 75 | TabIndex = 3 76 | Top = 1640 77 | Width = 732 78 | End 79 | Begin VB.Label lblNote 80 | BeginProperty Font 81 | Name = "Segoe UI" 82 | Size = 9 83 | Charset = 0 84 | Weight = 700 85 | Underline = 0 'False 86 | Italic = 0 'False 87 | Strikethrough = 0 'False 88 | EndProperty 89 | ForeColor = &H000000FF& 90 | Height = 732 91 | Left = 120 92 | TabIndex = 6 93 | Top = 5328 94 | Width = 3876 95 | WordWrap = -1 'True 96 | End 97 | End 98 | Attribute VB_Name = "frmSelectMemberDefinition" 99 | Attribute VB_GlobalNameSpace = False 100 | Attribute VB_Creatable = False 101 | Attribute VB_PredeclaredId = True 102 | Attribute VB_Exposed = False 103 | Option Explicit 104 | 105 | Public OKPressed As Boolean 106 | Public MemberID As Long 107 | Private mParams() As String 108 | Private mLongDesc() As String 109 | Private mShortDesc() As String 110 | Private mOrigParams As String 111 | Private mOrigShortDesc As String 112 | Public ParamsInfo As String 113 | Public ShortDescription As String 114 | 115 | Private Sub cboDisplay_Click() 116 | If lstMembers.ListIndex > -1 Then 117 | Select Case cboDisplay.ListIndex 118 | Case 0 ' Params info 119 | txtDetails.Text = mParams(lstMembers.ListIndex) 120 | Case 1 ' Long description 121 | txtDetails.Text = mLongDesc(lstMembers.ListIndex) 122 | Case 2 ' Short description 123 | txtDetails.Text = mShortDesc(lstMembers.ListIndex) 124 | End Select 125 | End If 126 | End Sub 127 | 128 | Private Sub cmdCancel_Click() 129 | Unload Me 130 | End Sub 131 | 132 | Private Sub cmdOK_Click() 133 | OKPressed = True 134 | Unload Me 135 | End Sub 136 | 137 | Public Sub LoadList(nDB As Database, nTable As String, nMemberName As String, nMemberType As String, nMemberIDNotToLoad As Long, nOrigParams As String, nOrigShortDesc As String) 138 | Dim iRec As Recordset 139 | 140 | Set iRec = nDB.OpenRecordset("SELECT * FROM " & nTable & " WHERE (Name = '" & nMemberName & "') AND (" & nMemberType & "_ID <> " & CStr(nMemberIDNotToLoad) & ") AND (Auxiliary_Field = 1)") 141 | If iRec.RecordCount > 0 Then 142 | iRec.MoveLast 143 | ReDim mParams(iRec.RecordCount - 1) 144 | ReDim mLongDesc(iRec.RecordCount - 1) 145 | ReDim mShortDesc(iRec.RecordCount - 1) 146 | iRec.MoveFirst 147 | Do Until iRec.EOF 148 | lstMembers.AddItem iRec!Name 149 | lstMembers.ItemData(lstMembers.NewIndex) = iRec.Fields(nMemberType & "_ID").Value 150 | mParams(lstMembers.NewIndex) = iRec!Params_Info 151 | mLongDesc(lstMembers.NewIndex) = iRec!Long_Description 152 | mShortDesc(lstMembers.NewIndex) = iRec!Short_Description 153 | iRec.MoveNext 154 | Loop 155 | End If 156 | cboDisplay.ListIndex = 0 157 | mOrigParams = nOrigParams 158 | mOrigShortDesc = nOrigShortDesc 159 | End Sub 160 | 161 | Private Sub Form_Load() 162 | Set Me.Icon = gIcon 163 | End Sub 164 | 165 | Private Sub lstMembers_Click() 166 | cboDisplay_Click 167 | If (mParams(lstMembers.ListIndex) <> mOrigParams) And (mShortDesc(lstMembers.ListIndex) <> mOrigShortDesc) Then 168 | lblNote.Caption = "Params info and short description are different from originals" 169 | ElseIf (mParams(lstMembers.ListIndex) <> mOrigParams) Then 170 | lblNote.Caption = "Params info is different from original" 171 | ElseIf (mShortDesc(lstMembers.ListIndex) <> mOrigShortDesc) Then 172 | lblNote.Caption = "Short description is different from original" 173 | Else 174 | lblNote.Caption = "" 175 | End If 176 | MemberID = lstMembers.ItemData(lstMembers.ListIndex) 177 | ParamsInfo = mParams(lstMembers.ListIndex) 178 | ShortDescription = mShortDesc(lstMembers.ListIndex) 179 | End Sub 180 | -------------------------------------------------------------------------------- /source/frm/frmSelectMemberDefinition.frx: -------------------------------------------------------------------------------- 1 | 000Parameter infoLong descriptionShort description -------------------------------------------------------------------------------- /source/frm/frmSelectOrpahnMember.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmSelectOrpahnMember 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select orphan member" 5 | ClientHeight = 6120 6 | ClientLeft = 1932 7 | ClientTop = 2160 8 | ClientWidth = 5124 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 6120 23 | ScaleWidth = 5124 24 | ShowInTaskbar = 0 'False 25 | Begin VB.CommandButton cmdCancel 26 | Cancel = -1 'True 27 | Caption = "Cancel" 28 | Height = 420 29 | Left = 3648 30 | TabIndex = 0 31 | Top = 5448 32 | UseMaskColor = -1 'True 33 | Width = 1092 34 | End 35 | Begin VB.CommandButton cmdOK 36 | Caption = "OK" 37 | Default = -1 'True 38 | Height = 420 39 | Left = 2160 40 | TabIndex = 1 41 | Top = 5448 42 | UseMaskColor = -1 'True 43 | Width = 1092 44 | End 45 | Begin VB.TextBox txtDetails 46 | Height = 2352 47 | Left = 0 48 | Locked = -1 'True 49 | MultiLine = -1 'True 50 | ScrollBars = 2 'Vertical 51 | TabIndex = 4 52 | Top = 2820 53 | Width = 5112 54 | End 55 | Begin VB.ListBox lstMembers 56 | Height = 2448 57 | Left = 0 58 | TabIndex = 2 59 | Top = 0 60 | Width = 5112 61 | End 62 | Begin VB.Label Label2 63 | Alignment = 2 'Center 64 | Caption = "This will replace the current text" 65 | Height = 552 66 | Left = 180 67 | TabIndex = 5 68 | Top = 5280 69 | Width = 1692 70 | WordWrap = -1 'True 71 | End 72 | Begin VB.Label Label1 73 | Caption = "Text:" 74 | Height = 252 75 | Left = 120 76 | TabIndex = 3 77 | Top = 2520 78 | Width = 2652 79 | End 80 | End 81 | Attribute VB_Name = "frmSelectOrpahnMember" 82 | Attribute VB_GlobalNameSpace = False 83 | Attribute VB_Creatable = False 84 | Attribute VB_PredeclaredId = True 85 | Attribute VB_Exposed = False 86 | Option Explicit 87 | 88 | Public OKPressed As Boolean 89 | Public Text As String 90 | Private mDetails() As String 91 | 92 | Private Sub cmdCancel_Click() 93 | Unload Me 94 | End Sub 95 | 96 | Private Sub cmdOK_Click() 97 | If lstMembers.ListIndex > -1 Then 98 | OKPressed = True 99 | End If 100 | Unload Me 101 | End Sub 102 | 103 | Private Sub Form_Load() 104 | Set Me.Icon = gIcon 105 | End Sub 106 | 107 | Private Sub lstMembers_Click() 108 | txtDetails.Text = mDetails(lstMembers.ListIndex) 109 | End Sub 110 | 111 | Private Sub txtDetails_Change() 112 | Text = txtDetails.Text 113 | End Sub 114 | 115 | Public Sub LoadList(nDB As Database, nTable As String) 116 | Dim iRec As Recordset 117 | 118 | Set iRec = nDB.OpenRecordset("SELECT * FROM " & nTable & " WHERE (Auxiliary_Field = 0)") 119 | If iRec.RecordCount > 0 Then 120 | iRec.MoveLast 121 | ReDim mDetails(iRec.RecordCount - 1) 122 | iRec.MoveFirst 123 | Do Until iRec.EOF 124 | lstMembers.AddItem iRec!Name 125 | mDetails(lstMembers.NewIndex) = iRec!Long_Description 126 | iRec.MoveNext 127 | Loop 128 | End If 129 | End Sub 130 | -------------------------------------------------------------------------------- /source/frm/frmSelectPrinter.frm: -------------------------------------------------------------------------------- 1 | VERSION 5.00 2 | Begin VB.Form frmSelectPrinter 3 | BorderStyle = 3 'Fixed Dialog 4 | Caption = "Select Printer" 5 | ClientHeight = 1704 6 | ClientLeft = 2820 7 | ClientTop = 2160 8 | ClientWidth = 4884 9 | BeginProperty Font 10 | Name = "Segoe UI" 11 | Size = 9 12 | Charset = 0 13 | Weight = 400 14 | Underline = 0 'False 15 | Italic = 0 'False 16 | Strikethrough = 0 'False 17 | EndProperty 18 | LinkTopic = "Form1" 19 | LockControls = -1 'True 20 | MaxButton = 0 'False 21 | MinButton = 0 'False 22 | ScaleHeight = 1704 23 | ScaleWidth = 4884 24 | ShowInTaskbar = 0 'False 25 | Begin VB.CommandButton cmdOK 26 | Caption = "OK" 27 | Default = -1 'True 28 | Height = 420 29 | Left = 1944 30 | TabIndex = 0 31 | Top = 1032 32 | UseMaskColor = -1 'True 33 | Width = 1092 34 | End 35 | Begin VB.CommandButton cmdCancel 36 | Cancel = -1 'True 37 | Caption = "Cancel" 38 | Height = 420 39 | Left = 3432 40 | TabIndex = 1 41 | Top = 1032 42 | UseMaskColor = -1 'True 43 | Width = 1092 44 | End 45 | Begin VB.ComboBox cboPrinters 46 | Height = 336 47 | Left = 1056 48 | Style = 2 'Dropdown List 49 | TabIndex = 3 50 | Top = 360 51 | Width = 3660 52 | End 53 | Begin VB.Label Label1 54 | Alignment = 1 'Right Justify 55 | Caption = "Printer:" 56 | Height = 348 57 | Left = 192 58 | TabIndex = 2 59 | Top = 360 60 | Width = 756 61 | End 62 | End 63 | Attribute VB_Name = "frmSelectPrinter" 64 | Attribute VB_GlobalNameSpace = False 65 | Attribute VB_Creatable = False 66 | Attribute VB_PredeclaredId = True 67 | Attribute VB_Exposed = False 68 | Option Explicit 69 | 70 | Public OKPressed As Boolean 71 | 72 | Private Sub cmdCancel_Click() 73 | Unload Me 74 | End Sub 75 | 76 | Private Sub cmdOK_Click() 77 | Dim c As Long 78 | 79 | For c = 0 To Printers.Count - 1 80 | If Printers(c).DeviceName = cboPrinters.Text Then 81 | Set Printer = Printers(c) 82 | frmMain.PrinterIndex = c 83 | Exit For 84 | End If 85 | Next 86 | OKPressed = True 87 | Unload Me 88 | If InStr(LCase$(Printer.DeviceName), "pdf") Then 89 | If Val(GetSetting(App.Title, AppPath4Reg, "HidePDFNote", "0")) = 0 Then 90 | frmPDFNote.Show vbModal 91 | End If 92 | End If 93 | End Sub 94 | 95 | Private Sub Form_Load() 96 | Dim p As Printer 97 | 98 | Set Me.Icon = gIcon 99 | 100 | For Each p In Printers 101 | cboPrinters.AddItem p.DeviceName 102 | If p.DeviceName = Printer.DeviceName Then 103 | cboPrinters.ListIndex = cboPrinters.NewIndex 104 | End If 105 | Next 106 | End Sub 107 | -------------------------------------------------------------------------------- /source/misc/CDoc.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/misc/CDoc.ico -------------------------------------------------------------------------------- /source/misc/VisualStyle_DPIAware_Manifest.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/EduardoVB/ComponentDocumenter/ca4cddd8d9d5f9e69cbcafa165b31df072bf0e80/source/misc/VisualStyle_DPIAware_Manifest.res --------------------------------------------------------------------------------