Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>> Author: Joforn <<<<<<<<<<<<<<<<<<
'>>>>>>>> Email: Joforn@sohu.com <<<<<<<<<<<<<<<<<<
'>>>>>>>> QQ: 42978116 <<<<<<<<<<<<<<<<<<
'>>>>>>>> Last time : 11/16/2015 <<<<<<<<<<<<<<<<<<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
#If VBA7 Then
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnd As Long) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDc As LongPtr) As Long
#Else
Private Declare Function GetDC Lib "user32"(ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32"(ByVal hWnd As Long,ByVal hDC As Long) As Long
#End If
Private Const HORZRES As Long = 8
Private Const VERTRES As Long = 10
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Public Enum EnumScale
vbTwips = 1 '缇
vbPoints '磅
vbPixels '像素
vbCharacters '字符
vbInches '英寸
vbMillimeters '毫米
vbCentimeters '厘米
End Enum
Public Property Get ScreenLogPixelsX() As Long
'获取屏幕分辨率宽度的每逻辑英寸的像素数
#If VBA7 Then
Dim hDc As LongPtr
#Else
Dim hDc As Long
#End If
hDc = GetDC(0)
ScreenLogPixelsX = GetDeviceCaps(hDc, LOGPIXELSX)
ReleaseDC 0, hDc
End Property
Public Property Get ScreenLogPixelsY() As Long
'获取屏幕分辨率高度的每逻辑英寸的像素数
#If VBA7 Then
Dim hDc As LongPtr
#Else
Dim hDc As Long
#End If
hDc = GetDC(0)
ScreenLogPixelsY = GetDeviceCaps(hDc, LOGPIXELSY)
ReleaseDC 0, hDc
End Property
Public Property Get ScreenWidth() As Long
'获取屏幕的宽度,以像素为单位
#If VBA7 Then
Dim hDc As LongPtr
#Else
Dim hDc As Long
#End If
hDc = GetDC(0)
ScreenWidth = GetDeviceCaps(hDc, HORZRES)
ReleaseDC 0, hDc
End Property
Public Property Get ScreenHeight() As Long
'获取屏幕的高度,以像素为单位
#If VBA7 Then
Dim hDc As LongPtr
#Else
Dim hDc As Long
#End If
hDc = GetDC(0)
ScreenHeight = GetDeviceCaps(hDc, VERTRES)
ReleaseDC 0, hDc
End Property
Public Function ScreenScaleX(ByVal Width As Single, Optional ByVal FromScale As EnumScale = vbPoints, Optional ByVal ToScale As EnumScale = vbPixels) As Single
Const TWIPSPERINCH = 1440!
Const TWIPSPERCENT = 567!
Const TWIPSPERMILL = 56.7!
Const TWIPSPERCHAR = 120!
Const TWIPSPERPOIT = 20!
If FromScale = ToScale Then
ScreenScaleX = Width
Else
Select Case FromScale
Case vbTwips
Select Case ToScale
Case vbPoints
ScreenScaleX = Width / TWIPSPERPOIT
Case vbPixels
ScreenScaleX = Width / TWIPSPERINCH * ScreenLogPixelsX
Case vbCharacters
ScreenScaleX = Width / TWIPSPERCHAR
Case vbInches
ScreenScaleX = Width / TWIPSPERINCH
Case vbMillimeters
ScreenScaleX = Width / TWIPSPERMILL
Case vbCentimeters
ScreenScaleX = Width / TWIPSPERCENT
Case vbTwips
ScreenScaleX = Width
End Select
Case vbCentimeters
ScreenScaleX = ScreenScaleX(Width * TWIPSPERCENT, vbTwips, ToScale)
Case vbMillimeters
ScreenScaleX = ScreenScaleX(Width * TWIPSPERMILL, vbTwips, ToScale)
Case vbInches
ScreenScaleX = ScreenScaleX(Width * TWIPSPERINCH, vbTwips, ToScale)
Case vbPoints
ScreenScaleX = ScreenScaleX(Width * TWIPSPERPOIT, vbTwips, ToScale)
Case vbPixels
ScreenScaleX = ScreenScaleX(Width * TWIPSPERINCH / ScreenLogPixelsX, vbTwips, ToScale)
Case vbCharacters
ScreenScaleX = ScreenScaleX(Width * TWIPSPERCHAR, vbTwips, ToScale)
End Select
End If
End Function
Public Function ScreenScaleY(ByVal Height As Single, Optional ByVal FromScale As EnumScale = vbPoints, Optional ByVal ToScale As EnumScale = vbPixels) As Single
Const TWIPSPERINCH = 1440!
Const TWIPSPERCENT = 567!
Const TWIPSPERMILL = 56.7!
Const TWIPSPERCHAR = 240!
Const TWIPSPERPOIT = 20!
If FromScale = ToScale Then
ScreenScaleY = Height
Else
Select Case FromScale
Case vbTwips
Select Case ToScale
Case vbPoints
ScreenScaleY = Height / TWIPSPERPOIT
Case vbPixels
ScreenScaleY = Height / TWIPSPERINCH * ScreenLogPixelsY
Case vbCharacters
ScreenScaleY = Height / TWIPSPERCHAR
Case vbInches
ScreenScaleY = Height / TWIPSPERINCH
Case vbMillimeters
ScreenScaleY = Height / TWIPSPERMILL
Case vbCentimeters
ScreenScaleY = Height / TWIPSPERCENT
Case vbTwips
ScreenScaleY = Height
End Select
Case vbCentimeters
ScreenScaleY = ScreenScaleY(Height * TWIPSPERCENT, vbTwips, ToScale)
Case vbMillimeters
ScreenScaleY = ScreenScaleY(Height * TWIPSPERMILL, vbTwips, ToScale)
Case vbInches
ScreenScaleY = ScreenScaleY(Height * TWIPSPERINCH, vbTwips, ToScale)
Case vbPoints
ScreenScaleY = ScreenScaleY(Height * TWIPSPERPOIT, vbTwips, ToScale)
Case vbPixels
ScreenScaleY = ScreenScaleY(Height * TWIPSPERINCH / ScreenLogPixelsY, vbTwips, ToScale)
Case vbCharacters
ScreenScaleY = ScreenScaleY(Height * TWIPSPERCHAR, vbTwips, ToScale)
End Select
End If
End Function
Public Property Get RangeWidth(ByVal Target As Range, Optional ByVal ScaleMode As EnumScale = vbPoints) As Single
Dim I As Long, rngWidth As Single
If Target Is Nothing Then Exit Property
If Target.Count Then
Set Target = Target.Cells(1)
Set Target = Target.MergeArea
For I = 1 To Target.Columns.Count
rngWidth = rngWidth + Target.Cells(1, I).Width
Next
RangeWidth = ScreenScaleX(rngWidth, vbPoints, ScaleMode)
End If
End Property
Public Property Get RangeHeight(ByVal Target As Range, Optional ByVal ScaleMode As EnumScale = vbPoints) As Single
Dim I As Long, rngHeight As Single
If Target Is Nothing Then Exit Property
If Target.Count Then
Set Target = Target.Cells(1)
Set Target = Target.MergeArea
For I = 1 To Target.Rows.Count
rngHeight = rngHeight + Target.Cells(I, 1).Height
Next
RangeHeight = ScreenScaleY(rngHeight, vbPoints, ScaleMode)
End If
End Property
