Print Page - Open, Save, and Folder dialogs using Pipecom

Option _Explicit
Print GetOpenFileName("This is a test", _Dir$("desktop"), "txt files (*.txt)|*.txt|All files (*.*)|*.*", 2)
'Dim As String savefile
'savefile = GetSaveFileName("Save test", _CWD$, "txt files (*.txt)|*.txt|All files (*.*)|*.*", 1)
'If savefile <> "" Then
' Open savefile For Output As #1
' Print #1, Chr$(34) + "Success! Success! We've done it! We've done it!" + Chr$(34)
' Print #1, Chr$(9) + Chr$(9) + Chr$(9) + "-Every diplomatic leader in The Batman Movie";
' Close
'End If
'Print GetFolderName("Pick a folder")
'ReDim As String filelist(1 To 1)
'GetOpenFileNames "Pick multiple files", _Dir$("desktop"), "txt files (*.txt)|*.txt|All files (*.*)|*.*", 1, filelist()
'Dim x
'For x = LBound(filelist) To UBound(filelist)
' Print filelist(x)
'Next
Function GetOpenFileName$ (Title As String, InitialDir As String, Filter As String, FilterIndex As Long)
Dim As String cmd, stdout, stderr
Dim As Long exit_code
If Mid$(InitialDir, Len(InitialDir) - 1) <> "\" Then InitialDir = InitialDir + "\"
cmd = "PowerShell Add-Type -AssemblyName System.Windows.Forms;$FileBrowser = New-Object System.Windows.Forms.OpenFileDialog -Property @{ Title = '" + Chr$(34) + Title + Chr$(34) + "'; InitialDirectory = '" + Chr$(34) + InitialDir + Chr$(34) + "'; Filter = '" + Chr$(34) + Filter + Chr$(34) + "'; FilterIndex = '" + Chr$(34) + LTrim$(Str$(FilterIndex)) + Chr$(34) + "'; };$null = $FileBrowser.ShowDialog();$FileBrowser.FileName;exit $LASTEXITCODE"
exit_code = pipecom(cmd, stdout, stderr)
If stdout <> "" Then GetOpenFileName = Mid$(stdout, 1, Len(stdout) - 1)
End Function
Sub GetOpenFileNames (Title As String, InitialDir As String, Filter As String, FilterIndex As Long, filenames() As String)
Dim As String cmd, stdout, stderr
Dim As Long exit_code
If Mid$(InitialDir, Len(InitialDir) - 1) <> "\" Then InitialDir = InitialDir + "\"
cmd = "PowerShell Add-Type -AssemblyName System.Windows.Forms;$FileBrowser = New-Object System.Windows.Forms.OpenFileDialog -Property @{ Title = '" + Chr$(34) + Title + Chr$(34) + "'; InitialDirectory = '" + Chr$(34) + InitialDir + Chr$(34) + "'; Filter = '" + Chr$(34) + Filter + Chr$(34) + "'; FilterIndex = '" + Chr$(34) + LTrim$(Str$(FilterIndex)) + Chr$(34) + "'; Multiselect = 'true'; };$null = $FileBrowser.ShowDialog();$FileBrowser.FileNames;exit $LASTEXITCODE"
exit_code = pipecom(cmd, stdout, stderr)
If stdout <> "" Then
stdout = Mid$(stdout, 1, Len(stdout) - 1)
If InStr(stdout, Chr$(10)) = 0 Then
filenames(1) = stdout
Else
String.Split stdout, Chr$(10), filenames()
End If
End If
End Sub
Function GetSaveFileName$ (Title As String, InitialDir As String, Filter As String, FilterIndex As Long)
Dim As String cmd, stdout, stderr
Dim As Long exit_code
If Mid$(InitialDir, Len(InitialDir) - 1) <> "\" Then InitialDir = InitialDir + "\"
cmd = "PowerShell Add-Type -AssemblyName System.Windows.Forms;$FileBrowser = New-Object System.Windows.Forms.SaveFileDialog -Property @{ Title = '" + Chr$(34) + Title + Chr$(34) + "'; InitialDirectory = '" + Chr$(34) + InitialDir + Chr$(34) + "'; Filter = '" + Chr$(34) + Filter + Chr$(34) + "'; FilterIndex = '" + Chr$(34) + LTrim$(Str$(FilterIndex)) + Chr$(34) + "'; };$null = $FileBrowser.ShowDialog();$FileBrowser.FileName;exit $LASTEXITCODE"
exit_code = pipecom(cmd, stdout, stderr)
If stdout <> "" Then GetSaveFileName = Mid$(stdout, 1, Len(stdout) - 1)
End Function
Function GetFolderName$ (Title As String)
Dim As String cmd, stdout, stderr
Dim As Long exit_code
cmd = "PowerShell Add-Type -AssemblyName System.Windows.Forms;$FolderBrowser = New-Object System.Windows.Forms.FolderBrowserDialog -Property @{ Description = '" + Chr$(34) + Title + Chr$(34) + "'; ShowNewFolderButton = 'true'; };$null = $FolderBrowser.ShowDialog();$FolderBrowser.SelectedPath;exit $LASTEXITCODE"
exit_code = pipecom(cmd, stdout, stderr)
If stdout <> "" Then GetFolderName = Mid$(stdout, 1, Len(stdout) - 1)
End Function
Sub String.Split (Expression As String, delimiter As String, StorageArray() As String)
Dim copy As String, p As Long, curpos As Long, arrpos As Long, dpos As Long
copy = Expression
If delimiter = " " Then
copy = RTrim$(LTrim$(copy))
p = InStr(copy, " ")
While p > 0
copy = Mid$(copy, 1, p - 1) + Mid$(copy, p + 1)
p = InStr(copy, " ")
Wend
End If
curpos = 1
arrpos = UBound(StorageArray)
dpos = InStr(curpos, copy, delimiter)
Do Until dpos = 0
StorageArray(UBound(StorageArray)) = Mid$(copy, curpos, dpos - curpos)
ReDim _Preserve StorageArray(UBound(StorageArray) + 1) As String
curpos = dpos + Len(delimiter)
dpos = InStr(curpos, copy, delimiter)
Loop
StorageArray(UBound(StorageArray)) = Mid$(copy, curpos)
ReDim _Preserve StorageArray(UBound(StorageArray)) As String
End Sub
'$INCLUDE:'pipecomqb64.bas'

