bin seit kurzem stolzer Besitzer von PureBasic 4.3.
Jetzt würde ich gerne verschiedene Projekte mit PureBasic
realisieren.
Folgende Frage hätte ich zu den nun folgenden Code:
Ist es möglich dies auch in PureBasic zu realisieren?
Gibt es einen Konverter oder könnte mir jemand bei
der Übersetzung dieses Codes helfen? Wäre super.
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
Für Eure Hilfe wäre ich sehr dankbar.
Viele Grüße
