frmmdis.frm

vb做的看图系统

            sbStatusBar.Panels(1) = "正在刷新中..."
            iForm.RefreshLv Path
            sbStatusBar.Panels(1) = ""
            Exit Function
        End If
    Next
End Function

Function DriveAReady() As Boolean
    Dim sPath   As String
    Dim uWFD    As WIN32_FIND_DATA
    Dim hSearch As Long
    sPath = "a:\*.*" & vbNullChar
    hSearch = FindFirstFile(sPath, uWFD)
    FindClose (hSearch)
    DriveAReady = hSearch
    ' Debug.Print hSearch
    DriveAReady = True
    'If (Not m_bEnding And Not ucFolderView.PathIsValid("a:\")) Then
    '  If (Not m_bEnding) Then
    '  DriveAReady = False
    '  End If
End Function

Sub ResizePic()
    Dim ximg As cIMAGE
    Dim xexif As cEXIF
    Dim TempFile As String
    Dim retval As Long
    On Error GoTo ResizeErr
    Set ximg = New cIMAGE
    FilePath = Me.ActiveForm.Caption
    FileSelect = Me.ActiveForm.Lv1.SelectedItem.Key
    Set xexif = New cEXIF
    TempFile = FilePath & "Resize_" & Me.ActiveForm.Lv1.SelectedItem.Text
    If ximg.Load(Me.ActiveForm.Lv1.SelectedItem.Key) = True Then
        sbStatusBar.Panels(3).Text = "Resize..."
        SaveJPG ximg.Picture, TempFile, 75
    End If
    Set ximg = Nothing
    xexif.Load TempFile
    xexif.EXIFmodified = Now & Chr$(13)
    xexif.EXIFsoftware = "XP Viewer ver 1.0 " & Chr$(13)
    xexif.Save
    Set xexif = Nothing
    DiskOps FileSelect, FileSelect, F_DelUndo, 1
    DiskOps TempFile, FileSelect, F_Rename, 1
    sbStatusBar.Panels(3).Text = ""
    Exit Sub
ResizeErr:
    Set ximg = Nothing
    Resume Next
End Sub

Sub ShowPreview()
    Dim fpreview As FrmPreview
    Set fpreview = New FrmPreview
    Dim ximg As cIMAGE
    Dim retval As Long
    Dim mRect As RECT
    Set ximg = New cIMAGE
    lwFontAlign = DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
    FileSelect = Me.ActiveForm.Lv1.SelectedItem.Key
    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
        SetRect mRect, 1, 11, ximg.ImageWidth + 1, 45
        fpreview.PicPreview.Picture = ximg.Picture
        fpreview.PicPreview.Width = ximg.ImageWidth
        fpreview.PicPreview.Height = ximg.ImageHeight
        fpreview.PicPreview.Left = 10
        fpreview.PicPreview.Top = fpreview.Picture1.Height + 10
        DrawText fpreview.PicPreview.hDC, "    Summer Studio && Colour Photo    ", -1, mRect, lwFontAlign
        fpreview.PicPreview.Visible = True
        fpreview.Show 1
    End If
    Set ximg = Nothing
End Sub

