frmmdis.frm

vb做的看图系统

End Sub

Private Sub MnuSmartMove_Click()
    Oper SmartMove
End Sub

Private Sub MnuWallCenter_Click()
    If Me.ActiveForm.Lv1.SelectedItem.Key = "" Then Exit Sub
    Me.MousePointer = 11
    SetWallPaper Me.ActiveForm.Lv1.SelectedItem.Key, Center
    Me.MousePointer = 0
End Sub

Private Sub MnuWallStretch_Click()
    If Me.ActiveForm.Lv1.SelectedItem.Key = "" Then Exit Sub
    Me.MousePointer = 11
    SetWallPaper Me.ActiveForm.Lv1.SelectedItem.Key, Stretch
    Me.MousePointer = 0
End Sub

Private Sub MnuWallTile_Click()
    If Me.ActiveForm.Lv1.SelectedItem.Key = "" Then Exit Sub
    Me.MousePointer = 11
    SetWallPaper Me.ActiveForm.Lv1.SelectedItem.Key, Tile
    Me.MousePointer = 0
End Sub

Private Sub TMcmdAbout_Click()
    frmAbout.Show 1
End Sub

Private Sub TMcmdbutton1_Click()
    GoPaths TMcmdbutton1.Tag
End Sub

Private Sub TMcmdRefresh_Click()
    Drive1.Refresh
    GoPaths FilePath
End Sub

Private Sub TMcmdbutton2_Click()
    GoPaths TMcmdbutton2.Tag
End Sub

Private Sub TMcmdbutton3_Click()
    GoPaths TMcmdbutton3.Tag
End Sub

Private Sub TMcmdbutton4_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub TMcmdbutton5_Click()
Me.Arrange vbTileHorizontal
End Sub

Private Sub TMcmdbutton6_Click()
    Me.Arrange vbCascade
End Sub

Private Sub TMcmdbutton7_Click()
    GoPaths FavoritePath '   FolderLocation(CSIDL_PERSONAL) ' My Document
End Sub

Private Sub TMcmdbutton8_Click()
    On Error Resume Next
    If Me.ActiveForm.Lv1.View = 3 Then
        Me.ActiveForm.Lv1.View = 0 'icon
    Else
        Me.ActiveForm.Lv1.View = 3
    End If
End Sub

Private Sub TMcmdbutton9_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then FormatDrive "a:"  ' format a:
    If Button = 1 Then GoPaths "a:"
End Sub

Private Sub TMcmdDesktop_Click()
GoPaths FolderLocation(CSIDL_Desktop)
End Sub

Private Sub TMcmdNewFolder_Click()
    On Error Resume Next
    Dim ret As Boolean
    If Len(TxtNewFolder.Text) <> 0 Then
        If Dir(FilePath & TxtNewFolder.Text, vbDirectory) = "" Then
            ret = ShowMsg("创建文件夹 :" & TxtNewFolder.Text, vbYesNo, "提示")
            If ret Then
                MkDir FilePath & TxtNewFolder.Text
                GoPaths FilePath
            End If
        Else
            ShowMsg "文件夹 :" & TxtNewFolder.Text & vbCrLf & "已经存在!", vbOKOnly, "提示"
        End If
    End If
End Sub

Private Sub TMcmdOption_Click()
    Dim fOption As frmOptions
    Set fOption = New frmOptions
    With fOption
        .TxtFolder(0).Text = FavoritePath
        .TxtFolder(1).Text = CDBurnPath
        .TxtFolder(2).Text = StartPath
        .TxtFolder(3).Text = SmartPath
        .TxtThumbnailSize.Text = ThumbnailSize
        .TxtSlideTimer.Text = SlideTimer
        .Show 1
    End With
    Set fOption = Nothing
End Sub

Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Sub LoadNewWin(Path As String)
    Dim iForm As Form
    Dim fLv As FrmLv
    For Each iForm In Forms
        If iForm.Caption = Path Then
            iForm.PicExif.Forecolor = DFontColor
            iForm.PicExif.Font = DFontName
            iForm.PicExif.FontSize = DFontSize
            iForm.SetFocus
            Exit Sub
        End If
    Next
    Set fLv = New FrmLv
    fLv.Caption = Path
    fLv.PicTop.Refresh
    Screen.MousePointer = 11
    sbStatusBar.Panels(1) = "正在加载图片 ..."
    fLv.RefreshLv Path
    Screen.MousePointer = 0
    'On Error Resume Next
    If fLv.Lv1.ListItems.Count > 0 Then
        If bFileExists(Path & "desktop.ini") And bFileExists(Path & "bg") Then
            fLv.Lv1.Picture = LoadPicture(Path & "bg")
        End If
        fLv.Show
        AddPath2Cb Path
    Else
        Unload fLv
    End If
    Set fLv = Nothing
    sbStatusBar.Panels(1) = ""
End Sub

Sub ClosedAll()
    Dim iForm As Form
    For Each iForm In Forms
        Unload iForm
    Next
