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
|
