MT-Pioneer分享 http://blog.sciencenet.cn/u/陈小斌 一切以发表论文为科研目的的学者都是伪学者。

留言板

每天23点到次日7点之间禁止发表留言。

[17]陈小斌   2012-10-22 22:27
抱歉,我家里的机器正在做大规模的运算,无法及时调试程序。我现在用iPad。我明天到办公室给您看看。
[16]zhaoyazhe   2012-10-22 22:19
陈先生,您好!
打扰您了。代码如下:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Math,typinfo, StdCtrls;

Const   //记录设计时的屏幕分辨率
   OriWidth=1366;
   OriHeight=768;


{type TPropInfo = packed record
PropType: PPTypeInfo;
// 属性类型信息指针的指针
GetProc: Pointer;
// 属性的 Get 方法指针
SetProc: Pointer;
// 属性的 Set 方法指针
StoredProc: Pointer;
     // 属性的 StoredProc 指针
        Index: Integer;
                  // 属性的 Index 值
    Default: Longint;
  // 属性的 Default 值
     NameIndex: SmallInt;
          // 属性的名称索引(以 0 开始计数)
           Name: ShortString;
                // 属性的名称
                end;
PPropInfo = ^TPropInfo;
}
type
  TfmForm = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
  private
//fPosition:array of Byte;
fPosition:array of Trect;
  fScrResolutionRateW: Double;
    fScrResolutionRateH: Double;
    fIsFitDeviceDone: Boolean;
  Protected
    Property IsFitDeviceDone:Boolean Read fIsFitDeviceDone;
    Property ScrResolutionRateH:Double Read fScrResolutionRateH;
    Property ScrResolutionRateW:Double Read fScrResolutionRateW;
  Public
   function PropertyExists(const AObject: TObject;const APropName:String):Boolean;
   function GetObjectProperty( const AObject   : TObject; const APropName : string ):TObject;

   Procedure CalBasicScalePars;

   Procedure FreeListItem(vList:TList);
   Procedure AdjustComponentFont(vCmp:TComponent);
   Procedure AdjustControlsScale(vCtl:TControl;vList:TList;Var vK:Integer);
   Procedure ControlsPostoList(vCtl:TControl;vList:TList);
   procedure FitDeviceResolution;
   Constructor Create(AOwner: TComponent); Override;
  End;

var
  fmForm: TfmForm;
    LocList:TList;
  LocFontRate:Double;
  LocFontSize:Integer;
  LocFont:TFont;
  locK:Integer;
implementation

{$R *.dfm}
Procedure TfmForm.CalBasicScalePars;
  Begin
  try
  Self.Scaled:=False;
  fScrResolutionRateH:=screen.height/OriHeight;
  fScrResolutionRateW:=screen.Width/OriWidth;
  LocFontRate:=Min(fScrResolutionRateH,fScrResolutionRateW);
  except
  Raise;
  end;
End;

constructor TfmForm.Create(AOwner: TComponent);
begin
  Inherited Create(AOwner);
  fScrResolutionRateH:=1;
  fScrResolutionRateW:=1;
  Try
    if Not fIsFitDeviceDone then
    Begin
      FitDeviceResolution;
      fIsFitDeviceDone:=True;
    End;
  Except
    fIsFitDeviceDone:=False;
  End;
end;
//--------------

procedure TfmForm.FitDeviceResolution;
Var
  i:Integer;
  LocList:TList;
  LocFontSize:Integer;
  LocFont:TFont;
  LocCmp:TComponent;
  LocFontRate:Double;
  LocRect:TRect;
  LocCtl:TControl;
