showdaw.frm

电脑编程技巧和源码。很不错的。

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form MainForm 
   AutoRedraw      =   -1  'True
   Caption         =   "Test Showdaw By DragonJiang"
   ClientHeight    =   1215
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4200
   LinkTopic       =   "Form1"
   ScaleHeight     =   81
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   280
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog dlg 
      Left            =   3600
      Top             =   600
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Close"
      Height          =   375
      Left            =   3120
      TabIndex        =   3
      Top             =   120
      Width           =   975
   End
   Begin VB.TextBox ShowSize 
      Enabled         =   0   'False
      Height          =   270
      Left            =   1440
      TabIndex        =   2
      Text            =   "10"
      Top             =   240
      Width           =   855
   End
   Begin VB.VScrollBar UpDown 
      Height          =   255
      Left            =   2280
      Max             =   100
      Min             =   2
      TabIndex        =   1
      Top             =   240
      Value           =   92
      Width           =   255
   End
   Begin VB.Timer Timer1 
      Interval        =   400
      Left            =   3120
      Top             =   600
   End
   Begin VB.Label labColor 
      BackColor       =   &H80000007&
      BorderStyle     =   1  'Fixed Single
      Height          =   375
      Left            =   1440
      TabIndex        =   5
      Top             =   600
      Width           =   1095
   End
   Begin VB.Label Label2 
      Caption         =   "投影色彩："
      Height          =   255
      Left            =   360
      TabIndex        =   4
      Top             =   720
      Width           =   1095
   End
   Begin VB.Label Label1 
      Caption         =   "投影大小："
      Height          =   255
      Left            =   360
      TabIndex        =   0
      Top             =   240
      Width           =   1215
   End
   Begin VB.Label Label4 
      BorderStyle     =   1  'Fixed Single
      Height          =   975
      Left            =   120
      TabIndex        =   6
      Top             =   120
      Width           =   2775
   End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim ShowdawDepth   As Integer
 
Dim WinX, WinY, WinW, WinH, wx, wy, xw, xh As Long
Dim ShowdawColor As Long

Private Sub GetWandH()
  Dim r As RECT
  wy = MainForm.Top
  wx = MainForm.Left
  
  Call GetWindowRect(MainForm.hwnd, r) '获取当前窗口在屏幕上的位置
  
  WinX = r.Left
  WinY = r.Top
  
  WinH = r.Bottom - r.Top + 1
  WinW = r.Right - r.Left + 1
   
  '重新调整左边投影的位置
  LeftForm.Left = CLng(ScaleX(r.Right, 3, 1) + 0.5)
  LeftForm.Top = CLng(ScaleY(r.Top, 3, 1) + 0.5)
  LeftForm.Width = xw
  LeftForm.Height = CLng(ScaleY(WinH, 3, 1) + 0.5)
  
  '重新调整下边投影的位置
  DownForm.Width = CLng(ScaleX(WinW, 3, 1) + 0.5)
  DownForm.Height = xh
  DownForm.Top = CLng(ScaleY(r.Bottom, 3, 1) + 0.5)
  DownForm.Left = CLng(ScaleX(r.Left, 3, 1) + 0.5)
  
  '重新调整右下角边投影的位置
  RdForm.Top = CLng(ScaleY(r.Bottom, 3, 1) + 0.5)
  RdForm.Left = CLng(ScaleX(r.Right, 3, 1) + 0.5)
  RdForm.Width = xw
  RdForm.Height = xh
    
End Sub

Private Sub Command1_Click()
  Unload MainForm
End Sub



 
Private Sub Form_Load()
    ShowdawDepth = 10
    xh = CLng(ScaleY(ShowdawDepth, 3, 1) + 0.5)
    xw = CLng(ScaleX(ShowdawDepth, 3, 1) + 0.5)
    ShowdawColor = 0
    Timer1.Interval = 100
    dlg.CancelError = True
    labColor.BorderStyle = 1
    labColor.BackStyle = 1
    labColor.BackColor = ShowdawColor


End Sub

