非常好！我们来对 VBA 宏进行 **精准优化**，满足你的新需求：
---
## ✅ 需求解析
你希望：
- 单元格设置为：**列宽 = 32 字符宽度**（Excel 的 `ColumnWidth` 单位）
- 行高设置为：**120 磅**（Excel 的 `RowHeight` 单位）
- 图片插入到这些大单元格中
- 图片 **保持原始比例不变**（即不拉伸变形）
- 图片整体适应在 `32×120` 的单元格内，居中显示
> ⚠️ 注意区别：
> - Excel 列宽单位 ≠ 像素。例如 `ColumnWidth=32` ≈ 大约 **240~300 像素宽**（取决于字体）
> - 行高 `120` 是磅（pt），≈ **160 像素高**
---
## ✅ 实现思路
1. 设置目标单元格：`.ColumnWidth = 32`, `.RowHeight = 120`
2. 插入图片后，根据单元格实际像素尺寸计算最大可容纳图像区域
3. 调整图片大小：**等比缩放**，使其完全放入单元格内，并居中
4. 使用 `.Top` 和 `.Left` 居中定位图片
---
## ✅ 最终优化代码（含完整逻辑）
```vba
Option Explicit
' === API 声明（支持 32/64 位）===
#If VBA7 Then
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, Picture As IPicture) As Long
#Else
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, Picture As IPicture) As Long
#End If
' === 结构体定义 ===
#If VBA7 Then
Private Type uPicDesc
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
#Else
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
#End If
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
' === 常量 ===
Const CF_BITMAP = 2
Sub InsertImagesAndCompareWithBCompare()
' 定义变量
Dim fso As Object
Dim folderOld As Object
Dim folderNew As Object
Dim fileOld As Object
Dim fileNew As Object
Dim dictOld As Object
Dim imgPathOld As String
Dim imgPathNew As String
Dim ws As Worksheet
Dim colInsertOld As Long
Dim colInsertNew As Long
Dim colInsertScreenshot As Long
Dim startRow As Long
Dim currentRow As Long
Dim picOld As Picture
Dim picNew As Picture
Dim inputColOld As String
Dim inputColNew As String
Dim inputColScreenshot As String
Dim workbookDir As String
Dim pathOld As String
Dim pathNew As String
Dim bcomparePath As String
Dim lastDataRow As Long
Dim screenshotRow As Long
' 设置参数
Set ws = ThisWorkbook.Sheets(1)
startRow = 2
currentRow = startRow
' 创建文件系统对象
Set fso = CreateObject("Scripting.FileSystemObject")
' 获取当前工作簿目录
workbookDir = ThisWorkbook.Path
If workbookDir = "" Then
MsgBox "请先保存工作簿！", vbCritical, "错误"
Exit Sub
End If
' 构建 OLD / NEW 路径
pathOld = workbookDir & "\OLD"
pathNew = workbookDir & "\NEW"
If Not fso.FolderExists(pathOld) Then
MsgBox "未找到文件夹：" & pathOld, vbCritical, "错误"
Exit Sub
End If
If Not fso.FolderExists(pathNew) Then
MsgBox "未找到文件夹：" & pathNew, vbCritical, "错误"
Exit Sub
End If
Set folderOld = fso.GetFolder(pathOld)
Set folderNew = fso.GetFolder(pathNew)
' 构建字典存储 OLD 文件
Set dictOld = CreateObject("Scripting.Dictionary")
Dim extOld As String
For Each fileOld In folderOld.Files
extOld = LCase(fso.GetExtensionName(fileOld.Name))
If extOld = "jpg" Or extOld = "jpeg" Or extOld = "png" Or extOld = "bmp" Or extOld = "gif" Then
dictOld(fileOld.Name) = fileOld.Path
End If
Next fileOld
' 清除旧图片
On Error Resume Next
ws.Pictures.Delete
On Error GoTo 0
' === 用户选择插入列 ===
Do
inputColOld = InputBox("请输入【OLD】图片插入列（如 B）：", "选择列", "B")
If inputColOld = "" Then Exit Sub
colInsertOld = ColumnLetterToNumber(inputColOld)
Loop While colInsertOld = -1
Do
inputColNew = InputBox("请输入【NEW】图片插入列（如 C）：", "选择列", "C")
If inputColNew = "" Then Exit Sub
colInsertNew = ColumnLetterToNumber(inputColNew)
Loop While colInsertNew = -1
If colInsertOld = colInsertNew Then
If MsgBox("警告：两列相同，是否继续？", vbYesNo) = vbNo Then Exit Sub
End If
' === 用户选择截图插入列 ===
Do
inputColScreenshot = InputBox("请输入【截图】插入列（如 D）：", "选择截图列", "D")
If inputColScreenshot = "" Then Exit Sub
colInsertScreenshot = ColumnLetterToNumber(inputColScreenshot)
Loop While colInsertScreenshot = -1
' === 插入 OLD/NEW 图片 ===
Dim extNew As String
For Each fileNew In folderNew.Files
extNew = LCase(fso.GetExtensionName(fileNew.Name))
If extNew = "jpg" Or extNew = "jpeg" Or extNew = "png" Or extNew = "bmp" Or extNew = "gif" Then
imgPathNew = fileNew.Path
imgPathOld = ""
If dictOld.Exists(fileNew.Name) Then imgPathOld = dictOld(fileNew.Name)
ws.Cells(currentRow, 1).Value = fileNew.Name
' 插入 OLD 图
If imgPathOld <> "" And fso.FileExists(imgPathOld) Then
Set picOld = ws.Pictures.Insert(imgPathOld)
Call ResizePictureToFitCell(picOld, ws.Cells(currentRow, colInsertOld), 32, 120)
End If
' 插入 NEW 图
Set picNew = ws.Pictures.Insert(imgPathNew)
Call ResizePictureToFitCell(picNew, ws.Cells(currentRow, colInsertNew), 32, 120)
currentRow = currentRow + 1
End If
Next fileNew
' === 设置单元格尺寸：列宽 32，行高 120 ===
Const TARGET_COLUMN_WIDTH As Double = 32 ' 字符宽度
Const TARGET_ROW_HEIGHT As Double = 120 ' 磅 (pt)
ws.Columns(colInsertOld).ColumnWidth = TARGET_COLUMN_WIDTH
ws.Columns(colInsertNew).ColumnWidth = TARGET_COLUMN_WIDTH
ws.Columns(colInsertScreenshot).ColumnWidth = TARGET_COLUMN_WIDTH
lastDataRow = currentRow - 1
If lastDataRow >= startRow Then
ws.Rows(startRow & ":" & lastDataRow).RowHeight = TARGET_ROW_HEIGHT
End If
' 标题行
ws.Rows(1).RowHeight = 20
ws.Cells(1, 1).Value = "文件名"
ws.Cells(1, colInsertOld).Value = "OLD"
ws.Cells(1, colInsertNew).Value = "NEW"
ws.Cells(1, colInsertScreenshot).Value = "对比截图"
' === 调用 Beyond Compare ===
bcomparePath = "E:\APP\Beyond_Compare_4\BCompare.exe"
If fso.FileExists(bcomparePath) Then
MsgBox "即将启动 Beyond Compare，请完成对比后点击【确定】以截图。", vbInformation, "提示"
Shell """" & bcomparePath & """ """ & pathOld & """ """ & pathNew & """", vbNormalFocus
Else
MsgBox "未找到 BCompare：" & bcomparePath & vbCrLf & "请手动打开比较。", vbExclamation, "错误"
Exit Sub
End If
' === 截图处理 ===
If MsgBox("请确保 Beyond Compare 窗口已激活。" & vbCrLf & _
"点击【是】将截取当前窗口并插入到第 " & Split(ws.Cells(1, colInsertScreenshot).Address, "$")(1) & " 列。", _
vbYesNo + vbQuestion, "是否截图？") = vbNo Then
GoTo Cleanup
End If
SendKeys "%{PRTSC}", True ' Alt + PrintScreen
Application.Wait Now + TimeValue("00:00:01")
screenshotRow = startRow
PasteClipboardImage ws, colInsertScreenshot, screenshotRow, 32, 120 ' 按照相同尺寸调整
MsgBox "截图已插入至 " & ws.Cells(screenshotRow, colInsertScreenshot).Address(False, False) & "。", vbInformation, "完成"
Cleanup:
Set picOld = Nothing
Set picNew = Nothing
Set dictOld = Nothing
Set folderOld = Nothing
Set folderNew = Nothing
Set fso = Nothing
MsgBox "全部任务完成！", vbInformation, "成功"
End Sub
' === 辅助函数：列字母转列号 ===
Function ColumnLetterToNumber(colInput As String) As Long
Dim tempCell As Range
On Error Resume Next
Set tempCell = ThisWorkbook.Sheets(1).Range(Trim(colInput) & "1")
On Error GoTo 0
If Not tempCell Is Nothing Then
ColumnLetterToNumber = tempCell.Column
Else
ColumnLetterToNumber = -1
End If
End Function
' === 辅助函数：调整图片以适应指定单元格（保持比例）===
Sub ResizePictureToFitCell(pic As Picture, cell As Range, colWidthChars As Double, rowHeightPts As Double)
Dim cellWidthPx As Double
Dim cellHeightPx As Double
Dim picWidth As Double
Dim picHeight As Double
Dim ratio As Double
Dim maxWidth As Double
Dim maxHeight As Double
' 将列宽（字符）转换为像素（近似值）
With cell.Worksheet.Parent.Application
cellWidthPx = .CentimetersToPoints(.Width * colWidthChars / 8.5) ' 近似换算
cellWidthPx = cell.Width ' 更准确的方式：直接读取实际宽度
cellHeightPx = cell.Height
End With
' 获取原始图片尺寸
picWidth = pic.Width
picHeight = pic.Height
' 计算缩放比例：保证图片完整放入单元格且保持比例
maxWidth = cellWidthPx * 0.95 ' 留一点边距
maxHeight = cellHeightPx * 0.95
If picWidth <= maxWidth And picHeight <= maxHeight Then
' 原图较小，无需缩放
Else
ratio = Application.Min(maxWidth / picWidth, maxHeight / picHeight)
pic.Width = picWidth * ratio
pic.Height = picHeight * ratio
End If
' 居中放置
pic.Top = cell.Top + (cell.Height - pic.Height) / 2
pic.Left = cell.Left + (cell.Width - pic.Width) / 2
pic.Placement = 1 ' 移动但与单元格对齐
End Sub
' === 辅助函数：粘贴剪贴板图片并适配单元格 ===
Sub PasteClipboardImage(ws As Worksheet, col As Long, row As Long, colWidthChars As Double, rowHeightPts As Double)
Dim Pic As IPicture
Dim h As LongPtr
Dim IID_IDispatch(0 To 3) As Long
Dim uPicInfo As uPicDesc
Dim picObj As Picture
If OpenClipboard(0&) = 0 Then Exit Sub
h = GetClipboardData(CF_BITMAP)
If h <> 0 Then
With IID_IDispatch
.Data1 = &H20400
.Data2 = &H0
.Data3 = &HC0
.Data4(0) = &H46: .Data4(1) = &H0: .Data4(2) = &H0
.Data4(3) = &H0: .Data4(4) = &H0: .Data4(5) = &H0: .Data4(6) = &H0: .Data4(7) = &H0
End With
uPicInfo.Size = Len(uPicInfo)
uPicInfo.Type = 1
uPicInfo.hPic = h
uPicInfo.hPal = 0
OleCreatePictureIndirect uPicInfo, IID_IDispatch(0), True, Pic
Set picObj = ws.Pictures.Insert(Pic)
' 调整并居中图片
Call ResizePictureToFitCell(picObj, ws.Cells(row, col), colWidthChars, rowHeightPts)
End If
CloseClipboard
End Sub
```
---
## ✅ 功能亮点说明
| 特性 | 实现方式 |
|------|----------|
| ✅ 单元格 `32×120` | `.ColumnWidth=32`, `.RowHeight=120` |
| ✅ 图片等比缩放 | 使用 `Min(width_ratio, height_ratio)` 缩放 |
| ✅ 图片居中 | `(cell.Width - pic.Width)/2` 计算偏移 |
| ✅ 支持任意分辨率图片 | 自动判断并缩放 |
| ✅ 截图也适配相同规则 | 复用 `ResizePictureToFitCell` 函数 |
---
## ✅ 视觉效果预览
| 单元格 | 尺寸（近似像素） | 图片行为 |
|-------|------------------|---------|
| 宽度 32 字符 | ≈ 240–300 px（取决于字体） | 横向居中 |
| 高度 120 pt | ≈ 160 px | 纵向居中 |
| 图片 | 等比缩放至不超过边界 | 不变形、不溢出 |
---
###
扫一扫
245
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
