【重磅发布】：聚光灯——我的加载宏系列小工具【单元格小工具】之四

ggmmlol · 发表于 2018-2-5 08:40

继续播放《窗体“变形记”》第二集

接下来，我们先让窗体变成所“选定的【单元格区域】”的大小。

“选定的【单元格区域】”，在通常情况下，它就是Application.Selection对象。但是，当表格中存在有图片、形状、“单元格相片”（由“照相机”取得的单元格的动态图形）、文本框、表单控件、或ActiveX控件、外部文档对象时，我们有可能选中它们中的一个或多个，而这时，Application.Selection的对象就成了所选取的这些对象。所以，Application.Selection对象不是正确的目标。

那么，EXCEL中，要用那个对象来准确地表示 “选定的【单元格区域】”呢？
答案是：Application.ActiveWindow.RangeSelection。这个对象，才准确地表示了EXCEL活动工作簿窗口的活动单元格区域。

让我们先来看一看RangeSelection在帮助文档中的说明：

ggmmlol · 发表于 2018-2-5 11:21

改变窗体的大小，可以使用其Width和Height属性来完成。
所以，让窗体的大小适应单元格区域的大小，只需要先计算出这个单元格区域的大小即可。
为了后面便于应用，我们让Sub过程也像Function过程一样带有一个参数，其类型为Range
首先，从最简单的方式开始，选择一个“固定靶”，就定为单元格区域“A1:E5”吧。
代码如下：

Private Sub UserFormFitRange(ByVal oRng As Range)
Dim lft, tp, rght, btn, wd, ht
With oRng
.Parent.Parent.Windows(1).Zoom = 100
lft = .Cells(1).Left
tp = .Cells(1).Top
rght = .Cells(1, .Columns.Count).Left + .Cells(1, .Columns.Count).Width
btn = .Cells(.Rows.Count, 1).Top + .Cells(.Rows.Count, 1).Height
wd = rght - lft
ht = btn - tp
End With
Unload UserForm1 '此步骤使窗体在下次显示时恢复默认风格，以便能够用鼠标来移动它。
'否则，如果窗体已经设为鼠标穿透的话，就不能用鼠标来移动它了
With UserForm1
.Width = wd
.Height = ht
.Show 0
End With
End Sub
Private Sub UserFormFightRangeSelection()
With Application.ActiveWindow
UserFormFitRange .RangeSelection.Areas(1)
End With
End Sub
Sub UserformFitA1E5()
Range("A1:E5").Activate
UserFormFightRangeSelection
End Sub

复制代码

运行宏 UserformFitA1E5，可以看到，窗体显示在EXCEL窗口的中心，而其大小，已经变成单元格区域“A1:E5"的大小了。这可以通过把窗体移动到单元格区域A1:E5来直观地得到验证，如下面的两张图片所示：
第一张图，是窗体显示出来时的状态
窗体大小适合单元格区域1.PNG

第二张图，是在手动把它移动到A1:E5区域后的状态。
窗体大小适合单元格区域2.PNG

ggmmlol · 发表于 2018-2-5 11:31

把代码测试的第4个附件发上来：

窗口测试_窗体大小适合单元格区域.rar (20.02 KB, 下载次数: 164)

ggmmlol · 发表于 2018-2-5 12:01

然而，上面附件的代码，只适合活动工作簿的窗口显示比例为100%的整数倍的情况。
如果显示比例的值是一个小数，而且指定的区域的单元格的行数、列数较多时，上述代码运行的结果，窗体的大小与选定的单元格区域的大小相比较，会有较明显的偏差。

比如，先把整个工作表全部的行高调整为13个像素高，宽度调整为13个像素宽，再把窗口显示比例调整为50%，并且把指定的单元格区域扩大到A1:Z30再来测试代码
为此，需要把上面附件中的代码的2处需要对应修改一下。

其一，原来.Parent.Parent.Windows(1).Zoom = 100，替换成
.Parent.Parent.Windows(1).Zoom = 50
其二，原来 Range("A1:E5").Activate，替换成
Range("A1:Z30").Activate

其测试结果就如下图所示，大小的误差就非常明显：
窗体大小适合单元格区域3.PNG

ggmmlol · 发表于 2018-2-5 15:36

所以，接下来，我们需要对上面的代码做出改进，以便能够准确地适应工作簿窗口的显示比例不是100%时的情况。
而这时，就必须要用到前面介绍过的GDI相关的API函数来救场了！
代码的改进，包含以下几个步骤
1、先把制作异形窗体的那个附件中的API函数，及其参数用到的命名常数定义一起复制过来，GetDC，ReleaseDC，GetDeviceCaps。
2、然后添加两个Long型的全局变量PPI和IZoom，用于存储屏幕的分辨率（每英寸的像素个数）和窗口显示比例的百分值。
3、编写两个公用的过程:GetPPI和pt2Px，具体如下：