Sub Oper(op As ImgOperation)
    Dim xexif As cEXIF
    Dim Loading As Boolean
    Dim SelectFile As String
    Dim SmartFolder As String
    Dim NewFile As String
    Dim itmx As ListItem
    Dim ret As Boolean

    On Error GoTo OperErr

    FilePath = Me.ActiveForm.Caption
    Set itmx = Me.ActiveForm.Lv1.SelectedItem
    Me.MousePointer = 11
    For Each itmx In Me.ActiveForm.Lv1.ListItems
        If itmx.Selected Then
            SetAttr itmx.Key, vbArchive
            Select Case op
                Case ImgOperation.Exif_Date
                'exit date
                sbStatusBar.Panels(1) = itmx.Text & "==> 可交换图形文件日期..."
                Set xexif = New cEXIF
                Loading = xexif.Load(itmx.Key)
                If AddSoftwareName Then
                    xexif.EXIFsoftware = "XP Viewer"
                    xexif.Save
                End If
                If Loading Then
                    NewFile = FilePath & Format$(xexif.EXIFmodified, "yyyy-mm-dd hh-nn-ss") & ".JPG"
                    If xexif.EXIFmodified = "12:00:00 AM" Then
                        NewFile = FilePath & Format$(FileDate(itmx.Key), "yyyy-mm-dd hh-nn-ss") & ".JPG"
                    End If
                End If
                Set xexif = Nothing
                If Loading Then
                    If bFileExists(NewFile) = False Then
                        SetAttr itmx.Key, vbArchive
                        Name itmx.Key As NewFile
                    Else
                        If ShowMsg("文件 : " & GetFName(NewFile) & " 已经存在!" & vbCrLf & "是否替换该文件?", vbYesNo, "提示") Then
                            SetAttr NewFile, vbArchive
                            Kill NewFile
                            SetAttr itmx.Key, vbArchive
                            Name itmx.Key As NewFile
                        End If
                    End If
                End If

                Case ImgOperation.Rotate_90
                'rotate 90
                sbStatusBar.Panels(1) = itmx.Text & "==> 旋转 90 度..."
                Set xexif = New cEXIF
                If xexif.Load(itmx.Key) = True Then
                    xexif.SaveAs EncoderValueTransformRotate90
                End If
                Set xexif = Nothing

                Case ImgOperation.Rotate_180
                'rotate 180
                sbStatusBar.Panels(1) = itmx.Text & "==> 旋转 180 度..."
                Set xexif = New cEXIF
                If xexif.Load(itmx.Key) = True Then
                    xexif.SaveAs EncoderValueTransformRotate180
                End If
                Set xexif = Nothing

                Case ImgOperation.Rotate_270
                'rotate 270
                sbStatusBar.Panels(1) = itmx.Text & "==> 旋转 270 度..."
                Set xexif = New cEXIF
                If xexif.Load(itmx.Key) = True Then
                    xexif.SaveAs EncoderValueTransformRotate270
                End If
                Set xexif = Nothing

                Case ImgOperation.Flip_Vertical
                'Flip Vertical
                sbStatusBar.Panels(1) = itmx.Text & "==> 垂直翻转..."
                Set xexif = New cEXIF
                If xexif.Load(itmx.Key) = True Then
                    xexif.SaveAs EncoderValueTransformFlipVertical
                End If
                Set xexif = Nothing

                Case ImgOperation.Flip_Horizontal
                'Flip Horizontal
                sbStatusBar.Panels(1) = itmx.Text & "==> 水平翻转..."
                Set xexif = New cEXIF
                If xexif.Load(itmx.Key) = True Then
                    xexif.SaveAs EncoderValueTransformFlipHorizontal
                End If
                Set xexif = Nothing

                Case ImgOperation.moveto

                sbStatusBar.Panels(1) = itmx.Text & "==> 移动到..."
                DiskOps itmx.Key, LastPathSelect & itmx.Text, F_Move, 1
                ' Smart Folder - Must set to exifDate first
                Case ImgOperation.SmartMove

                sbStatusBar.Panels(1) = itmx.Text & "==> 快速移动..."
                SmartFolder = SmartPath & Mid$(itmx.Text, 6, 2) & Mid$(itmx.Text, 3, 2) & "\"
                If Dir$(SmartFolder, vbDirectory) <> "" Then
                    DiskOps itmx.Key, SmartFolder & itmx.Text, F_Move, 1
                Else
                    ret = ShowMsg("文件夹 " & SmartFolder & vbCrLf & "没有找到." & vbCrLf & "是否创建 ?", vbYesNo, "提示")
                    If ret Then
                        MkDir SmartFolder
                        DiskOps itmx.Key, SmartFolder & itmx.Text, F_Move, 1
                    End If
                End If

                Case ImgOperation.copyto
                sbStatusBar.Panels(1) = itmx.Text & "==> 正在复制到..."
                DiskOps itmx.Key, LastPathSelect & itmx.Text, F_CopySmart, 1

                Case ImgOperation.AddExifDate
                sbStatusBar.Panels(1) = itmx.Text & "==> 添加可交换文件日期..."
                PrintDate itmx.Key
            End Select
            sbStatusBar.Panels(1) = ""
        End If

    Next
    Me.MousePointer = 0
    GotoForm FilePath
    Exit Sub