Private Sub Paint() '窗口绘制
    Dim hScreenDc, hMemLeftDc, hMemDownDc, hMemRdDc, x, y As Long
    Dim hMemLeftBit, hMemDownBit, hMemRdBit, curColor, srcColor As Long
   
    
    LeftForm.Visible = False
    DoEvents
    DownForm.Visible = False
    DoEvents
    RdForm.Visible = False
    DoEvents
    
    hScreenDc = GetDC(0) '获取桌面DC
    
    hMemLeftDc = CreateCompatibleDC(hScreenDc)
    
       
    hMemLeftBit = CreateCompatibleBitmap(hScreenDc, ShowdawDepth, WinH)
    SelectObject hMemLeftDc, hMemLeftBit
    
    hMemDownDc = CreateCompatibleDC(hScreenDc)
    hMemDownBit = CreateCompatibleBitmap(hScreenDc, WinW, ShowdawDepth)
    SelectObject hMemDownDc, hMemDownBit
    
    hMemRdDc = CreateCompatibleDC(hScreenDc)
    hMemRdBit = CreateCompatibleBitmap(hScreenDc, ShowdawDepth, ShowdawDepth)
    SelectObject hMemRdDc, hMemRdBit
    
    For y = 0 To WinH - 1
       For x = 0 To ShowdawDepth - 1 '左边的投影
     
         srcColor = GetPixel(hScreenDc, WinW + WinX + x, WinY + y)
         
         If srcColor <> -1 Then
           
           If y < ShowdawDepth And x < y Or y >= ShowdawDepth Then
               curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, x)
           Else
               curColor = srcColor
           End If
           
           SetPixel hMemLeftDc, x, y, curColor
         End If
      Next x
    Next y
    
    For y = 0 To ShowdawDepth - 1  '右下角的投影
      For x = 0 To ShowdawDepth - 1
      
         srcColor = GetPixel(hScreenDc, WinW + WinX + x, WinY + WinH + y)
         If srcColor <> -1 Then
           If x <= y Then
              curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, y)
           Else
              curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, x)
           End If
           SetPixel hMemRdDc, x, y, curColor
         End If
      Next x
    Next y
   
   For y = 0 To ShowdawDepth - 1
      For x = 0 To WinW - 1
    
      srcColor = GetPixel(hScreenDc, WinX + x, WinY + WinH + y)
         If srcColor <> -1 Then
           If y < ShowdawDepth And x >= y Or x >= ShowdawDepth Then
             curColor = GetTrienColor(ShowdawColor, srcColor, ShowdawDepth, y)
           Else
             curColor = srcColor
           End If
           SetPixel hMemDownDc, x, y, curColor
         End If
      Next x
    Next y
    
    LeftForm.Visible = True
    DoEvents
    Call BitBlt(LeftForm.hdc, 0, 0, ShowdawDepth, WinH, hMemLeftDc, 0, 0, SRCCOPY)
    
    DownForm.Visible = True
    DoEvents
    Call BitBlt(DownForm.hdc, 0, 0, WinW, ShowdawDepth, hMemDownDc, 0, 0, SRCCOPY)
    
    RdForm.Visible = True
    DoEvents
    Call BitBlt(RdForm.hdc, 0, 0, ShowdawDepth, ShowdawDepth, hMemRdDc, 0, 0, SRCCOPY)
    
    DeleteDC hMemLeftDc
    DeleteDC hMemDownDc
    DeleteDC hScreenDc
    DeleteDC hMemRdDc
 
    DeleteObject hMemLeftBit
    DeleteObject hMemRdBit
    DeleteObject hMemDownBit
    
  
     
End Sub



Private Sub Form_Resize()
  If MainForm.WindowState = vbNormal Then '窗口在正常状态下才显示立体投影
  
    If MainForm.Height < 2 * xh Then MainForm.Height = 2 * xh
    If MainForm.Width < 2 * xw Then MainForm.Width = 2 * xw
    Call GetWandH
    Call Paint
   
  Else
    wx = -1
    LeftForm.Visible = False
    DownForm.Visible = False
    RdForm.Visible = False
  End If
  
  
  
End Sub

Private Sub Form_Unload(Cancel As Integer)
   Unload LeftForm
   Unload DownForm
   Unload RdForm
End Sub
   


Private Sub labColor_Click()
  On Error GoTo exitLabColor
  dlg.ShowColor
  ShowdawColor = dlg.Color
  labColor.BackColor = ShowdawColor
  Call Paint
exitLabColor:
     
  
End Sub

Private Sub Timer1_Timer()
 
  If MainForm.WindowState = vbNormal And (MainForm.Left <> wx Or MainForm.Top <> wy) Then
     Call GetWandH
     Call Paint
  End If
End Sub
 Private Sub Form_Paint()
   Call GetWandH
   Call Paint
 End Sub
Private Sub UpDown_Change()
  ShowdawDepth = UpDown.Max + UpDown.Min - UpDown.Value
  ShowSize.Text = ShowdawDepth
  xh = CLng(ScaleY(ShowdawDepth, 3, 1) + 0.5)
  xw = CLng(ScaleX(ShowdawDepth, 3, 1) + 0.5)
  Call GetWandH
  Call Paint

End Sub