Attribute VB_Name = "modProcedures" Option Explicit '******************************************************************************************************* '* Private Constants '******************************************************************************************************* Private Const mucModuleName = "modProcedures" Private Const REG_KEY_OPEN = "OPEN" Private Const REG_KEY_PRINT = "PRINT" Private Const B64ALPHABET = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" Private Const HTTP_HEAD_AUTHORISATION_BASIC As String = "Authorization: Basic " '******************************************************************************************************* '* Private Class Members '******************************************************************************************************* Private msLastError As String '******************************************************************************************************* '* Public Enumerations '******************************************************************************************************* Public Enum SNLinkType ltFileSystem = 1 ltLinkHTTP = 2 ltLinkVoyager = 3 ltLinkSAPNetSAPIDB = 4 ltLinkSAPNetSAPIDP = 5 ltLinkSAPNetForm = 5 ltLinkSAPNetDownload = 6 ltLinkSAPNetIRON = 7 End Enum Public Enum EnSpecialObjectHandling sohEdit = -1 sohDisplay = -2 sohPrint = -3 sohDisplaySource = -4 End Enum '******************************************************************************************************* '* Public Data Types '******************************************************************************************************* '******************************************************************************************************* '* Private Windows API Declarations '******************************************************************************************************* Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function CoCreateGuid Lib "ole32" _ (ByRef GUID As Byte) As Long Private Type OPENFILENAME lStructSize As Long ' Filled with UDT size hWndOwner As Long ' Tied to Owner hInstance As Long ' Ignored (used only by templates) lpstrFilter As String ' Tied to Filter lpstrCustomFilter As String ' Ignored (exercise for reader) nMaxCustFilter As Long ' Ignored (exercise for reader) nFilterIndex As Long ' Tied to FilterIndex lpstrFile As String ' Tied to FileName nMaxFile As Long ' Handled internally lpstrFileTitle As String ' Tied to FileTitle nMaxFileTitle As Long ' Handled internally lpstrInitialDir As String ' Tied to InitDir lpstrTitle As String ' Tied to DlgTitle Flags As Long ' Tied to Flags nFileOffset As Integer ' Ignored (exercise for reader) nFileExtension As Integer ' Ignored (exercise for reader) lpstrDefExt As String ' Tied to DefaultExt lCustData As Long ' Ignored (needed for hooks) lpfnHook As Long ' Ignored (good luck with hooks) lpTemplateName As Long ' Ignored (good luck with templates) End Type Type SHELLEXECUTEINFO cbSize As Long fMask As Long hwnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long ' Optional fields lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long End Type Private Declare Function GetOpenFileName Lib "COMDLG32" _ Alias "GetOpenFileNameA" (file As OPENFILENAME) As Long Declare Function RegQueryValue Lib "advapi32.dll" Alias "RegQueryValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal lpValue As String, lpcbValue As Long) As Long Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long '******************************************************************************************************* '* private variables '******************************************************************************************************* Private mstrMenuEntryOpen As String 'default display entry Private mstrMenuEntryPrint As String 'default print entry Public Function AddDir(dir1 As String, dir2 As String) As String On Error Resume Next If Len(dir1) > 0 And Len(dir2) > 0 Then If Right$(dir1, 1) = "\" And Left$(dir2, 1) = "\" Then AddDir = Left$(dir1, Len(dir1) - 1) + dir2 ElseIf Right$(dir1, 1) = "\" Or Left$(dir2, 1) = "\" Then AddDir = dir1 + dir2 Else AddDir = dir1 & "\" & dir2 End If Else AddDir = dir1 + dir2 End If End Function Public Function GetTempDir() As String Dim sRet As String, c As Long sRet = String(cMaxPath, 0) c = GetTempPath(cMaxPath, sRet) If c <> 0 Then GetTempDir = Left$(sRet, c) End If End Function Function VBGetOpenFileName(FileName As String, _ Optional FileTitle As String, _ Optional FileMustExist As Boolean = True, _ Optional MultiSelect As Boolean = False, _ Optional ReadOnly As Boolean = False, _ Optional HideReadOnly As Boolean = False, _ Optional filter As String = "All (*.*)| *.*", _ Optional FilterIndex As Long = 1, _ Optional InitDir As String, _ Optional DlgTitle As String, _ Optional DefaultExt As String, _ Optional Owner As Long = -1, _ Optional Flags As Long = 0) As Boolean Dim opfile As OPENFILENAME, s As String, afFlags As Long With opfile .lStructSize = Len(opfile) ' Add in specific flags and strip out non-VB flags .Flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _ (-MultiSelect * OFN_ALLOWMULTISELECT) Or _ (-ReadOnly * OFN_READONLY) Or _ (-HideReadOnly * OFN_HIDEREADONLY) Or _ (Flags And CLng(Not (OFN_ENABLEHOOK Or _ OFN_ENABLETEMPLATE))) ' Owner can take handle of owning window If Owner <> -1 Then .hWndOwner = Owner ' InitDir can take initial directory string .lpstrInitialDir = InitDir ' DefaultExt can take default extension .lpstrDefExt = DefaultExt ' DlgTitle can take dialog box title .lpstrTitle = DlgTitle ' To make Windows-style filter, replace | and : with nulls Dim ch As String, i As Integer For i = 1 To Len(filter) ch = Mid$(filter, i, 1) If ch = "|" Or ch = ":" Then s = s & vbNullChar Else s = s & ch End If Next ' Put double null at end s = s & vbNullChar & vbNullChar .lpstrFilter = s .nFilterIndex = FilterIndex ' Pad file and file title buffers to maximum path s = FileName & String$(cMaxPath - Len(FileName), 0) .lpstrFile = s .nMaxFile = cMaxPath s = FileTitle & String$(cMaxFile - Len(FileTitle), 0) .lpstrFileTitle = s .nMaxFileTitle = cMaxFile ' All other fields set to zero If GetOpenFileName(opfile) Then VBGetOpenFileName = True FileName = StrZToStr(.lpstrFile) FileTitle = StrZToStr(.lpstrFileTitle) Flags = .Flags ' Return the filter index FilterIndex = .nFilterIndex ' Look up the filter the user selected and return that filter = FilterLookup(.lpstrFilter, FilterIndex) If (.Flags And OFN_READONLY) Then ReadOnly = True Else VBGetOpenFileName = False FileName = sEmpty FileTitle = sEmpty Flags = 0 FilterIndex = -1 filter = sEmpty End If End With End Function Private Function StrZToStr(s As String) As String StrZToStr = Left$(s, lstrlen(s)) End Function Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String Dim iStart As Long, iEnd As Long, s As String iStart = 1 If sFilters = sEmpty Then Exit Function Do ' Cut out both parts marked by null character iEnd = InStr(iStart, sFilters, vbNullChar) If iEnd = 0 Then Exit Function iEnd = InStr(iEnd + 1, sFilters, vbNullChar) If iEnd Then s = Mid$(sFilters, iStart, iEnd - iStart) Else s = Mid$(sFilters, iStart) End If iStart = iEnd + 1 If iCur = 1 Then FilterLookup = s Exit Function End If iCur = iCur - 1 Loop While iCur End Function |