OperErr:
    ShowMsg Err.Description, vbOKOnly, "操作错误"
    Resume Next
End Sub

Public Sub ShowExif(FileName As String)
    Dim xexif As cEXIF
    Set xexif = New cEXIF
    If xexif.Load(FileName) = True Then
        LblExifdata = xexif.EXIFmake & vbCrLf
        LblExifdata = LblExifdata & xexif.EXIFmodel & vbCrLf
        LblExifdata = LblExifdata & Mid$(xexif.EXIFsoftware, 1, 28) & vbCrLf
        LblExifdata = LblExifdata & xexif.EXIFmodified & vbCrLf
        ' LblExifdata = LblExifdata & xexif.EXIFFNumber & vbCrLf
        ' LblExifdata = LblExifdata & xexif.EXIFiso & vbCrLf
        ' LblExifdata = LblExifdata & xexif.ExifShutterSpeed & vbCrLf
        ' LblExifdata = LblExifdata & xexif.ExifExposureProg & vbCrLf
        LblExifdata = LblExifdata & xexif.Width & vbCrLf
        LblExifdata = LblExifdata & xexif.Height
    End If
    Set xexif = Nothing
End Sub

Sub LoadTitle()
    LblExifTitle = "厂商" & vbCrLf
    LblExifTitle = LblExifTitle & "型号" & vbCrLf
    LblExifTitle = LblExifTitle & "软件" & vbCrLf
    LblExifTitle = LblExifTitle & "日期/时间" & vbCrLf
    'LblExifTitle = LblExifTitle & "F Number" & vbCrLf
    'LblExifTitle = LblExifTitle & "Iso" & vbCrLf
    'LblExifTitle = LblExifTitle & "Speed" & vbCrLf
    'LblExifTitle = LblExifTitle & "Mode" & vbCrLf
    LblExifTitle = LblExifTitle & "宽度" & vbCrLf
    LblExifTitle = LblExifTitle & "高度"
    TMcmdbutton1.Caption = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button1", "")
    TMcmdbutton1.Tag = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button1", "Tag")
    TMcmdbutton2.Caption = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button2", "")
    TMcmdbutton2.Tag = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button2", "Tag")
    TMcmdbutton3.Caption = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button3", "")
    TMcmdbutton3.Tag = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\Button\Button3", "Tag")
End Sub

Public Sub OperDelete()
    FilePath = Me.ActiveForm.Caption
    Dim itmx As ListItem
    Dim ximg As cIMAGE
    Dim action As Boolean
    Dim ret&
    Set itmx = Me.ActiveForm.Lv1.SelectedItem
    action = False
    For Each itmx In Me.ActiveForm.Lv1.ListItems
        If itmx.Selected And ShowDelPic Then
            Set ximg = New cIMAGE
            ximg.Load itmx.Key
            If ximg.ImageHeight < ximg.ImageWidth Then
                ximg.ReSize 120, 0, False
            Else
                ximg.ReSize 0, 120, False
            End If
            With FrmMessage
                .Image1.Visible = False
                .Image1.Width = ximg.ImageWidth
                .Image1.Height = ximg.ImageHeight
                .Image1.Picture = ximg.Picture
                .Image1.Visible = True
                Set ximg = Nothing
            End With
            If ShowMsg("删除文件 : " & itmx.Text & vbCrLf & "请确认是否删除 ?", vbYesNo, "删除文件") = True Then
                action = True
                If GetAttr(itmx.Key) <> vbArchive Then
                    SetAttr itmx.Key, vbArchive
                End If
                ret = DiskOps(itmx.Key, itmx.Key, F_DelUndo, 1)
                'cannot undo
                ' ret = DeleteFile(itmx.Key)
                '  Debug.Print "delete", ret, GetAttr(itmx.Key)
                '            Kill itmx.Key
            End If
        End If
        If itmx.Selected And Not ShowDelPic Then
            action = True
            If GetAttr(itmx.Key) <> vbArchive Then
                SetAttr itmx.Key, vbArchive
            End If
            sbStatusBar.Panels(1) = itmx.Text & "==> Delete ..."
            ret = DiskOps(itmx.Key, itmx.Key, F_DelUndo, 1)
            'DeleteFile itmx.Key
        End If
    Next
    sbStatusBar.Panels(1) = ""
    If action Then GotoForm FilePath
