PureBoard

Code: Alles auswählen

VERSION 5.00
Begin VB.Form USBAutoRunFrm 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "USB-Autorun-Tool"
   ClientHeight    =   3975
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   4410
   Icon            =   "USBAutoRun.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   265
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   294
   ShowInTaskbar   =   0   'False
   StartUpPosition =   3  'Windows Default
   Visible         =   0   'False
   Begin VB.CommandButton cmdSave 
      Caption         =   "Speichern"
      CausesValidation=   0   'False
      Default         =   -1  'True
      Height          =   375
      Left            =   1920
      TabIndex        =   4
      Top             =   3480
      Width           =   1095
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "Abbrechen"
      Height          =   375
      Left            =   3120
      TabIndex        =   1
      Top             =   3480
      Width           =   1095
   End
   Begin VB.ListBox List1 
      Columns         =   4
      Height          =   1740
      IntegralHeight  =   0   'False
      Left            =   120
      Style           =   1  'Checkbox
      TabIndex        =   0
      Top             =   1560
      Width           =   4095
   End
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   120
      Top             =   120
   End
   Begin VB.Line Line1 
      X1              =   119
      X2              =   49
      Y1              =   59
      Y2              =   59
   End
   Begin VB.Image Image1 
      Height          =   255
      Left            =   720
      MouseIcon       =   "USBAutoRun.frx":322A
      MousePointer    =   99  'Custom
      Top             =   720
      Width           =   1095
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   $"USBAutoRun.frx":337C
      Height          =   780
      Left            =   120
      TabIndex        =   3
      Top             =   120
      Width           =   4215
      WordWrap        =   -1  'True
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "AutoRun bei folgenden Laufwerken aktivieren:"
      Height          =   195
      Left            =   120
      TabIndex        =   2
      Top             =   1200
      Width           =   3900
   End
End
Attribute VB_Name = "USBAutoRunFrm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Drive1(26) As Boolean
Dim KnownDrive(26) As Boolean

Dim DriveSettings As String

Private Sub cmdCancel_Click()
  End
End Sub

Private Sub cmdSave_Click()
 SaveSetting "Christian Bläul", "USB-Autorun-Tool", "DriveSettings", DriveSettings
 End
End Sub

Private Sub Form_Load()
  Dim ds As String, param As String
  ds = GetSetting("Christian Bläul", "USB-Autorun-Tool", "DriveSettings", "")
  param = Command$
  
  'erster Start auf neuem Rechner
  If ds = "" Then
    For i = Asc("A") To Asc("Z")
      Select Case GetDriveType(Chr$(i) & ":")
      Case DRIVE_CDROM, DRIVE_FIXED
        ds = ds & "0"
      Case Else
        ds = ds & "1"
      End Select
    Next
    param = "cfg"
    cmdSave.Move cmdCancel.Left
    cmdCancel.Visible = False
    SaveSetting "Christian Bläul", "USB-Autorun-Tool", "DriveSettings", ds
  End If
  If param <> "" Then
    cmdSave.Move cmdCancel.Left
    cmdCancel.Visible = False
  End If
  
  If App.PrevInstance Then
    DriveSettings = String$(26, "0")
    Visible = True
    For i = Asc("A") To Asc("Z")
      List1.AddItem Chr$(i) & ":"
      If Mid$(ds, i - 64, 1) = "1" Then
        List1.Selected(i - 65) = True
      End If
      List1.ListIndex = 0
    Next
  Else
    DriveSettings = ds
    Drive1DotRefresh
    For i = 1 To 26
     KnownDrive(i) = Drive1(i)
    Next i
    Timer1.Enabled = True
  End If
End Sub

Private Sub Image1_Click()
  ShellExecute hWnd, "open", "http://blaeul.de/docs/de_usb_autorun.php", "", "C:", SW_SHOW
End Sub

Private Sub List1_ItemCheck(Item As Integer)
  Dim c As String * 1
  c = Mid$(DriveSettings, Item + 1, 1)
  Mid$(DriveSettings, Item + 1, 1) = IIf(c = "1", "0", "1")
End Sub

