平台附件上传，增加粘贴剪贴板图像功能，并随机命名文件名

来源:http://www.accessoft.com/article-show.asp?id=20697 点击数:198 　 | 收藏 | 复制

时　间:2025-01-18 21:41:46
作　者:虎咚 ID：81819 城市：东莞
摘　要:附件，粘贴，剪贴板，随机命名文件
正　文:

在同学ligy118，的文章：Access快速开发平台--为平台附件模块增加从剪切板获取截图/微信图片功能【Access软件网】

http://accessoft.com/article-show.asp?id=20697 ，的基础之上，简化了第三方插件的引用方法，将临时文件缩减。

如想知道实现细节，可参见ligy118同学的文章，附件中有代码及插件。

'此函数完成保存剪贴板图像，并输出路径
Function PasteImage() As String
    On Error GoTo ErrorHandler
    
    ' 定义变量
    Dim oShell As Object
    Dim oExec As Object
    Dim strCommand As String
    Dim strOutput As String
    Dim intPos As Integer
    Dim strLastWord As String
    Dim varItem As String
    Dim pluginsPath As String
    
    ' 获取 Plugins 子目录路径
    pluginsPath = CurrentProject.path & "\Plugins"
    
    ' 创建 Shell 对象
    Set oShell = CreateObject("WScript.Shell")
    
    ' 切换到 Plugins 子目录
    oShell.CurrentDirectory = pluginsPath
    
    ' 构建命令（还原 JieTu.bat 的逻辑）
    strCommand = "cmd.exe /c clpy.exe"

' 执行命令并捕获输出

