demo.frm

vb中shell API的应用实例 vb中shell API的应用实例

         Left            =   120
         ScaleHeight     =   1575
         ScaleWidth      =   5475
         TabIndex        =   18
         TabStop         =   0   'False
         Top             =   600
         Width           =   5475
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' Brought to you by:
'   Brad Martinez
'   [e-mail]
'   [e-mail]
'   http://members.aol.com/btmtz/vb

Dim m_sCurDir As String
Dim m_fLoading As Boolean
'

Private Sub Form_Load()
  Dim sDirBuf As String * MAX_PATH
  On Error Resume Next   ' covers invalid path selection

  ' We'll need this flag to determine if
  ' strings should be converted to Unicode
  g_fIsWinNT = IsWinNT

  ' This will get changed.
  ' Saved now, restored on unload.
  m_sCurDir = CurDir
  
  ' Set initial path, setting the properties may invoke clicks.
  m_fLoading = True
  If GetWindowsDirectory(sDirBuf, MAX_PATH) Then
    Drive1.Drive = LCase$(Left$(sDirBuf, 3))   ' "c:\"
    Dir1.Path = LCase$(GetStrFromBuffer(sDirBuf))   ' "c:\windows"
  Else   ' use root
    Drive1.Drive = LCase$(Left$(m_sCurDir, 3))
    Dir1.Path = LCase$(Left$(m_sCurDir, 3))
  End If
  m_fLoading = False
  
  ' Flag pretented invoked clicks above
  Dir1_Change
  
  Move (Screen.Width - Width) * 0.5, (Screen.Height - Height) * 0.5
  
  ' Setup the rest of the controls
  txtIconIdx = 0
  txtRunTitle = "Run your program"
  txtRunPrompt = "Type in the name of a program..."
  
  If g_fIsWinNT Then
    txtRestartPrompt = "It's your call..." & vbCrLf & vbCrLf
    With cboRestartOp
      .AddItem "0 - EWX_LOGOFF"
      .AddItem "1 - EWX_SHUTDOWN"   ' NT: needs SE_SHUTDOWN_NAME privilege"
      .AddItem "2 - EWX_REBOOT"        ' NT: needs SE_SHUTDOWN_NAME privilege"
      .AddItem "4 - EWX_FORCE"
      .AddItem "8 - EWX_POWEROFF"   ' NT: needs SE_SHUTDOWN_NAME privilege"
      .Text = "< your value here >"
    End With
      
  Else   ' Win95
    txtRestartPrompt = "Warning...!" & vbCrLf & _
                                 "  Clicking Yes will end the windows session and close" & vbCrLf & _
                                 "  all programs without any prompt to save changes...!" & vbCrLf & vbCrLf
    With cboRestartOp
      .AddItem "1 - exit, no def prompt"
      .AddItem "2 - reboot system"
      .Text = "< your value here >"
    End With
  
  End If
    
End Sub

Private Sub Drive1_Change()
  If Not m_fLoading Then
    On Error GoTo Out   ' covers invalid path selection
    Dir1.Path = Drive1.Drive
Out: If Err Then MsgBox Err.Description
  End If
End Sub

Private Sub Dir1_Change()
  If Not m_fLoading Then
    On Error GoTo Out   ' covers invalid path selection
    File1 = Dir1.Path
    txtPaths = Dir1.Path
    txtIconPath = txtPaths
    DoPathFunctions
Out: If Err Then MsgBox Err.Description
  End If
End Sub

Private Sub File1_Click()
  Dim sFilePath  As String
  On Error GoTo Out   ' covers invalid path selection
  ' Normalize the selected path and show it w/ the filename
  txtPaths = NormalizePath(File1.Path) & File1
  txtIconPath = txtPaths
  On Error GoTo 0
  DoPathFunctions
Out: If Err Then MsgBox Err.Description
End Sub
'

' ====================================================
' Path functions:
'
Private Sub txtPaths_KeyPress(KeyAscii As Integer)
  ' Enter key processes textbox entry
  If KeyAscii = vbKeyReturn Then DoPathFunctions: KeyAscii = 0
End Sub

Private Sub cmdPaths_Click()
  DoPathFunctions
End Sub

Private Sub DoPathFunctions()
  Dim sTB As String
  Dim sOut As String
  
  sTB = txtPaths
  
  On Error GoTo Out   ' covers invalid path selection
  ' Make the displayed path the current drive and
  ' dir so that FileExists evaluates relative paths
  ChDrive Drive1
  ChDir Dir1
  On Error GoTo 0
  
  sOut = "Current dir:" & vbTab & Dir1 & vbCrLf
  sOut = sOut & "GetExtension:" & vbTab & GetExtension(sTB) & vbCrLf
  sOut = sOut & "GetFileName:" & vbTab & GetFileName(sTB) & vbCrLf
  sOut = sOut & "IsPathRelative:" & vbTab & IsPathRelative(sTB) & vbCrLf
  sOut = sOut & "IsPathExe:" & vbTab & IsPathExe(sTB) & vbCrLf
  sOut = sOut & "FileExists:" & vbTab & FileExists(sTB) & vbCrLf
  sOut = sOut & "GetArgs:   " & vbTab & GetArgs(sTB) & vbCrLf
  sOut = sOut & "GetShortPath:" & vbTab & GetShortPath(sTB)
  
  picPaths.AutoRedraw = True
  picPaths.Cls
  picPaths.Print sOut
  picPaths.AutoRedraw = False

