modfx.bas

vb做的看图系统

Attribute VB_Name = "modFx"
'****************************************************************************
'人人为我，我为人人
'枕善居汉化收藏整理
'发布日期：2007/10/12
'描    述：极速数码照片查看播放工具 Ver 2.02
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************


Option Explicit
Public Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const CS_DROPSHADOW = &H20000
Public Const GCL_STYLE = (-26)

Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOW = 5
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Private Const SPIF_SENDWININICHANGE = &H2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Const SEE_MASK_INVOKEIDLIST = &HC
Public Type POINTAPI
        x As Long
        y As Long
End Type
Public Enum WallPaperMode
    Stretch = 0
    Tile = 1
    Center = 2
End Enum
Public Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
' NOTE: Oringinal enum was unnamed
Public Enum SHFolders
    CSIDL_Desktop = &H0
    CSIDL_INTERNET = &H1
    CSIDL_PROGRAMS = &H2
    CSIDL_CONTROLS = &H3
    CSIDL_PRINTERS = &H4
    CSIDL_PERSONAL = &H5
    CSIDL_FAVORITES = &H6
    CSIDL_STARTUP = &H7
    CSIDL_RECENT = &H8
    CSIDL_SENDTO = &H9
    CSIDL_BITBUCKET = &HA
    CSIDL_STARTMENU = &HB
    CSIDL_DESKTOPDIRECTORY = &H10
    CSIDL_DRIVES = &H11
    CSIDL_NETWORK = &H12
    CSIDL_NETHOOD = &H13
    CSIDL_FONTS = &H14
    CSIDL_templates = &H15
    CSIDL_COMMON_STARTMENU = &H16
    CSIDL_COMMON_PROGRAMS = &H17
    CSIDL_COMMON_STARTUP = &H18
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19
    CSIDL_APPDATA = &H1A
    CSIDL_PRINTHOOD = &H1B
    CSIDL_ALTSTARTUP = &H1D '// DBCS
    CSIDL_COMMON_ALTSTARTUP = &H1E '// DBCS
    CSIDL_COMMON_FAVORITES = &H1F
    CSIDL_INTERNET_CACHE = &H20
    CSIDL_COOKIES = &H21
    CSIDL_HISTORY = &H22
End Enum
Type FILETIME
    dwLowDateTime  As Long
    dwHighDateTime As Long
End Type
Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime   As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime  As FILETIME
    nFileSizeHigh    As Long
    nFileSizeLow     As Long
    dwReserved0      As Long
    dwReserved1      As Long
    cFileName        As String * 260
    cAlternate       As String * 14
End Type
Public Const DT_CENTER = &H1
Public Const DT_SINGLELINE = &H20
Public Const DT_VCENTER = &H4
Public Const DT_LEFT = &H0
Public Const DT_RIGHT = &H2
Public Const DT_TOP = &H0
Public Const DT_BOTTOM = &H8

Public Const FO_COPY = &H2
Public Const FO_DELETE = &H3
Public Const FO_MOVE = &H1
Public Const FO_RENAME = &H4
Const FOF_MULTIDESTFILES = &H1      'Destination specifies multiple files
Const FOF_SILENT = &H4              'Don't display progress dialog
Const FOF_RENAMEONCOLLISION = &H8   'Rename if destination already exists
Const FOF_NOCONFIRMATION = &H10     'Don't prompt user
Const FOF_WANTMAPPINGHANDLE = &H20  'Fill in hNameMappings member
Const FOF_ALLOWUNDO = &H40          'Store undo information if possible
Const FOF_FILESONLY = &H80          'On *.*, don't copy directories
Const FOF_SIMPLEPROGRESS = &H100    'Don't show name of each file
Const FOF_NOCONFIRMMKDIR = &H200    'Don't confirm making any needed dirs


