www.pudn.com > virtualdrive.zip > Virtual.frm
VERSION 5.00
Begin VB.Form Virtual
BorderStyle = 1 'Fixed Single
Caption = "The Virtual Drive Creator"
ClientHeight = 1335
ClientLeft = 45
ClientTop = 330
ClientWidth = 3495
Icon = "Virtual.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 1335
ScaleWidth = 3495
StartUpPosition = 2 'CenterScreen
Begin VB.Frame Frame1
Height = 1335
Left = 0
TabIndex = 0
Top = 0
Width = 3495
Begin VirtualDrive.TrayArea TrayArea1
Left = 2040
Top = 720
_ExtentX = 900
_ExtentY = 900
Icon = "Virtual.frx":08CA
ToolTip = "Virtual Drive"
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H000000C0&
Height = 540
Left = 2040
Picture = "Virtual.frx":11A4
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 5
Top = 240
Visible = 0 'False
Width = 540
End
Begin VB.TextBox txtUnit
Alignment = 2 'Center
Height = 285
Left = 2280
MaxLength = 1
TabIndex = 3
Text = "G"
Top = 840
Width = 975
End
Begin VB.CommandButton cmdDestroy
Caption = "&Destroy"
BeginProperty Font
Name = "Comic Sans MS"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 2
Top = 720
Width = 1935
End
Begin VB.CommandButton cmdCreate
Caption = "&Create"
BeginProperty Font
Name = "Comic Sans MS"
Size = 14.25
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 1
Top = 240
Width = 1935
End
Begin VB.Label LabelDrive
Alignment = 2 'Center
BorderStyle = 1 'Fixed Single
Caption = "Drive Letter"
Height = 495
Left = 2280
TabIndex = 4
Top = 360
Width = 975
End
End
Begin VB.Menu mnuTray
Caption = "Hidden Menu"
Visible = 0 'False
Begin VB.Menu mnuVirtual
Caption = "&Open Virtual Drive"
End
End
End
Attribute VB_Name = "Virtual"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cmdCreate_Click()
If txtUnit.Text <> "" Then
'try to create the virtual drive, if succedds then
'send the program to the tray
If VirtualDrv(txtUnit.Text) = True Then Me.WindowState = vbMinimized
End If
DoEvents
Call CompDrive
End Sub
Private Sub cmdDestroy_Click()
If txtUnit.Text <> "" Then UnVirtual txtUnit.Text
DoEvents
cmdDestroy.Enabled = False
End Sub
Private Sub Form_Load()
ChDir App.Path
Call CompDrive
'if you want to add this to the start of windows, you
'may use the /t switch to make the app start in the tray
If Command = "/t" Then Me.WindowState = vbMinimized
End Sub
Private Sub Form_Resize()
'if window is minimized then hide to tray
If Me.WindowState = vbMinimized Then
Me.Hide
TrayArea1.Visible = True
End If
End Sub
Private Sub mnuVirtual_Click()
'show main window
Me.WindowState = vbNormal
Me.Show
Me.SetFocus
Call CompDrive
TrayArea1.Visible = False
End Sub
Private Sub txtUnit_Change()
txtUnit.Text = UCase(txtUnit.Text)
Call CompDrive
End Sub
Private Sub txtUnit_GotFocus()
'select the text within the TextBox.
txtUnit.SelStart = 0
txtUnit.SelLength = Len(txtUnit.Text)
End Sub
Private Sub txtUnit_KeyPress(KeyAscii As Integer)
'here we check that the key pressed is a letter and not a number
If ((KeyAscii < 65) And (KeyAscii <> 8)) Or (KeyAscii > 122) Then
'avoid that horrible beep
KeyAscii = 0
Else
'convert to UpperCase
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End If
End Sub
Function VirtualDrv(UnitToCreate As String) As Boolean
On Error Resume Next
Dim sFolderPath As String
Dim filesys
Dim drv
Dim wsh
sFolderPath = "C:\$Cdrom$" '<<<<<<<< Set the folder you want to use<<<<<<<<
drv = UnitToCreate & ":" '<<<<<<<< Set a drive letter<<<<<<<<
Set filesys = CreateObject("Scripting.FileSystemObject")
Set wsh = CreateObject("WScript.Shell")
If filesys.FolderExists(drv) Then
MsgBox (drv & " still exists" & vbCrLf & "you must choose another unit to create")
Exit Function
End If
If filesys.FolderExists(sFolderPath) Then
wsh.Run ("subst " & drv & " " & sFolderPath)
Else
filesys.CreateFolder (sFolderPath)
wsh.Run ("subst " & drv & " " & sFolderPath)
End If
'prevent errors doing some DoEvents
DoEvents
SavePicture Picture1.Picture, sFolderPath & "\Icon.ico"
DoEvents
Open sFolderPath & "\Autorun.inf" For Output As 1
Print #1, "[autorun]"
Print #1, "icon=Icon.ico"
Close #1
'hide those files
SetAttr sFolderPath & "\Icon.ico", vbHidden
SetAttr sFolderPath & "\Autorun.inf", vbHidden
'function succedded, return true
VirtualDrv = True
End Function
Private Sub UnVirtual(ByVal WhatDrive As String)
'On Error Resume Next
Dim wsh
Set wsh = CreateObject("WScript.Shell")
wsh.Run ("subst " & LCase(WhatDrive) & ": /d")
End Sub
Private Sub TrayArea1_DblClick()
Call mnuVirtual_Click
End Sub
Private Sub TrayArea1_MouseUp(Button As Integer)
'show the menu only on right-click
If Button = 2 Then PopupMenu mnuTray
End Sub
Private Sub CompDrive()
On Local Error GoTo Err
If txtUnit.Text = "" Then GoTo Err
Dim curDr As String
curDr = UCase(Left(CurDir, 1))
ChDrive txtUnit.Text
ChDrive curDr
cmdDestroy.Enabled = True
Exit Sub
Err:
cmdDestroy.Enabled = False
ChDrive curDr
End Sub