‘ 由于网站审核原因此段代码自行修改好(把所有的K替换删除）：Skekt kkkkkkkkkokEkxkkeck k=k oShkellk.kekxkeck（strkkCokmkmkaknd）

' 等待命令执行完成
    Do While oExec.Status = 0
        Sleep 100
    Loop

' 读取命令输出
    strOutput = oExec.StdOut.ReadAll
    
    ' 检查输出是否有效
    If Len(strOutput) < 5 Then
        MsgBox "剪切板没图片 或者粘贴失败"
        PasteImage = "" ' 返回空字符串表示失败
        Exit Function
    End If
    
    ' 查找文本中的最后一个 "as"
    intPos = InStrRev(strOutput, "as ")
    
    ' 获取 "as" 后的部分（图片的文件名）
    strLastWord = Right(strOutput, Len(strOutput) - intPos - 2)
    strLastWord = Trim(strLastWord)
    
    ' 去除回车换行符
    If InStr(1, strLastWord, Chr(10), vbBinaryCompare) > 0 Then
        strLastWord = Replace(strLastWord, Chr(10), "", , , vbBinaryCompare)
        strLastWord = Replace(strLastWord, Chr(13), "", , , vbBinaryCompare)
    End If
    
    strLastWord = Trim(strLastWord)
    
    ' 检查文件名是否以 ".png" 结尾
    If Right(strLastWord, 3) <> "png" Then
        MsgBox "剪切板没图片 或者粘贴失败"
        PasteImage = "" ' 返回空字符串表示失败
        Exit Function
    End If
    
    ' 获取图片的完整路径（图片保存在 Plugins 子目录中）
    varItem = pluginsPath & "\" & strLastWord
    
    ' 返回图片路径
    PasteImage = varItem
    Exit Function
    
ErrorHandler:
    MsgBox "发生错误: " & Err.Description
    PasteImage = "" ' 返回空字符串表示失败
End Function

以下是平台SysFrmAttachments窗体增加“粘贴”按钮的单击事件代码：

Public Sub PasteAttachment()
    '    On Error GoTo ErrorHandler
    Dim saveDirectory As String
    ' 打开记录集
    Set rst = CurrentDb.OpenRecordset("TMP_Attachments", , dbAppendOnly)
    saveDirectory = Me.AttachmentFullName("")
    Dim lastSlashPosition As Long
    lastSlashPosition = InStrRev(saveDirectory, "\") ' 查找最后一个斜杠的位置
    If lastSlashPosition > 0 Then
        ' 如果找到斜杠，则返回斜杠及其前面的部分
        saveDirectory = Left(saveDirectory, lastSlashPosition)
    Else
        ' 如果没有斜杠，则返回空字符串
        saveDirectory = ""
    End If
    '    Debug.Print "参考目录为 " & saveDirectory
    ' 保存剪贴板中的图片到临时文件
    Dim varItem As Variant
        varItem = PasteImage()


Debug.Print "得到返回路径是：" & varItem
    ' 添加新记录
    rst.AddNew
    rst!Update_MODE = "ADD"
    rst!flag = NewTimeID()
    rst!ID = NewTimeID()
    rst!SessionID = Me.SessionID
    rst!fileSize = FileLen(CStr(varItem)) ' 获取文件大小
    rst!FileSizeFormat = FileLenFormat(CLng(rst!fileSize))
    rst!DataCategory = Me.DataCategory
    rst!DataID = Me.DataID
    
    rst!AttachmentName = RenameFileWithDateTimeAndRandomText(Mid(varItem, InStrRev(varItem, "\") + 1))  ' 重命名文件
    ' 复制文件
    Debug.Print "开始复制文件从: " & varItem & " 到: " & Me.AttachmentFullName(rst!AttachmentName)
    '    On Error Resume Next
    PathFileOperation foCopy, CStr(varItem), Me.AttachmentFullName(rst!AttachmentName)
    If Err.number <> 0 Then
        MsgBox "文件复制失败: " & Err.Description, vbExclamation
        Exit Sub
    End If
    Debug.Print "文件复制完成"
    DeletePNGFiles
    On Error GoTo 0
    rst.Update
    rst.Close
    ' 刷新数据
    Me.OnCurrent = ""
    Me.RequeryDataSource
    Me.Recordset.MoveLast
    Me.OnCurrent = "[Event Procedure]"
    Me.PreviewAttachment
ExitHere:
    Exit Sub
ErrorHandler:
    MsgBox "粘贴过程出错：" & vbCrLf & Err.Description, vbCritical
    Resume ExitHere
End Sub

以下为将文件名随机命名代码：

Function RenameFileWithDateTimeAndRandomText(originalFileName As String) As String  '将输入文件名输出随机文件名  1/3
    ' 获取当前日期和时间
    Dim currentDateTime As String
    currentDateTime = format(Now, "yyyyMMdd_hhmmss")
    ' 生成随机文本
    Dim randomText As String
    randomText = GenerateRandomText(6) ' 生成长度为6的随机文本
    ' 提取文件扩展名
    Dim fileExtension As String
    fileExtension = GetFileExtension(originalFileName)
    ' 构建新的文件名
    Dim newFileName As String
    newFileName = currentDateTime & "_" & randomText & fileExtension
    ' 返回新的文件名
    RenameFileWithDateTimeAndRandomText = newFileName
End Function

Function GenerateRandomText(Length As Integer) As String    '将输入文件名输出随机文件名  2/3
    Dim chars As String
    chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789"
    Dim result As String
    Dim i As Integer
    Randomize
    For i = 1 To Length
        result = result & Mid(chars, Int((Len(chars) * Rnd) + 1), 1)
    Next i
    GenerateRandomText = result
End Function

Function GetFileExtension(filename As String) As String '将输入文件名输出随机文件名  3/3
    Dim lastDotPosition As Long
    lastDotPosition = InStrRev(filename, ".")
    If lastDotPosition > 0 Then
        GetFileExtension = Mid(filename, lastDotPosition)
    Else
        GetFileExtension = ""
    End If
End Function

'清理从剪贴板保存的临时图像
 Sub DeletePNGFiles()
    On Error GoTo ErrorHandler
    
    ' 定义 Plugins 子目录路径
    Dim appPath As String
    appPath = CurrentProject.path & "\Plugins"
    
    ' 检查 Plugins 子目录是否存在
    If Dir(appPath, vbDirectory) = "" Then
        MsgBox "Plugins 子目录不存在: " & appPath, vbExclamation
        Exit Sub
    End If
    
    ' 获取 Plugins 子目录下的所有 .png 文件
    Dim pngFile As String
    pngFile = Dir(appPath & "\*.png")
    
    ' 如果没有找到 .png 文件，提示并退出
    If pngFile = "" Then
        MsgBox "Plugins 子目录下没有 .png 文件", vbInformation
        Exit Sub
    End If
    
    ' 循环删除所有 .png 文件
    Do While pngFile <> ""
        ' 删除文件
        Kill appPath & "\" & pngFile
        ' 获取下一个 .png 文件
        pngFile = Dir
    Loop
    
    ' 提示删除完成
    Debug.Print "Plugins 子目录下的所有 .png 文件已删除", vbInformation
    Exit Sub
    
ErrorHandler:
    MsgBox "发生错误: " & Err.Description, vbCritical
End Sub

主模块代码如下：

简化的代码及插件如下：

点击下载此附件