Out: If Err Then MsgBox Err.Description
End Sub
'

' ====================================================
' Change Icon dialog:
'
Private Sub txtIconPath_KeyPress(KeyAscii As Integer)
  ' Enter key processes textbox entry
  If KeyAscii = vbKeyReturn Then DoIconDialog: KeyAscii = 0
End Sub

Private Sub cmdIconDlg_Click()
  DoIconDialog
End Sub

Private Sub DoIconDialog()
  Dim sFilename As String
  Dim nIconIdx As Long  ' 0 on init
  Dim hSmallIcon As Long
  Dim hLargeIcon As Long
  
  ' Allocate rtn buffer
  sFilename = MakeMaxPath(txtIconPath)
  If g_fIsWinNT Then sFilename = StrConv(sFilename, vbUnicode)
  nIconIdx = txtIconIdx
  
  ' Rtns 1 if selection, 0 if cancelled
  If SHChangeIconDialog(hWnd, sFilename, 0, nIconIdx) Then
    ' Display selection
    txtIconPath = GetStrFromBuffer(sFilename)
    txtIconIdx = nIconIdx
    
    ' Rtns number of icons extracted, 0 on error, -1 if invalid filename.
    ' Creates specified number of icons and must all be destroyed
    ' when no longer need (frees the memory they occupy).
    If ExtractIconEx(sFilename, nIconIdx, hLargeIcon, hSmallIcon, 1) > 0 Then
      picSmallIcon.AutoRedraw = True
      picSmallIcon.Cls
      picLargeIcon.AutoRedraw = True
      picLargeIcon.Cls
      
      ' See MSKB article ID Q141933 for info on creating a picture object
      ' from an image handle (which can then be assigned to a picturebox's
      ' picture property)
      DrawIconEx picSmallIcon.hDC, 1, 1, hSmallIcon, 0, 0, 0, 0, DI_NORMAL
      DrawIconEx picLargeIcon.hDC, 1, 1, hLargeIcon, 0, 0, 0, 0, DI_NORMAL
      DestroyIcon hSmallIcon
      DestroyIcon hLargeIcon
      
      picSmallIcon.Refresh
      picSmallIcon.AutoRedraw = False
      picLargeIcon.Refresh
      picLargeIcon.AutoRedraw = False
    End If
  
  End If

End Sub
'

' ====================================================
' Restart system message box:
'
' A Yes click will end the Windows session immediately!

Private Sub cmdRestartDlg_Click()
  Dim sPrompt As String
  Dim uFlag As Long
  
  sPrompt = txtRestartPrompt
  If g_fIsWinNT Then sPrompt = StrConv(sPrompt, vbUnicode)
  
  Select Case cboRestartOp.ListIndex
    Case -1: uFlag = Val(cboRestartOp.Text)
    Case 0:  uFlag = shrsExitNoDefPrompt
    Case 1:  uFlag = shrsRebootSystem
  End Select
  
  If SHRestartSystemMB(hWnd, sPrompt, uFlag) = vbYes Then
    MsgBox "bye-bye..."   ' Never gets here...!
  End If
  
End Sub
'

' ====================================================
' Run dialog:

Private Sub cmdRunDlg_Click()
  Dim sTitle As String
  Dim sPrompt As String
  
  If chkRunDefaults Then
    SHRunDialog hWnd, 0, 0, vbNullString, vbNullString, -chkRunNoMRU   ' sets bit 2 if checked
  Else
    sTitle = txtRunTitle
    sPrompt = txtRunPrompt
    If g_fIsWinNT Then sTitle = StrConv(sTitle, vbUnicode)
    If g_fIsWinNT Then sPrompt = StrConv(sPrompt, vbUnicode)
    SHRunDialog hWnd, 0, 0, sTitle, sPrompt, -chkRunNoMRU
  End If
End Sub
'

' ====================================================
' Shut Down Windows dialog:

Private Sub cmdShutDown_Click()
  SHShutDownDialog 0
End Sub

Private Sub Form_Unload(Cancel As Integer)
  ' Restore cur drive & dir (cached at app start)
  ChDrive Left$(m_sCurDir, 1)
  ChDir m_sCurDir
  Set Form1 = Nothing
  End
End Sub