End Sub

Public Sub LoadPreview(FileName As String)
    Dim ximg As cIMAGE
    Dim PicRatio, xRatio As Single
    On Error GoTo PreviewErr
    Set ximg = New cIMAGE
    Screen.MousePointer = 11
    sbStatusBar.Panels(1) = "正在加载图片..."
    With PicPreview
        PicRatio = .Width / .Height
        ximg.Load FileName
        xRatio = ximg.ImageWidth / ximg.ImageHeight
        If ximg.ImageHeight < ximg.ImageWidth Then
            ximg.ReSize .Width * 15 / 16, 0, False
        Else
            ximg.ReSize 0, .Height * 15 / 16, False
        End If
        ImgPreview.Visible = False
        ImgPreview.Left = (.ScaleWidth - ximg.ImageWidth) / 2
        ImgPreview.Top = (.ScaleHeight - ximg.ImageHeight) / 2
        ImgPreview.Width = ximg.ImageWidth
        ImgPreview.Height = ximg.ImageHeight
        ImgPreview.Picture = ximg.Picture
        ImgPreview.Visible = True
        .Tag = FileName
    End With
    Set ximg = Nothing
    sbStatusBar.Panels(1) = Me.ActiveForm.Lv1.SelectedItem.Text
    Screen.MousePointer = 0
    Exit Sub
PreviewErr:
    Set ximg = Nothing
    sbStatusBar.Panels(1) = ""
    Screen.MousePointer = 0
    Resume Next
End Sub

Sub SaveResize()
    Dim ximg As cIMAGE
    Dim TempFile As String
    Dim retval As Long
    On Error GoTo SaveResizeErr
    Set ximg = New cIMAGE
    If DriveAReady Then
        ShowMsg "驱动器A: 没有准备好!", vbOKOnly, "错误"
        Exit Sub
    End If
    If Val(Me.ActiveForm.Lv1.SelectedItem.Tag) > 1280000 Then
        ShowMsg "文件 :" & Me.ActiveForm.Lv1.SelectedItem.Text & vbCrLf & "文件太大.", vbOKOnly, "提示"
        Exit Sub
    End If
    FileSelect = Me.ActiveForm.Lv1.SelectedItem.Key
    TempFile = GetATemporaryFileName
    sbStatusBar.Panels(3).Text = "设置为背景 "
    If ximg.Load(Me.ActiveForm.Lv1.SelectedItem.Key) = True Then
        If ximg.ImageHeight < ximg.ImageWidth Then
            ximg.ReSize 800, 0, False
        Else
            ximg.ReSize 0, 600, False
        End If
        sbStatusBar.Panels(3).Text = "计算 desktop.ini "
        SaveDesktop "a:", "bg"
        sbStatusBar.Panels(3).Text = "保存 desktop.ini"
        DrawCaption ximg, TempFile, "..."
        sbStatusBar.Panels(3).Text = "保存主文件"
        DiskOps FileSelect, "a:\" & Me.ActiveForm.Lv1.SelectedItem.Text, F_CopySmart, 1
        sbStatusBar.Panels(3).Text = "保存背景 "
        DiskOps TempFile, "a:\bg", F_CopySmart, 1
        sbStatusBar.Panels(3).Text = "复制背景 "
        SetAttr "a:\bg", vbHidden
        SetAttr "a:\desktop.ini", vbHidden
        sbStatusBar.Panels(3).Text = "设置文件属性 "
        DiskOps TempFile, TempFile, F_DelUndo, 1
        sbStatusBar.Panels(3).Text = "删除临时文件 "
    End If
    Set ximg = Nothing
    sbStatusBar.Panels(3).Text = ""
    Exit Sub
SaveResizeErr:
    Set ximg = Nothing
    Resume Next
End Sub