begin
  LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        Self.Scaled:=False;
        fScrResolutionRateH:=screen.height/OriHeight;
        fScrResolutionRateW:=screen.Width/OriWidth;
        Try
          if fScrResolutionRateH<fScrResolutionRateW then
            LocFontRate:=fScrResolutionRateH
          Else
            LocFontRate:=fScrResolutionRateW;
        Finally
          ReleaseDC(0, GetDc(0));
        End;

        For i:=Self.ComponentCount-1 Downto 0 Do
        Begin
          LocCmp:=Self.Components;
          If LocCmp Is TControl Then
            LocList.Add(LocCmp);
          If PropertyExists(LocCmp,'FONT') Then
          Begin
            LocFont:=TFont(GetObjectProperty(LocCmp,'FONT'));
            LocFontSize := Round(LocFontRate*LocFont.Size);
            LocFont.Size:=LocFontSize;
          End;
        End;

        SetLength(fPosition,LocList.Count+1);
        For i:=0 to LocList.Count-1 Do
          With TControl(LocList.Items)Do
            fPosition[i+1]:=BoundsRect;
        fPosition[0]:=Self.BoundsRect;

        With LocRect Do
        begin
           Left:=Round(fPosition[0].Left*fScrResolutionRateW);
           Right:=Round(fPosition[0].Right*fScrResolutionRateW);
           Top:=Round(fPosition[0].Top*fScrResolutionRateH);
           Bottom:=Round(fPosition[0].Bottom*fScrResolutionRateH);
           Self.SetBounds(Left,Top,Right-Left,Bottom-Top);
        end;

        i:= LocList.Count-1;
        While (i>=0) Do
         Begin
          LocCtl:=TControl(LocList.Items);
          If LocCtl.Align=alClient Then
          begin
            Dec(i);
            Continue;
          end;
          With LocRect Do
          begin
             Left:=Round(fPosition[i+1].Left*fScrResolutionRateW);
             Right:=Round(fPosition[i+1].Right*fScrResolutionRateW);
             Top:=Round(fPosition[i+1].Top*fScrResolutionRateH);
             Bottom:=Round(fPosition[i+1].Bottom*fScrResolutionRateH);
             LocCtl.SetBounds(Left,Top,Right-Left,Bottom-Top);
          end;
          Dec(i);
        End;
      End;

    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    LocList.Free;
  End;
end;



Procedure TfmForm.ControlsPostoList(vCtl:TControl;vList:TList);
  Var
    locPRect:^TRect;
    i:Integer;
    locCtl:TControl;
  Begin
    try
      New(locPRect);
      locPRect^:=vCtl.BoundsRect;
      vList.Add(locPRect);
      If vCtl Is TWinControl Then
        For i:=0 to TWinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls;
          ControlsPosToList(locCtl,vList);
        end;
    except
      Raise;
    end;
  End;

Procedure TfmForm.AdjustControlsScale(vCtl:TControl;vList:TList;Var vK:Integer);
  Var
    locOriRect,LocNewRect:TRect;
    i:Integer;
    locCtl:TControl;
Begin
    try
      If vCtl.Align<>alClient Then
      Begin
        locOriRect:=TRect(vList.Items[vK]^);
        With locNewRect Do
        begin
          Left:=Round(locOriRect.Left*fScrResolutionRateW);
          Right:=Round(locOriRect.Right*fScrResolutionRateW);
          Top:=Round(locOriRect.Top*fScrResolutionRateH);
          Bottom:=Round(locOriRect.Bottom*fScrResolutionRateH);
          vCtl.SetBounds(Left,Top,Right-Left,Bottom-Top);
        end;
      End;
      Inc(vK);
      If vCtl Is TWinControl Then
        For i:=0 to TwinControl(vCtl).ControlCount-1 Do
        begin
          locCtl:=TWinControl(vCtl).Controls;
          AdjustControlsScale(locCtl,vList,vK);
        end;
    except
      Raise;
    end;
End;

Procedure TfmForm.AdjustComponentFont(vCmp:TComponent);
  Var
    i:Integer;
    locCmp:TComponent;
