DPI原來是96，改成100后程序界面背景圖片和按鈕控件錯位了，怎么辦才能保證背景圖片和按鈕在固定位置，不受DPI的影響，或者DPI更改后，控件位置不出現錯亂呢

 

 

本程序解決使用VB生成應用程序后，在高DPI下，特別是在WIN7下高DPI導致界面錯位，錯亂的問題。

思路：
1.獲得系統DPI值
2.計算得程序中所有窗體的高度和寬度像素值
3.設定所有控件隨著窗體變化而縮放
4.在標準96DPI下打開VB設置DPI縮放公式用來獲得不同DPI的實際緹數

示例代碼：【FORM1，COMMAND1，IMAGE 控件】
'96 DPI 下 TwipsPerPixelX TwipsPerPixelY 為 15 --- 即DPI為96時,15緹等于1像素
'120 DPI 下 TwipsPerPixelX TwipsPerPixelY 為 12 --- 即DPI為120時,12緹等于1像素
'這么看來 每高 1 DPI 就+8
'------------
'這個窗體高度是[在96DPI下測得]:2145緹[143像素,Y] 寬度是:8715緹[581像素,X]
'在這提供一個公式:1 像素 = 1440 TPI / 96 DPI = 15 緹
'所以X像素=1440/DPI值=Y緹;
'####################################################################################################################################
Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X

Private FormOldWidth As Long
'保存窗體的原始寬度
Private FormOldHeight As Long
'保存窗體的原始高度

'在調用ResizeForm前先調用本函數
Public Sub ResizeInit(FormName As Form)
Dim Obj As Control
FormOldWidth = FormName.ScaleWidth
FormOldHeight = FormName.ScaleHeight
On Error Resume Next
For Each Obj In FormName
Obj.Tag = Obj.Left & " " & Obj.Top & " " & Obj.Width & " " & Obj.Height & " "
Next Obj
On Error GoTo 0
End Sub

'按比例改變表單內各元件的大小，
'在調用ReSizeForm前先調用ReSizeInit函數
Public Sub ResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos As Long
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double

ScaleX = FormName.ScaleWidth / FormOldWidth
'保存窗體寬度縮放比例
ScaleY = FormName.ScaleHeight / FormOldHeight
'保存窗體高度縮放比例
On Error Resume Next
For Each Obj In FormName
StartPos = 1
For i = 0 To 4
'讀取控件的原始位置與大小

TempPos = InStr(StartPos, Obj.Tag, " ", vbTextCompare)
If TempPos > 0 Then
Pos(i) = Mid(Obj.Tag, StartPos, TempPos - StartPos)
StartPos = TempPos + 1
Else
Pos(i) = 0
End If
'根據控件的原始位置及窗體改變大小
'的比例對控件重新定位與改變大小
Obj.Move Pos(0) * ScaleX, Pos(1) * ScaleY, Pos(2) * ScaleX, Pos(3) * ScaleY
Next i
Next Obj
On Error GoTo 0
End Sub

Private Sub Form_Activate()
Dim aa As Long
Dim hdc0 As Long
hdc0 = GetDC(0)
aa = GetDeviceCaps(hdc0, LOGPIXELSX) '獲得DPI值
Dim x As Integer
x = 1440 / aa 'X緹=1像素
Me.Height = 143 * x
Me.Width = 581 * x
Image1.Height = 114 * x
Image1.Width = 581 * x

End Sub

Private Sub Form_Load()
Call ResizeInit(Me) '在程序裝入時必須加入
End Sub

Private Sub Form_Resize()
Call ResizeForm(Me) '確保窗體改變時控件隨之改變
End Sub

源程序包【示例代碼】下載地址：http://www.thfyhome.com/DPI.rar

該文章在 2014/1/8 0:00:15 編輯過