mytitlebar.ctl

用visual basic语言开发的动网论坛自动注册代码

Private Sub LabelC_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
    Call ReleaseCapture
    Call SendMessage(UserControl.Parent.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
    End If
End Sub

Private Sub PicCloseU_Click()
'UserControl.Parent.Hide
PicCloseU.Cls
Unload UserControl.Parent
End Sub

Private Sub PicCloseU_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With PicCloseU
        If Button = 0 Then
            If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
                ReleaseCapture ' 鼠标离开
                .Cls
            Else
                SetCapture .hWnd '鼠标进入
                BitBlt .hdc, 0, 0, 15, 16, PicClose.hdc, 0, 0, vbSrcCopy
                .Refresh
            End If
        End If
    End With
End Sub

Private Sub PicMaxU_Click()
If UserControl.Parent.WindowState = 2 Then
    UserControl.Parent.WindowState = 0
Else
    UserControl.Parent.WindowState = 2
End If
PicMaxU.Cls
End Sub

Private Sub PicMaxU_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With PicMaxU
        If Button = 0 Then
            If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
                ReleaseCapture ' 鼠标离开
                .Cls
            Else
                SetCapture .hWnd '鼠标进入
                
                BitBlt .hdc, 0, 0, 15, 16, PicMax.hdc, 0, 0, vbSrcCopy
                .Refresh
            End If
        End If
    End With
End Sub

Private Sub PicMinU_Click()
UserControl.Parent.WindowState = 1
PicMinU.Cls
End Sub

Private Sub PicMinU_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    With PicMinU
        If Button = 0 Then
            If (X < 0) Or (Y < 0) Or (X > .Width) Or (Y > .Height) Then
                ReleaseCapture ' 鼠标离开
                .Cls
            Else
                SetCapture .hWnd '鼠标进入
                BitBlt .hdc, 0, 0, 15, 16, PicMin.hdc, 0, 0, vbSrcCopy
                .Refresh
            End If
        End If
    End With
End Sub

Private Sub UserControl_Resize()
Dim i As Long
Dim BorderColor As Long, ForeColor As Long, BorderWidth As Long, BackColor As Long, MyObject As Object
On Error Resume Next
    ImageM.Picture = LoadPicture(AppPath & "\Skins\MidTitle.bmp")
    ImageL.Picture = LoadPicture(AppPath & "\Skins\LeftTitle.bmp")
    ImageR.Picture = LoadPicture(AppPath & "\Skins\RightTitle.bmp")
    ImageM.Width = UserControl.ScaleWidth - ImageL.Width - ImageR.Width
    ImageM.Left = ImageL.Width
    ImageR.Left = UserControl.ScaleWidth - ImageR.Width
    UserControl.Height = 360
    UserControl.Width = UserControl.Parent.Width
    PicCloseU.Left = UserControl.ScaleWidth - 20
    PicMaxU.Left = UserControl.ScaleWidth - 43
    PicMinU.Left = UserControl.ScaleWidth - 67

    Picture000.Picture = LoadPicture(AppPath & "\Skins\Back.bmp")
    
    If "True" = Trim(ReadIni("Skin", "IsBackground", AppPath & "\Skins\Skin.ini")) Then AllBlt UserControl.Parent, Picture000
    
    If ("True" = Trim(ReadIni("Skin", "IsBold", AppPath & "\Skins\Skin.ini"))) And UserControl.Parent.ControlBox = True Then LabelC.FontBold = True
    LabelC.ForeColor = Val(ReadIni("Skin", "ForeColor", AppPath & "\Skins\Skin.ini"))
    
    PicMaxU.Picture = LoadPicture(AppPath & "\Skins\max.bmp")
    PicMinU.Picture = LoadPicture(AppPath & "\Skins\min.bmp")
    PicCloseU.Picture = LoadPicture(AppPath & "\Skins\close.bmp")
    
    PicMax.Picture = LoadPicture(AppPath & "\Skins\lightmax.bmp")
    PicMin.Picture = LoadPicture(AppPath & "\Skins\lightmin.bmp")
    PicClose.Picture = LoadPicture(AppPath & "\Skins\lightclose.bmp")
    
    PicUn.Picture = LoadPicture(AppPath & "\Skins\None.bmp")
    
    If "True" = Trim(ReadIni("Skin", "IsCutRect", AppPath & "\Skins\Skin.ini")) Then
      Dim Regn As Long
      Dim CER As Long
      'MakeNoBorderForm UserControl.Parent
      X1 = UserControl.Parent.Width / Screen.TwipsPerPixelX
      Y1 = UserControl.Parent.Height / Screen.TwipsPerPixelY
    
      Regn = CreateRectRgn(0, 4, X1, Y1)  '把句柄设为第一个矩形区域
      CER = CreateRectRgn(4, 0, X1 - 4, 10) '创建第二个矩形区域
      CombineRgn Regn, Regn, CER, RGN_OR   '把临时句柄变量或运算到句柄变量中
      CER = CreateRectRgn(2, 1, X1 - 2, 10)
      CombineRgn Regn, Regn, CER, RGN_OR   '把临时句柄变量或运算到句柄变量中
      CER = CreateRectRgn(1, 2, X1 - 1, 10)
      CombineRgn Regn, Regn, CER, RGN_OR   '把临时句柄变量或运算到句柄变量中
      Call SetWindowRgn(UserControl.Parent.hWnd, Regn, True) '创建窗体
    End If
      
    BorderWidth = Val(ReadIni("Skin", "BorderWidth", AppPath & "\Skins\Skin.ini"))
    'UserControl.Parent.DrawWidth = BorderWidth
    
    BorderColor = Val(ReadIni("Skin", "BorderColor", AppPath & "\Skins\Skin.ini"))
    
    BackColor = Val(ReadIni("Skin", "BackColor", AppPath & "\Skins\Skin.ini"))
    UserControl.Parent.BackColor = BackColor
    
    ForeColor = Val(ReadIni("Skin", "ForeColor", AppPath & "\Skins\Skin.ini"))
    
    For Each MyObject In UserControl.Parent
      MyObject.BackColor = BackColor
      MyObject.ForeColor = ForeColor
    Next MyObject
    
    
    UserControl.Parent.ScaleMode = 3
    
    For i = 1 To BorderWidth
      UserControl.Parent.Line (i - 1, ImageM.Height)-(i - 1, UserControl.Parent.ScaleHeight - i), BorderColor
      UserControl.Parent.Line (i - 1, UserControl.Parent.ScaleHeight - i)-(UserControl.Parent.ScaleWidth - i, UserControl.Parent.ScaleHeight - i), BorderColor
      UserControl.Parent.Line (UserControl.Parent.ScaleWidth - i, ImageM.Height)-(UserControl.Parent.ScaleWidth - i, UserControl.Parent.ScaleHeight), BorderColor
    Next i
End Sub

Private Function AllBlt(frm As Object, pic As Object)
Dim i As Long, j As Long
  frm.ScaleMode = 3
  frm.AutoRedraw = True
  pic.AutoRedraw = True
  pic.ScaleMode = 3
  pic.AutoSize = True
  For i = 0 To frm.ScaleWidth Step pic.ScaleWidth
    For j = 0 To frm.ScaleHeight Step pic.ScaleHeight
      BitBlt frm.hdc, i, j, pic.ScaleWidth, pic.ScaleHeight, pic.hdc, 0, 0, vbSrcCopy
    Next j
  Next i
  frm.Refresh
End Function

Private Sub MakeNoBorderForm(frm As Form)
'切除窗口的边框
Dim rctClient As RECT, rctFrame As RECT
Dim hRGN As Long
Dim lRes As Long
ReDim XY(3) As POINTAPI
Dim lpTL As POINTAPI, lpBR As POINTAPI
    
    '获得窗口矩形区域
    '将窗口矩形坐标转换为屏幕坐标
    lpTL.X = frm.Left / 15
    lpTL.Y = frm.Top / 15
    ScreenToClient frm.hWnd, lpTL
    rctClient.Left = Abs(lpTL.X)
    rctClient.Top = Abs(lpTL.Y)
    
    frm.ScaleMode = 1                                       'Twip
    
    rctClient.Right = frm.ScaleWidth / 15 + Abs(lpTL.X)
    rctClient.Bottom = frm.ScaleHeight / 15 + Abs(lpTL.Y)
    
    '建立要切割的数组
    XY(0).X = rctClient.Left
    XY(0).Y = rctClient.Top
    XY(1).X = rctClient.Right
    XY(1).Y = rctClient.Top
    XY(2).X = rctClient.Right
    XY(2).Y = rctClient.Bottom
    XY(3).X = rctClient.Left
    XY(3).Y = rctClient.Bottom
     
    hRGN = CreatePolygonRgn(XY(0), 4, 2)
    lRes = SetWindowRgn(frm.hWnd, hRGN, True)
    
    frm.ScaleMode = 3
End Sub

Public Function RefreshTitle()
LabelC.Caption = UserControl.Parent.Caption
End Function

Private Sub UserControl_Show()
Call UserControl_Resize
If UserControl.Parent.MinButton = False Then
    BitBlt PicMinU.hdc, 0, 0, 15, 16, PicUn.hdc, 0, 0, vbSrcCopy
    PicMinU.Refresh
    PicMinU.Enabled = False
End If
    
If UserControl.Parent.MaxButton = False Then
    BitBlt PicMaxU.hdc, 0, 0, 15, 16, PicUn.hdc, 0, 0, vbSrcCopy
    PicMaxU.Refresh
    PicMaxU.Enabled = False
End If

If UserControl.Parent.ControlBox = False Then
  PicMinU.Visible = False
  PicMaxU.Visible = False
  PicCloseU.Visible = False
  ImageIco.Visible = False
  LabelC.Left = 6
End If

LabelC.Caption = UserControl.Parent.Caption
ImageIco.Picture = UserControl.Parent.Icon
End Sub

Private Function AppPath() As String
If Right(App.Path, 2) = ":\" Then
  AppPath = Left(App.Path, Len(App.Path) - 1)
Else
  AppPath = App.Path
End If
End Function