Well the holidays are upon us and I found myself going through some 20+ years of 'home videos'. The problem is files like CG54671.MOV doesn't tell me much about it. So I was thinking if only there was a way I could watch a bit of the vid while changing the file name, and maybe also move it to a different folder. Well, I suppose that is all possible by setting up the player in one part of the screen and a couple of File Explorer windows adjacent to the player, but what fun is that?!
So I'm putting together a little something for Windows that will be less obtrusive and more fun to use.
This is a fun project for me, because it utilizes some new tricks made possible by the QB64 Developers. The program makes use of _MESSAGEBOX, the folder and file dialog additions, and I even through in Spriggsy's Recycle Bin function.
Note: Linux users might be able to take out the Windows declare library stuff and get it to wok without recycle bin or persistency.
Be careful. This is just a WIP and it does manipulate files, see KILL statements, RENAME, etc. Use at your own risk. I highly recommend trying it out on some files you have copies off, backed, up, etc. I don't want users to lose any vids.
Happy Holidays Screw that, Merry Christmas!
Pete
So I'm putting together a little something for Windows that will be less obtrusive and more fun to use.
This is a fun project for me, because it utilizes some new tricks made possible by the QB64 Developers. The program makes use of _MESSAGEBOX, the folder and file dialog additions, and I even through in Spriggsy's Recycle Bin function.
Note: Linux users might be able to take out the Windows declare library stuff and get it to wok without recycle bin or persistency.
Be careful. This is just a WIP and it does manipulate files, see KILL statements, RENAME, etc. Use at your own risk. I highly recommend trying it out on some files you have copies off, backed, up, etc. I don't want users to lose any vids.
Code: (Select All)
' Pete's Video Naming Utility for Windows. Rename/Move/Copy/Delete videos as they play.
help:
Data VidName Video Renaming App.
Data "-----------------------------------------------------"
Data F1 to past the name of the file selected from a folder.
Data F2 or "File" button to Open a folder to select a file.
Data Enter or "Save" button to process the event.
Data Ctrl + D or "Dest" to select a destination folder for move or copy to a different folder.
Data Ctrl + D or "Dest" can also be used to add a folder to the scrolling mouse wheel list of folder destinations.
Data Ctrl + Enter or "Copy" button to copy the file to a different folder with rename options.
Data Ctrl + R to send file to the Recycle Bin.
Data Ctrl + Delete to PERMANENTLY delete file. No button. Hopefully "cat proof".
Data Right mouse click to display select all/cut/copy/paste/close menu actions in title bar. Scroll with mouse wheel inside app window and right or middle click to select.
Data Mouse wheel in app window to scroll folder list made with "Dest" selections.
Data Mouse wheel to scroll select all/cut/copy/paste/close menu actions if a right click was previously made to display those options in the title bar.
Data No need to type extensions. The extension will be the same as the loaded file.
Data Run app. A directory window will open. Select the folder then select a vid. Vid will open in the default video player.
Data The video name will appear highlighted in the input field. Make any edits to the name while watching the video.
Data Save the name to add the event to the queue. The app will ask to open the next vid to unlock the file from the player.
Data Esc or X in title bar at anytime to quit. The app will ask to save any event in the queue before exiting.
Data eof
Const HWND_TOPMOST%& = -1
Const SWP_NOSIZE%& = &H1
Const SWP_NOMOVE%& = &H2
Const SWP_SHOWWINDOW%& = &H40
Declare Dynamic Library "user32"
Function ShowWindow& (ByVal hwnd As _Offset, Byval nCmdShow As Long)
Function SetWindowPos& (ByVal hWnd As Long, Byval hWndInsertAfter As _Offset, Byval X As Integer, Byval Y As Integer, Byval cx As Integer, Byval cy As Integer, Byval uFlags As _Offset)
Function GetForegroundWindow& ' Current focused process handle.
End Declare
Dim Shared Myhwnd As Long, file$, win As windowvars, flag As Integer, autokey$
Dim Shared lb, mb, rb, my, mx, mw, shift%, clkcnt, drag ' Allows mouse in main.
Dim Shared nob, b_hover, b_active, button$(1 To 5), escape As _Bit, er
ReDim Shared y_btl(5), y_bbr(5), x_btl(5), x_bbr(5)
Dim Shared PastStatus%
Dim Shared restricted_keys$
restricted_keys$ = "<>:/\|?*" + Chr$(34)
Myhwnd = _WindowHandle ' Get hWnd value.
' SpriggsySpriggs Excellent Windows Files Function for Recycle Bin. Includes optional functions for Rename/Move/Copy.
'To - From, From - To Flags
Const FO_MOVE = &H1
Const FO_COPY = &H2
Const FO_DELETE = &H3
Const FO_RENAME = &H4
'File Op Flags
Const FOF_MULTIDESTFILES = &H1
Const FOF_CONFIRMMOUSE = &H2
Const FOF_SILENT = &H4
Const FOF_RENAMEONCOLLISION = &H8
Const FOF_NOCONFIRMATION = &H10
Const FOF_WANTMAPPINGHANDLE = &H20
Const FOF_ALLOWUNDO = &H40
Const FOF_FILESONLY = &H80
Const FOF_SIMPLEPROGRESS = &H100
Const FOF_NOCONFIRMMKDIR = &H200
Const FOF_NOERRORUI = &H400
Const FOF_NOCOPYSECURITYATTRIBS = &H800
Const FOF_NORECURSION = &H1000
Const FOF_NO_CONNECTED_ELEMENTS = &H2000
Const FOF_WANTNUKEWARNING = &H4000
Const FOF_NORECURSEREPARSE = &H8000
Const FOF_NO_UI = FOF_SILENT
'Return Values
Const DE_SAMEFILE = &H71
Const DE_MANYSRC1DEST = &H72
Const DE_DIFFDIR = &H73
Const DE_ROOTDIR = &H74
Const DE_OPCANCELLED = &H75
Const DE_DESTSUBTREE = &H76
Const DE_ACCESSDENIEDSRC = &H78
Const DE_PATHTOODEEP = &H79
Const DE_MANYDEST = &H7A
Const DE_INVALIDFILES = &H7C
Const DE_DESTSAMETREE = &H7D
Const DE_FLDDESTISFILE = &H7E
Const DE_FILEDESTISFLD = &H80
Const DE_FILENAMETOOLONG = &H81
Const DE_DEST_IS_CDROM = &H82
Const DE_DEST_IS_DVD = &H83
Const DE_DEST_IS_CDRECORD = &H84
Const DE_FILE_TOO_LARGE = &H85
Const DE_SRC_IS_CDROM = &H86
Const DE_SRC_IS_DVD = &H87
Const DE_SRC_IS_CDRECORD = &H88
Const DE_ERROR_MAX = &HB7
Const UNKNOWN = &H402
Const ERRORONDEST = &H10000
Const DE_ROOTDIR_ERRORONDEST = &H10074
Type SHFILEOPSTRUCTA
hwnd As _Offset
$If 64BIT Then
wfunc As _Unsigned _Integer64 'To - From, From - To Flags
$Else
wfunc AS _UNSIGNED LONG
$End If
pFrom As _Offset
pTo As _Offset
fFlags As Long
fAnyOperationsAborted As _Byte
hNameMappings As _Offset
lpszProgressTitle As _Offset
End Type
Type SHQUERYRBINFO
$If 64BIT Then
cbsize As _Integer64
i64Size As _Integer64
i64NumItems As _Integer64
$Else
cbsize AS LONG
i64Size AS _INTEGER64
i64NumItems AS _INTEGER64
$End If
End Type
Declare Dynamic Library "Shell32"
Function FileOperation% Alias SHFileOperationA (lpFileOp As SHFILEOPSTRUCTA)
End Declare
'--------------------------------------------------------------------------------------------------------------------
Width 50, 3
_Font 16
x = (_DesktopWidth \ 2) - _Width * 8 \ 2
y = _DesktopHeight - _Height * 16 - 70
_ScreenMove x, y
ReDim text$(1)
ReDim Shared index$(0)
Do
main b$, text$(), index$() ' main call #1
Loop
erhandler:
If Err = 75 Then
er = er + 1
If er < 3 Then
If _MessageBox(" Alert!", "Close video then click OK to process queue before exiting.", "okcancel", "question") = 0 Then
temp$ = "Process aborted."
If escape Then
temp$ = temp$ + " Exiting..."
End If
_Title temp$
_Delay 2.5
System
End If
Resume ' OK selected so retry.
End If
_Delay 2 ' Give some time to unlock previous file.
If er < 3 Then Resume ' Try again.
End If
_Title "Process error " + LTrim$(Str$(Err)) + " at line " + LTrim$(Str$(Erl))
End
Sub main (b$, text$(), index$())
Static form_style%, origtitle$, rflag, SourceFolder$, DestFolder$, target$, origqueue$, queue$, file$, ren$, ext$, f_cmsg$, noi, index, rt_click, rt_menu$(), InputOff
form_style% = 5
Do
If _Exit Then
If flag = 0 Or flag = 1 Then System ' Conditions 0 and 1.
b$ = "_exit"
End If
Select Case flag
Case 0
Color 15, 1: Locate 2, 3: iflag% = -1 ' Note: Triggers exit in Input routine.
MyInput text$(), form_style%, iflag%: iflag% = 0 ' Setup.
If flag = -1 Then flag = 0: Exit Do ' To main call #1
flag = 1
Exit Do ' To main call #1.
Case 1
flag = 2: InputOff = 1
Color 15, 1: Locate 2, 3: MyInput text$(), form_style%, iflag%: Color 15, 0
If flag = -1 Then flag = 0: Exit Do ' To main call #1.
Case 2
GoSub persistency_appearance '|--------------->
If Len(autokey$) Then
b_hover = 0: GoSub mouse_actions '|--------------->
Exit Do ' Back to main call #2 until autokey$ = "".
End If
If Len(HoldClipboard$) Then _Clipboard$ = HoldClipboard$: HoldClipboard$ = ""
If InputOff Then
If InputOff = 1 Then
b_hover = 0 ' Remove button highlighting.
GoSub mute_buttons '|--------------->
If rflag Then
origtitle$ = "F2 next video. (" + f_cmsg$ + " queued)."
Else
origtitle$ = "F2 load video."
End If
_Title origtitle$
Color 15, 0: Locate 2, 3: Print Space$(_Width - 4);: Locate 2, 3
text$(1) = ""
InputOff = 2
End If
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor.
GoSub mouse_actions '|--------------->
If Len(b$) Then
Select Case b$
Case Chr$(27), "_exit", Chr$(0) + Chr$(60), Chr$(0) + Chr$(59)
' Allow these keys to operate.
Case Else
b$ = "" ' Key blocked.
text$(1) = ""
Locate 2, 3: Print Space$(_Width - 4);: Locate 2, 3
End Select
End If
Else
If lb = 1 Or rb = 2 Or rt_click Then
If lb = 1 Then
If rt_click Then rt_click = 0: _Title origtitle$ ' Close right click menu.
Else
If rt_click = 0 Then
rt_click = 1
ReDim rt_menu$(6)
rt_menu$(1) = "Select All"
rt_menu$(2) = "Cut"
rt_menu$(3) = "Copy"
rt_menu$(4) = "Paste"
rt_menu$(5) = "Delete"
rt_menu$(6) = "Close"
_Title rt_menu$(1)
ElseIf mb = 2 Or rb = 2 Then
Select Case rt_click
Case 1: autokey$ = Chr$(1) ' Select all.
Case 2: autokey$ = Chr$(24) ' Cut.
Case 3: autokey$ = Chr$(3) ' Copy.
Case 4: autokey$ = Chr$(22) ' Paste.
Case 5: autokey$ = Chr$(0) + "S" ' Delete.
Case 6: ' Close right click menu here and upon selection.
End Select
rt_click = 0: _Title origtitle$
Exit Do
End If
End If
End If
GoSub mouse_actions '|--------------->
End If
If Len(text$(1)) Then
GoSub activate_buttons '|--------------->
Else
GoSub mute_buttons '|--------------->
End If
If Len(b$) Then
Select Case b$
Case Chr$(0) + Chr$(59)
Restore help
Do
Read d$
If d$ = "eof" Then Exit Do
help$ = help$ + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + d$
Loop
b_hover = 0: GoSub mouse_actions '|--------------->
_MessageBox " App Help", help$, "info"
mx = 0: my = 0
Case Chr$(0) + Chr$(60) ' Load new file [F2].
b_hover = 0 ' Remove button highlighting.
GoSub mouse_actions '|--------------->
temp$ = _OpenFileDialog$("Open video to rename, move, or copy...", "", "*.*", "", 0)
If Len(temp$) Then
If rflag And temp$ = target$ Then ' Same file conflict.
_MessageBox " Alert! Cannot select the same file until queue is processed.", "Press OK to redo selection.", "info"
_Continue ' Resuming menu selection.
End If
Else ' Resuming menu selection.
Exit Do ' To main call #2.
End If
target$ = temp$ ' File from source folder was selected from dialog menu.
SourceFolder$ = Mid$(target$, 1, _InStrRev(target$, "\"))
If rflag Then ' Event in queue. Process before loading next file.
_Title "Performing task in queue..."
_Delay 2.5
GoSub process1 '|--------------->
End If
InputOff = 0
If DestFolder$ = "" Then DestFolder$ = SourceFolder$
ext$ = Mid$(target$, _InStrRev(target$, "."))
temp$ = Mid$(target$, _InStrRev(target$, "\") + 1)
file$ = Mid$(temp$, 1, _InStrRev(temp$, ".") - 1)
HoldClipboard$ = _Clipboard$
_Clipboard$ = file$
autokey$ = Chr$(1) + "," + Chr$(22) + "," + Chr$(1) ' Paste file into empty input line.
_Title "Loading " + file$
Shell _Hide "start " + target$
origtitle$ = file$ + " : " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1) ' Remove trailing slash for appearance sake. (1 of 2).
_Title origtitle$
index$(0) = SourceFolder$
mki.CurShow = 1: Locate , , mki.CurShow ' Show cursor.
Exit Do ' To main call #2.
Case Chr$(0) + Chr$(134) ' Paste file name [F1]. Flag unchanged / remain in input loop.
temp$ = Mid$(target$, _InStrRev(target$, "\") + 1)
temp$ = Mid$(temp$, 1, _InStrRev(temp$, ".") - 1)
HoldClipboard$ = _Clipboard$
_Clipboard$ = temp$
autokey$ = Chr$(1) + "," + Chr$(22) + "," + Chr$(1)
Case Chr$(13) ' Process [Enter].
If Len(text$(1)) Then
If SourceFolder$ = DestFolder$ Then
If _FileExists(DestFolder$ + text$(1) + ext$) Then
_MessageBox " Alert!", "Destination folder already contains a file with this name." + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + "Press OK and redo.", "info"
Exit Do ' Cancel rename.
End If
f_cmsg$ = "Rename": rflag = 1 ' Rename file in source folder.
Else
If _FileExists(DestFolder$ + text$(1) + ext$) Then ' Check for existing file name.
j = 0
If _MessageBox(" Overwrite Alert!", Mid$(DestFolder$, 1, Len(DestFolder$) - 1) + " contains a file with this name." + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + "Do you want to overwrite the existing file?", "yesno", "question") = 1 Then
' Set to overwrite unless confirmation below is 'Cancel'.
If _MessageBox(" Overwrite Confirmation...", "Overwrite " + DestFolder$ + file$ + ext$, "okcancel", "question") = 0 Then ' Overwrite else cancel.
j = 1 ' Cancel overwrite. Resuming input.
End If
Else
j = 1 ' Cancel overwrite. Resuming input.
End If
If j = 1 Then ' Action canceled. Resuming input or file selection.
_Title "Move canceled."
_Delay 2.5
_Title origtitle$
Exit Do ' To main call #2.
End If
End If
If LCase$(text$(1)) = LCase$(file$) Then
f_cmsg$ = "Move": rflag = 2 ' Move file to destination folder.
Else
f_cmsg$ = "Move": rflag = 3 ' Move and rename source file to destination folder.
End If
End If
ren$ = text$(1)
origqueue$ = target$
queue$ = DestFolder$ + ren$ + ext$
InputOff = 1
Else
j = _MessageBox(" Alert! No Name.", "Click OK then type and enter a name for this file.", "ok", "info")
End If
Case Chr$(4) ' Set destination directory [Ctrl + D].
If Len(text$(1)) Then
If rflag = 0 Then ' Bypass if an event is waiting in the queue.
b_hover = 0 ' Remove button highlighting.
GoSub mouse_actions '|--------------->
temp$ = _SelectFolderDialog$("Select folder to move/copy to:", DestFolder$)
If Len(temp$) Then ' Change destination folder
DestFolder$ = temp$
If Right$(DestFolder$, 1) <> "\" Then DestFolder$ = DestFolder$ + "\"
origtitle$ = file$ + " : " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1) ' Remove trailing slash for appearance sake. (1 of 2).
_Title origtitle$
noi = noi + 1: ReDim _Preserve index$(noi): index$(noi) = DestFolder$ ' Add new folder to recent directory list.
End If
End If
Else
j = _MessageBox(" Alert! No Name.", "Click OK then type and enter a name for this file.", "ok", "info")
End If
Case Chr$(10) ' Copy to new folder [Ctrl + Enter]. Note: This selection does not use or require the queue.
If Len(text$(1)) Then
b_hover = 0 ' Remove button highlighting.
GoSub mouse_actions ' |--------------->
temp$ = _SelectFolderDialog$("Select folder to move/copy to:", DestFolder$) ' Open directory selection dialog.
If temp$ = "" Then ' Cancel change directory.
b$ = "": _Continue
End If
DestFolder$ = temp$ ' Folder selected from dialog. Continue copy process.
If Right$(DestFolder$, 1) <> "\" Then DestFolder$ = DestFolder$ + "\"
CopyID$ = "" ' Single place to nullify this non-static variable.
xcopy$ = text$(1) ' Local variable.
If _FileExists(DestFolder$ + text$(1) + ext$) Then ' Check for duplicate file name.
CopyID$ = "-Copy"
j = InStr(LCase$(xcopy$ + "."), "-copy.")
If j = 0 Then j = InStr(LCase$(xcopy$), "-copy(")
i = 0
If j Then
i = Val(Mid$(xcopy$, j + 6))
xcopy$ = Mid$(xcopy$, 1, j - 1)
End If
If i Then
CopyID$ = "-Copy" + "(" + LTrim$(Str$(i)) + ")": j = i - 1
Else
j = 0
End If
Do
temp$ = DestFolder$ + xcopy$ + CopyID$
temp2$ = CopyID$
j = j + 1
If j > 1 Then CopyID$ = "-Copy" + "(" + LTrim$(Str$(j)) + ")"
Loop While _FileExists(temp$ + ext$)
CopyID$ = temp2$
End If
If file$ = text$(1) Then ' Copy with same file name.
rflag = 4
f_cmsg$ = "Copy"
Else ' Rename and copy.
rflag = 5
f_cmsg$ = "Rename and copy"
End If
ren$ = xcopy$ + CopyID$
origqueue$ = target$
queue$ = DestFolder$ + ren$ + ext$
GoSub process1 '--------------->
Exit Do ' To main call #2 and then back to main call #1 via flag set in subroutine above.
Else
j = _MessageBox(" Alert! No Name.", "Click OK then type and enter a name for this file.", "ok", "info")
End If
Case Chr$(18) ' Recycle Bin (Function credited to SpriggsySpriggs).
j = Recycle(target$)
_Title file$ + " removed."
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor.
_Delay 2.5
file$ = "": ren$ = "": rflag = 0
InputOff = 1
Case Chr$(0) + Chr$(147) ' Ctrl + Del Permanently Delete.
Locate 2, 3: Print Space$(_Width - 5);: Locate 2, 3 ' Important: This location needs to be changed if the location of the input line is altered.
If _MessageBox(" Are you sure you want to PERMANENTLY delete this file?", Mid$(target$, _InStrRev(target$, "\") + 1), "yesno", "warning") Then
On Error GoTo erhandler
Kill target$ ' Permanently removes file.
_Title file$ + " removed."
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor.
_Delay 2.5
file$ = "": ren$ = "": rflag = 0
InputOff = 1
Else ' Cancel delete file.
_Title "Delete Aborted..."
_Delay 2.5
autokey$ = Chr$(0) + Chr$(134)
_Title origtitle$
End If
Case Chr$(27), "_exit"
If rflag Then ' Rename in queue.
escape = -1
GoSub process1 '|--------------->
End If
System
End Select
End If
Exit Do ' To main call #2 in input sub-routine.
End Select
Loop
Exit Sub '/-------------------------------->
persistency_appearance:
Select Case win.focus
Case 1
Palette 1, 7: Palette 15, 56
win.focus = -win.focus
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor
_Title "Click to regain focus..."
Case 2
Palette 1, 1: Palette 15, 63
win.focus = -win.focus
mki.CurShow = 1: Locate , , mki.CurShow ' Show cursor
_Title origtitle$
End Select
Return
mouse_actions:
If b_hover <> b_active Then ' Hover off or unhighlight active button.
If b_active Then ' Unhighlight active button.
If y_btl(b_active) > 0 Then
y = CsrLin: x = Pos(0)
s1color = _DefaultColor: s2color = _BackgroundColor
Locate y_btl(b_active), x_btl(b_active) - 1
Color 15, 1
Print " " + button$(b_active) + " ";
Color s1color, s2color
Locate y, x
End If
b_active = 0
End If
If b_hover Then ' Highlight and make a button active.
b_active = b_hover
If y_btl(b_active) > 0 Then
y = CsrLin: x = Pos(0)
s1color = _DefaultColor: s2color = _BackgroundColor
Locate y_btl(b_active), x_btl(b_active) - 1
If Abs(win.focus) = 2 Then Palette 2, 17 Else Palette 2, 63 ' Hover highlighting when window is active or inactive. -2 in focus -1 lost focus.
Color 2, 1: Print Chr$(222); Space$(Len(button$(b_active))); Chr$(221);
Locate y_btl(b_active), x_btl(b_active)
Color 15, 2
Print button$(b_active);
Color s1color, s2color
Locate y, x
End If
End If
Else ' Hover on active button.
If lb = 2 Then ' Select active button.
Select Case b_active
Case 1: b$ = Chr$(0) + Chr$(60) ' F2 Open file.
Case 2: b$ = Chr$(13) ' Enter Process file.
Case 3: b$ = Chr$(4) ' Ctrl + D Select destination folder.
Case 4: b$ = Chr$(10) ' Ctrl + Enter Copy.
Case 5: b$ = Chr$(0) + Chr$(59) ' F1 Help.
End Select
Palette 2, 35
_Delay .1
Palette 2, 17
End If
End If
If mw Then
Select Case rt_click
Case 0
j = index: i = UBound(index$)
index = index + mw
If index > i Then
index = 0
ElseIf index < 0 Then
index = UBound(index$)
End If
If j <> index Then
DestFolder$ = index$(index)
If Right$(DestFolder$, 1) <> "\" Then DestFolder$ = DestFolder$ + "\"
origtitle$ = file$ + " Dest " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1)
_Title origtitle$
End If
Case Else ' Right click menu is open in title bar.
rt_click = rt_click + mw
If rt_click = 0 Then rt_click = 6
If rt_click > 6 Then rt_click = 1
_Title rt_menu$(rt_click)
End Select
End If
Return
mute_buttons:
If y_btl(2) > 0 Then
y = CsrLin: x = Pos(0)
s1color = _DefaultColor: s2color = _BackgroundColor
For i = 1 To nob - 1 ' Allows last button help to always be active.
If i = 1 Then Color 15, 1 Else Color 8, 1
Locate y_btl(i), x_btl(i) - 1: Print " " + button$(i) + " ";
If i <> 1 Then y_btl(i) = -Abs(y_btl(i)): y_bbr(i) = -Abs(y_bbr(i))
If i <> 1 Then x_btl(i) = -Abs(x_btl(i)): x_bbr(i) = -Abs(x_bbr(i))
Next
b_active = 0 ' Must deactivate button before next cycle to avoid negative locate values in mouse_actions routine.
Color s1color, s2color
Locate y, x
End If
Return
activate_buttons:
If y_btl(2) < 0 Then
y = CsrLin: x = Pos(0)
s1color = _DefaultColor: s2color = _BackgroundColor
Color 15, 1
For i = 1 To nob
y_btl(i) = Abs(y_btl(i)): y_bbr(i) = Abs(y_bbr(i))
x_btl(i) = Abs(x_btl(i)): x_bbr(i) = Abs(x_bbr(i))
Locate y_btl(i), x_btl(i) - 1: Print " " + button$(i) + " ";
Next
b_active = 0
Color s1color, s2color
Locate y, x
End If
Return
process1:
b_hover = 0 ' Remove button highlighting.
GoSub mouse_actions '|--------------->
Select Case rflag
Case 1 ' Rename to same folder.
temp$ = "Naming " + file$ + " as " + ren$
Case 2 ' Move.
temp$ = file$ + " to " + queue$
Case 3 ' Move and rename.
temp$ = "Moving " + ren$ + " to " + queue$
Case 4 ' Copy to same folder with -copy added.
temp$ = file$ + " copying as " + ren$
Case 5 ' Copy and move.
temp$ = file$ + " copying to " + queue$
End Select
_Title temp$
If rflag < 4 Then _Delay 2.5 Else _Delay 1
If escape Then
If _MessageBox(" Process queue before exiting?", temp$, "yesno", "question") = 0 Then
_Title "Queue aborted. Exiting..."
_Delay 2.5
System
End If
End If
copy_switch = 1
On Error GoTo erhandler
Select Case rflag
Case 1 ' Rename in queue.
Name origqueue$ As queue$
Case 2, 3 ' Move in queue.
If move_switch = 0 Then
If _FileExists(queue$) Then Kill queue$
Name origqueue$ As queue$
Else
Shell _Hide _DontWait "move " + origqueue$ + " " + queue$ ' (DOS Alternative).
End If
Case 4, 5 ' Copy in queue.
On Error GoTo 0
Select Case copy_switch
Case 0 ' Copy without progress report.
Open origqueue$ For Binary As #1
a$ = Space$(LOF(1))
Get #1, , a$
Close #1
Open queue$ For Binary As #1
Put #1, , a$
Close #1
Case 1 ' Copy with progress report.
Open origqueue$ For Binary As #1
i&& = LOF(1)
If i&& < 10000001 Then
a$ = Space$(i)
Get #1, , a$
Close #1
Open queue$ For Binary As #1
Put #1, , a$
Else
a$ = Space$(1000000)
temp$ = origtitle$
Open queue$ For Binary As #2
h&& = i&& \ 1000000
j = i&& Mod 1000000
For k&& = 1 To h&&
Get #1, , a$
Put #2, , a$
l&& = (k&& * 1000000 * 100) \ i&&
_Title "Copying: " + LTrim$(Str$(l&&)) + "%"
Next
If j Then a$ = Space$(j): Get #1, , a$: Put #2, , a$
Close #1, #2
_Title "Copying: 100%"
_Delay 1
End If
Close #1
If rflag = 4 Then origtitle$ = file$ + " : " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1) ' Remove trailing slash for appearance sake. (1 of 2).
If rflag = 5 Then ' Copy rename original file option.
temp$ = SourceFolder$ + xcopy$ + ext$
If _FileExists(temp$) Then
_MessageBox " Alert!", " Copy completed but there is no" + Chr$(13) + Chr$(10) + " option to rename the original file" + Chr$(13) + Chr$(10) + " because a file with this name already" + Chr$(13) + Chr$(10) + " exists in the source folder." + Chr$(13) + Chr$(10) + Chr$(13) + Chr$(10) + " Press OK to continue."
origtitle$ = file$ + " : " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1) ' Remove trailing slash for appearance sake. (1 of 2).
Else
If _MessageBox(" Also rename original file?", file$ + " to " + text$(1), "yesno", "question") Then
Name origqueue$ As temp$
origtitle$ = ren$ + " : " + Mid$(DestFolder$, 1, Len(DestFolder$) - 1) ' Remove trailing slash for appearance sake. (1 of 2).
End If
End If
End If
Case Else ' DOS copy to allow program to continue while copying takes place in the background.
Shell _Hide _DontWait "copy " + origqueue$ + " " + queue$ ' (DOS Alternative).
End Select
End Select
On Error GoTo 0
er = 0 ' Set error counter back to zero.
Select Case rflag
Case 1: temp$ = "Rename completed."
Case 2: temp$ = "Move completed."
Case 3: temp$ = "Move & Rename completed."
Case 4: temp$ = "Copy completed."
Case 5: temp$ = "Copy & Rename completed."
End Select
If escape Then temp$ = temp$ + " Exiting..."
_Title temp$
_Delay 2.5
If rflag = 4 Or rflag = 5 Then
_Title origtitle$
End If
rflag = 0
origqueue$ = "": queue$ = "": ren$ = "": ext$ = "": f_cmsg$ = "": rt_click = 0
b_hover = 0: b_active = 0
Return
End Sub
Sub Persistency (Myhwnd)
Type windowvars
focus As Integer
End Type
FGwin& = GetForegroundWindow&
If Myhwnd <> FGwin& Then ' App lost focus.
y& = SetWindowPos&(Myhwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE + SWP_SHOWWINDOW)
If win.focus <> -1 Then win.focus = 1
Else
If win.focus <> -2 Then win.focus = 2
End If
End Sub
Sub MyInput (text$(), form_style%, iflag%) ' Single line keyboard routine for input.
Dim As Integer tabx, tabmax
Dim mhlinput As _Bit
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
Type inputvars
CurStyle As Integer
CurShow As Integer
hl1 As Integer
hl2 As Integer
fld As Integer
mhovery As Integer
mhoverx As Integer
mvar As Integer
mtop As Integer
mleft As Integer
myclose As Integer
mxclose As Integer
page_color As Integer
skin_frg As Integer
skin_bkg As Integer
input_frg As Integer
input_bkg As Integer
skin_shadow_frg As Integer
skin_shadow_bkg As Integer
mwidth As Integer
mheight As Integer
End Type
Dim mki As inputvars
If mki.CurStyle = 0 Then mki.CurStyle = 7: mki.CurShow = 1 ' Default cursor.
MyInput_User_Defined_Variables mki, form_style%
MyInput_Skin mki, form_style%
If form_style% Then
Restore MyFormData
j = 0: noe = 7 ' Number of elements in each data field.
Do
Read a$
If a$ = "eof" Then If j = 0 Then mki.fld = 1: Exit Do Else Exit Do
j = j + 1
If j Mod noe = 1 Then mki.fld = mki.fld + 1 ' Number of fields from our data statement.
Loop
Else
mki.fld = 1: j = 0
End If
ReDim ncol(mki.fld) ' Name start column.
ReDim nfield$(mki.fld) ' Name.
ReDim yfield(mki.fld) ' Row.
ReDim xfield(mki.fld) ' Column.
ReDim flen(mki.fld) ' Field length.
ReDim maxflen(mki.fld) ' Max text length.
ReDim text$(mki.fld) ' Text input
If j = 0 Then ' No data so default to single line input.
ncol(1) = 1
nfield$(1) = ""
yfield(1) = CsrLin
xfield(1) = Pos(0)
flen(1) = _Width - Pos(0)
maxflen(1) = flen(1) * 2
text$(1) = ""
nof% = 1
Color mki.skin_bkg, mki.input_bkg
Locate yfield(1), xfield(1) - 1: Print Chr$(221);
Color mki.input_frg, mki.input_bkg: Print Space$(flen(1));
Else
Restore MyFormData: nof% = 0
Do ' Faux loop.
For i = 1 To mki.fld
For j = 1 To noe: Read a$: If a$ = "eof" Then Exit Do
Select Case j
Case 1: ncol(i) = Val(a$) + mki.mleft
Case 2: nfield$(i) = a$
Case 3: yfield(i) = Val(a$) + mki.mtop
Case 4: xfield(i) = Val(a$) + mki.mleft
Case 5: flen(i) = Val(a$)
Case 6: maxflen(i) = Val(a$)
Case 7
text$(i) = a$
Color mki.skin_frg, mki.skin_bkg
Locate yfield(i), ncol(i): Print nfield$(i);
Color mki.skin_bkg, mki.input_bkg
Locate yfield(i), xfield(i) - 1: Print Chr$(221);
Color mki.input_frg, mki.input_bkg: Print Space$(flen(i));
Locate yfield(i), xfield(i): Print text$(i);
End Select
Next j
nof% = nof% + 1
Next
Loop
End If
mki.fld = 1: tabx = 1: tabmax = nof%
If tabx = 0 Then tabx = 1
ml = xfield(mki.fld)
mr = xfield(mki.fld) + flen(mki.fld)
y = yfield(mki.fld): x = xfield(mki.fld) ' Initial cursor position.
mki.CurShow = 1: Locate y, x, mki.CurShow, 7, mki.CurStyle ' Show cursor.
Do
_Limit 60
string_pos = Pos(0) - ml ' Track text position from 0 to maxflen(mki.fld).
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$
If InStr(restricted_keys$, LCase$(b$)) And Len(b$) = 1 Then
_MessageBox " Invalid character.", "File names cannot contain the following characters: " + restricted_keys$, "info"
b$ = ""
End If
If mki.myclose Then ' Self contained close on x click routine. Includes hover and left click release.
If my = mki.myclose And mx = mki.mxclose Or mhover_close Then
If mhover_close And lb = 2 Then Exit Do ' Close popup and exit input routine.
y = CsrLin: x = Pos(0)
s1color = _DefaultColor: s2color = _BackgroundColor
j = mhover_close
If my = mki.myclose And mx = mki.mxclose Then
If mhover_close = 0 Then Color mki.skin_bkg, 4: mhover_close = 1
Else
If mhover_close Then Color mki.skin_frg, mki.skin_bkg: mhover_close = 0
End If
If j <> mhover_close Then
Locate mki.myclose, mki.mxclose - 1: Print " x ";
Color s1color, s2color
Locate y, x
End If
End If
End If
If drag = 0 And mhlinput Then mhlinput = 0 ' Quit mouse input line highlighting.
If lb > 0 Or drag Then ' Mouse button events.
Do
If drag Then
If my = yfield(mki.fld) Or mhlinput Then
If mx >= ml - hscr And mx <= ml + Len(text$(mki.fld)) - hscr Or mhlinput Then
mhlinput = -1
If drag > 0 Then
If mx > Pos(0) - 1 Then
shift% = -1: GoSub cursor_forward '|--------------->
string_pos = Pos(0) - ml
y = CsrLin: x = Pos(0)
End If
Else
If mx < Pos(0) Then
shift% = -1: GoSub cursor_back '|--------------->
string_pos = Pos(0) - ml
y = CsrLin: x = Pos(0)
End If
End If
End If
Exit Do
End If
End If
If lb = 1 Or clkcnt Then
For i = 1 To UBound(yfield) ' Find input line.
If my = yfield(i) And mx >= xfield(i) And mx <= xfield(i) + flen(i) Then ' Mouse cursor in an input field.
If hl Then GoSub hl_off '|--------------->
Rem If i <> 1 Then If text$(1) = "" Then Beep: Exit Do ' Unique restriction when no text is present in first input field.
mki.fld = i: tabx = i
If clkcnt Then
GoSub select_all '|--------------->
Else
GoSub mouse_click_relocate '|--------------->
End If
y = CsrLin: x = Pos(0)
Exit For
End If
Next
Exit Do
End If
If lb = 2 Then ' Mouse button pressed and released.
'</----------------------- USER DEFINED ROUTINE -----------------------/>
Exit Do
End If
Exit Do
Loop
End If
If rb = 2 Then ' Right mouse button released.
If mki.mvar < 1 Then
If my <> yfield(mki.fld) Then ' Check for change input field click.
For i = 1 To UBound(yfield)
If my = yfield(i) Then ' Change input fields.
Rem If i <> 1 Then If text$(1) = "" Then Beep: Exit Do ' Unique restriction when no text is present in first input field.
If i <> mki.fld Then ' Remove any highlighting ifinput line is being changed.
If hl Then GoSub hl_off '|--------------->
End If
mki.fld = i: tabx = i
GoSub mouse_click_relocate '|--------------->
Exit For
End If
Next
End If
MyInput_PopUp mki, menu$(), text$(), b$, hl
mki.CurShow = 1: Locate , , mki.CurShow, 7, mki.CurStyle ' Show cursor
Select Case mki.mvar
Case 1: b$ = Chr$(24) ' Cut
Case 2: b$ = Chr$(3) ' Copy
Case 3: b$ = Chr$(22) ' Paste
Case 4: b$ = Chr$(0) + "S" ' Delete
Case 5: b$ = Chr$(1) ' Select All
Case 6 ' Do nothing. (Close Menu).
End Select
mki.mvar = 0
End If
End If
If Len(b$) Then
Select Case b$
Case Chr$(27) ' Esc key.
Rem Exit Do ' Leave sub.
Case Chr$(9) ' Tab key. Change text fields.
If hl Then GoSub hl_off: GoSub cur_home '|--------------->
If tabmax > 1 Then
mki.fld = mki.fld + 1: If mki.fld > UBound(yfield) Then mki.fld = 1
Locate yfield(mki.fld), xfield(mki.fld)
tabx = tabx + 1: If tabx > tabmax Then tabx = 1
Rem Exit Do ' Leave sub but maintain window if a flow-through design is adopted.
End If
Case Chr$(13) ' Enter key.
If hl Then GoSub hl_off '|--------------->
'</----------------------- USER DEFINED ROUTINE -----------------------/>
Rem Exit Do ' Leave sub.
Case Chr$(8) ' Backspace key.
GoSub backspace '|--------------->
Case Chr$(0) + "S" ' Delete key.
GoSub delete '|--------------->
Case Chr$(0) + "M" ' Arrow right key.
GoSub cursor_forward '|--------------->
Case Chr$(0) + "K" ' Arrow left key.
GoSub cursor_back '|--------------->
Case Chr$(0) + "t" ' Ctrl + Arrow right key.
GoSub ctrl_rt '|--------------->
Case Chr$(0) + "s" ' Ctrl + Arrow left key.
GoSub ctrl_lt '|--------------->
Case Chr$(0) + "G" ' Home
GoSub cur_home '|--------------->
Case Chr$(0) + "O" ' End
GoSub cur_end '|--------------->
Case Chr$(0) + "R" ' Insert/overwrite toggle.
ovw = 1 - ovw
If ovw Then mki.CurStyle = 30 Else mki.CurStyle = 7
Locate , , mki.CurShow, 7, mki.CurStyle ' Change cursor appearance. Assumes cursor is shown, not hidden.
Case Chr$(22) ' Ctrl + V - Paste
GoSub paste '|--------------->
Case Chr$(3) ' Ctrl + C - Copy
GoSub copy '|--------------->
Case Chr$(24) ' Ctrl + X - Cut
GoSub cut '|--------------->
Case Chr$(1) ' Select all.
GoSub select_all '|--------------->
Case Chr$(32) To "z"
If tabx < 3 Then GoSub print_chr '|--------------->
End Select
y = CsrLin: x = Pos(0) ' Track cursor.
End If
If iflag% = -1 Then Exit Sub
' Special to this app only.-----------------------------
Persistency Myhwnd
main b$, text$(), index$(): If flag = -1 Then Exit Sub
'-------------------------------------------------------
Loop
If form_style% < 0 Then PCopy 2, 0 ' Close popup.
hscr = 0: mki.mhovery = 0: mki.mhoverx = 0: mhlinput = 0: tabx = 0: mki.fld = 0
Color restore_color1, restore_color2
Exit Sub
print_chr:
If hl Then GoSub cut '|--------------->
string_pos = Pos(0) - ml
If string_pos + ml < mr - 1 And Len(text$(mki.fld)) < flen(mki.fld) - 1 Then
If ml + Len(text$(mki.fld)) < mr Then
text$(mki.fld) = Mid$(text$(mki.fld), 1, string_pos) + b$ + Mid$(text$(mki.fld), string_pos + 1 + ovw)
Locate , ml: Print Space$(flen(mki.fld));: Locate , ml
Print text$(mki.fld);
Locate , ml + string_pos + 1
End If
Else ' Horizontal scrolling.
If Len(text$(mki.fld)) < maxflen(mki.fld) Then
If string_pos = flen(mki.fld) - 1 Or string_pos = flen(mki.fld) - 2 And string_pos < Len(text$(mki.fld)) - hscr - 1 Then
j = 1 ' At right margin.
ElseIf string_pos = Len(text$(mki.fld)) - hscr Then
j = 0 ' Cursor leading text.
Else
j = 0 ' Cursor inside text.
End If
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos) + b$ + Mid$(text$(mki.fld), hscr + string_pos + 1 + ovw)
hscr = hscr + j
Locate , ml
If ovw Then Print Space$(flen(mki.fld));: Locate , ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , ml + string_pos + 1 - j
End If
End If
Return
backspace:
If hl And shift% = 0 Then GoSub cut: Return '|--------------->
If string_pos = 0 And hscr > 0 Or string_pos > 0 Then
If hl Then GoSub hl_off '|--------------->
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos - 1) + Mid$(text$(mki.fld), hscr + string_pos + 1)
If hscr Then hscr = hscr - 1: j = 0 Else j = 1
Locate , ml: Print Space$(flen(mki.fld));
Locate , ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , x - j
End If
Return
delete:
If hl Then
GoSub cut '|--------------->
Else
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos) + Mid$(text$(mki.fld), hscr + string_pos + 2)
Locate , ml: Print Space$(flen(mki.fld));
Locate , ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , x
End If
Return
cur_home:
Do
GoSub cursor_back '|--------------->
string_pos = Pos(0) - ml
Loop Until hscr = 0 And string_pos = 0
Return
cur_end:
Do
GoSub cursor_forward '|--------------->
string_pos = Pos(0) - ml
Loop Until string_pos + 1 > Len(text$(mki.fld)) - hscr
Return
cursor_forward:
If hl And shift% = 0 Then GoSub hl_off '|--------------->
If string_pos + 1 <= Len(text$(mki.fld)) - hscr Then
If ml + string_pos + 1 = mr And Len(text$(mki.fld)) > flen(mki.fld) And shift% = 0 Then
hscr = hscr + 1
Locate , ml: Print Space$(flen(mki.fld));: Locate , ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
If string_pos <> Len(text$(mki.fld)) - hscr Then Locate , Pos(0) - 1
ElseIf shift% And string_pos < Len(text$(mki.fld)) - hscr Then
If string_pos = flen(mki.fld) - 1 Then
hscr = hscr + 1
Color mki.input_frg, mki.input_bkg
Locate , ml: Print Space$(flen(mki.fld));: Locate , ml
If string_pos - hl > flen(mki.fld) Then
Print Mid$(text$(mki.fld), hscr + 1, (flen(mki.fld)) - 1);
Else
Print Mid$(text$(mki.fld), hscr + 1, string_pos - hl - 1);
End If
If hl < 0 Then Color mki.input_frg, mki.input_bkg Else Color mki.hl1, mki.hl2
hl = hl + 1
If Pos(0) = ml Then
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld) - 1);
Else
Print Mid$(text$(mki.fld), hscr + 1 + string_pos - hl, (flen(mki.fld)) - (string_pos - hl) - 1);
End If
Else
If hl < 0 Then Color mki.input_frg Else Color mki.hl1, mki.hl2
hl = hl + 1
Print Mid$(text$(mki.fld), hscr + string_pos + 1, 1);
End If
Else
If hl Then GoSub hl_off '|--------------->
If Pos(0) < mr Then Locate , Pos(0) + 1
End If
Color mki.input_frg
End If
Return
cursor_back:
If hl And shift% = 0 Then GoSub hl_off '|--------------->
If string_pos = 0 And shift% = 0 Then
If hscr Then hscr = hscr - 1: Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));: Locate , ml
ElseIf shift% Then
If string_pos = 0 Then
If hscr Then
hscr = hscr - 1
If hl > 0 Then Color mki.input_frg, mki.input_bkg Else Color mki.hl1, mki.hl2
hl = hl - 1
j = Abs(hl): If j > (flen(mki.fld)) Then j = flen(mki.fld)
Print Mid$(text$(mki.fld), hscr + 1, j);
Color mki.input_frg, mki.input_bkg: Print Mid$(text$(mki.fld), hscr + 1 + j, (flen(mki.fld)) - j);
Locate , ml
End If
Else
Locate , Pos(0) - 1
If hl > 0 Then Color mki.input_frg, mki.input_bkg Else Color mki.hl1, mki.hl2
Print Mid$(text$(mki.fld), hscr + string_pos, 1);
Locate , Pos(0) - 1
hl = hl - 1
End If
Color mki.input_frg, mki.input_bkg
Else
If hl Then GoSub hl_off '|--------------->
Locate , Pos(0) - 1
End If
Return
ctrl_rt:
Do
GoSub cursor_forward '|--------------->
string_pos = Pos(0) - ml
Loop Until Mid$(text$(mki.fld), hscr + string_pos, 1) = " " Or string_pos >= Len(text$(mki.fld)) - hscr
Return
ctrl_lt:
Do
GoSub cursor_back '|--------------->
string_pos = Pos(0) - ml
Loop Until Mid$(text$(mki.fld), hscr + string_pos, 1) = " " Or Pos(0) = ml And hscr = 0
Return
hl_off:
j = Pos(0)
Locate , ml
Color mki.input_frg, mki.input_bkg
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , j
hl = 0
Return
cut:
Color mki.input_frg, mki.input_bkg
Select Case hl
Case Is > 0
If b$ = Chr$(24) Then _Clipboard$ = Mid$(text$(mki.fld), string_pos + 1 + hscr - hl, hl) ' Only copy to clipboard for 'cut' and not delete or paste over highlighted text calls.
j = ml + string_pos - hl
Locate , ml
Print Space$(flen(mki.fld));
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos - hl) + Mid$(text$(mki.fld), hscr + string_pos + 1)
Locate , ml
If j < ml Then hscr = hscr + string_pos - hl: j = ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , j
Case 0
' Do nothing
Case Is < 0
If b$ <> Chr$(0) + "S" Then _Clipboard$ = Mid$(text$(mki.fld), string_pos + 1 + hscr, Abs(hl))
Locate , ml
Print Space$(flen(mki.fld));
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos) + Mid$(text$(mki.fld), hscr + string_pos + 1 + Abs(hl))
Locate , ml
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , ml + string_pos
End Select
hl = 0 ' No need for hl_off.
Return
copy:
Select Case hl
Case Len(text$(mki.fld)) ' Select all.
_Clipboard$ = text$(mki.fld)
Case 1 To Len(text$(mki.fld)) - 1
_Clipboard$ = Mid$(text$(mki.fld), string_pos + 1 - hl, hl)
Case 0
' Do nothing
Case Is < 0
_Clipboard$ = Mid$(text$(mki.fld), string_pos + 1, Abs(hl))
End Select
Return
paste:
If Len(_Clipboard$) Then
If InStr(_Clipboard$, Chr$(13)) Then
tmp$ = "": j = 0
For i = 1 To Len(_Clipboard$)
x$ = Mid$(_Clipboard$, i, 1)
If x$ = Chr$(13) And j = 0 Then
tmp$ = tmp$ + " "
j = -1
Else
If Asc(x$) > 32 Then j = 0
If j = 0 Then tmp$ = tmp$ + x$
End If
Next
Else
tmp$ = _Clipboard$
End If
If Len(text$(mki.fld)) - Abs(hl) + Len(tmp$) <= maxflen(mki.fld) Then
If hl Then GoSub cut '|--------------->
text$(mki.fld) = Mid$(text$(mki.fld), 1, hscr + string_pos) + tmp$ + Mid$(text$(mki.fld), hscr + string_pos + 1)
If Pos(0) + Len(tmp$) + 1 >= mr Then
i = hscr
hscr = hscr + Pos(0) + Len(tmp$) + 1 - mr
j = Pos(0) + Len(tmp$) - (hscr - i)
Else
j = Pos(0) + Len(tmp$)
End If
Locate , ml: Print Space$(flen(mki.fld));
Locate , ml: Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Locate , j
PastStatus% = 0 ' Paste successful.
Else
Beep: PastStatus% = 1 ' Too many characters to paste.
End If
End If
Return
select_all:
GoSub cur_end '|--------------->
hl = Len(text$(mki.fld))
Locate , ml
Color mki.hl1, mki.hl2
Print Mid$(text$(mki.fld), hscr + 1, flen(mki.fld));
Color mki.input_frg, mki.input_bkg
Return
mouse_click_relocate:
If text$(mki.fld) = "" Then
Locate yfield(mki.fld), ml: Print Mid$(text$(mki.fld), 1, flen(mki.fld));
Else
If mx <= xfield(mki.fld) + Len(text$(mki.fld)) Then
Locate my, mx
Else
If Len(text$(mki.fld)) >= flen(mki.fld) - 1 Then
Locate yfield(mki.fld), xfield(mki.fld) + flen(mki.fld) - 1
Else
Locate yfield(mki.fld), xfield(mki.fld) + Len(text$(mki.fld))
End If
End If
End If
Return
End Sub
Sub MyInput_User_Defined_Variables (mki As inputvars, form_style%)
' Set form_style% here if it is not being imported from calling routine.
nob = 5 ' Number of buttons.
y_called = CsrLin: x_called = Pos(0)
skin_save_frg = _DefaultColor: skin_save_bgd = _BackgroundColor
mki.page_color = _BackgroundColor
mki.hl1 = 0
mki.hl2 = 6: Palette 6, 46
mki.input_frg = 15
mki.input_bkg = 0
mki.skin_frg = 3
mki.skin_bkg = 5
mki.skin_shadow_frg = 8
mki.skin_shadow_bkg = 0
Palette mki.skin_frg, 1
Palette mki.skin_bkg, 63
Select Case form_style%
Case -1 ' Popup
mki.mtop = 3: mki.mleft = 5: mki.mwidth = 60: mki.mheight = 8
PCopy 0, 2
Case 0 ' No skin
Color , mki.page_color: Cls
mki.mtop = 1: mki.mleft = 1
mki.skin_frg = 1
mki.skin_bkg = mki.page_color
Case 1 ' Divider top and bottom
mki.mtop = 2: mki.mleft = 1
mki.skin_frg = 15
mki.skin_bkg = mki.page_color
Case 2 ' Frame
mki.mtop = 1: mki.mleft = 1: mki.mwidth = _Width: mki.mheight = _Height
mki.skin_frg = 15
mki.skin_bkg = mki.page_color
Case 3 ' Frame with top menu option.
mki.mtop = 2: mki.mleft = 1: mki.mwidth = _Width: mki.mheight = _Height - 1
mki.skin_frg = 15
mki.skin_bkg = mki.page_color
Case 4 ' Frame with top and bottom menu options.
mki.mtop = 2: mki.mleft = 1: mki.mwidth = _Width: mki.mheight = _Height - 2
mki.skin_frg = 15
mki.skin_bkg = mki.page_color
Case Else ' <------ User Defined.
mki.mtop = 1: mki.mleft = 1: mki.mwidth = _Width: mki.mheight = _Height
mki.skin_frg = 15
mki.skin_bkg = mki.page_color
End Select
MyFormData: ' Name column, name, input row, input column, input length, max length, initial text. Note eof must be lowercase.
Data eof
PopupMenuData: ' eof must be lowercase.
Data Cut.........Ctrl+X,Copy........Ctrl+C,Paste.......Ctrl+V,Clear..........Del,Select All..Ctrl+A
Data Close..........Esc,eof
Color skin_save_frg, skin_save_bgd
Locate y_called, x_called
End Sub
Sub MyInput_Skin (mki As inputvars, form_style%)
y_called = CsrLin: x_called = Pos(0)
skin_save_frg = _DefaultColor: skin_save_bgd = _BackgroundColor
Color mki.skin_frg, mki.skin_bkg
If form_style% > 0 Then Color , mki.page_color: Cls
Select Case form_style%
Case 1
Locate mki.mtop, mki.mleft
Color mki.skin_frg, mki.skin_bkg
Print String$(_Width, 196);
Locate _Height - 1, mki.mleft: Print String$(_Width, 196);
Case -1, 2, 3, 4
Locate mki.mtop, mki.mleft
Print Chr$(218) + String$(mki.mwidth - 2, 196) + Chr$(191)
j = CsrLin
For i = 1 To mki.mheight - 2
If CsrLin < _Height Then Locate j, mki.mleft Else Locate , mki.mleft
Print Chr$(179); Space$(mki.mwidth - 2) + Chr$(179);
j = j + 1
Next
Locate j, mki.mleft
Print Chr$(192) + String$(mki.mwidth - 2, 196) + Chr$(217);
Case Else ' <-------USER DEFINED SKIN GOES HERE.
Locate mki.mtop, mki.mleft
Print Chr$(218) + String$(mki.mwidth - 2, 196) + Chr$(191)
j = CsrLin
For i = 1 To mki.mheight - 2
If CsrLin < _Height Then Locate j, mki.mleft Else Locate , mki.mleft
Print Chr$(179); Space$(mki.mwidth - 2) + Chr$(179);
j = j + 1
Next
Locate j, mki.mleft
Print Chr$(192) + String$(mki.mwidth - 2, 196) + Chr$(217);
button$(1) = "File": button$(2) = "Save": button$(3) = "Dest": button$(4) = "Copy": button$(5) = "Help"
Locate mki.mtop, mki.mleft + 1: Print " " + button$(1) + " ";
y_btl(1) = mki.mtop: y_bbr(1) = y_btl(1)
x_btl(1) = mki.mleft + 2: x_bbr(1) = x_btl(1) + Len(button$(1)) - 1
Locate mki.mtop, mki.mleft + mki.mwidth - 22
Print " ";
For i = 2 To nob
Print button$(i) + " ";
y_btl(i) = mki.mtop: y_bbr(i) = y_btl(i)
x_btl(i) = mki.mleft + mki.mwidth - 22 + (i - 1) * (Len(button$(i)) + 1) - Len(button$(i)): x_bbr(i) = x_btl(i) + Len(button$(i)) - 1
Next
End Select
If form_style% < 0 Then ' Shadow effects for popup win.
' Shadow below.
Color mki.skin_shadow_frg, mki.skin_shadow_bkg
Locate CsrLin + 1, mki.mleft + 2
For i = 1 To mki.mwidth
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
Next
' Shadow to right.
Locate mki.mtop + 1
For i = 1 To mki.mheight - 1
Locate , mki.mleft + mki.mwidth
j = Screen(CsrLin, Pos(0))
Print Chr$(j);
j = Screen(CsrLin, Pos(0))
Print Chr$(j)
Next
Color mki.skin_frg, mki.skin_bkg
Locate mki.mtop, mki.mleft + mki.mwidth - 4
mki.myclose = mki.mtop: mki.mxclose = mki.mleft + mki.mwidth - 3
Print " x "; ' Close symbol.
End If
Color skin_save_frg, skin_save_bgd
Locate y_called, x_called
End Sub
Sub MyInput_PopUp (mki As inputvars, menu$(), text$(), b$, hl) ' Self-contained subroutine.
Static initialize_menu, WinCon.noi, oldmy, cp1, cp2, cp3, cp4, cp5
restore_color1 = _DefaultColor: restore_color2 = _BackgroundColor
If initialize_menu = 0 Then
initialize_menu = 1
cp1 = 0 ' Available menu item.
cp2 = 5 ' Popup background. (Same as mki.skin_bkg)
cp3 = 7 ' Unavailable menu item.
cp4 = 7 ' Shadow.
cp5 = 8 ' Characters under shadow.
Restore PopupMenuData
WinCon.noi = 0
Do
Read tmp$
If tmp$ = "eof" Then Exit Do
WinCon.noi = WinCon.noi + 1
ReDim _Preserve menu$(WinCon.noi)
menu$(WinCon.noi) = tmp$
Loop
If WinCon.noi > _Height - 2 Or Len(menu$(1)) > _Width - 4 Then WinCon.noi = 0: initialize_menu = 0: Exit Sub ' Not enough room to open popup.
End If
y = CsrLin: x = Pos(0)
mki.CurShow = 0: Locate , , mki.CurShow ' Hide cursor
Dim atmp As String
ReDim menu_restrict(WinCon.noi) ' Restrictions.
If text$(mki.fld) = "" Then
For i = 1 To WinCon.noi - 2: menu_restrict(i) = 1: Next
Else
If hl = 0 Then
For i = 1 To 4: menu_restrict(i) = 1: Next
End If
End If
If Len(_Clipboard$) Then menu_restrict(3) = 0 Else menu_restrict(3) = 1 ' End Restrictions.
Do
_Limit 30
MyMouse_and_Keyboard lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$
mxalt = 0
If b$ = Chr$(0) + "H" Or mw = -1 Then
If (MenuHL - MenuT + 1) \ 2 > 1 Then
myalt = MenuHL - 2: mxalt = -1
End If
ElseIf b$ = Chr$(0) + "P" Or mw = 1 Then
If MenuHL = 0 Then
myalt = MenuT + 1: mxalt = -1
Else
If (MenuHL - MenuT + 1) \ 2 < WinCon.noi Then
myalt = MenuHL + 2: mxalt = -1
End If
End If
ElseIf b$ = Chr$(13) Or mb = 2 Then
If menu_restrict((MenuHL - MenuT + 1) \ 2) = 0 Then
mki.mvar = (MenuHL - MenuT + 1) \ 2
Exit Do
End If
End If
Select Case mki.mvar
Case -1 ' Hover.
If mxalt = 0 Then myalt = my: mxalt = mx
i = myalt > MenuT And myalt < MenuB And mxalt > MenuL And mxalt < MenuR
If i Or mxalt = -1 Then
i = (myalt - MenuT) \ 2 <> (myalt - MenuT) / 2 And myalt <> oldmy
If i Or mxalt = -1 Then ' Works for odd or even number top margins.
If MenuHL Then ' Remove highlighting from previous hover.
atmp = Space$(mki.mwidth - 2)
Mid$(atmp, 2, Len(menu$((MenuHL - MenuT + 1) \ 2))) = menu$((MenuHL - MenuT + 1) \ 2)
Locate MenuHL, MenuL + 2 - 1
If menu_restrict((MenuHL - MenuT + 1) \ 2) Then Color cp3, cp2 Else Color cp1, cp2
Print atmp
End If
atmp = Space$(mki.mwidth - 2)
Mid$(atmp, 2, Len(menu$((myalt - MenuT + 1) \ 2))) = menu$((myalt - MenuT + 1) \ 2)
Locate myalt, MenuL + 2 - 1
If menu_restrict((myalt - MenuT + 1) \ 2) Then Color cp2, cp3 Else Color cp2, cp1
Print atmp;
Color cp1, cp2
MenuHL = myalt
oldmy = my
End If
If lb = 2 Then
If menu_restrict((myalt - MenuT + 1) \ 2) = 0 Then
mki.mvar = (myalt - MenuT + 1) \ 2
Exit Do
End If
End If
Else
' Toggle close popup menu.
If lb = 1 Then
If myalt >= _ScreenY And my <= _ScreenY + 24 And mx >= _ScreenX + 36 And mx <= _ScreenX + 48 Then
mki.mvar = 0: Exit Do
Else
If myalt >= _ScreenY And my <= _ScreenY + _FontHeight * (_Height + 1) And mx >= _ScreenX And mx <= _ScreenX + _FontWidth * _Width Then
Else ' Outside of app win.
mki.mvar = 0: Exit Do
End If
End If
End If
End If
If Len(b$) Then
'-----------------------------------------------------------------------------------------------------------
' Valid menu shortcut key list here.
Select Case b$
Case Chr$(0) + "S", Chr$(22), Chr$(24), Chr$(1), Chr$(3): Exit Do
Case Chr$(27): b$ = "": mki.mvar = 0: Exit Do ' Simply close popup.
End Select
End If
Case Else ' Open menu.
menu_variety = 1
h = 5 ' Variable to determine margin spaces from the right of menu.
For i = 1 To WinCon.noi
j = Len(menu$(i))
If j > k Then k = j
Next
mki.mwidth = k + h
mki.mheight = WinCon.noi * 2 + 1 ' Add one for the separate border element.
Select Case menu_variety
Case 0 ' Fixed menu to left.
MenuT = 3: MenuL = 1: MenuR = MenuL + mki.mwidth: MenuB = MenuT + mki.mheight
Case 1 ' Movable menu.
While _MouseInput: Wend
MenuT = _MouseY + 1 ' One below input line.
MenuL = _MouseX
If MenuT + mki.mheight >= _Height Then MenuT = _Height - mki.mheight - 1 ' -1 for shadow.
If MenuL + mki.mwidth >= _Width Then MenuL = _Width - mki.mwidth - 1 ' -1 for shadow.
MenuR = MenuL + mki.mwidth: MenuB = MenuT + mki.mheight
End Select
mki.mvar = -1 ' Identifies the menu is open.
PCopy 0, 1
Color cp1, cp2
Locate MenuT, MenuL
Print Chr$(218) + String$(mki.mwidth - 2, 196) + Chr$(191)
For i = 1 To mki.mheight - 2
Color cp1, cp2: Locate , MenuL
Print Chr$(179); Space$(mki.mwidth - 2) + Chr$(179);
Color cp2, cp4: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1)): Color cp5, cp2
Next
Color cp1, cp2: Locate , MenuL
Print Chr$(192) + String$(mki.mwidth - 2, 196) + Chr$(217);
Color cp2, cp4: Print Chr$(Screen(CsrLin, Pos(0))) + Chr$(Screen(CsrLin, Pos(0) + 1))
Locate , MenuL + 2
For i = 1 To mki.mwidth
Print Chr$(Screen(CsrLin, Pos(0)));
Next
Locate MenuT + 2, MenuL + 2
For i = 0 To WinCon.noi - 1
Locate MenuT + 1 + i * 2, MenuL + 2
If menu_restrict(i + 1) Then Color cp3, cp2 Else Color cp1, cp2
Print menu$(i + 1)
Color cp1, cp2
Locate , MenuL
If i + 1 < WinCon.noi Then Print "Ã" + String$(mki.mwidth - 2, Chr$(196)) + "´";
Next
End Select
Loop
PCopy 1, 0
Color restore_color1, restore_color2
Locate y, x
_KeyClear
End Sub
Sub MyMouse_and_Keyboard (lb, mb, rb, my, mx, mw, shift%, clkcnt, drag, b$)
Static oldmy, oldmx, z1, hover, mwy, oldmwy
If Len(autokey$) Then
b$ = Mid$(autokey$, 1, InStr(autokey$ + ",", ",") - 1)
autokey$ = Mid$(autokey$, InStr(autokey$ + ",", ",") + 1)
Else
b$ = InKey$
End If
If z1 Then If Abs(Timer - z1) > .3 Then z1 = 0: clkcnt = 0
If lb > 0 Then
If lb = 1 Then
lb = -1
Else
lb = 0
End If
End If
If rb > 0 Then If rb = 1 Then rb = -1 Else rb = 0
If mb > 0 Then If mb = 1 Then mb = -1 Else mb = 0
While _MouseInput
mwy = mwy + _MouseWheel
Wend
my = _MouseY
mx = _MouseX
b_hover = 0
For i = 1 To nob ' number of buttons.
If my >= y_btl(i) And my <= y_bbr(i) And mx >= x_btl(i) And mx <= x_bbr(i) Then
b_hover = i
Exit For
End If
Next
If lb = -1 Then
If oldmy And oldmx <> mx Or oldmy And oldmy <> my Then
If mx <> oldmx Then drag = Sgn(mx - oldmx) ' Prevent zero which can occur if mouse moves off row when being dragged horizontally.
End If
End If
If drag = 0 Then
If mwy <> oldmw Then
mw = Sgn(mwy - oldmwy): mwy = 0
Else
mw = 0
End If
oldmwy = mwy
If _KeyDown(100303) Or _KeyDown(100304) Then shift% = -1 Else If shift% Then shift% = 0
End If
If lb = -1 And _MouseButton(1) = 0 Then
lb = 2: drag = 0: hover = 0
ElseIf rb = -1 And _MouseButton(2) = 0 Then
rb = 2
ElseIf mb = -1 And _MouseButton(3) = 0 Then
mb = 2
End If
If _MouseButton(1) Then
If lb = 0 Then
lb = 1
If z1 = 0 Then
z1 = Timer ' Let first click go through.
Else
clkcnt = clkcnt + 1
End If
End If
ElseIf _MouseButton(2) And rb = 0 Then
rb = 1
ElseIf _MouseButton(3) And mb = 0 Then
mb = 1
End If
oldmy = my: oldmx = mx
End Sub
Function Recycle% (file As String)
Dim lpFileOp As SHFILEOPSTRUCTA
Dim doublenull As String
doublenull = Chr$(0) + Chr$(0)
file = file + doublenull
lpFileOp.hwnd = _WindowHandle
lpFileOp.wfunc = FO_DELETE
lpFileOp.pFrom = _Offset(file)
lpFileOp.fFlags = FOF_ALLOWUNDO + FOF_WANTNUKEWARNING
Recycle = FileOperation(lpFileOp)
End Function
Function Copy% (file As String, dest As String)
Dim lpFileOp As SHFILEOPSTRUCTA
Dim doublenull As String
doublenull = Chr$(0) + Chr$(0)
file = file + doublenull
dest = dest + doublenull
lpFileOp.hwnd = _WindowHandle
lpFileOp.wfunc = FO_COPY
lpFileOp.pFrom = _Offset(file)
lpFileOp.pTo = _Offset(dest)
lpFileOp.fFlags = FOF_ALLOWUNDO
Copy = FileOperation(lpFileOp)
End Function
Function Move% (file As String, dest As String)
Dim lpFileOp As SHFILEOPSTRUCTA
Dim doublenull As String
doublenull = Chr$(0) + Chr$(0)
file = file + doublenull
dest = dest + doublenull
lpFileOp.hwnd = _WindowHandle
lpFileOp.wfunc = FO_MOVE
lpFileOp.pFrom = _Offset(file)
lpFileOp.pTo = _Offset(dest)
lpFileOp.fFlags = FOF_ALLOWUNDO
Move = FileOperation(lpFileOp)
End Function
Function Rename% (file As String, newname As String)
Dim lpFileOp As SHFILEOPSTRUCTA
Dim doublenull As String
doublenull = Chr$(0) + Chr$(0)
file = file + doublenull
newname = newname + doublenull
lpFileOp.hwnd = _WindowHandle
lpFileOp.wfunc = FO_RENAME
lpFileOp.pFrom = _Offset(file)
lpFileOp.pTo = _Offset(newname)
lpFileOp.fFlags = FOF_ALLOWUNDO
Rename = FileOperation(lpFileOp)
End Function
Happy Holidays Screw that, Merry Christmas!
Pete
