VB API 定义坐标 将坐标单位变成像素

[lyyliuyuanyuan]

我现在想在下列程序的基础上，将横纵坐标单位变成像素，比如Picture1的最右边横坐标是6000，怎么办





Option Explicit

Dim K As Double
Dim lngX As Long 'X的值
Dim dblY As Double 'Y的值
Dim L As Long '绘图区域的宽
Dim H As Long '绘图区域的高
Dim lngMemoryDC As Long '内存中绘图的设备场景的句柄
Dim lngBMPHandle As Long '位图的句柄
Dim lngBrushHandle As Long '填充刷子的句柄
Dim hRgn As Long '填充区域的句柄


Private Const PI = 3.1415926 'PI
Private Const DC_L = 500 '内存设备场景对图片设备场景的倍数,注意，这个数据太大会导致函数执行失败
Private Const SRCCOPY = &HCC0020
Private Const SRCAND = &H8800C6
Private Const SRCDECIMALBIND = 19
Private Const SRCERASE = &H440328


Private Type POINTAPI
x As Long
y As Long
End Type
Private Declare Function PolyBezier Lib "gdi32.dll" (ByVal hdc As Long, lppt As POINTAPI, ByVal cPoints As Long) As Long
Private Declare Function PolyBezierTo Lib "gdi32.dll" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
Private Declare Function PolyPolygon Lib "gdi32.dll" (ByVal hdc As Long, lpPoint As POINTAPI, lpPolyCounts As Long, ByVal nCount As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long

Private Sub Command1_Click()
Dim lngP As Long
If Command1.Caption = "开始" Then
Timer1.Enabled = True
Command1.Caption = "停止"
Else
Timer1.Enabled = False
Command1.Caption = "开始"
End If
End Sub

Private Sub Form_Load()
Dim intP As Integer
Dim x As Double
Dim y As Double
Dim lngP As Long
On Error GoTo errSub
L = Picture1.ScaleWidth / 15
H = Picture1.ScaleHeight / 15
K = 4 * PI / L
dblY = H * 0.5
lngMemoryDC = CreateCompatibleDC(Picture1.hdc) '创建一个与窗体相兼容的设备场景
lngBMPHandle = CreateCompatibleBitmap(lngMemoryDC, DC_L * L, H) '在内存中创建与窗体同样大小的位图
SelectObject lngMemoryDC, lngBMPHandle '将位图选入刚才创建的设备场景中
lngBrushHandle = CreateSolidBrush(RGB(255, 255, 255)) '用白色创建一个实色画刷
hRgn = CreateRectRgn(0, H, DC_L * L, 0) '创建一个与窗体同样大小的矩形区域
lngP = FillRgn(lngMemoryDC, hRgn, lngBrushHandle) '用创建的画刷对该区域进行填充
Exit Sub
errSub:
MsgBox Err.Description
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DeleteObject hRgn '删除以前创建的对像用于释放内存
DeleteObject lngBrushHandle
DeleteObject lngBMPHandle
DeleteDC lngMemoryDC
End Sub
Private Sub Timer1_Timer()
Dim lngP As Long
Dim lngT As Long
Dim lngK As Long
Dim intP As Integer
On Error GoTo errSub
lngK = GetTickCount
MoveToEx lngMemoryDC, lngX, dblY, ByVal 0&
lngX = lngX + 1
dblY = (0.45 * H * Sin(K * lngX) + 0.5 * H)
lngP = LineTo(lngMemoryDC, lngX, dblY)
If lngX <= L Then
lngP = BitBlt(Picture1.hdc, 0, 0, L, H, lngMemoryDC, 0, 0, SRCCOPY) '将内存位图中的图形拷贝到窗体上显示
Else
lngP = BitBlt(Picture1.hdc, 0, 0, L, H, lngMemoryDC, lngX - L, 0, SRCCOPY) '将内存位图中的图形拷贝到窗体上显示
End If
Exit Sub
errSub:
End Sub

[cbm6666]

将坐标单位变成像素

Screen.Height / Screen.TwipsPerPixelX

或

Screen.Height / 15

[cbm6666]

将坐标单位变成像素

Screen.Height / Screen.TwipsPerPixelY

或

Screen.Height / 15

'*********************************
Screen.Width / Screen.TwipsPerPixelX

或

Screen.Width / 15

[贝隆]

这个代码已经做过这个处理了

[cbm6666]

哈哈那么长的代码懒得看 只看标题

[贝隆]

呵呵,我也没有仔细看,不过这个代码是我写的:),故而知道.

[熊孩子开学喽]

...
要用API画画,就不要乱用其他单位了,像素单位是最方便的

[几罗星人]

Picture1.ScaleMode = 3'设置Picture1的坐标单位是像素
搞定，所有坐标出来的都是像素了