Begin
    try
      For i:=vCmp.ComponentCount-1 Downto 0 Do
      Begin
        locCmp:=vCmp.Components;
        If PropertyExists(LocCmp,'FONT') Then
        Begin
          LocFont:=TFont(GetObjectProperty(LocCmp,'FONT'));
          LocFontSize := Round(LocFontRate*LocFont.Size);
          LocFont.Size:=LocFontSize;
        End;
      End;
    except
      Raise;
    end;
End;

Procedure TfmForm.FreeListItem(vList:TList);
  Var
    i:Integer;
Begin
    For i:=0 to vList.Count-1 Do
      Dispose(vList.Items);
    vList.Free;
   LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        CalBasicScalePars;
        AdjustComponentFont(Self);
        ControlsPostoList(Self,locList);
        locK:=0;
        AdjustControlsScale(Self,locList,locK);

      End;
    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    FreeListItem(locList);
  End;
end;

function TfmForm.PropertyExists(const AObject: TObject;const APropName:String):Boolean;
//判断一个属性是否存在
var
   PropInfo:PPropInfo;
begin
   PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
   Result:=Assigned(PropInfo);
   LocList:=TList.Create;
  Try
    Try
      if (Screen.width<>OriWidth)OR(Screen.Height<>OriHeight) then
      begin
        CalBasicScalePars;
        AdjustComponentFont(Self);
        ControlsPostoList(Self,locList);
        locK:=0;
        AdjustControlsScale(Self,locList,locK);

      End;
    Except on E:Exception Do
      Raise Exception.Create('进行屏幕分辨率自适应调整时出现错误'+E.Message);
    End;
  Finally
    FreeListItem(locList);
  End;
end;

function TfmForm.GetObjectProperty(const AObject   : TObject; const APropName : string ):TObject;
var
   PropInfo:PPropInfo;
begin
   Result  :=  nil;
   PropInfo:=GetPropInfo(AObject.ClassInfo,APropName);
   if Assigned(PropInfo) and
       (PropInfo^.PropType^.Kind = tkClass) then
     Result  :=  GetObjectProp(AObject,PropInfo);
end;
再次表示谢意!
zhaoyazhe888888@sohu.com



end.
[15]zhaoyazhe   2012-10-22 21:00
陈先生,您好!
不好意思打扰您。我按照您的程序作了一下(不知是否完整和理解有错误),在正常分辨率(默认:1366*768)下运行正常,在本机上改变为1024*768出错,显示:Stack Overflow.我修改了允许内存为16*1000,000,即增大10倍,仍然出错,想请指导一下,多谢
zhaoyazhe
zhaoyazhe888888@sohu.com
我的回复(2012-10-22 21:51):把您的代码发给我看看。估计是创建的对象忘了释放。
[14]zhaoyazhe   2012-10-22 13:03
谢谢陈先生!
zhaoyazhe
zhaoyazhe888888@sohu.com
2012-10-22
我的回复(2012-10-22 13:35):这样,您把您编译过程中遇到的问题告诉我,我把相应的子例程发给你。因为uMySysUtils单元里面又引用了很多其它单元,那样的话,牵涉到很多其它源代码。

我可以把这些需要的子程序单独剥离出来给您。
[13]zhaoyazhe   2012-10-22 06:49
陈先生,您好!
看了您的《Delphi:窗体自适应屏幕分辨率》文章,但仍然做不出,想请您给我一份能运行的delph的程序源码,不知可否?
多谢!
zhaoyahze888888@sohu.com
18240047035
我的回复(2012-10-22 09:35):感谢关注!看到了您的留言,但最近很忙,未及回复抱歉。

我估计是里面的typinfo单元您那找不到吧?但这个单元互联网上很多。其它单元,应该都是公用的吧。

另外,我的实现方法,但大部分情况下没有问题,但在分辨率差别很大的时候,在有些机器上还是会出现问题,出现部分组件被吃掉的现象。这些问题,需要大家一起来改进。
[12]mengqingkui   2012-7-3 09:40
谢谢 陈老师
[11]mengqingkui   2012-7-1 15:28
陈老师:
我在淘宝网看了关于delphi的书籍,不知道哪本是经典的比较好的,可以吧书名告诉我吗?
还有比较好的论坛的链接发给我可以吗?
Thanks!
邮箱:250443247@qq.com
我的回复(2012-7-2 23:44):现在忙,过段时间给你发些Delphi的电子书。

