Devil World

این هم مرتب کردن دسکتاب جون من نظر بدین

Private Const LVA_ALLIGNLEFT = &H1
Private Const LVM_ARRANGE = &H1016
Private Const GW_CHILD = 5
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Sub Command1_Click()
Dim lnghWnd As Long
Dim lngReturn As Long
lnghWnd = FindWindow("Program", vbNullString)
lnghWnd = GetWindow(lnghWnd, GW_CHILD)
lnghWnd = GetWindow(lnghWnd, GW_CHILD)
lngReturn = SendMessage(lnghWnd, LVM_ARRANGE, LVA_ALLIGNLEFT, 0)
End Sub

آیکون های دسکتاپ را چگونه محو کنیم

Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long 

Private Sub Cmd_HideAppearance_Click()
    subkey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\System"
    rtn = InStr(subkey, "\")
    If Left(subkey, rtn - 1) = "HKEY_CURRENT_USER" Then MainKeyHandle = &H80000001
    subkey = Right(subkey, Len(subkey) - rtn)
    entry = "NoDesktop"
    If MainKeyHandle Then
        rtn = RegOpenKeyEx(MainKeyHandle, subkey, 0, Key_Write, hKey)
        If rtn = error_success Then
            rtn = RegSetValueEx(hKey, entry, 0, REG_DWORD, 1, 4)
            rtn = RegCloseKey(hKey)
        End If
    End If
End Sub

Private Sub Cmd_ShowIcon_Click()
    subkey = "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Policies\Explorer"
    rtn = InStr(subkey, "\")
    If Left(subkey, rtn - 1) = "HKEY_CURRENT_USER" Then MainKeyHandle = &H80000001
    subkey = Right(sunkey, Len(subkey) - rtn)
    entry = "NoDesktop"
    If MainKeyHandle Then
        rtn = RegOpenKeyEx(MainKeyHandle, subkey, 0, Key_Write, hKey)
        If rtn = error_success Then
            rtn = RegSetValueEx(hKey, entry, 0, REG_DWORD, 0, 4)
            rtn = RegCloseKey(hKey)
        End If
    End If
End Sub

Private Sub Exit_Click()
    End
End Sub

اگه نظر بدین ممنون می شوم

روش عوض کردن برچسب درایو:

Private Declare Function SetVolumeLabel Lib "kernel32" Alias "SetVolumeLabelA" (ByVal lpRootPathName As String, ByVal lpVolumeName As String) As Long

Private Sub Cmd_ChangeLabel_Click()
RootName = "C:\"
NewLabel = "Devil Soft"
(Call SetVolumeLabel(RootName, NewLabel
End Sub

باز هم مثل همیشه مشکل پرانتز ها هست

Private Declare Function GetDiskFreeSpace Lib "Kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorPerCluster As Long, lpBytesPerSector As Long, lpNumberOfClusters As Long, lpTotalNumberOfClusters As Long) As Long

Private Sub Cmd_Diskinfo_Click()
Dim lAnswer As Long
Dim lpRootPathName As String
Dim lpSectorPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lBytesPerCluster As Long
Dim lNumFreeBytes As Double
Dim sString As String

lpRootPathName = "D:\"
lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorPerCluster, lpBytesPerSector, lpNumberOfClusters, lpTotalNumberOfClusters)
lBytesPerCluster = lpSectorPerCluster * lpBytesPerSector
lNumFreeBytes = lBytesPerCluster * lpNumberOfClusters
sString = "Number of Free Bytes: " & lNumFreeBytes & vbCr & vbCrLf
sString = sString & "Number of Free Kilobytes: " & CStr(lNumFreeBytes / 1024) & " K" & vbCr & vbCrLf
sString = sString & "Number of Free Megabytes: " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & " MB"
MsgBox sString
End Sub

البته همین طور که می بینید برنامه خراب شده موقع تایپ یا کپی کردن مواظب باشید

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Sub Cmd_NoLine_Click()
Dim lngLineCount As Long
On Error Resume Next
lngLineCount = SendMessage(Text1.hwnd, &HBA, 0&, 0&)
MsgBox Format$(lngLineCount, "##,###")
End Sub