--- /dev/null
+Attribute VB_Name = "Other"\r
+'\r
+' BrowseForFolder comes from codeguru\r
+' GetExecutable comes from VBWorld\r
+' TrimAll comes from freevbcode\r
+\r
+'\r
+' Suport for the browse directory dialog\r
+'\r
+Public Enum eBIF\r
+ BIF_RETURNONLYFSDIRS = &H1\r
+ BIF_DONTGOBELOWDOMAIN = &H2\r
+ BIF_STATUSTEXT = &H4\r
+ BIF_RETURNFSANCESTORS = &H8\r
+ BIF_BROWSEFORCOMPUTER = &H1000\r
+ BIF_BROWSEFORPRINTER = &H2000\r
+End Enum\r
+\r
+Private Type BROWSEINFO\r
+ hwndOwner As Long\r
+ pidlRoot As Long\r
+ pszDisplayName As String\r
+ lpszTitle As String\r
+ ulFlags As Long\r
+ lpfnCallback As Long\r
+ lParam As Long\r
+ iImage As Long\r
+End Type\r
+\r
+Private Declare Function SHBrowseForFolder Lib "shell32.dll" (lpbi As BROWSEINFO) As Long\r
+Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long\r
+Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)\r
+\r
+'\r
+' Support for the find executable\r
+'\r
+\r
+Private Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _\r
+ (ByVal lpFile As String, ByVal lpDirectory _\r
+ As String, ByVal lpResult As String) As Long\r
+\r
+Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal _\r
+ lpszPath As String, ByVal lpPrefixString _\r
+ As String, ByVal wUnique As Long, ByVal _\r
+ lpTempFileName As String) As Long\r
+\r
+Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal _\r
+ nBufferLength As Long, ByVal lpBuffer As _\r
+ String) As Long\r
+\r
+'\r
+' high level interfaces\r
+'\r
+\r
+Public Function BrowseForFolder(ByVal hwndOwner As Long, _\r
+ ByVal sPrompt As String, _\r
+ Optional ByVal lFlags As eBIF = BIF_RETURNONLYFSDIRS) As String\r
+ '\r
+ Dim iNull As Integer\r
+ Dim lpIDList As Long\r
+ Dim lResult As Long\r
+ Dim sPath As String\r
+ Dim udtBI As BROWSEINFO\r
+\r
+ With udtBI\r
+ .hwndOwner = hwndOwner\r
+ .lpszTitle = sPrompt & ""\r
+ .ulFlags = BIF_RETURNONLYFSDIRS\r
+ End With\r
+\r
+ lpIDList = SHBrowseForFolder(udtBI)\r
+ If lpIDList Then\r
+ sPath = String$(260, 0)\r
+ lResult = SHGetPathFromIDList(lpIDList, sPath)\r
+ Call CoTaskMemFree(lpIDList)\r
+ iNull = InStr(sPath, vbNullChar)\r
+ If iNull Then\r
+ sPath = Left$(sPath, iNull - 1)\r
+ End If\r
+ Else\r
+ 'Cancel is clicked\r
+ sPath = ""\r
+ End If\r
+\r
+ BrowseForFolder = sPath\r
+End Function\r
+\r
+\r
+Public Function GetExecutable(ByVal Extension As String) As String\r
+\r
+ Dim Path As String\r
+ Dim FileName As String\r
+ Dim nRet As Long\r
+ Const MAX_PATH As Long = 260\r
+ \r
+ 'Create a tempfile\r
+ Path = String$(MAX_PATH, 0)\r
+ \r
+ If GetTempPath(MAX_PATH, Path) Then\r
+ FileName = String$(MAX_PATH, 0)\r
+ \r
+ If GetTempFileName(Path, "~", 0, FileName) Then\r
+ FileName = Left$(FileName, _\r
+ InStr(FileName, vbNullChar) - 1)\r
+ \r
+ 'Rename it to use supplied extension\r
+ Name FileName As Left$(FileName, _\r
+ InStr(FileName, ".")) & Extension\r
+ FileName = Left$(FileName, _\r
+ InStr(FileName, ".")) & Extension\r
+ \r
+ 'Get name of associated EXE\r
+ Path = String$(MAX_PATH, 0)\r
+ \r
+ Call FindExecutable(FileName, vbNullString, Path)\r
+ GetExecutable = Left$(Path, InStr(Path, vbNullChar) - 1)\r
+ \r
+ 'Clean up\r
+ Kill FileName\r
+ End If\r
+ End If\r
+\r
+End Function\r
+\r
+Public Function GetFileExtension(ByVal FilePath As String) As String\r
+ Dim Pos As Integer\r
+ Pos = InStrRev(FilePath, "\")\r
+ If Pos <> 0 Then\r
+ FilePath = Right$(FilePath, Len(FilePath) - Pos)\r
+ End If\r
+ Pos = InStrRev(FilePath, ".")\r
+ If Pos <> 0 Then\r
+ GetFileExtension = Right$(FilePath, Len(FilePath) - Pos)\r
+ Else\r
+ GetFileExtension = ""\r
+ End If\r
+End Function\r
+\r
+Public Function GetFileName(ByVal FilePath As String) As String\r
+ Dim Pos As Integer\r
+ Dim apos As Integer\r
+ \r
+ Pos = InStrRev(FilePath, "\")\r
+ apos = InStrRev(FilePath, ".")\r
+ \r
+ GetFileName = Mid(FilePath, _\r
+ IIf(Pos = 0, 1, Pos + 1), _\r
+ IIf(apos = 0, Len(FilePath), apos - Pos - 1))\r
+End Function\r
+\r
+Public Function TrimAll(ByVal TextIN As String, Optional NonPrints As Boolean) As String\r
+\r
+ TrimAll = Trim(TextIN)\r
+\r
+ If NonPrints Then\r
+ Dim x As Long\r
+ ' remove all non-printable characters\r
+ While InStr(TrimAll, vbCrLf) > 0\r
+ TrimAll = Replace(TrimAll, vbCrLf, " ")\r
+ Wend\r
+\r
+ While InStr(TrimAll, vbTab) > 0\r
+ TrimAll = Replace(TrimAll, vbTab, " ")\r
+ Wend\r
+\r
+ For x = 0 To 31\r
+ While InStr(TrimAll, Chr(x)) > 0\r
+ TrimAll = Replace(TrimAll, Chr(x), " ")\r
+ Wend\r
+ Next x\r
+\r
+ For x = 127 To 255\r
+ While InStr(TrimAll, Chr(x)) > 0\r
+ TrimAll = Replace(TrimAll, Chr(x), " ")\r
+ Wend\r
+ Next x\r
+ End If\r
+\r
+ While InStr(TrimAll, String(2, " ")) > 0\r
+ TrimAll = Replace(TrimAll, String(2, " "), " ")\r
+ Wend\r
+\r
+End Function\r
+\r
--- /dev/null
+Attribute VB_Name = "Process"\r
+' From Microsoft Knowledge Base Article - Q129796 and 173085\r
+'\r
+'\r
+\r
+Public Type ProcessOutput\r
+ ret As Long 'return value\r
+ out As String 'whatever was printed to stdout\r
+ err As String 'whatever was printed to stderr\r
+End Type\r
+\r
+Public Type ProcessContext\r
+ outHnd As Long 'handler for the redirected output\r
+ outName As String 'name of the file to which output is redirected\r
+End Type\r
+\r
+Private Type STARTUPINFO\r
+ cb As Long\r
+ lpReserved As String\r
+ lpDesktop As String\r
+ lpTitle As String\r
+ dwX As Long\r
+ dwY As Long\r
+ dwXSize As Long\r
+ dwYSize As Long\r
+ dwXCountChars As Long\r
+ dwYCountChars As Long\r
+ dwFillAttribute As Long\r
+ dwFlags As Long\r
+ wShowWindow As Integer\r
+ cbReserved2 As Integer\r
+ lpReserved2 As Long\r
+ hStdInput As Long\r
+ hStdOutput As Long\r
+ hStdError As Long\r
+End Type\r
+\r
+Private Type PROCESS_INFORMATION\r
+ hProcess As Long\r
+ hThread As Long\r
+ dwProcessID As Long\r
+ dwThreadID As Long\r
+End Type\r
+\r
+Private Type SECURITY_ATTRIBUTES\r
+ nLength As Long\r
+ lpSecurityDescriptor As Long\r
+ bInheritHandle As Long\r
+End Type\r
+\r
+Public Type OVERLAPPED\r
+ Internal As Long\r
+ InternalHigh As Long\r
+ offset As Long\r
+ OffsetHigh As Long\r
+ hEvent As Long\r
+End Type\r
+ \r
+Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal _\r
+ hHandle As Long, ByVal dwMilliseconds As Long) As Long\r
+\r
+Private Declare Function CreateProcessA Lib "kernel32" (ByVal _\r
+ lpApplicationName As String, ByVal lpCommandLine As String, ByVal _\r
+ lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, _\r
+ ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, _\r
+ ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As String, _\r
+ lpStartupInfo As STARTUPINFO, lpProcessInformation As _\r
+ PROCESS_INFORMATION) As Long\r
+\r
+Private Declare Function CloseHandle Lib "kernel32" _\r
+ (ByVal hObject As Long) As Long\r
+\r
+Private Declare Function GetExitCodeProcess Lib "kernel32" _\r
+ (ByVal hProcess As Long, lpExitCode As Long) As Long\r
+\r
+Private Declare Function CreatePipe Lib "kernel32" _\r
+ (phReadPipe As Long, phWritePipe As Long, _\r
+ lpPipeAttributes As Any, ByVal nSize As Long) As Long\r
+\r
+Public Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" _\r
+ (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, _\r
+ ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, _\r
+ ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, _\r
+ ByVal hTemplateFile As Long) As Long\r
+ \r
+Public Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" _\r
+ (ByVal lpFileName As String) As Long\r
+\r
+Private Declare Function ReadFile Lib "kernel32" _\r
+ (ByVal hFile As Long, ByVal lpBuffer As String, _\r
+ ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, _\r
+ ByVal lpOverlapped As Any) As Long\r
+\r
+Public Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _\r
+ (ByVal lpszPath As String, ByVal lpPrefixString As String, _\r
+ ByVal wUnique As Long, ByVal lpTempFileName As String) As Long\r
+\r
+Public Declare Function GetFileSize Lib "kernel32" _\r
+ (ByVal hFile As Long, lpFileSizeHigh As Long) As Long\r
+ \r
+Public Declare Function SetFilePointer Lib "kernel32" _\r
+ (ByVal hFile As Long, ByVal lDistanceToMove As Long, _\r
+ lpDistanceToMoveHigh As Long, ByVal dwMoveMethod As Long) As Long\r
+ \r
+\r
+\r
+Private Const NORMAL_PRIORITY_CLASS = &H20&\r
+Private Const STARTF_USESTDHANDLES = &H100&\r
+Private Const INFINITE = -1&\r
+\r
+Public Const GENERIC_WRITE = &H40000000\r
+Public Const GENERIC_READ = &H80000000\r
+\r
+Public Const FILE_SHARE_READ = &H1\r
+Public Const FILE_SHARE_WRITE = &H2\r
+Public Const FILE_SHARE_DELETE = &H4\r
+\r
+Public Const CREATE_ALWAYS = 2\r
+\r
+Public Const INVALID_HANDLE_VALUE = -1\r
+\r
+Public Const FILE_FLAG_DELETE_ON_CLOSE = &H4000000\r
+Public Const FILE_FLAG_OVERLAPPED = &H40000000\r
+\r
+Public Const FILE_ATTRIBUTE_NORMAL = &H80\r
+Public Const FILE_ATTRIBUTE_TEMPORARY = &H100\r
+\r
+Public Const FILE_BEGIN = 0\r
+\r
+Public Const MAX_PATH = 260\r
+\r
+'my own constants\r
+Private Const STDOUT_PIPE = 1\r
+Private Const STDOUT_IN_PIPE = 2\r
+Private Const STDERR_PIPE = 3\r
+Private Const STDERR_IN_PIPE = 4\r
+\r
+Private Const READ_BUFF_SIZE = 256\r
+\r
+\r
+'\r
+' Pending issue here: waiting for the called process is infinite\r
+' The output is intercepted only if doWait and doOutput are set to true\r
+'\r
+Public Function ExecCmd(cmdline$, doWait As Boolean, doOutput As Boolean) As ProcessOutput\r
+ Dim ret As Long\r
+ Dim res As ProcessOutput\r
+ Dim ctx As ProcessContext\r
+ '\r
+ Dim proc As PROCESS_INFORMATION\r
+ Dim start As STARTUPINFO\r
+ '\r
+ Dim doPipes As Boolean\r
+ '\r
+ Dim cnt As Long, atpt As Long\r
+ Dim buff As String * READ_BUFF_SIZE\r
+ \r
+ doPipes = (doWait = True) And (doOutput = True)\r
+ ctx.outName = String(MAX_PATH, Chr$(0))\r
+ \r
+ ' Initialize the STARTUPINFO structure:\r
+ start.cb = Len(start)\r
+ \r
+ If doPipes Then\r
+ OpenContext ctx, True\r
+ start.dwFlags = STARTF_USESTDHANDLES\r
+ start.hStdError = ctx.outHnd\r
+ End If\r
+ \r
+ ' Start the shelled application:\r
+ ret& = CreateProcessA(vbNullString, cmdline$, 0&, 0&, 1&, _\r
+ NORMAL_PRIORITY_CLASS, 0&, vbNullString, start, proc)\r
+\r
+ If ret <> 1 Then\r
+ CloseContext ctx, False\r
+ err.Raise 12001, , "CreateProcess failed. Error: " & err.LastDllError\r
+ End If\r
+ \r
+ ' Wait for the shelled application to finish:\r
+ If doWait = True Then\r
+ ret& = WaitForSingleObject(proc.hProcess, INFINITE)\r
+ Call GetExitCodeProcess(proc.hProcess, res.ret&)\r
+ \r
+ Call CloseHandle(proc.hThread)\r
+ Call CloseHandle(proc.hProcess)\r
+ \r
+ 'read the dump of the stderr, non-blocking\r
+ If doPipes Then\r
+ ret& = GetFileSize(ctx.outHnd, 0)\r
+ 'we consider that not being able to read the stderr log is not a fatal error\r
+ If ret <> -1 Then\r
+ ret = SetFilePointer(ctx.outHnd, 0, 0, FILE_BEGIN)\r
+ If ret = 0 Then\r
+ Do\r
+ ret = ReadFile(ctx.outHnd, buff, READ_BUFF_SIZE, cnt, 0&)\r
+ res.err = res.err & Left$(buff, cnt)\r
+ Loop While ret <> 0 And cnt <> 0\r
+ Else\r
+ MsgBox "SetFilePointer failed. Error: " & err.LastDllError & " " & err.Description\r
+ End If\r
+ Else\r
+ MsgBox "GetFileSize failed. Error: " & err.LastDllError & " " & err.Description\r
+ End If\r
+ \r
+ CloseContext ctx, False\r
+ End If\r
+ \r
+ End If\r
+ \r
+ ExecCmd = res\r
+End Function\r
+\r
+Private Sub OpenContext(ByRef Context As ProcessContext, doError As Boolean)\r
+\r
+ Dim sa As SECURITY_ATTRIBUTES\r
+ Dim msg As String\r
+ \r
+ ' Initialize the SECURITY_ATRIBUTES info\r
+ sa.nLength = Len(sa)\r
+ sa.bInheritHandle = 1&\r
+ sa.lpSecurityDescriptor = 0&\r
+ \r
+ ret& = GetTempFileName(".", "err", 0, Context.outName)\r
+ If ret = 0 Then\r
+ msg = "GetTempFileName failed for stderr. Error: " & err.LastDllError\r
+ If doError = True Then\r
+ err.Raise 12000, , msg\r
+ Else\r
+ MsgBox msg\r
+ End If\r
+ End If\r
+ \r
+ Context.outHnd = CreateFile(Context.outName, _\r
+ GENERIC_WRITE Or GENERIC_READ, _\r
+ FILE_SHARE_WRITE Or FILE_SHARE_READ Or FILE_SHARE_DELETE, _\r
+ sa, CREATE_ALWAYS, _\r
+ FILE_ATTRIBUTE_TEMPORARY, _\r
+ FILE_FLAG_DELETE_ON_CLOSE)\r
+ \r
+ If Context.outHnd = INVALID_HANDLE_VALUE Then\r
+ msg = "CreateFile failed for stderr. Error: " & err.LastDllError\r
+ If doError = True Then\r
+ err.Raise 12000, , msg\r
+ Else\r
+ MsgBox msg\r
+ End If\r
+ End If\r
+ \r
+End Sub\r
+\r
+Private Sub CloseContext(ByRef Context As ProcessContext, doError As Boolean)\r
+ Dim msg As String\r
+ If Context.outHnd <> 0 Then\r
+ CloseHandle Context.outHnd\r
+ End If\r
+ If Not IsNull(Context.outName) Then\r
+ 'delete the file\r
+ ret = DeleteFile(Context.outName)\r
+ If ret = 0 Then\r
+ msg = "DeleteFile failed. Error: " & err.LastDllError & Chr(13) & _\r
+ "You have a temporary file at " & pathBuff\r
+ If doError = True Then\r
+ err.Raise 12000, , msg\r
+ Else\r
+ MsgBox msg\r
+ End If\r
+ End If\r
+ End If\r
+End Sub\r
+\r
+Private Sub ClosePipes(ByRef Pipes() As Long, Size As Integer)\r
+ Dim i As Integer\r
+ For i = 0 To Size\r
+ ClosePipe Pipes, i\r
+ Next i\r
+End Sub\r
+\r
+Private Sub ClosePipe(ByRef Pipes() As Long, Pos As Integer)\r
+ \r
+ If Pipes(Pos) <> 0 Then\r
+ CloseHandle Pipes(Pos)\r
+ Pipes(Pos) = 0\r
+ End If\r
+End Sub\r
+\r
--- /dev/null
+Attribute VB_Name = "Registry"\r
+' From the VBWorld website\r
+' Detailed Registry access through win32 apis\r
+'\r
+\r
+Public Const HKEY_CLASSES_ROOT = &H80000000\r
+Public Const HKEY_CURRENT_USER = &H80000001\r
+Public Const HKEY_LOCAL_MACHINE = &H80000002\r
+Public Const HKEY_USERS = &H80000003\r
+Public Const HKEY_CURRENT_CONFIG = &H80000005\r
+Public Const HKEY_DYN_DATA = &H80000006\r
+Public Const REG_SZ = 1 'Unicode nul terminated string\r
+Public Const REG_BINARY = 3 'Free form binary\r
+Public Const REG_DWORD = 4 '32-bit number\r
+Public Const ERROR_SUCCESS = 0&\r
+\r
+Public Declare Function RegCloseKey Lib "advapi32.dll" _\r
+(ByVal hKey As Long) As Long\r
+\r
+Public Declare Function RegCreateKey Lib "advapi32.dll" _\r
+Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey _\r
+As String, phkResult As Long) As Long\r
+\r
+'Public Declare Function RegDeleteKey Lib "advapi32.dll" _\r
+'Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey _\r
+'As String) As Long\r
+\r
+'Public Declare Function RegDeleteValue Lib "advapi32.dll" _\r
+'Alias "RegDeleteValueA" (ByVal hKey As Long, ByVal _\r
+'lpValueName As String) As Long\r
+\r
+Public Declare Function RegOpenKey Lib "advapi32.dll" _\r
+Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey _\r
+As String, phkResult As Long) As Long\r
+\r
+Public Declare Function RegQueryValueEx Lib "advapi32.dll" _\r
+Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _\r
+As String, ByVal lpReserved As Long, lpType As Long, lpData _\r
+As Any, lpcbData As Long) As Long\r
+\r
+Public Declare Function RegSetValueEx Lib "advapi32.dll" _\r
+Alias "RegSetValueExA" (ByVal hKey As Long, ByVal _\r
+lpValueName As String, ByVal Reserved As Long, ByVal _\r
+dwType As Long, lpData As Any, ByVal cbData As Long) As Long\r
+\r
+\r
+Public Function GetSettingString(hKey As Long, _\r
+ strPath As String, _\r
+ strValue As String, _\r
+ Optional Default As String) As String\r
+ Dim hCurKey As Long\r
+ Dim lResult As Long\r
+ Dim lValueType As Long\r
+ Dim strBuffer As String\r
+ Dim lDataBufferSize As Long\r
+ Dim intZeroPos As Integer\r
+ Dim lRegResult As Long\r
+\r
+ 'Set up default value\r
+ If Not IsEmpty(Default) Then\r
+ GetSettingString = Default\r
+ Else\r
+ GetSettingString = ""\r
+ End If\r
+\r
+ lRegResult = RegOpenKey(hKey, strPath, hCurKey)\r
+ lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, _\r
+ lValueType, ByVal 0&, lDataBufferSize)\r
+\r
+ If lRegResult = ERROR_SUCCESS Then\r
+ If lValueType = REG_SZ Then\r
+ strBuffer = String(lDataBufferSize, " ")\r
+ lResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, _\r
+ ByVal strBuffer, lDataBufferSize)\r
+ intZeroPos = InStr(strBuffer, Chr$(0))\r
+ If intZeroPos > 0 Then\r
+ GetSettingString = Left$(strBuffer, intZeroPos - 1)\r
+ Else\r
+ GetSettingString = strBuffer\r
+ End If\r
+ End If\r
+ Else\r
+ Err.Raise 5013, "Registry", "Unable to find get key value"\r
+ End If\r
+\r
+ lRegResult = RegCloseKey(hCurKey)\r
+End Function\r
+\r
+Public Sub CreateKey(hKey As Long, strPath As String)\r
+ \r
+ Dim hCurKey As Long\r
+ Dim lRegResult As Long\r
+\r
+ lRegResult = RegCreateKey(hKey, strPath, hCurKey)\r
+ If lRegResult <> ERROR_SUCCESS Then\r
+ Err.Raise 5013, "Registry", "Unable to find create registry key"\r
+ End If\r
+ lRegResult = RegCloseKey(hCurKey)\r
+\r
+End Sub\r
+\r
+Public Sub SaveSettingString(hKey As Long, _\r
+ strPath As String, _\r
+ strValue As String, _\r
+ strData As String)\r
+ Dim hCurKey As Long\r
+ Dim lRegResult As Long\r
+\r
+ lRegResult = RegCreateKey(hKey, strPath, hCurKey)\r
+ lRegResult = RegSetValueEx(hCurKey, strValue, 0, REG_SZ, _\r
+ ByVal strData, Len(strData))\r
+\r
+ If lRegResult <> ERROR_SUCCESS Then\r
+ Err.Raise 5013, "Registry", "Unable to find save registry settings"\r
+ End If\r
+\r
+ lRegResult = RegCloseKey(hCurKey)\r
+End Sub\r
projects / graphviz / commitdiff