你可以搜索Delphi盒子论坛,那可能是国内目前有关Delphi的最活跃的论坛了。
[10]mengqingkui   2012-7-1 14:40
非常非常感谢陈老师的帮助!
祝陈老师工作顺利,家庭幸福!
[9]mengqingkui   2012-6-28 23:22
陈老师:
您好!
对于您编制的MT-Pioneer,我深感敬佩。我是研究方向为电磁法应用的一名研究生,硕士论文的方向为张量CSAMT数据处理,我想用delphi编制一个简单的处理界面,因为张量CSAMT数据处理的文献不多,而且我对delphi做界面也比较生疏。所以,我希望陈老师可以给我提供一些关于张量CSAMT或MT数据处理的一些文章或资料,和学习delphi的一本好教材,谢谢陈老师!我的邮箱:250443247@qq.com
我的回复(2012-7-1 08:25):Delphi的教材现在确实比较少。你可以参考一下刘艺和李维的几本经典教材。还有那个意大利人的delphi从入门到精通系列,此外,要常上网,到各个论坛上厮混。google可能是更好的帮助手段吧。

你要做科学数据分析,Teechart套件非常好。
我的回复(2012-6-29 13:25):张量CSAMT与张量MT并没有太大的区别,除非你要搞过渡区、近区数据的分析和反演。所以,我建议你先去好好看看有关MT的阻抗张量的定义。这些,每一本大地电磁教材里面都会有介绍。

了解了张量阻抗的概念后,再进一步了解阻抗张量分解技术及其应用情况。这个,会有一定的难度,全中国搞清楚的人不多。
[8]胡宏友   2012-6-8 21:41
SCI,我的个后妈!您可千万别说太多。洋博士可就是凭这个吃饭的。
我的回复(2012-6-8 21:50):是啊是啊。
[7]shenglixiaoli   2012-4-22 10:17
陈老师。一直在关注您的博客,目前也在从事电法学习。能不能给我个您的联系方式。谢谢。
我的回复(2012-4-23 14:54):小李,有事可以给我发邮件。

cxb@pku.edu.cn
[6]sunseeyu   2012-1-5 16:32
陳老師,您好
我對此軟體專業版有興趣,可否與我聯繫
孫思優技師,台灣
sunpro.geo@msa.hinet.net
[5]单明   2011-12-3 17:14
深有同感!鄙视那些靠文章数据而上的学者
我的回复(2012-1-9 12:16):是杨老师?
[4]景依   2011-11-26 23:37
陈老师,看了您的中国科学家没有评价能力这篇文章,觉得很认同,我觉得是不是还是与我们国家的国际影响力有关呢,缺乏创新能力,也许我们在国际上还是不那么自信。
[3]陈长敬   2011-10-14 07:10
陈老师你好,请问您开发的MT软件现在对外销售么?我们单位想采购一套,如何联系您?我的电话:15926350006
我的回复(2011-10-16 22:48):你可以留下你的QQ。
[2]苏洲   2011-5-31 19:04
陈老师,您好,我是长江大学地物学院电磁实验室胡文宝老师的学生,现在上研二。由于本科学的是数学,胡老师结合我的本科专业,给我定的方向是正反演算法研究。现在正在进行的工作是有限元正演研究,在研究中有些问题想请教您,我的QQ:569859582。
[1]陈儒军   2010-3-15 03:21
你可以安装电驴,再在电驴里输入关键词“翻墙”。或者先用GOOGLE搜索一下翻墙软件有那些,然后在电驴里找相应的软件。我是用电驴搞定的。

Archiver|手机版|科学网 ( 京ICP备14006957 )

GMT+8, 2020-2-20 04:48

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部