Sub SaveResizeCD(Dest As String)
    Dim ximg As cIMAGE
    Dim xexif As cEXIF
    Dim Exifdate As String
    Dim TempFile As String
    Dim retval As Long
    On Error GoTo SaveResizeCDErr
    Dest = Dest + IIf(Right$(Dest, 1) <> "\", "\", "")
    If Dir(Dest, vbDirectory) = "" Then
        retval = ShowMsg("文件夹 : " & Dest & vbCrLf & "没有找到." & vbCrLf & "是否创建文件夹?", vbYesNo, "提示")
        If retval Then
            MkDir Dest
        Else
            Exit Sub
        End If
    End If
    Set ximg = New cIMAGE
    Set xexif = New cEXIF
    FileSelect = Me.ActiveForm.Lv1.SelectedItem.Key
    If xexif.Load(FileSelect) Then
        Exifdate = Format$(xexif.EXIFmodified, "yyyy-mm-dd hh:nn:ss")
    Else
        Exifdate = ""
    End If
    Set xexif = Nothing
    TempFile = GetATemporaryFileName
    sbStatusBar.Panels(3).Text = "计算背景 "
    If ximg.Load(Me.ActiveForm.Lv1.SelectedItem.Key) = True Then
        If ximg.ImageHeight < ximg.ImageWidth Then
            ximg.ReSize 800, 0, False
        Else
            ximg.ReSize 0, 600, False
        End If
        sbStatusBar.Panels(3).Text = "计算 desktop.ini "
        SaveDesktop Dest$, "bg"
        sbStatusBar.Panels(3).Text = "保存 desktop.ini"
        DrawCaption ximg, TempFile, Exifdate
        sbStatusBar.Panels(3).Text = "保存主文件 "
        DiskOps FileSelect, Dest & Me.ActiveForm.Lv1.SelectedItem.Text, F_CopySmart, 1
        sbStatusBar.Panels(3).Text = "保存背景  "
        DiskOps TempFile, Dest & "bg", F_CopySmart, 1
        sbStatusBar.Panels(3).Text = "复制背景 "
        SetAttr Dest & "bg", vbHidden
        SetAttr Dest & "desktop.ini", vbHidden
        sbStatusBar.Panels(3).Text = "设置文件属性 "
        DiskOps TempFile, TempFile, F_DelUndo, 1
        sbStatusBar.Panels(3).Text = "删除临时文件 "
    End If
    Set ximg = Nothing
    sbStatusBar.Panels(3).Text = ""
    Exit Sub
SaveResizeCDErr:
    Set ximg = Nothing
    Resume Next
End Sub

Public Sub SaveDesktop(Dest$, BgFile$)
    Dim DeskStr$
    Dim TempFile$
    TempFile = GetATemporaryFileName
    DeskStr = "[ExtShellFolderViews]" & vbCrLf
    DeskStr = DeskStr & "{BE098140-A513-11D0-A3A4-00C04FD706EC}={BE098140-A513-11D0-A3A4-00C04FD706EC}" & vbCrLf
    DeskStr = DeskStr & "[{BE098140-A513-11D0-A3A4-00C04FD706EC}]" & vbCrLf
    DeskStr = DeskStr & "IconArea_Image =" & BgFile & vbCrLf
    DeskStr = DeskStr & "IconArea_Text=0x00000000" & vbCrLf
    DeskStr = DeskStr & "Attributes = 1" & vbCrLf
    DeskStr = DeskStr & "[.ShellClassInfo]" & vbCrLf
    DeskStr = DeskStr & "ConfirmFileOp = 0"
    Dim OutStream As TextStream
    Set OutStream = fsys.CreateTextFile(TempFile, True, False)
    OutStream.WriteLine DeskStr
    Set OutStream = Nothing
    Dest$ = Dest$ + IIf(Right$(Dest$, 1) <> "\", "\", "")
    DiskOps TempFile, Dest$ & "desktop.ini", F_CopySmart, 1
    DiskOps TempFile, TempFile, F_DelUndo, 1
End Sub

Sub DrawCaption(ximg As cIMAGE, FileName As String, Caption$)
    Dim fpreview As FrmPreview
    Set fpreview = New FrmPreview
    Dim mRect As RECT
    lwFontAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    With fpreview
        .PicPreview.Height = ximg.ImageHeight
        .PicPreview.Width = ximg.ImageWidth
        .PicPreview.Picture = ximg.Picture
        .PicPreview.FontName = "Courier New"
        .PicPreview.FontSize = 18
        .PicPreview.FontBold = True
        .PicPreview.DrawMode = 7
        .PicPreview.BackColor = vbBlue
        .PicPreview.Forecolor = vbBlack
        SetRect mRect, 1, 11, ximg.ImageWidth, 44
        DrawText .PicPreview.hDC, CompanyName, -1, mRect, lwFontAlign
        SetRect mRect, 1, ximg.ImageHeight - 41, ximg.ImageWidth, ximg.ImageHeight - 11
        DrawText .PicPreview.hDC, Caption$, -1, mRect, lwFontAlign
        .PicPreview.Forecolor = &HCCFF&       ' vbYellow
        SetRect mRect, 0, 10, ximg.ImageWidth, 44
        DrawText .PicPreview.hDC, CompanyName, -1, mRect, lwFontAlign
        SetRect mRect, 0, ximg.ImageHeight - 40, ximg.ImageWidth, ximg.ImageHeight - 10
        DrawText .PicPreview.hDC, Caption$, -1, mRect, lwFontAlign
        .PicPreview.Picture = .PicPreview.Image
        SaveJPG .PicPreview.Picture, FileName 'FilePath & "bg.jpg"
    End With
End Sub

Sub GoPaths(Path)
    Dim chkdisk As Boolean
    chkdisk = True
    If Path = "a:" Then chkdisk = CheckDiskette
    If chkdisk = False Then Exit Sub
    Drive1.Drive = Left$(Path, 1) & ":"
    Dir1.Path = Path
End Sub

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

Function GotoForm(Path As String)
    Dim iForm As Form
    For Each iForm In Forms
        If iForm.Caption = Path Then
            iForm.SetFocus