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