Private Sub Timer1_Timer()
 On Error Resume Next
 Drive1DotRefresh
 For i = 1 To 26
  If Drive1(i) Then ' A USB Drive is currently inserted...
   If KnownDrive(i) = False Then ' Ahh - it just happened!
    KnownDrive(i) = True ' OK, so remember it's there.
    DriveLetter$ = Chr$(64 + i) & ":"
    AutoPlayFile$ = DriveLetter$ & "\AUTORUN.INF"
    If FileExists(AutoPlayFile$) Then
     DriveSettings = GetSetting("Christian Bläul", "USB-Autorun-Tool", "DriveSettings", "11011111111111111111111111")
     If Mid$(DriveSettings, i, 1) = "1" Then
      Open AutoPlayFile$ For Input As #1
      While Not EOF(1)
       Line Input #1, A$
       If InStr(UCase$(A$), "OPEN=") Or InStr(UCase$(A$), "OPEN =") Then
         S = InStr(A$, "=")
         Program$ = Trim$(Right$(A$, Len(A$) - S))
         Program$ = DriveLetter$ & IIf(Left$(Program$, 1) <> "\", "\", "") & Program$
         Shell Program$, vbNormalFocus
         Close
         GoTo UpdateKnownDrive:
       End If
       If InStr(UCase$(A$), "SHELLEXECUTE") Then
         S = InStr(A$, "=")
         Program$ = Trim$(Right$(A$, Len(A$) - S))
         ShellExecute hWnd, "open", Program$, "", DriveLetter$, SW_SHOW
         Close
         GoTo UpdateKnownDrive:
       End If
      Wend
      Close
     End If
    End If
    Exit Sub
   End If
   KnownDrive(i) = True
  End If
 Next i
UpdateKnownDrive:
 For i = 4 To 26
  KnownDrive(i) = Drive1(i)
 Next i
End Sub

Sub Drive1DotRefresh()
 Debug.Print "Drive1DotRefresh()"
 On Error GoTo NoDrive:
 For i = 4 To 26
  DriveLetter$ = Chr$(64 + i)
  Drive1(i) = FileExists(DriveLetter$ & ":\AutoRun.inf")
NextDrive:
 Next i
 T = Timer + 0.1
 While T > Timer
  DoEvents
 Wend
 Exit Sub
NoDrive:
 Resume NextDrive:
End Sub

'Ersatz für die Dir()-Funktion, erzeugt keine VB-Fehler.
'gibt auch False zurück, wenn keine CD in ein Laufwerk eingelegt ist (z.B. mit FileExists("F:") )
Public Function FileExists(ByVal Filename As String) As Boolean
Dim hSearch As Long, FD As WIN32_FIND_DATA
  If Len(Filename) <= 3 And Mid$(Filename, 2, 1) = ":" Then Filename = AddSlash(Filename) & "nul"
  If Right$(Filename, 1) = "\" Then Filename = Filename & "nul"
  hSearch = FindFirstFile(Filename, FD)
FindClose hSearch
FileExists = hSearch <> 0 And hSearch <> -1
End Function

Function AddSlash(Path As String) As String
  If Right$(Path, 1) <> "\" Then
    AddSlash = Path & "\"
  Else
    AddSlash = Path
  End If
End Function

Code: Alles auswählen

EnableExplicit

Structure sDrive
  Letter.s
  Known.l
EndStructure

Global NewList Drive.sDrive()

Procedure CheckDrives()
  
  ForEach Drive()
    
    Select GetDriveType_(Drive()\Letter)
        
      Case 0, 1  ; 0 = drive not determined ; 1 =   The root directory does not exist
        
      Case #DRIVE_CDROM, #DRIVE_FIXED
        
      Default
        
        If Drive()\Known = #False
          
          Debug "Neu hinzugekommen: " + Drive()\Letter
          
          ; todo für TheSaint: autorun.inf auslesen
          ; -> siehe Preferences-Befehle
          
          ; todo für TheSaint: evtl. eingetragenes programm starten
          ; -> siehe RunProgram()
          
          Drive()\Known = #True
          
        EndIf
        
    EndSelect
    
  Next
  
EndProcedure

Enumeration
  #frmMain
  #frmMain_Timer
EndEnumeration

Define Counter

For Counter = 'A' To 'Z'
  AddElement(Drive())
  Drive()\Letter = Chr(Counter) + ":"
Next 

; todo für TheSaint: Fensterelemente ergänzen
OpenWindow(#frmMain, #PB_Ignore, #PB_Ignore, 128, 80, "USB-Autorun-Tool")

SetTimer_(WindowID(#frmMain), #frmMain_Timer, 1000, @CheckDrives())

Define WWE, Quit

; todo für TheSaint: Event-Schleife erweitern
Repeat
  
  WWE = WaitWindowEvent()
  
  Select WWE
      
    Case #PB_Event_CloseWindow
      
      Quit = #True
      
  EndSelect
  
Until Quit = #True

KillTimer_(WindowID(#frmMain), #frmMain_Timer)