自用截图工具

显示全部楼层 · 发表于 3 天前

工作中，
有时需要连续截图，然后保存图片，保存在同一个位置。也就是上一次保存后，下一次直接默认在这个位置。
有时需要连续截图，在word中粘贴图片。在word中粘贴图片时，尺寸又很难统一，word中插入的图片，有的宽有的高不好看。
有时候又需要微信公众号做封面，要求的比例是2.35：1
基于上述自身的需要出发，做一个自用的截图工具。
功能很简单：
1、保存截图：默认使用上一次保存的文件夹
2、复制截图：直接粘贴到word或者其他地方
3、截图比例：内置了一些。可以使用相同的比例截图，也可以使用自定义比例连续截图
4、自定义比例：随意自定义
5、直接保存为.jpg格式
没有其他功能，不支持滚动不支持添加文字不支持除矩形外的其他图形。
单纯的截图工具。
就一个单文件exe，大小约25M。
如需源码可以私信我。（python）

我只在win10上测试使用。

窗口截图市面上有很多，我这个只是出于工作需要频繁往word里插入图片。.
保存截图时输入图片名称是必须的，可以配合word vb，把图片名称做为图片描述，放到图片下方。
效果如图：

WPS WORD 批量插入图片VB代码：
如有其它需求可自行修改VB代码
[Visual Basic]

