classpic.cls

来自「一个关于电脑管理汽车的软件」· CLS 代码 · 共 95 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClassPic"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function BitBlt& Lib "gdi32" (ByVal hDestDC&, ByVal x&, ByVal Y&, ByVal nWidth&, ByVal nHeight&, ByVal hSrcDC&, _
                                             ByVal xSrc&, ByVal ySrc&, ByVal dwRop&)
                                             
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent&, ByVal hWndChildAfter&, ByVal lpClassName$, ByVal lpWindowName$) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd&, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd&, lpRect As RECT, ByVal bErase&) As Long

Private Const API_FALSE As Long = 0&
Private Const API_TRUE As Long = 1&

Private Type RECT
    left As Long
    top As Long
    right As Long
    bottom As Long
End Type


Public currentImageFile As String
Public mdibg_mode As Boolean    'True is stretched mode, false is center mode


Public Sub CreateFormPic(fMain As MDIForm, pic1 As PictureBox, pic2 As PictureBox, mode As Boolean)
    
    Dim hCleintArea&, rc As RECT
  
    hCleintArea = FindWindowEx(fMain.hWnd, 0&, "MDIClient", vbNullChar)
    Call GetClientRect(hCleintArea, rc)
  
    pic2.Width = rc.right * 15 + 75
    pic2.Height = rc.bottom * 15 + 75
   ' pic2.ScaleWidth = 0
   ' pic2.ScaleHeight = 0
    Call InvalidateRect(hCleintArea, rc, API_TRUE)
    Call CenterPic(fMain, pic2, pic1, mode)
    Call InvalidateRect(hCleintArea, rc, API_TRUE)
    
End Sub

Public Sub CenterPic(fMain As MDIForm, picDest As PictureBox, picSource As PictureBox, mode As Boolean)

    On Error GoTo err1
    Dim left As Long
    Dim top As Long
    
    fMain.Picture = Nothing
    picDest.Picture = Nothing
    
    If picDest.Width > picSource.Width Then
        left = picDest.ScaleWidth \ 2 - picSource.ScaleWidth \ 2
    End If
    
    If picDest.Height > picSource.Height Then
        top = picDest.ScaleHeight \ 2 - picSource.ScaleHeight \ 2
    End If
    
    If mode Then
        Dim a, b, c, d As Long
        a = fMain.ScaleWidth \ 15
        b = fMain.ScaleHeight \ 15
        c = picSource.ScaleWidth
        d = picSource.ScaleHeight
        
        StretchBlt picDest.hdc, 0, 0, a, b, picSource.hdc, 0, 0, c, d, vbSrcCopy
    Else
        BitBlt picDest.hdc, left, top, 1024, 768, picSource.hdc, 0, 0, vbSrcCopy
    End If
    
    fMain.Picture = picDest.Image
    
    Exit Sub
err1:
    MsgBox Err.Number & " : " & Err.Description
End Sub