Sub GetPPI()
Dim hDc As Long
hDc = GetDC(0&)
PPI = GetDeviceCaps(hDc, LOGPIXELSX)
ReleaseDC 0&, hDc
End Sub
Function pt2px(ByVal x As Single)
pt2px = WorksheetFunction.Round(WorksheetFunction.Round(x * PPI / 72, 0) * iZoom / 100, 0) '切记：这里一定不要使用VB的Round函数。
End Function

复制代码

再修改UserFormFitRange过程的代码如下：

Private Sub UserFormFitRange(ByVal oRng As Range)
Dim lft, tp, wd, ht
Dim i As Long
GetPPI
With oRng
iZoom = .Parent.Parent.Windows(1).Zoom
For i = 1 To .Columns.Count
wd = wd + pt2px(.Columns(i).Width)
Next
For i = 1 To .Rows.Count
ht = ht + pt2px(.Rows(i).Height)
Next
End With
Unload UserForm1 '此步骤使窗体在下次显示时恢复默认风格，以便能够用鼠标来移动它。
'否则，如果窗体已经设为鼠标穿透的话，就不能用鼠标来移动它了
With UserForm1
.Width = wd / PPI * 72
.Height = ht / PPI * 72
.Show 0
End With
End Sub

复制代码

现在，再次运行宏“窗体大小适合单元格区域”，看看结果，如下图所示：
窗体大小适合单元格区域4.PNG

用鼠标把窗体移动到A1单元格位置，如下图所示，可以看到，窗体的大小与所选定的区域范围是正好合适的。
这说明代码的改进，确实是成功了。
窗体大小适合单元格区域5.PNG

ggmmlol · 发表于 2018-2-5 15:42

又到了上传新代码测试的附件的时候了。

窗口测试_窗体大小适合单元格区域_改进.rar (27.45 KB, 下载次数: 185)

ggmmlol · 发表于 2018-2-5 16:13

接下来，《窗体“变形记”》就到了最关键的时候了，让窗体显示在指定的单元格区域上。
“等等”，有的朋友可能要求打住，因为他可能发现了问题：
1、窗体的标题还在，如果用来做行列的指示时，就这样让窗体的标题显示出来，还露着右上角关闭窗体用的“×”按钮，就也太丑陋了，能不能先去掉它啊？
2、如果指定的单元格区域是单个的，而且其面域较小的话，上面的代码并不能窗体的大小调整到同样小的程度。

嘿嘿，我说我是故意这么做的，你们信吗？
“当然不信！”“信你个鬼哟！”
“朋友们，先别骂，刚才我是开玩笑的。我保证，现在、立刻、马上，就去把这两个问题解决了！”

ggmmlol · 发表于 2018-2-5 19:22

话说上面示例中的窗体，顶着一个标题，拧劲儿就不愿意变形到一个小单元格的大小。
就好比电视栏目《变形记》里那些年轻的主人公一样，顶着杀马特的发型，不情愿去大山沟里小山村完成人生的变形。
所以，在让他去变形之前，实在应该先修剪掉他的杀马特的发型，让他从外观上先不抵触“变形”。

修剪掉一个杀马特发型，对于理发师来说，这不是什么问题。那么，我们要修剪掉窗体的标题栏，又如何呢？

答案是：同样很简单，因为——修改套用一句小品台词来回答：不会修剪杀马特发型的程序猿绝不是一个合格的厨子！

言归正传，修剪掉窗体的标题，还是需要使用SetWindowLongp 这个API函数，具体的代码是：

Function SetWindowNoCaption(ByVal lHwnd As Long) As Long
Dim lStyle As Long, rvl As Long
lStyle = GetWindowLong(lHwnd, GWL_STYLE) '取得窗体原有风格
lStyle = lStyle And Not WS_CAPTION And Not WS_BORDER '预设窗体无标题、无边框风格
SetWindowNoCaption = SetWindowLong(lHwnd, GWL_STYLE, lStyle) '对窗体应用预设的风格
End Function

复制代码

ggmmlol · 发表于 2018-2-5 19:33

《窗体“变形记”》第二集播放完毕了。
还是用附件来验证前面所述代码是否正确：

窗口测试_窗体大小适合单元格区域_改进2.rar (29.91 KB, 下载次数: 195)

liucqa · 发表于 2018-2-5 20:59

写得很详细，再支持一下

		自动登录	找回密码
密码			免费注册

[原创] 【重磅发布】：聚光灯——我的加载宏系列小工具【单元格小工具】之四