Sub 图片处理()
Dim choice As Integer
' 弹出选项窗口，让用户选择插入模式
choice = InputBox("请选择图片插入模式：" & vbCrLf & _
"(1) 两图一行" & vbCrLf & _
"(2) 每页2张" & vbCrLf & _
"(3) 每页一张", "图片插入模式")
' 检查用户输入是否有效
If Len(choice) = 0 Then
MsgBox "未选择任何模式，程序退出！", vbExclamation, "提示"
Exit Sub
End If
Select Case val(choice)
Case 1
Call 两图一行图片名称是描述行
Case 2
Call 每页两张电脑选图图片是描述行
Case 3
Call 每页一张电脑选图图片是描述行
Case Else
MsgBox "无效的选择，请重新运行并选择正确的模式！", vbExclamation, "提示"
Exit Sub
End Select
End Sub
Sub 两图一行图片名称是描述行()
Dim doc As Document
Dim imgFiles As Collection
Dim tbl As Table
Dim i As Integer, imgCount As Integer
Dim rowIdx As Integer, colIdx As Integer
Dim cell As cell, rng As Range, img As InlineShape
Dim cellWidth As Single, cellHeight As Single
' 初始化变量
Set doc = ActiveDocument
Set imgFiles = New Collection
cellWidth = ConvertCmToPts(7.52) ' 列宽固定为 7.52 cm
cellHeight = ConvertCmToPts(7) ' 行高固定为 7 cm
' 打开文件选择对话框
Dim fileDialog As fileDialog
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.Title = "请选择图片文件"
.AllowMultiSelect = True
If .Show -1 Then Exit Sub ' 如果用户取消选择，退出
For Each varItem In .SelectedItems
imgFiles.Add varItem
Next varItem
End With
' 检查是否有图片
If imgFiles.Count = 0 Then
MsgBox "未选择任何图片文件！", vbExclamation
Exit Sub
End If
' 计算表格的行数和列数
imgCount = imgFiles.Count
Dim numRows As Integer, numCols As Integer
numCols = 2 ' 每行两张图
numRows = (imgCount + 1) \ 2 ' 向上取整，确保所有图片都有位置
' 在光标位置创建表格
Set tbl = doc.Tables.Add(Range:=Selection.Range, numRows:=numRows * 2, NumColumns:=numCols)
' 设置表格样式
With tbl
.AutoFitBehavior wdAutoFitFixed
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = cellWidth * 2 ' 两列总宽度
.Rows.HeightRule = wdRowHeightExactly
.Rows.Height = cellHeight
.Borders.Enable = True
' 设置单元格内容居中对齐
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter ' 垂直居中
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter ' 水平居中
' 设置单元格边距为 0 厘米
.TopPadding = 0
.LeftPadding = 0
.RightPadding = 0
.BottomPadding = 0
.Spacing = 0
End With
' 插入图片和描述行
rowIdx = 1: colIdx = 1
For i = 1 To imgCount
' 插入图片
Set cell = tbl.cell(rowIdx, colIdx)
Set rng = cell.Range
Set img = doc.InlineShapes.AddPicture(fileName:=imgFiles(i), LinkToFile:=False, SaveWithDocument:=True, Range:=rng)
' 调整图片大小以保持宽高比并适应单元格
With img
If .Width / .Height > cellWidth / cellHeight Then
.Width = cellWidth
.LockAspectRatio = msoTrue
Else
.Height = cellHeight
.LockAspectRatio = msoTrue
End If
End With
' 插入描述行
Set cell = tbl.cell(rowIdx + 1, colIdx)
Set rng = cell.Range
rng.text = GetFileNameWithoutExtension(imgFiles(i)) ' 使用图片文件名作为描述，去掉后缀
With rng
.Font.NameFarEast = "宋体" ' 中文字体
.Font.Name = "Times New Roman" ' 英文字体
.Font.Size = 10.5 ' 5号字体
.ParagraphFormat.Alignment = wdAlignParagraphCenter ' 水平居中
.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
End With
tbl.Rows(rowIdx + 1).Height = ConvertCmToPts(0.55) ' 描述行高度
' 移动到下一列或下一行
colIdx = colIdx + 1
If colIdx > numCols Then
colIdx = 1
rowIdx = rowIdx + 2
End If
Next i
MsgBox "图片插入完成！", vbInformation
End Sub
Sub 每页两张电脑选图图片是描述行()
Dim doc As Document
Dim imgFiles As Collection
Dim tbl As Table
Dim i As Integer, imgCount As Integer
Dim currentRow As Long
Dim imgRange As Range, img As InlineShape
Dim maxWidth As Single, maxHeight As Single
Dim aspectRatio As Single, newWidth As Single, newHeight As Single
Dim descHeight As Single, cellWidth As Single, imgCellHeight As Single
' 初始化变量
Set doc = ActiveDocument
Set imgFiles = New Collection
maxWidth = 14.5 ' 图片最大宽度（厘米）
maxHeight = 11 ' 图片最大高度（厘米）
descHeight = 0.55 ' 描述行高度（厘米）
cellWidth = 15 ' 表格单元格宽度（厘米）
imgCellHeight = 11.5 ' 图片单元格高度（包括描述行）
' 打开文件选择对话框
Dim fileDialog As fileDialog
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.Title = "请选择图片文件"
.AllowMultiSelect = True
If .Show -1 Then Exit Sub ' 如果用户取消选择，退出
For Each varItem In .SelectedItems
imgFiles.Add varItem
Next varItem
End With
' 检查是否有图片
If imgFiles.Count = 0 Then
MsgBox "未选择任何图片文件！", vbExclamation
Exit Sub
End If
' 统计选中的图片数量
imgCount = imgFiles.Count
' 在光标位置创建表格
Dim totalRows As Long
totalRows = imgCount * 2 ' 每张图片需要2行：1行图片+1行描述
Set tbl = doc.Tables.Add(Range:=Selection.Range, numRows:=totalRows, NumColumns:=1)
' 设置表格基础样式
With tbl
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = Centimeters2234ToPoints(cellWidth) ' 表格宽度
.AllowAutoFit = False
.Borders.Enable = True
' 设置列宽
.Columns(1).Width = Centimeters2234ToPoints(cellWidth)
End With
' 初始化表格位置（从第1行开始）
currentRow = 1
' 处理每张选中的图片
For i = 1 To imgCount
' 插入图片到表格
Set imgRange = tbl.cell(currentRow, 1).Range
Set img = doc.InlineShapes.AddPicture(fileName:=imgFiles(i), LinkToFile:=False, SaveWithDocument:=True, Range:=imgRange)
' --- 调整图片大小 ---
aspectRatio = img.Width / img.Height
If (maxWidth / maxHeight) > aspectRatio Then
newHeight = maxHeight
newWidth = newHeight * aspectRatio
Else
newWidth = maxWidth
newHeight = newWidth / aspectRatio
End If
img.LockAspectRatio = msoFalse
img.Width = Centimeters2234ToPoints(newWidth)
img.Height = Centimeters2234ToPoints(newHeight)
' 设置图片行高度
tbl.Rows(currentRow).Height = Centimeters2234ToPoints(imgCellHeight - descHeight)
tbl.Rows(currentRow).HeightRule = wdRowHeightExactly
' 设置单元格内容为居中对齐
With tbl.cell(currentRow, 1).Range.ParagraphFormat
.Alignment = wdAlignParagraphCenter ' 水平居中
.SpaceAfter = 0
End With
' 设置单元格垂直对齐方式
tbl.cell(currentRow, 1).VerticalAlignment = wdAlignVerticalCenter
' --- 添加描述行 ---
' 设置描述行格式
With tbl.Rows(currentRow + 1)
.Height = Centimeters2234ToPoints(descHeight)
.HeightRule = wdRowHeightAtLeast ' 最小值
With .Range
' 设置字体
.Font.Name = "Times New Roman"
.Font.NameFarEast = "宋体"
.Font.Size = 10.5 ' 5号字=10.5磅
' 设置段落格式
With .ParagraphFormat
.Alignment = wdAlignParagraphCenter
.LineSpacingRule = wdLineSpaceSingle ' 1倍行距
.SpaceAfter = 0
End With
End With
End With
' 设置描述行文本（去掉文件扩展名）
tbl.cell(currentRow + 1, 1).Range.text = GetFileNameWithoutExtension(imgFiles(i))
' 更新位置（每处理1张图片移动2行）
currentRow = currentRow + 2 ' 跳转到下一组行
Next i
MsgBox "成功处理 " & imgCount & " 张图片" & vbCrLf & _
"生成 " & imgCount & " 组图片描述行", _
vbInformation, "操作完成"
End Sub
Sub 每页一张电脑选图图片是描述行()
Dim doc As Document
Dim imgFiles As Collection
Dim tbl As Table
Dim i As Integer, imgCount As Integer
Dim currentRow As Long
Dim imgRange As Range, img As InlineShape
Dim maxWidth As Single, maxHeight As Single
Dim aspectRatio As Single, newWidth As Single, newHeight As Single
Dim descHeight As Single, cellWidth As Single, imgCellHeight As Single
' 初始化变量
Set doc = ActiveDocument
Set imgFiles = New Collection
maxWidth = 14.5 ' 图片最大宽度（厘米）
maxHeight = 23 ' 图片最大高度（厘米）
descHeight = 0.55 ' 描述行高度（厘米）
cellWidth = 15.03 ' 表格单元格宽度（厘米）
imgCellHeight = 23.55 ' 图片单元格高度（包括描述行）
' 打开文件选择对话框
Dim fileDialog As fileDialog
Set fileDialog = Application.fileDialog(msoFileDialogFilePicker)
With fileDialog
.Title = "请选择图片文件"
.AllowMultiSelect = True
If .Show -1 Then Exit Sub ' 如果用户取消选择，退出
For Each varItem In .SelectedItems
imgFiles.Add varItem
Next varItem
End With
' 检查是否有图片
If imgFiles.Count = 0 Then
MsgBox "未选择任何图片文件！", vbExclamation
Exit Sub
End If
' 统计选中的图片数量
imgCount = imgFiles.Count
' 在光标位置创建表格
Dim totalRows As Long
totalRows = imgCount * 2 ' 每张图片需要2行：1行图片+1行描述
Set tbl = doc.Tables.Add(Range:=Selection.Range, numRows:=totalRows, NumColumns:=1)
' 设置表格基础样式
With tbl
.PreferredWidthType = wdPreferredWidthPoints
.PreferredWidth = CentimetershhhToPoints(cellWidth) ' 表格宽度
.AllowAutoFit = False
.Borders.Enable = True
' 设置列宽
.Columns(1).Width = CentimetershhhToPoints(cellWidth)
End With
' 初始化表格位置（从第1行开始）
currentRow = 1
' 处理每张选中的图片
For i = 1 To imgCount
' 插入图片到表格
Set imgRange = tbl.cell(currentRow, 1).Range
Set img = doc.InlineShapes.AddPicture(fileName:=imgFiles(i), LinkToFile:=False, SaveWithDocument:=True, Range:=imgRange)
' --- 调整图片大小 ---
aspectRatio = img.Width / img.Height
If (maxWidth / maxHeight) > aspectRatio Then
newHeight = maxHeight
newWidth = newHeight * aspectRatio
Else
newWidth = maxWidth
newHeight = newWidth / aspectRatio
End If
img.LockAspectRatio = msoFalse
img.Width = CentimetershhhToPoints(newWidth)
img.Height = CentimetershhhToPoints(newHeight)
' 设置图片行高度
tbl.Rows(currentRow).Height = CentimetershhhToPoints(imgCellHeight - descHeight)
tbl.Rows(currentRow).HeightRule = wdRowHeightExactly
' 设置单元格内容为居中对齐
With tbl.cell(currentRow, 1).Range.ParagraphFormat
.Alignment = wdAlignParagraphCenter ' 水平居中
.SpaceAfter = 0
End With
' 设置单元格垂直对齐方式
tbl.cell(currentRow, 1).VerticalAlignment = wdAlignVerticalCenter
' --- 添加描述行 ---
' 设置描述行格式
With tbl.Rows(currentRow + 1)
.Height = CentimetershhhToPoints(descHeight)
.HeightRule = wdRowHeightAtLeast ' 最小值
With .Range
' 设置字体
.Font.Name = "Times New Roman"
.Font.NameFarEast = "宋体"
.Font.Size = 10.5 ' 5号字=10.5磅
' 设置段落格式
With .ParagraphFormat
.Alignment = wdAlignParagraphCenter
.LineSpacingRule = wdLineSpaceSingle ' 1倍行距
.SpaceAfter = 0
End With
End With
End With
' 设置描述行文本（去掉文件扩展名）
tbl.cell(currentRow + 1, 1).Range.text = GetFileNameWithoutExtension(imgFiles(i))
' 更新位置（每处理1张图片移动2行）
currentRow = currentRow + 2 ' 跳转到下一组行
Next i
MsgBox "成功处理 " & imgCount & " 张图片" & vbCrLf & _
"生成 " & imgCount & " 组图片描述行", _
vbInformation, "操作完成"
End Sub
' 辅助函数：获取文件名（去掉路径和后缀）
Function GetFileNameWithoutExtension(ByVal filePath As String) As String
Dim fileName As String
fileName = Mid(filePath, InStrRev(filePath, "") + 1) ' 获取文件名（含后缀）
fileName = Left(fileName, InStrRev(fileName, ".") - 1) ' 去掉后缀
GetFileNameWithoutExtension = fileName
End Function
' 将厘米转换为点数（重命名后的函数）
Function CentimetershhhToPoints(ByVal centimeters As Single) As Long
' 1 厘米 = 28.346 点
CentimetershhhToPoints = Round(centimeters * 28.346, 0)
End Function
' 将厘米转换为点数（原函数）
Function Centimeters2234ToPoints(ByVal centimeters As Single) As Long
' 1 厘米 = 28.346 点
Centimeters2234ToPoints = Round(centimeters * 28.346, 0)
End Function
' 辅助函数：厘米转磅
Function ConvertCmToPts(ByVal cm As Single) As Single
ConvertCmToPts = cm * 28.3464566929134 ' 1 厘米 = 28.3464566929134 磅
End Function

复制代码

本人水平有限，针对截图插入word并美化版面的工作流只能做出上述工具。
如有大神有更好的可以解决这个工作流的软件，推荐给我哈。

链接: https://pan.baidu.com/s/1oG8Jumr_uWyBKy8JkasuQw?pwd=52pj 提取码: 52pj

发表于 3 天前

大家好，我最近发现一款非常好用的截图工具——Snippai。它集成了 OCR 文字识别、屏幕录制、自动贴图、标注编辑等多种强大功能，同时界面简洁，无广告，完全免费。支持 Windows 和 Mac 跨平台，可自定义快捷键，讓你快速分享截图。非常适合日常办公和学习使用，推荐大家试用它。官网地址：https://snippai.de/ 欢迎大家下载体验！

发表于 3 天前

感谢分享

登录 · 发表于 3 天前

谢谢分享

发表于 3 天前

感谢分享，找个

发表于 3 天前

谢谢大佬分享下载试试

发表于 3 天前

感谢分享

发表于 3 天前

感谢分享

发表于 3 天前

感谢分享,用一下

发表于 3 天前

感谢分享。

自用截图工具

本帖子中包含更多资源

本帖子中包含更多资源