用VB如何实现XP界面?(不用皮肤,不用控件能实现吗?,最好有源码.)

Question

看了几篇文章都是在VB.net下作的.
http://www.mvps.org/vbnet/index.html?code/main/index.html
用VB能实现吗?

Answer 1

http://vbaccelerator.com/home/VB/Code/Controls/Skins/article.asp
http://www.cstsoft.com.cn/china/activeskin.htm
------------------------------------------------------------------
Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, 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 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 Type BITMAP '24 bytes
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPrivate m_hDC As Long
Private m_hBmpOld As Long
Private m_hBmp As Long
Private m_lWidth As Long
Private m_lheight As LongPublic Sub CreateFromPicture(sPic As IPicture)
    Dim tB As BITMAP
    Dim lhDCC As Long, lhDC As Long
    Dim lhBmpOld As Long
    GetObjectAPI sPic.Handle, Len(tB), tB
    Width = tB.bmWidth
    Height = tB.bmHeight
    lhDCC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    lhDC = CreateCompatibleDC(lhDCC)
    lhBmpOld = SelectObject(lhDC, sPic.Handle)
    BitBlt hdc, 0, 0, tB.bmWidth, tB.bmHeight, lhDC, 0, 0, vbSrcCopy
    SelectObject lhDC, lhBmpOld
    DeleteDC lhDC
    DeleteDC lhDCC
End SubPublic Property Get hdc() As Long
    hdc = m_hDC
End PropertyPublic Property Let Width(ByVal lW As Long)
    If lW > m_lWidth Then
        pCreate lW, m_lheight
    End If
End PropertyPublic Property Get Width() As Long
    Width = m_lWidth
End PropertyPublic Property Let Height(ByVal lH As Long)
    If lH > m_lheight Then
        pCreate m_lWidth, lH
    End If
End PropertyPublic Property Get Height() As Long
    Height = m_lheight
End PropertyPrivate Sub pCreate(ByVal lW As Long, ByVal lH As Long)
Dim lhDC As Long
    pDestroy
    lhDC = CreateDCAsNull("DISPLAY", ByVal 0&, ByVal 0&, ByVal 0&)
    m_hDC = CreateCompatibleDC(lhDC)
    m_hBmp = CreateCompatibleBitmap(lhDC, lW, lH)
    m_hBmpOld = SelectObject(m_hDC, m_hBmp)
    If m_hBmpOld = 0 Then
        pDestroy
    Else
        m_lWidth = lW
        m_lheight = lH
    End If
    DeleteDC lhDC
End SubPrivate Sub pDestroy()
    If Not m_hBmpOld = 0 Then
        SelectObject m_hDC, m_hBmpOld
        m_hBmpOld = 0
    End If
    If Not m_hBmp = 0 Then
        DeleteObject m_hBmp
        m_hBmp = 0
    End If
    m_lWidth = 0
    m_lheight = 0
    If Not m_hDC = 0 Then
        DeleteDC m_hDC
        m_hDC = 0
    End If
End SubPrivate Sub Class_Terminate()
    pDestroy
End Sub

Answer 2

我有演示超OUTLOOK软件(正式版SmartMail1.0免费提供源码(最新版))
运行演示图:http://bbs.2ccc.com/uploads/huangtao/运行效果图.jpg
下载地址:http://bbs.2ccc.com/uploads/huangtao/smartmail1.0.rar

Answer 3

:)hlfisagoodboy(泡泡糖)->
:) Dublue(谁抢了我的名字) ->这代码怎么用?能不能看到实际的效果.你的意思是做成控件吗?

Answer 4

我有演示,还有源代码.超OUTLOOK软件(正式版SmartMail1.0免费提供源码(最新版))
运行演示图:http://bbs.2ccc.com/uploads/huangtao/运行效果图.jpg
下载地址:http://bbs.2ccc.com/uploads/huangtao/smartmail1.0.rar

Answer 5

给你推荐一个，有好多控件的
http://www.99fst.com/stone/xp.rar
我也是下载的，希望对你有用

Answer 6

我这里有免费的源代码，而且是仿XP菜单，给我写信啊[email protected]