VB 如何使窗体背景图片自动适应屏幕分辨率填充整个屏幕
我有一个最大化无边框窗体,如何使窗体的背景图片根据屏幕的分辨率自动填充整个屏幕(我只有一张分辨率为1920*1200的背景图片)...
我有一个最大化无边框窗体,如何使窗体的背景图片根据屏幕的分辨率自动填充整个屏幕(我只有一张分辨率为1920*1200的背景图片)
展开
2个回答
展开全部
分了两步做,代码如下:
PaintPicture p, 0, 0, ScaleWidth, ScaleHeight '将图片填满窗体
Option Explicit '自动使用屏幕分辨率大小
PrivateObjOldWidth As Long '保存窗体的原始宽度
PrivateObjOldHeight As Long '保存窗体的原始高度
Private ObjOldFontAs Single '保存窗体的原始字体比
'在调用ResizeForm前先调用本函数
Public SubResizeInit(FormName As Form)
Dim Obj As Control
ObjOldWidth = FormName.ScaleWidth
ObjOldHeight = FormName.ScaleHeight
ObjOldFont = FormName.Font.Size /ObjOldHeight
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 SubResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos AsLong
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double
ScaleX = FormName.ScaleWidth / ObjOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / ObjOldHeight
'保存窗体高度缩放比例
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
Obj.Font.Size = ObjOldFont *FormName.ScaleHeight
Next i
Next Obj
On Error GoTo 0
End Sub
Private SubForm_Resize()
'确保窗体改变时控件随之改变
Call ResizeForm(Me)
End Sub
Private SubForm_Load()
'在程序装入时必须加入
Call ResizeInit(Me)
End Sub
PaintPicture p, 0, 0, ScaleWidth, ScaleHeight '将图片填满窗体
Option Explicit '自动使用屏幕分辨率大小
PrivateObjOldWidth As Long '保存窗体的原始宽度
PrivateObjOldHeight As Long '保存窗体的原始高度
Private ObjOldFontAs Single '保存窗体的原始字体比
'在调用ResizeForm前先调用本函数
Public SubResizeInit(FormName As Form)
Dim Obj As Control
ObjOldWidth = FormName.ScaleWidth
ObjOldHeight = FormName.ScaleHeight
ObjOldFont = FormName.Font.Size /ObjOldHeight
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 SubResizeForm(FormName As Form)
Dim Pos(4) As Double
Dim i As Long, TempPos As Long, StartPos AsLong
Dim Obj As Control
Dim ScaleX As Double, ScaleY As Double
ScaleX = FormName.ScaleWidth / ObjOldWidth
'保存窗体宽度缩放比例
ScaleY = FormName.ScaleHeight / ObjOldHeight
'保存窗体高度缩放比例
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
Obj.Font.Size = ObjOldFont *FormName.ScaleHeight
Next i
Next Obj
On Error GoTo 0
End Sub
Private SubForm_Resize()
'确保窗体改变时控件随之改变
Call ResizeForm(Me)
End Sub
Private SubForm_Load()
'在程序装入时必须加入
Call ResizeInit(Me)
End Sub
展开全部
Private Sub Form_Load()
Me.AutoRedraw = True
End Sub
Private Sub Form_Paint()
Form_Resize
End Sub
Private Sub Form_Resize()
Me.PaintPicture Me.Picture, 0, 0, Me.Width, Me.Height
End Sub
Me.AutoRedraw = True
End Sub
Private Sub Form_Paint()
Form_Resize
End Sub
Private Sub Form_Resize()
Me.PaintPicture Me.Picture, 0, 0, Me.Width, Me.Height
End Sub
本回答被提问者采纳
已赞过
已踩过<
评论
收起
你对这个回答的评价是?
推荐律师服务:
若未解决您的问题,请您详细描述您的问题,通过百度律临进行免费专业咨询