modfx.bas

vb做的看图系统

       ShowMsg "Cannot " & FileOp.wFunc & Source & vbCrLf & "to " & Dest, vbOKOnly, "Critical Error"
   Else
      If FileOp.fAnyOperationsAborted <> 0 Then
        MsgBox "Operation Failed", vbCritical Or vbOKOnly
         Success = -1
      End If
   End If
End Function

Public Function bFileExists(FileName As String) As Boolean
      Dim TempAttr         As Integer
   On Error GoTo ExitFileExist 'any errors show that the file doesnt exist, so goto this label
   TempAttr = GetAttr(FileName)  'get the attributes of the files
   bFileExists = ((TempAttr And vbDirectory) = 0) 'check if its a directory and not a file
ExitFileExist:
   On Error GoTo 0 'clear all errors
End Function

Public Function GetATemporaryFileName() As String
    'used to create swap file for lossless saving
    On Error Resume Next
    Dim sTempDir As String
    Dim sTempFileName As String
    
    'Create buffers
    sTempDir = String(100, Chr$(0))
    sTempFileName = String(260, 0)
    'Get the temporary path
    GetTempPath 100, sTempDir
    'Strip the 0's off the end
    sTempDir = Left$(sTempDir, InStr(sTempDir, Chr$(0)) - 1)
    'backup in case none found
    If Len(sTempDir) = 0 Then
        sTempDir = "C:\"
    End If
    'get file name
    GetTempFileName sTempDir, "DEK", 0, sTempFileName
    'Strip the 0's off the end
    sTempFileName = Left$(sTempFileName, InStr(sTempFileName, Chr$(0)) - 1)
    GetATemporaryFileName = sTempFileName
End Function

Public Sub SearchJpgType()
Dim JpgDefault$
JpgDefault = QueryValue(HKEY_CLASSES_ROOT, ".jpg", "")
Type_JPEG = QueryValue(HKEY_CLASSES_ROOT, JpgDefault, "")
'search registry for .jpg  default value
' search for that value
' search for defaut value -->type jpg
End Sub

Public Function FolderLocation(lFolder As SHFolders) As String
   Dim lp As Long
   'Get the PIDL for this folder
   SHGetSpecialFolderLocation 0&, lFolder, lp
   SHGetPathFromIDList lp, buffer
   FolderLocation = StripNull(buffer)
   'Free the PIDL
   CoTaskMemFree lp
End Function

Public Function StripNull(ByVal StrIn As String) As String
On Error Resume Next
Dim nul As Long
nul = InStr(StrIn, vbNullChar)
    Select Case nul
        Case Is > 1
            StripNull = Left$(StrIn, nul - 1)
        Case 1
            StripNull = ""
        Case 0
            StripNull = Trim$(StrIn)
   End Select
End Function

Public Function GetFName(FileName As String) As String
Dim fs, F
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set F = fs.GetFile(FileName)
    GetFName = F.Name
    Set F = Nothing
    Set fs = Nothing
End Function