Function pipecom& (cmd As String, stdout As String, stderr As String)
$If WIN Then
Type SECURITY_ATTRIBUTES
As Long nLength
$If 64BIT Then
As Long padding
$End If
As _Offset lpSecurityDescriptor
As Long bInheritHandle
$If 64BIT Then
As Long padding2
$End If
End Type
Type STARTUPINFO
As Long cb
$If 64BIT Then
As Long padding
$End If
As _Offset lpReserved, lpDesktop, lpTitle
As Long dwX, dwY, dwXSize, dwYSize, dwXCountChars, dwYCountChars, dwFillAttribute, dwFlags
As Integer wShowWindow, cbReserved2
$If 64BIT Then
As Long padding2
$End If
As _Offset lpReserved2, hStdInput, hStdOutput, hStdError
End Type
Type PROCESS_INFORMATION
As _Offset hProcess, hThread
As Long dwProcessId
$If 64BIT Then
As Long padding
$End If
End Type
Const STARTF_USESTDHANDLES = &H00000100
Const CREATE_NO_WINDOW = &H8000000
Const INFINITE = 4294967295
Const WAIT_FAILED = &HFFFFFFFF
Declare CustomType Library
Function CreatePipe%% (ByVal hReadPipe As _Offset, Byval hWritePipe As _Offset, Byval lpPipeAttributes As _Offset, Byval nSize As Long)
Function CreateProcess%% Alias CreateProcessA (ByVal lpApplicationName As _Offset, Byval lpCommandLine As _Offset, Byval lpProcessAttributes As _Offset, Byval lpThreadAttributes As _Offset, Byval bInheritHandles As Integer, Byval dwCreationFlags As Long, Byval lpEnvironment As _Offset, Byval lpCurrentDirectory As _Offset, Byval lpStartupInfor As _Offset, Byval lpProcessInformation As _Offset)
Function GetExitCodeProcess%% (ByVal hProcess As _Offset, Byval lpExitCode As _Offset)
Function HandleClose%% Alias CloseHandle (ByVal hObject As _Offset)
Function ReadFile%% (ByVal hFile As _Offset, Byval lpBuffer As _Offset, Byval nNumberOfBytesToRead As Long, Byval lpNumberOfBytesRead As _Offset, Byval lpOverlapped As _Offset)
Function WaitForSingleObject& (ByVal hHandle As _Offset, Byval dwMilliseconds As Long)
End Declare
Dim As _Byte ok: ok = 1
Dim As _Offset hStdOutPipeRead, hStdOutPipeWrite, hStdReadPipeError, hStdOutPipeError
Dim As SECURITY_ATTRIBUTES sa: sa.nLength = Len(sa): sa.lpSecurityDescriptor = 0: sa.bInheritHandle = 1
If CreatePipe(_Offset(hStdOutPipeRead), _Offset(hStdOutPipeWrite), _Offset(sa), 0) = 0 Then
pipecom = -1
Exit Function
End If
If CreatePipe(_Offset(hStdReadPipeError), _Offset(hStdOutPipeError), _Offset(sa), 0) = 0 Then
pipecom = -1
Exit Function
End If
Dim As STARTUPINFO si
si.cb = Len(si)
si.dwFlags = STARTF_USESTDHANDLES
si.hStdError = hStdOutPipeError
si.hStdOutput = hStdOutPipeWrite
si.hStdInput = 0
Dim As PROCESS_INFORMATION pi
Dim As _Offset lpApplicationName
Dim As String fullcmd: fullcmd = "cmd /c " + cmd + Chr$(0)
Dim As String lpCommandLine: lpCommandLine = fullcmd
Dim As _Offset lpProcessAttributes, lpThreadAttributes
Dim As Integer bInheritHandles: bInheritHandles = 1
Dim As Long dwCreationFlags: dwCreationFlags = CREATE_NO_WINDOW
Dim As _Offset lpEnvironment, lpCurrentDirectory
ok = CreateProcess(lpApplicationName,_
_Offset(lpCommandLine),_
lpProcessAttributes,_
lpThreadAttributes,_
bInheritHandles,_
dwCreationFlags,_
lpEnvironment,_
lpCurrentDirectory,_
_Offset(si),_
_Offset(pi))
If ok = 0 Then
pipecom = -1
Exit Function
End If
ok = HandleClose(hStdOutPipeWrite)
ok = HandleClose(hStdOutPipeError)
Dim As String buf: buf = Space$(4096 + 1)
Dim As Long dwRead
While ReadFile(hStdOutPipeRead, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
buf = Mid$(buf, 1, dwRead)
GoSub RemoveChr13
stdout = stdout + buf
buf = Space$(4096 + 1)
Wend
While ReadFile(hStdReadPipeError, _Offset(buf), 4096, _Offset(dwRead), 0) <> 0 And dwRead > 0
buf = Mid$(buf, 1, dwRead)
GoSub RemoveChr13
stderr = stderr + buf
buf = Space$(4096 + 1)
Wend
Dim As Long exit_code, ex_stat
If WaitForSingleObject(pi.hProcess, INFINITE) <> WAIT_FAILED Then
If GetExitCodeProcess(pi.hProcess, _Offset(exit_code)) Then
ex_stat = 1
End If
End If
ok = HandleClose(hStdOutPipeRead)
ok = HandleClose(hStdReadPipeError)
If ex_stat = 1 Then
pipecom = exit_code
Else
pipecom = -1
End If
Exit Function
RemoveChr13:
Dim As Long j
j = InStr(buf, Chr$(13))
Do While j
buf = Left$(buf, j - 1) + Mid$(buf, j + 1)
j = InStr(buf, Chr$(13))
Loop
Return
$Else
Declare CustomType Library
Function popen%& (cmd As String, readtype As String)
Function feof& (ByVal stream As _Offset)
Function fgets$ (str As String, Byval n As Long, Byval stream As _Offset)
Function pclose& (ByVal stream As _Offset)
End Declare
Declare Library
Function WEXITSTATUS& (ByVal stat_val As Long)
End Declare
Dim As String pipecom_buffer
Dim As _Offset stream
Dim buffer As String * 4096
If _FileExists("pipestderr") Then
Kill "pipestderr"
End If
stream = popen(cmd + " 2>pipestderr", "r")
If stream Then
While feof(stream) = 0
If fgets(buffer, 4096, stream) <> "" And feof(stream) = 0 Then
stdout = stdout + Mid$(buffer, 1, InStr(buffer, Chr$(0)) - 1)
End If
Wend
Dim As Long status, exit_code
status = pclose(stream)
exit_code = WEXITSTATUS(status)
If _FileExists("pipestderr") Then
Dim As Integer errfile
errfile = FreeFile
Open "pipestderr" For Binary As #errfile
If LOF(errfile) > 0 Then
stderr = Space$(LOF(errfile))
Get #errfile, , stderr
End If
Close #errfile
Kill "pipestderr"
End If
pipecom = exit_code
Else
pipecom = -1
End If
$End If
End Function
Function pipecom_lite$ (cmd As String)
Dim As Long a
Dim As String stdout, stderr
a = pipecom(cmd, stdout, stderr)
If stderr <> "" Then
pipecom_lite = stderr
Else
pipecom_lite = stdout
End If
End Function

QB64.org Forum

Active Forums => Programs => Topic started by: SpriggsySpriggs on June 12, 2021, 12:02:09 am