End Sub


Sub PrintDate(sFileName$)
    Dim xexif As cEXIF
    Dim sexif As String
    Dim rc As RECT
    Set xexif = New cEXIF
    xexif.Load sFileName
    If ChkDateAttach = "0" Then
        sexif = Format$(xexif.EXIFmodified, "yyyy-mm-dd hh:nn AM/PM")
    Else
        sexif = Format$(DateAttach, "yyyy-mm-dd")
    End If
    With Me.ActiveForm
        .scaleMode = 3
        .PicExif.Picture = LoadPicture
        .PicExif.Cls
        .PicExif.Refresh
        .PicExif.Forecolor = DFontColor
        .PicExif.Font = DFontName
        .PicExif.FontSize = .PicExif.Height \ 12  'DFontSize
        .PicExif.AutoRedraw = True
        .PicExif.Height = xexif.Height
        .PicExif.Width = xexif.Width
        SetRect rc, 1, 1, .PicExif.Width - Val(OffsetX), .PicExif.Height - Val(OffsetY)
        xexif.PaintDC .PicExif.hDC, 0, 0
        DrawText .PicExif.hDC, sexif, -1, rc, FontAlign
        .PicExif.AutoRedraw = False
        .PicExif.Picture = .PicExif.Image
        .PicExif.Refresh
        SaveJPG .PicExif.Picture, GetFPath(sFileName) & "x_" & GetFName(sFileName), 92
        .scaleMode = 1
    End With
    InvalidateRect hwnd, rc, False
    SaveExif GetFPath(sFileName) & "x_" & GetFName(sFileName), xexif
    Set xexif = Nothing
End Sub

Sub LoadWallPaper()
    WallFileName = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\WallPaper", "Filename")
    WallTiles = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\WallPaper", "Tiles")
    WallBackColor = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\WallPaper", "BackColor")
    WallBackPicture = QueryValue(HKEY_CURRENT_USER, "XPViewer\Control\WallPaper", "BackPicture")
End Sub

Sub LoadPrintDate()
    FontAlign = DT_BOTTOM Or DT_RIGHT Or DT_SINGLELINE
    DFontName = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach\Font", "Name")
    DFontSize = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach\Font", "Size")
    DFontColor = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach\Font", "Color")
    OffsetX = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach\Offset", "x")
    OffsetY = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach\Offset", "y")
    DFormat = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach", "Format")
    DateAttach = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach", "Date")
    ChkDateAttach = QueryValue(HKEY_CURRENT_USER, "XPViewer\Attach", "Check")
    If ChkDateAttach = "1" Then
        MnuAddExifDate.Caption = "添加日期 :" & Format$(DateAttach, "yyyy-mm-dd")
    Else
        MnuAddExifDate.Caption = "添加可交换文件日期"
    End If
End Sub

Sub LoadPlugIns()
    On Error Resume Next
    Dim i%
    PluginCount = Val(QueryValue(HKEY_CURRENT_USER, "XPViewer\PlugIn", "PlugInCount"))
    If PluginCount > 0 Then
        For i% = 1 To PluginCount
            PlugInSoftware(i%) = QueryValue(HKEY_CURRENT_USER, "XPViewer\PlugIn", "PlugIn " & Trim$(i%))
            Load MnuPlugIn1(i% - 1)
            MnuPlugIn1(i% - 1).Caption = GetFName(PlugInSoftware(i%))
            MnuPlugIn1(i% - 1).Tag = PlugInSoftware(i%)
            MnuPlugIn1(i% - 1).Visible = True
        Next i%
    End If
End Sub