Public Function GetFPath(FileName As String) As String
Dim fs, F
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set F = fs.GetFile(FileName)
    GetFPath = F.ParentFolder + IIf(Right(F.ParentFolder, 1) <> "\", "\", "")
    Set F = Nothing
    Set fs = Nothing
End Function

Function DragForm(frm As Form)
  Dim ret As Long
  ret = ReleaseCapture()
  ret = SendMessage(frm.hwnd, WM_NCLBUTTONDOWN, 2&, 0&)
End Function

Public Function CheckDiskette() As Boolean
On Error GoTo CheckDiskette_Error
'set default for error flag

'this will generate a trappable error if card not inserted
ChDir "a:"
'go back to original hard drive
ChDir "c:"
On Error GoTo 0
CheckDiskette = True
Exit Function
CheckDiskette_Error:
If Err.Number = 75 Then
   ShowMsg "Please check that the diskette " & vbCrLf & "is properly inserted and try again.", vbOKOnly, "Xpress Viewer"
   CheckDiskette = False
    Exit Function
Else
    ShowMsg "Error " & Err.Number & vbCrLf & " (" & Err.Description & ") in procedure CheckDiskette", vbOKOnly, "Xpress Viewer"
Err.Clear
End If
End Function

Sub FormatDrive(strDrive As String)
Dim strDriveLetter As String
Dim lngDriveNumber As Long
Dim lngRetVal As Long
Dim lngDriveType As Long
Dim lngRet As Long

strDriveLetter = UCase(strDrive)
lngDriveNumber = (Asc(strDriveLetter) - 65) ' Change letter to Number: A=0
lngDriveType = GetDriveType(strDriveLetter)

If lngDriveType = 2 Then 'Floppies, etc
lngRetVal = SHFormatDrive(FrmMdi.hwnd, lngDriveNumber, 0&, 0&)
Else
lngRet = MsgBox("This drive is NOT a removeable" & vbCrLf & _
"drive! Format this drive?", 276, "SHFormatDrive Example")
Select Case lngRet
Case 6 'Yes
lngRetVal = SHFormatDrive(FrmMdi.hwnd, lngDriveNumber, 0&, 0&)
Case 7 'No
' Do nothing
End Select
End If
End Sub

Public Sub FileProperties(FileName$)
Dim shInfo As SHELLEXECUTEINFO

    With shInfo
        .cbSize = LenB(shInfo)
        .lpFile = FileName$
        .nShow = SW_SHOW
        .fMask = SEE_MASK_INVOKEIDLIST
        .lpVerb = "properties"
    End With
    ShellExecuteEx shInfo

End Sub

Public Sub SetWallPaper(PathName$, Mode As WallPaperMode)
On Error Resume Next
Dim ximg As cIMAGE
Dim WallPaperPath As String
Dim wStyle, wTile As String
Dim ScreenHeight As Integer, ScreenWidth As Integer
Dim ImgRatio As Single, ScreenRatio As Single
Dim PicWall As PictureBox
    WallPaperPath = WindowsFolder & GetFName(PathName)
    ScreenWidth = Screen.Width / Screen.TwipsPerPixelX
    ScreenHeight = Screen.Height / Screen.TwipsPerPixelY
    ScreenRatio = Screen.Width / Screen.Height
    If Mode = Stretch Then
        'Get monitor display settings.
        With PicWall
            .Width = ScreenWidth
            .Height = ScreenHeight
            .BackColor = WallBackColor
            .Picture = LoadPicture(WallBackPicture)
            Set ximg = New cIMAGE
            ximg.Load PathName
            If ximg.ImageWidth > ximg.ImageHeight Then
                ximg.ReSize .Width, 0, True
            Else
                ximg.ReSize 0, .Height, True
            End If
            ximg.PaintDC .hDC, (ScreenWidth - ximg.ImageWidth) / 2, (ScreenHeight - ximg.ImageHeight) / 2
            Set ximg = Nothing
            .Picture = .Image
            SavePicture .Picture, WallPaperPath
            .Picture = LoadPicture
            .Cls
        End With
    Else
            Set ximg = New cIMAGE
            ximg.Load PathName
            If ximg.ImageWidth > ximg.ImageHeight Then
                ximg.ReSize ScreenWidth \ Val(WallTiles), 0, 0
            Else
                ximg.ReSize 0, ScreenHeight \ Val(WallTiles), 0
            End If
            'set the path to the wallpaper bitmap
            ' save as bitmap , so desktop will automatically replace wallpaper & refresh
            ' If save as Jpeg , it will not refresh desktop
            'SavePicture LoadPicture(PathName), WallPaperPath
            SavePicture ximg.Picture, WallPaperPath
            Set ximg = Nothing
    End If
Select Case Mode
    Case 0    'Stretch wallpaper
        wStyle = "2"
        wTile = "0"
    Case 1 'Tile wallpaper
        wStyle = "0"
        wTile = "1"
    Case 2 'Center wallpaper
        wStyle = "0"
        wTile = "0"
End Select
Set PicWall = Nothing
    SetKeyValue HKEY_CURRENT_USER, "Control Panel\Desktop", "WallpaperStyle", wStyle, REG_SZ
    SetKeyValue HKEY_CURRENT_USER, "Control Panel\Desktop", "TileWallpaper", wTile, REG_SZ
    SetKeyValue HKEY_CURRENT_USER, "Control Panel\Desktop", "Wallpaper", WallPaperPath, REG_SZ
    SystemParametersInfo SPI_SETDESKWALLPAPER, 0&, WallPaperPath, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE
End Sub

Public Function WindowsFolder() As String
Dim buffer  As String * MAX_PATH
GetWindowsDirectory buffer, 255
WindowsFolder = StripNull(buffer)
WindowsFolder = WindowsFolder + IIf(Right(WindowsFolder, 1) <> "\", "\", "")
End Function

Sub DropShadow(hwnd As Long)
    SetClassLong hwnd, GCL_STYLE, GetClassLong(hwnd, GCL_STYLE) Or CS_DROPSHADOW
End Sub

Public Function ShowMsg(Msg As String, style As MsgStyle, TitleMsg As String) As Boolean
ShowMsg = False
With FrmMessage
Select Case style
    Case vbOKOnly:
        .CmdYes.Caption = "确定"
        .CmdYes.Left = (.ScaleWidth - .CmdYes.Width) / 2
        .CmdNo.Visible = False
    Case vbOKCancel:
        .CmdYes = "Ok"
        .CmdNo.Caption = "取消"
    Case vbYesNo:
        .CmdYes.Caption = "是"
        .CmdNo.Caption = "否"
End Select
    .LblMsg = Msg
    .LblMsg2 = Msg
    .LblTitle = TitleMsg
    .LblTitle2 = TitleMsg
    .Show 1
End With
If ReturnMsg = "Yes" Or ReturnMsg = "Ok" Then
    ShowMsg = True
End If
End Function