I am using this code to retrieve the active screen size of a form.
Dim lngHWND As Long
Dim hMonitor As Long
Dim MonitorInfo As typMonitorInfo
Dim apiReturnCode As Long
lngHWND = frm.hwnd
hMonitor = MonitorFromWindow(lngHWND, MONITOR_DEFAULTTONEAREST)
MonitorInfo.cbSize = LenB(MonitorInfo)
apiReturnCode = GetMonitorInfo(hMonitor, VarPtr(MonitorInfo))
' Récupération de la taille de l'écran
With MonitorInfo.rcMonitor
dblWidth_Ecran = (.Right - .Left)
dblHeight_Ecran = (.Bottom - .Top)
End With
On my screens, if I set 1920x1080, it goes back to 1920x1080.
If I switch to 125% scaling, it brings me back 1536x864 (1920/1.25 & 108/1.25).
Which suits me perfectly.
On the other hand, on other workstations (client side), it always goes back to 1920x1080, whatever the scaling.
Do you have an explanation or any leads to use to make it functional, as in the first case?
Best regards,
Related
I am having a problem trying to get a Web Browser control in a MS Access form to display an image from a URL correctly.
I am using .navigate (strImagePath) to place the imaging in to WebBrowser1. That works fine. The images are jpg and I have the full path and image filename.
The problem is the that the image is displayed at 100% scale, which is larger than the size of the browser. I can use zoom (OLECMDID_OPTICAL_ZOOM) to scale the image, but this only works if I know the size of the image, which I don't to get the right zoom factor.
Ideally, I would like to have the image fit to window without having to determine the image size.
It that is not possible, the other option is to determine the image size and then set the appropriate zoom. I have not figured a way to determine the image size without saving it locally. Which would be a big overhead and add a unacceptable lag to the form display, specially when move through records. Any ideals here?
Thanks
I was able to get it running after the code from Thomas.
There is the final code.
Public Function DisplayImage(ctlImageControl As Control, strImagePath As Variant) As String
On Error GoTo Err_DisplayImage
Dim strResult As String
Dim intHeight As Integer
Dim intWidth As Integer
Dim intHeightZoom As Integer
Dim intWidthZoom As Integer
Dim intPageZoom As Integer
With ctlImageControl
If strImagePath = "" Then
.Visible = False
strResult = "No image name specified."
Else
.Visible = True
.Navigate (strImagePath)
Do While .Object.Busy Or .Object.ReadyState <> 4 'wait to imaged loaded
DoEvents
Loop
intHeight = .Document.images(0).clientHeight
intWidth = .Document.images(0).clientWidth
intHeightZoom = CLng(21600) / intHeight
intWidthZoom = CLng(43200) / intWidth
If intHeightZoom < intWidthZoom Then
intPageZoom = intHeightZoom
Else
intPageZoom = intWidthZoom
End If
.Object.ExecWB OLECMDID_OPTICAL_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, _
CLng(intPageZoom), vbNull
strResult = "success"
End If
End With
Exit_DisplayImage:
DisplayImage = strResult
Exit Function
Err_DisplayImage:
Select Case Err.Number
Case 2220 ' Can't find the picture.
ctlImageControl.Visible = False
strResult = "Can't find image in the specified name."
Resume Exit_DisplayImage:
Case Else ' Some other error.
MsgBox Err.Number & " " & Err.Description
strResult = "An error occurred displaying image."
Resume Exit_DisplayImage:
End Select
End Function
There the function is called by
Me!txtFaceResults = DisplayImage(Me!WebBrowser1, strFullImageName)
While it works to zoom the images to a uniform size, the scaling is still off. But the general process works of loading the images in to the ActiveX Web Browser object. Reads the image size and calculates a zoom factor and then apply the zoom. It is important to wait for the image to load, otherwise you will either get an error or the size of the previously loaded image.
I was not able to use HtmlImg Type as Thomas used, so I got the elements individually. I used the documentation on Mozilla at:
https://developer.mozilla.org/en-US/docs/Web/API/Element
to see the element available.
If you have only the image loaded, the following code will get you the width and height of that image.
Dim img As HtmlImg
Set img = Me.WebBrowser1.Document.images(0)
Debug.Print img.naturalHeight, img.naturalWidth
However, I was not really able to calculate the correct zoom factor nor to pass a variable zoom factor to the ExecWB-method - I always got a runtime error, not matter which data type I used (constant values are working).
Plus, at least in my tests, the image was displayed with (white) borders which also would influence the zoom factor. Anyhow, the width and height are exactly the dimensions of the test image I was playing with.
After experiencing problems with Visual Basic's printform quality, I have decided to take a different approach. I am going to simulate an ALT-PRINTSCREEN keyboard key-press to capture the form in its current state.
However, before this happens, I need to remove certain elements from the form (such as the border), and after getting the image, I need to replace these elements. I am having some timing/synchronization problems with this, as I am noticing that certain elements are still on the image that has been copied to the clipboard.
I figured this was due to the fact that it takes time to process the changes, and time for Windows to process the simulated "send keys", so I set up sleep timers. I am having mixed results. I notice that if I don't replace the elements afterwords, the clipboard image appears correctly. However, if I do replace them, even if I set up a 20 second sleep timer, they do not appear.
Therefore, I know there is some sort of synchronization problem, but I am not sure how to fix it. Here is the code I am using:
'Make these forms invisble so they are not printed
Logo.Visible = False
MenuStrip1.Visible = False
ReportsButton.Visible = False
pnlmain.BorderStyle = 0 'remove the border
'Sleep
System.Threading.Thread.Sleep(1000)
'simulate an ALT and PRINTSCREEN key click to get ONLY the report
SendKeys.Send("%{PRTSC}")
'Sleep
System.Threading.Thread.Sleep(1000)
'Now, get the image from the clipboard
Dim formImage As System.Drawing.Image
formImage = My.Computer.Clipboard.GetImage()
Logo.Visible = True
MenuStrip1.Visible = True
ReportsButton.Visible = True
pnlmain.BorderStyle = 1
Changing the sleep durations does not seem to change much (unless they are very low).
Any suggestions?
EDIT: here is the code for draw to bitmap (after modifying the code above):
formImage = New Bitmap(Me.Width, Me.Height, Me.CreateGraphics())
Me.DrawToBitmap(formImage, New Rectangle(0, 0, Me.Width, Me.Height))
When it is sent to the print action:
Dim g As Graphics = e.Graphics
'transform the form image so it fits the height and width of the paper, with a 5 px margin
Dim res = printSettings.PrinterResolutions
Dim newSizeDestinationPoints As Point() = {
New Point(5, 5),
New Point(841, 5),
New Point(5, 956)
} 'These values are based on A4 sized paper
'g.DrawImage(formImage, 5, 5)
g.DrawImage(formImage, newSizeDestinationPoints)
The low quality is not coming from the stretch.
in the load event, I'm setting left and top position. What's happening is the form shows up in the default position, then goes to the location that I set manually. So it flashes at one position then immediately goes to the manual settings. (hope this makes sense.. let me know if I need to provide more info)
Dim rkCurrentUser As RegistryKey = Registry.CurrentUser
If rkCurrentUser IsNot Nothing Then
Dim rkTest As RegistryKey = rkCurrentUser.OpenSubKey("My Secret Life")
If rkTest IsNot Nothing Then
regKey = Registry.CurrentUser.CreateSubKey("My Secret Life")
Dim myLeft As Integer = 0
myLeft = regKey.GetValue("frmMainLeft", myLeft)
Dim myTop As Integer = 0
myTop = regKey.GetValue("frmMainTop", myTop)
Dim myMinutes As Integer = 0
myMinutes = regKey.GetValue("waitMinutes", myMinutes)
Me.Top = myTop
Me.Left = myLeft
regKey.Close()
rkTest.Close()
rkCurrentUser.Close()
End If
Else
MsgBox("Key doesn't exist")
regKey = Registry.CurrentUser.CreateSubKey("My Secret Life")
regKey.SetValue("waitMinutes", 0)
regKey.SetValue("frmMainLeft", Me.Left)
regKey.SetValue("frmMainTop", Me.Top)
regKey.Close()
End If
rkCurrentUser.Close(
Thanks for any help... plus I know the last character is removed.
Here's some sample code that illustrates the kind of thing I usually do:
Function Display() As DialogResult
Me.Icon = frmMain.Icon 'so we only change icons in one place
'other initialisation stuff goes here
RestoreFormSettings(Me) 'get form position (and size if resizable) from registry (your code)
Return Me.ShowDialog() 'show the form modally, then return dialog result
End Function
You should find that this gets rid of the flicker. I've also included what I do to ensure icon consistency across the app, and how to return a DialogResult which is one way for the calling code to know what you did in the form. To clarify, call this instead of calling frm.ShowDialog directly.
I create a browser like so, and manually navigate to the web page I need to be. I intend to automatically pull certain elements once I get to the page I need to be on via a seperate macro
Sub Test()
Set CAS = New SHDocVw.InternetExplorer ' create a browser
CAS.Visible = True ' make it visible
CAS.navigate "http://intraneturl"
Do Until CAS.readyState = 4
DoEvents
Loop
This works fine, then I do
Public Sub Gather
Set HTMLDoc2 = CAS.document.frames("top").document
Call Timer1
With HTMLDoc2
.getElementById("tab4").FirstChild.Click
End With
Call Timer2
Dim fir, las, add1, add2, cit, stat, zi As String
Dim First As Variant
Dim Last As Variant
Dim addr1 As Variant
Dim addr2 As Variant
Dim city As Variant
Dim Thisstate As Variant
Dim Zip As Variant
Call Timer2
Set HTMLDoc = CAS.document.frames("MainFrame").document
Call Timer2
With HTMLDoc
First = .getElementsByName("IndFirst")
Last = .getElementsByName("IndLast")
addr1 = .getElementsByName("txtAdd_Line1")
addr2 = .getElementsByName("txtAdd_Line2")
city = .getElementsByName("txtAdd_City")
Thisstate = .getElementsByName("cmb_Add_State")
Zip = .getElementsByName("txtAdd_Zip")
End With
fir = First.Value
las = Last.Value
add1 = addr1.Value
add2 = addr2.Value
cit = city.Value
stat = Thisstate.Value
zi = Zip.Value
'navigate back to start page
With HTMLDoc2
.getElementById("tab3").FirstChild.Click
End With
End Sub
This works the first time, but after the first time, I get "Object variable or with block variable not set" when trying to run the gather() sub again, on a different web page that contains similar information. Any Ideas as to what im doing wrong?
"The error "object variable or with block variable not set" occurs on: Set HTMLDoc2 = CAS.document.frames("top").document the second time i try running Gather()."
This is probably one of three things:
CAS is no longer an object
To check this, set a breakpoint on the line, press ctr+G in the VBA Editor and type ?CAS Is Nothing in the Immediate Window; the result should be False; if it is True CAS is no longer an object
Like Daniel Dusek suggested, make sure CAS.document.frames("top") is an actual element on the page.
To check this, open the webpage you are trying to script, press F12 in Internet Explorer, click on the arrow in the toolbar and click on the "top" frame element in the webpage, switch back to the Developer Tool and look at the line highlighted. Make sure the frame element is named "top".
The HTML hasn't fully loaded when you try to reference the frame element. Set a longer delay or a loop.
i.e. (untested):
Do Until HtmlDoc2 Is Nothing = false
Set HTMLDoc2 = CAS.document.frames("top").document
Loop
Maybe the more important question is why manually navigate to another page? Can't you automate that part of your process too?
I am trying to write program in vb 2010 that is independent of screen resolution.
I am designing the program in 1920*1080 and when I change the resolution to e.g. 800*600 everything blows up and the program won't fit the screen. How can I fix this?
I have tried three different approaches:
loop through all controls and scale their position and dimensions
Friend Sub ResizeControl(ByRef ctl As Control)
'---------------------------- GET SCALES -------------------------
Dim DesignScreenWidth As Integer = 1920
Dim DesignScreenHeight As Integer = 1080
Dim CurrentScreenWidth As Integer = Screen.PrimaryScreen.Bounds.Width
Dim CurrentScreenHeight As Integer = Screen.PrimaryScreen.Bounds.Height
'Ratios
Dim ratioX As Double = CurrentScreenWidth / DesignScreenWidth ' e.g. 800/1920
Dim ratioY As Double = CurrentScreenHeight / DesignScreenHeight
With ctl
Dim height As Integer = Math.Min(.Height, CurrentScreenHeight)
Dim width As Integer = Math.Min(.Width, CurrentScreenWidth)
'Position
If (.GetType.GetProperty("Top").CanRead) Then .Top = CInt(.Top * ratioY)
If (.GetType.GetProperty("Left").CanRead) Then .Left = CInt(.Left * ratioX)
'Size
If (.GetType.GetProperty("Width").CanRead) Then .Width = CInt(width * ratioX)
If (.GetType.GetProperty("Height").CanRead) Then .Height = CInt(height * ratioY)
End With
'---------------------- RESIZE SUB CONTROLS -------------------------------
For Each subCtl As Control In ctl.Controls
ResizeControl(subCtl)
Next subCtl
End Sub
Anchor each control to the main Form and only resize the main form
tried to AutoScale Mode
Dim factorX As Double = ratioX * 96.0F
Dim factorY As Double = ratioY * 96.0F
Dim newSize As SizeF = New SizeF(factorX, factorY)
AutoScaleDimensions = newSize
AutoScaleMode = AutoScaleMode.Dpi
Scale(newSize)
Font = New Font(Font.FontFamily, Font.Size * factorX)
None of these methods has worked for me. What am I doing wrong?
One thing I figured out was that my main form is larger than 800*600 pixels so when I run the designer in 800*600 resolution VS cut down the with to 812px so my calculations of with and thus scaling ratio becomes wrong. This error goes applies for all three methods.
Please advise on the best method and if I am doing something wrong.
As an expansion to my first comment, take a look at some best practices from the UX (user experience) world. There is a lot of science and and deliberation put into UIs that work.
There's a great SE site - ux.stackexchange.com that you may find can answer your questsions better than SO.
Here's some questions you may find helpful:
https://ux.stackexchange.com/questions/3414/desktop-software-design-patterns (see MS & Apple have their own guidelines incl. things like button widths)
https://ux.stackexchange.com/questions/11361/responsive-web-design-technique-in-desktop-application
Responsive web design seems to parallel what you're doing. The idea behind it is to have your website be able to handle any client device - which is becoming very important because of the mobile explosion.
I suggest doing some studying in these areas to come up with a good solution.