Private Const MAX_PATH = 260
Public buffer As String * MAX_PATH
Public Message$, Title$, ReturnMsg$
Public Enum MsgStyle
vbOKOnly = 0
vbOKCancel = 1
vbYesNo = 2
End Enum
Public Enum FileOpt
  F_CopySmart = 1 'FO_COPY
  F_COPY = 2
  F_Move = 4
  F_Delete = 8
  F_DelUndo = 16
  F_Vault = 64
  F_Rename = 128
End Enum
         
      
Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Type SHFILEOPSTRUCT
     hwnd As Long
     wFunc As Long
     pFrom As String
     pTo As String
     fFlags As Integer
     fAnyOperationsAborted As Boolean
     hNameMappings As Long
     lpszProgressTitle As String
End Type
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As String, ByVal fuWinIni As Long) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
Public Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function AlphaBlend Lib "MSImg32.dll" (ByVal hDcDest As Long, ByVal nXOriginDest As Long, ByVal nYOriginDest As Long, ByVal nWidthDest As Long, ByVal nHeightDest As Long, ByVal hDcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal BLENDFUNCTION As Long) As Long
' Drag Form Declaration
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As POINTAPI, ByVal nCount As Long) As Long
Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long
Public Declare Function ShellExecuteEx Lib "shell32.dll" (ByRef S As SHELLEXECUTEINFO) As Long
Public Declare Function fCreateShellLink Lib "Vb5stkit.DLL" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
Private Declare Function SHFormatDrive Lib "shell32" (ByVal hwnd As Long, ByVal Drive As Long, ByVal fmtID As Long, ByVal options As Long) As Long
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDC As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Public FilePath As String
Public FileSelect As String
Public FileSelectIndex As Integer
Public LastPathSelect As String
Public fsys As New FileSystemObject
Public WallTiles$
Public WallFileName$
Public WallBackColor$
Public WallBackPicture$
Public AddSoftwareName As Boolean
Public Shadow As String
Public ChkCRC As Boolean
Public Type_JPEG As String
Public FavoritePath As String
Public PlugInSoftware(5) As String  ' let 6 plugIns software
Public PluginCount As Integer
Public DateAttach As String
Public DFontName$
Public DFontSize$
Public DFontColor$
Public DFormat$
Public OffsetX$
Public OffsetY$
Public lwFontAlign As Long
Public ThumbnailSize As String
Public SlideTimer As String
Public ChkDateAttach As String
Public CDBurnPath As String
Public StartPath As String
Public SmartPath As String
Public CompanyName As String
Public BurnSoftware As String
Public FolderOper As Boolean

Public FileDrag As New Collection
Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long

Public Function DiskOps(Source As String, Dest As String, Flavor As FileOpt, Success As Long) As Long
'On Error GoTo DiskOpsErr
Dim result As Long
Dim FileOp As SHFILEOPSTRUCT
With FileOp
.hwnd = 0
   Select Case Flavor
      Case 1                           ' SmartCopy
         .wFunc = FO_COPY
         .fFlags = FOF_NOCONFIRMATION
      Case 2                           ' Copy
         .wFunc = FO_COPY
      Case 4                           ' Move
         .wFunc = FO_MOVE
      Case 8                           ' Delete
         .wFunc = FO_DELETE
      Case 16                          ' Delete (Recycle bin)
         .wFunc = FO_DELETE
         .fFlags = FOF_ALLOWUNDO Or FOF_NOCONFIRMATION
      Case 64                          ' Vault
         .wFunc = FO_COPY
         .fFlags = FOF_MULTIDESTFILES
      Case 128                         ' Rename
         .wFunc = FO_RENAME
   End Select
  '.lpszProgressTitle = ""
   .pFrom = Source & vbNullChar & vbNullChar    ' The files to copy separated by Nulls and terminated by 2 nulls
   .pTo = Dest & vbNullChar & vbNullChar                ' The directory or filename(s) to copy into terminated in 2 nulls
End With
   result = SHFileOperation(FileOp)
   DiskOps = result
   If result <> 0 Then 'Operation failed
      'Msgbox the error that occurred in the API.
   '''  MsgBox Err.Number & vbCrLf & Err.description & vbCrLf & Err.LastDllError, vbCritical Or vbOKOnly